diff --git a/Data/Containers/ListUtils.hs b/Data/Containers/ListUtils.hs new file mode 100644 --- /dev/null +++ b/Data/Containers/ListUtils.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Containers.ListUtils +-- Copyright : (c) Gershom Bazerman 2018 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This module provides efficient containers-based functions on the list type. +----------------------------------------------------------------------------- + +module Data.Containers.ListUtils ( + nubOrd, + nubOrdOn, + nubInt, + nubIntOn + ) where + +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet +import Data.IntSet (IntSet) +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts ( build ) +#endif + +-- *** Ord-based nubbing *** + + +-- | \( O(n \log n \). The @nubOrd@ function removes duplicate elements from a list. +-- In particular, it keeps only the first occurrence of each element. By using a +-- 'Set' internally it has better asymptotics than the standard 'Data.List.nub' +-- function. +-- +-- ==== Strictness +-- +-- @nubOrd@ is strict in the elements of the list. +-- +-- ==== Efficiency note +-- +-- When applicable, it is almost always better to use 'nubInt' or 'nubIntOn' instead +-- of this function. For example, the best way to nub a list of characters is +-- +-- @ nubIntOn fromEnum xs @ +nubOrd :: Ord a => [a] -> [a] +nubOrd = nubOrdOn id +{-# INLINE nubOrd #-} + +-- | The @nubOrdOn@ function behaves just like 'nubOrd' except it performs +-- comparisons not on the original datatype, but a user-specified projection +-- from that datatype. +-- +-- ==== Strictness +-- +-- @nubOrdOn@ is strict in the values of the function applied to the +-- elements of the list. +nubOrdOn :: Ord b => (a -> b) -> [a] -> [a] +-- For some reason we need to write an explicit lambda here to allow this +-- to inline when only applied to a function. +nubOrdOn f = \xs -> nubOrdOnExcluding f Set.empty xs +{-# INLINE nubOrdOn #-} + +-- Splitting nubOrdOn like this means that we don't have to worry about +-- matching specifically on Set.empty in the rewrite-back rule. +nubOrdOnExcluding :: Ord b => (a -> b) -> Set b -> [a] -> [a] +nubOrdOnExcluding f = go + where + go _ [] = [] + go s (x:xs) + | fx `Set.member` s = go s xs + | otherwise = x : go (Set.insert fx s) xs + where !fx = f x + +#ifdef __GLASGOW_HASKELL__ +-- We want this inlinable to specialize to the necessary Ord instance. +{-# INLINABLE [1] nubOrdOnExcluding #-} + +{-# RULES +-- Rewrite to a fusible form. +"nubOrdOn" [~1] forall f as s. nubOrdOnExcluding f s as = + build (\c n -> foldr (nubOrdOnFB f c) (constNubOn n) as s) + +-- Rewrite back to a plain form +"nubOrdOnList" [1] forall f as s. + foldr (nubOrdOnFB f (:)) (constNubOn []) as s = + nubOrdOnExcluding f s as + #-} + +nubOrdOnFB :: Ord b + => (a -> b) + -> (a -> r -> r) + -> a + -> (Set b -> r) + -> Set b + -> r +nubOrdOnFB f c x r s + | fx `Set.member` s = r s + | otherwise = x `c` r (Set.insert fx s) + where !fx = f x +{-# INLINABLE [0] nubOrdOnFB #-} + +constNubOn :: a -> b -> a +constNubOn x _ = x +{-# INLINE [0] constNubOn #-} +#endif + + +-- *** Int-based nubbing *** + + +-- | \( O(n \min(n,W)) \). The @nubInt@ function removes duplicate 'Int' +-- values from a list. In particular, it keeps only the first occurrence +-- of each element. By using an 'IntSet' internally, it attains better +-- asymptotics than the standard 'Data.List.nub' function. +-- +-- See also 'nubIntOn', a more widely applicable generalization. +-- +-- ==== Strictness +-- +-- @nubInt@ is strict in the elements of the list. +nubInt :: [Int] -> [Int] +nubInt = nubIntOn id +{-# INLINE nubInt #-} + +-- | The @nubIntOn@ function behaves just like 'nubInt' except it performs +-- comparisons not on the original datatype, but a user-specified projection +-- from that datatype. +-- +-- ==== Strictness +-- +-- @nubIntOn@ is strict in the values of the function applied to the +-- elements of the list. +nubIntOn :: (a -> Int) -> [a] -> [a] +-- For some reason we need to write an explicit lambda here to allow this +-- to inline when only applied to a function. +nubIntOn f = \xs -> nubIntOnExcluding f IntSet.empty xs +{-# INLINE nubIntOn #-} + +-- Splitting nubIntOn like this means that we don't have to worry about +-- matching specifically on IntSet.empty in the rewrite-back rule. +nubIntOnExcluding :: (a -> Int) -> IntSet -> [a] -> [a] +nubIntOnExcluding f = go + where + go _ [] = [] + go s (x:xs) + | fx `IntSet.member` s = go s xs + | otherwise = x : go (IntSet.insert fx s) xs + where !fx = f x + +#ifdef __GLASGOW_HASKELL__ +-- We don't mark this INLINABLE because it doesn't seem obviously useful +-- to inline it anywhere; the elements the function operates on are actually +-- pulled from a list and installed in a list; the situation is very different +-- when fusion occurs. In this case, we let GHC make the call. +{-# NOINLINE [1] nubIntOnExcluding #-} + +{-# RULES +"nubIntOn" [~1] forall f as s. nubIntOnExcluding f s as = + build (\c n -> foldr (nubIntOnFB f c) (constNubOn n) as s) +"nubIntOnList" [1] forall f as s. foldr (nubIntOnFB f (:)) (constNubOn []) as s = + nubIntOnExcluding f s as + #-} + +nubIntOnFB :: (a -> Int) + -> (a -> r -> r) + -> a + -> (IntSet -> r) + -> IntSet + -> r +nubIntOnFB f c x r s + | fx `IntSet.member` s = r s + | otherwise = x `c` r (IntSet.insert fx s) + where !fx = f x +{-# INLINABLE [0] nubIntOnFB #-} +#endif diff --git a/Data/Graph.hs b/Data/Graph.hs --- a/Data/Graph.hs +++ b/Data/Graph.hs @@ -1,15 +1,14 @@ {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -#endif -#if __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} +# if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE Safe #-} +# else +{-# LANGUAGE Trustworthy #-} +# endif #endif #include "containers.h" @@ -23,56 +22,82 @@ -- Maintainer : libraries@haskell.org -- Portability : portable -- --- A version of the graph algorithms described in: +-- = Finite Graphs -- --- /Structuring Depth-First Search Algorithms in Haskell/, --- by David King and John Launchbury. +-- The @'Graph'@ type is an adjacency list representation of a finite, directed +-- graph with vertices of type @Int@. -- +-- The @'SCC'@ type represents a +-- +-- of a graph. +-- +-- == Implementation +-- +-- The implementation is based on +-- +-- * /Structuring Depth-First Search Algorithms in Haskell/, +-- by David King and John Launchbury. +-- ----------------------------------------------------------------------------- -module Data.Graph( +module Data.Graph ( - -- * External interface + -- * Graphs + Graph + , Bounds + , Edge + , Vertex + , Table - -- At present the only one with a "nice" external interface - stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, + -- ** Graph Construction + , graphFromEdges + , graphFromEdges' + , buildG - -- * Graphs + -- ** Graph Properties + , vertices + , edges + , outdegree + , indegree - Graph, Table, Bounds, Edge, Vertex, + -- ** Graph Transformations + , transposeG - -- ** Building graphs + -- ** Graph Algorithms + , dfs + , dff + , topSort + , components + , scc + , bcc + , reachable + , path - graphFromEdges, graphFromEdges', buildG, transposeG, - -- reverseE, - -- ** Graph properties - - vertices, edges, - outdegree, indegree, + -- * Strongly Connected Components + , SCC(..) - -- * Algorithms + -- ** Construction + , stronglyConnComp + , stronglyConnCompR - dfs, dff, - topSort, - components, - scc, - bcc, - -- tree, back, cross, forward, - reachable, path, + -- ** Conversion + , flattenSCC + , flattenSCCs - module Data.Tree + -- * Trees + , module Data.Tree ) where -#if __GLASGOW_HASKELL__ -# define USE_ST_MONAD 1 -#endif - --- Extensions #if USE_ST_MONAD import Control.Monad.ST -import Data.Array.ST (STArray, newArray, readArray, writeArray) +import Data.Array.ST.Safe (newArray, readArray, writeArray) +# if USE_UNBOXED_ARRAYS +import Data.Array.ST.Safe (STUArray) +# else +import Data.Array.ST.Safe (STArray) +# endif #else import Data.IntSet (IntSet) import qualified Data.IntSet as Set @@ -90,25 +115,29 @@ import Control.DeepSeq (NFData(rnf)) import Data.Maybe import Data.Array +#if USE_UNBOXED_ARRAYS +import qualified Data.Array.Unboxed as UA +import Data.Array.Unboxed ( UArray ) +#else +import qualified Data.Array as UA +#endif import Data.List #if MIN_VERSION_base(4,9,0) import Data.Functor.Classes import Data.Semigroup (Semigroup (..)) #endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic, Generic1) -#elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif #ifdef __GLASGOW_HASKELL__ +import GHC.Generics (Generic, Generic1) import Data.Data (Data) -#endif import Data.Typeable +#endif +-- Make sure we don't use Integer by mistake. +default () ------------------------------------------------------------------------- -- - --- External interface +-- Strongly Connected Components -- - ------------------------------------------------------------------------- @@ -131,14 +160,10 @@ #ifdef __GLASGOW_HASKELL__ -- | @since 0.5.9 deriving instance Data vertex => Data (SCC vertex) -#endif -#if __GLASGOW_HASKELL__ >= 706 -- | @since 0.5.9 deriving instance Generic1 SCC -#endif -#if __GLASGOW_HASKELL__ >= 702 -- | @since 0.5.9 deriving instance Generic (SCC vertex) #endif @@ -246,31 +271,59 @@ -- | Abstract representation of vertices. type Vertex = Int -- | Table indexed by a contiguous set of vertices. +-- +-- /Note: This is included for backwards compatibility./ type Table a = Array Vertex a -- | Adjacency list representation of a graph, mapping each vertex to its -- list of successors. -type Graph = Table [Vertex] --- | The bounds of a 'Table'. +type Graph = Array Vertex [Vertex] +-- | The bounds of an @Array@. type Bounds = (Vertex, Vertex) -- | An edge from the first vertex to the second. type Edge = (Vertex, Vertex) --- | All vertices of a graph. +#if !USE_UNBOXED_ARRAYS +type UArray i a = Array i a +#endif + +-- | Returns the list of vertices in the graph. +-- +-- ==== __Examples__ +-- +-- > vertices (buildG (0,-1) []) == [] +-- +-- > vertices (buildG (0,2) [(0,1),(1,2)]) == [0,1,2] vertices :: Graph -> [Vertex] vertices = indices --- | All edges of a graph. +-- | Returns the list of edges in the graph. +-- +-- ==== __Examples__ +-- +-- > edges (buildG (0,-1) []) == [] +-- +-- > edges (buildG (0,2) [(0,1),(1,2)]) == [(0,1),(1,2)] edges :: Graph -> [Edge] edges g = [ (v, w) | v <- vertices g, w <- g!v ] -mapT :: (Vertex -> a -> b) -> Table a -> Table b -mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] - -- | Build a graph from a list of edges. +-- +-- Warning: This function will cause a runtime exception if a vertex in the edge +-- list is not within the given @Bounds@. +-- +-- ==== __Examples__ +-- +-- > buildG (0,-1) [] == array (0,-1) [] +-- > buildG (0,2) [(0,1), (1,2)] == array (0,1) [(0,[1]),(1,[2])] +-- > buildG (0,2) [(0,1), (0,2), (1,2)] == array (0,2) [(0,[2,1]),(1,[2]),(2,[])] buildG :: Bounds -> [Edge] -> Graph buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0 -- | The graph obtained by reversing all edges. +-- +-- ==== __Examples__ +-- +-- > transposeG (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,[]),(1,[0]),(2,[1])] transposeG :: Graph -> Graph transposeG g = buildG (bounds g) (reverseE g) @@ -278,13 +331,28 @@ reverseE g = [ (w, v) | (v, w) <- edges g ] -- | A table of the count of edges from each node. -outdegree :: Graph -> Table Int -outdegree = mapT numEdges - where numEdges _ ws = length ws +-- +-- ==== __Examples__ +-- +-- > outdegree (buildG (0,-1) []) == array (0,-1) [] +-- +-- > outdegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,1),(1,1),(2,0)] +outdegree :: Graph -> Array Vertex Int +-- This is bizarrely lazy. We build an array filled with thunks, instead +-- of actually calculating anything. This is the historical behavior, and I +-- suppose someone *could* be relying on it, but it might be worth finding +-- out. Note that we *can't* be so lazy with indegree. +outdegree = fmap length -- | A table of the count of edges into each node. -indegree :: Graph -> Table Int -indegree = outdegree . transposeG +-- +-- ==== __Examples__ +-- +-- > indegree (buildG (0,-1) []) == array (0,-1) [] +-- +-- > indegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,0),(1,1),(2,1)] +indegree :: Graph -> Array Vertex Int +indegree g = accumArray (+) 0 (bounds g) [(v, 1) | (_, outs) <- assocs g, v <- outs] -- | Identical to 'graphFromEdges', except that the return value -- does not include the function which maps keys to vertices. This @@ -298,8 +366,60 @@ -- | Build a graph from a list of nodes uniquely identified by keys, -- with a list of keys of nodes this node should have edges to. --- The out-list may contain keys that don't correspond to --- nodes of the graph; they are ignored. +-- +-- This function takes an adjacency list representing a graph with vertices of +-- type @key@ labeled by values of type @node@ and produces a @Graph@-based +-- representation of that list. The @Graph@ result represents the /shape/ of the +-- graph, and the functions describe a) how to retrieve the label and adjacent +-- vertices of a given vertex, and b) how to retrive a vertex given a key. +-- +-- @(graph, nodeFromVertex, vertexFromKey) = graphFromEdges edgeList@ +-- +-- * @graph :: Graph@ is the raw, array based adjacency list for the graph. +-- * @nodeFromVertex :: Vertex -> (node, key, [key])@ returns the node +-- associated with the given 0-based @Int@ vertex; see /warning/ below. +-- * @vertexFromKey :: key -> Maybe Vertex@ returns the @Int@ vertex for the +-- key if it exists in the graph, @Nothing@ otherwise. +-- +-- To safely use this API you must either extract the list of vertices directly +-- from the graph or first call @vertexFromKey k@ to check if a vertex +-- corresponds to the key @k@. Once it is known that a vertex exists you can use +-- @nodeFromVertex@ to access the labelled node and adjacent vertices. See below +-- for examples. +-- +-- Note: The out-list may contain keys that don't correspond to nodes of the +-- graph; they are ignored. +-- +-- Warning: The @nodeFromVertex@ function will cause a runtime exception if the +-- given @Vertex@ does not exist. +-- +-- ==== __Examples__ +-- +-- An empty graph. +-- +-- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [] +-- > graph = array (0,-1) [] +-- +-- A graph where the out-list references unspecified nodes (@'c'@), these are +-- ignored. +-- +-- > (graph, _, _) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c'])] +-- > array (0,1) [(0,[1]),(1,[])] +-- +-- +-- A graph with 3 vertices: ("a") -> ("b") -> ("c") +-- +-- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])] +-- > graph == array (0,2) [(0,[1]),(1,[2]),(2,[])] +-- > nodeFromVertex 0 == ("a",'a',"b") +-- > vertexFromKey 'a' == Just 0 +-- +-- Get the label for a given key. +-- +-- > let getNodePart (n, _, _) = n +-- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])] +-- > getNodePart . nodeFromVertex <$> vertexFromKey 'a' == Just "A" +-- graphFromEdges :: Ord key => [(node, key, [key])] @@ -372,7 +492,11 @@ -- Use the ST monad if available, for constant-time primitives. -newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a } +#if USE_UNBOXED_ARRAYS +newtype SetM s a = SetM { runSetM :: STUArray s Vertex Bool -> ST s a } +#else +newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a } +#endif instance Monad (SetM s) where return = pure @@ -452,10 +576,14 @@ preorderF :: Forest a -> [a] preorderF ts = preorderF' ts [] -tabulate :: Bounds -> [Vertex] -> Table Int -tabulate bnds vs = array bnds (zipWith (,) vs [1..]) +tabulate :: Bounds -> [Vertex] -> UArray Vertex Int +tabulate bnds vs = UA.array bnds (zipWith (flip (,)) [1..] vs) +-- Why zipWith (flip (,)) instead of just using zip with the +-- arguments in the other order? We want the [1..] to fuse +-- away, and these days that only happens when it's the first +-- list argument. -preArr :: Bounds -> Forest Vertex -> Table Int +preArr :: Bounds -> Forest Vertex -> UArray Vertex Int preArr bnds = tabulate bnds . preorderF ------------------------------------------------------------ @@ -519,18 +647,35 @@ forward :: Graph -> Graph -> Table Int -> Graph forward g tree' pre = mapT select g where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree' ! v + +mapT :: (Vertex -> a -> b) -> Array Vertex a -> Array Vertex b +mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] -} ------------------------------------------------------------ -- Algorithm 6: Finding reachable vertices ------------------------------------------------------------ --- | A list of vertices reachable from a given vertex. -reachable :: Graph -> Vertex -> [Vertex] +-- | Returns the list of vertices reachable from a given vertex. +-- +-- ==== __Examples__ +-- +-- > reachable (buildG (0,0) []) 0 == [0] +-- +-- > reachable (buildG (0,2) [(0,1), (1,2)]) 0 == [0,1,2] +reachable :: Graph -> Vertex -> [Vertex] reachable g v = preorderF (dfs g [v]) --- | Is the second vertex reachable from the first? -path :: Graph -> Vertex -> Vertex -> Bool +-- | Returns @True@ if the second vertex reachable from the first. +-- +-- ==== __Examples__ +-- +-- > path (buildG (0,0) []) 0 0 == True +-- +-- > path (buildG (0,2) [(0,1), (1,2)]) 0 2 == True +-- +-- > path (buildG (0,2) [(0,1), (1,2)]) 2 0 == False +path :: Graph -> Vertex -> Vertex -> Bool path g v w = w `elem` (reachable g v) ------------------------------------------------------------ @@ -545,10 +690,10 @@ where forest = dff g dnum = preArr (bounds g) forest -do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) -do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us +do_label :: Graph -> UArray Vertex Int -> Tree Vertex -> Tree (Vertex,Int,Int) +do_label g dnum (Node v ts) = Node (v, dnum UA.! v, lv) us where us = map (do_label g dnum) ts - lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] + lv = minimum ([dnum UA.! v] ++ [dnum UA.! w | w <- g!v] ++ [lu | Node (_,_,lu) _ <- us]) bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex] diff --git a/Data/IntMap.hs b/Data/IntMap.hs --- a/Data/IntMap.hs +++ b/Data/IntMap.hs @@ -1,7 +1,13 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DataKinds, FlexibleContexts #-} +#endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE MonoLocalBinds #-} +#endif #include "containers.h" @@ -54,43 +60,42 @@ module Data.IntMap ( module Data.IntMap.Lazy +#ifdef __GLASGOW_HASKELL__ +-- For GHC, we disable these, pending removal. For anything else, +-- we just don't define them at all. , insertWith' , insertWithKey' , fold , foldWithKey +#endif ) where -import Prelude () -- hide foldr -import qualified Data.IntMap.Strict as Strict import Data.IntMap.Lazy --- | /O(log n)/. Same as 'insertWith', but the result of the combining function --- is evaluated to WHNF before inserted to the map. - -{-# DEPRECATED insertWith' "As of version 0.5, replaced by 'Data.IntMap.Strict.insertWith'." #-} -insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith' = Strict.insertWith - --- | /O(log n)/. Same as 'insertWithKey', but the result of the combining --- function is evaluated to WHNF before inserted to the map. +#ifdef __GLASGOW_HASKELL__ +import Utils.Containers.Internal.TypeError -{-# DEPRECATED insertWithKey' "As of version 0.5, replaced by 'Data.IntMap.Strict.insertWithKey'." #-} -insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWithKey' = Strict.insertWithKey +-- | This function is being removed and is no longer usable. +-- Use 'Data.IntMap.Strict.insertWith' +insertWith' :: Whoops "Data.IntMap.insertWith' is gone. Use Data.IntMap.Strict.insertWith." + => (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWith' _ _ _ _ = undefined --- | /O(n)/. Fold the values in the map using the given --- right-associative binary operator. This function is an equivalent --- of 'foldr' and is present for compatibility only. -{-# DEPRECATED fold "As of version 0.5, replaced by 'foldr'." #-} -fold :: (a -> b -> b) -> b -> IntMap a -> b -fold = foldr -{-# INLINE fold #-} +-- | This function is being removed and is no longer usable. +-- Use 'Data.IntMap.Strict.insertWithKey'. +insertWithKey' :: Whoops "Data.IntMap.insertWithKey' is gone. Use Data.IntMap.Strict.insertWithKey." + => (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithKey' _ _ _ _ = undefined --- | /O(n)/. Fold the keys and values in the map using the given --- right-associative binary operator. This function is an equivalent --- of 'foldrWithKey' and is present for compatibility only. +-- | This function is being removed and is no longer usable. +-- Use 'Data.IntMap.Lazy.foldr'. +fold :: Whoops "Data.IntMap.fold' is gone. Use Data.IntMap.foldr or Prelude.foldr." + => (a -> b -> b) -> b -> IntMap a -> b +fold _ _ _ = undefined -{-# DEPRECATED foldWithKey "As of version 0.5, replaced by 'foldrWithKey'." #-} -foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldWithKey = foldrWithKey -{-# INLINE foldWithKey #-} +-- | This function is being removed and is no longer usable. +-- Use 'foldrWithKey'. +foldWithKey :: Whoops "Data.IntMap.foldWithKey is gone. Use foldrWithKey." + => (Key -> a -> b -> b) -> b -> IntMap a -> b +foldWithKey _ _ _ = undefined +#endif diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -5,7 +5,7 @@ {-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 @@ -303,6 +303,7 @@ import Control.DeepSeq (NFData(rnf)) import Data.Bits import qualified Data.Foldable as Foldable +import Data.Foldable (Foldable()) import Data.Maybe (fromMaybe) import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null) @@ -310,7 +311,6 @@ import Data.IntSet.Internal (Key) import qualified Data.IntSet.Internal as IntSet import Utils.Containers.Internal.BitUtil -import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair #if __GLASGOW_HASKELL__ @@ -444,13 +444,10 @@ go (Tip _ v) = f v go (Bin _ _ l r) = go l `mappend` go r {-# INLINE foldMap #-} - -#if MIN_VERSION_base(4,6,0) foldl' = foldl' {-# INLINE foldl' #-} foldr' = foldr' {-# INLINE foldr' #-} -#endif #if MIN_VERSION_base(4,8,0) length = size {-# INLINE length #-} @@ -1003,18 +1000,18 @@ -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] -unions :: [IntMap a] -> IntMap a +unions :: Foldable f => f (IntMap a) -> IntMap a unions xs - = foldlStrict union empty xs + = Foldable.foldl' union empty xs -- | The union of a list of maps, with a combining operation. -- -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a +unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a unionsWith f ts - = foldlStrict (unionWith f) empty ts + = Foldable.foldl' (unionWith f) empty ts -- | /O(n+m)/. The (left-biased) union of two maps. -- It prefers the first map when duplicate keys are encountered, @@ -1082,7 +1079,7 @@ -- | /O(n+m)/. Remove all the keys in a given set from a map. -- -- @ --- m `withoutKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.notMember'` s) m +-- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.notMember`` s) m -- @ -- -- @since 0.5.8 @@ -1160,7 +1157,7 @@ -- | /O(n+m)/. The restriction of a map to the keys in a set. -- -- @ --- m `restrictKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.member'` s) m +-- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.member`` s) m -- @ -- -- @since 0.5.8 @@ -3031,7 +3028,7 @@ fromList :: [(Key,a)] -> IntMap a fromList xs - = foldlStrict ins empty xs + = Foldable.foldl' ins empty xs where ins t (k,x) = insert k x t @@ -3052,7 +3049,7 @@ fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromListWithKey f xs - = foldlStrict ins empty xs + = Foldable.foldl' ins empty xs where ins t (k,x) = insertWithKey f k x t diff --git a/Data/IntMap/Internal/DeprecatedDebug.hs b/Data/IntMap/Internal/DeprecatedDebug.hs --- a/Data/IntMap/Internal/DeprecatedDebug.hs +++ b/Data/IntMap/Internal/DeprecatedDebug.hs @@ -1,20 +1,17 @@ +{-# LANGUAGE CPP, FlexibleContexts, DataKinds, MonoLocalBinds #-} + module Data.IntMap.Internal.DeprecatedDebug where -import qualified Data.IntMap.Internal as IM import Data.IntMap.Internal (IntMap) -{-# DEPRECATED showTree, showTreeWith - "These debugging functions will be removed from this module. They are available from Data.IntMap.Internal.Debug." - #-} +import Utils.Containers.Internal.TypeError --- | /O(n)/. Show the tree that implements the map. The tree is shown --- in a compressed, hanging format. -showTree :: Show a => IntMap a -> String -showTree = IM.showTree -{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows - the tree that implements the map. If @hang@ is - 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If - @wide@ is 'True', an extra wide version is shown. --} -showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String -showTreeWith = IM.showTreeWith +-- | 'showTree' has moved to 'Data.IntMap.Internal.Debug.showTree' +showTree :: Whoops "Data.IntMap.showTree has moved to Data.IntMap.Internal.Debug.showTree" + => IntMap a -> String +showTree _ = undefined + +-- | 'showTreeWith' has moved to 'Data.IntMap.Internal.Debug.showTreeWith' +showTreeWith :: Whoops "Data.IntMap.showTreeWith has moved to Data.IntMap.Internal.Debug.showTreeWith" + => Bool -> Bool -> IntMap a -> String +showTreeWith _ _ _ = undefined diff --git a/Data/IntMap/Lazy.hs b/Data/IntMap/Lazy.hs --- a/Data/IntMap/Lazy.hs +++ b/Data/IntMap/Lazy.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif @@ -14,26 +14,47 @@ -- Maintainer : libraries@haskell.org -- Portability : portable -- --- An efficient implementation of maps from integer keys to values --- (dictionaries). -- --- API of this module is strict in the keys, but lazy in the values. --- If you need value-strict maps, use "Data.IntMap.Strict" instead. --- The 'IntMap' type itself is shared between the lazy and strict modules, --- meaning that the same 'IntMap' value can be passed to functions in --- both modules (although that is rarely needed). +-- = Finite Int Maps (lazy interface) -- --- These modules are intended to be imported qualified, to avoid name --- clashes with Prelude functions, e.g. +-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary) +-- from keys of type @Int@ to values of type @v@. -- --- > import Data.IntMap.Lazy (IntMap) --- > import qualified Data.IntMap.Lazy as IntMap +-- The functions in "Data.IntMap.Strict" are careful to force values before +-- installing them in an 'IntMap'. This is usually more efficient in cases where +-- laziness is not essential. The functions in this module do not do so. -- +-- For a walkthrough of the most commonly used functions see the +-- . +-- +-- This module is intended to be imported qualified, to avoid name clashes with +-- Prelude functions: +-- +-- > import Data.IntMap.Lazy (IntMap) +-- > import qualified Data.IntMap.Lazy as IntMap +-- +-- Note that the implementation is generally /left-biased/. Functions that take +-- two maps as arguments and combine them, such as `union` and `intersection`, +-- prefer the values in the first argument to those in the second. +-- +-- +-- == Detailed performance information +-- +-- The amortized running time is given for each operation, with /n/ referring to +-- the number of entries in the map and /W/ referring to the number of bits in +-- an 'Int' (32 or 64). +-- +-- Benchmarks comparing "Data.IntMap.Lazy" with other dictionary +-- implementations can be found at https://github.com/haskell-perf/dictionaries. +-- +-- +-- == Implementation +-- -- The implementation is based on /big-endian patricia trees/. This data --- structure performs especially well on binary operations like 'union' --- and 'intersection'. However, my benchmarks show that it is also --- (much) faster on insertions and deletions when compared to a generic --- size-balanced map implementation (see "Data.Map"). +-- structure performs especially well on binary operations like 'union' and +-- 'intersection'. Additionally, benchmarks show that it is also (much) faster +-- on insertions and deletions when compared to a generic size-balanced map +-- implementation (see "Data.Map"). -- -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86, @@ -43,18 +64,9 @@ -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), -- October 1968, pages 514-534. -- --- Operation comments contain the operation time complexity in --- the Big-O notation . --- Many operations have a worst-case complexity of /O(min(n,W))/. --- This means that the operation can become linear in the number of --- elements with a maximum of /W/ -- the number of bits in an 'Int' --- (32 or 64). ----------------------------------------------------------------------------- module Data.IntMap.Lazy ( - -- * Strictness properties - -- $strictness - -- * Map type #if !defined(TESTING) IntMap, Key -- instance Eq,Show @@ -62,32 +74,29 @@ IntMap(..), Key -- instance Eq,Show #endif - -- * Operators - , (!), (!?), (\\) - - -- * Query - , IM.null - , size - , member - , notMember - , IM.lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - -- * Construction , empty , singleton + , fromSet - -- ** Insertion + -- ** From Unordered Lists + , fromList + , fromListWith + , fromListWithKey + + -- ** From Ascending Lists + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Insertion , insert , insertWith , insertWithKey , insertLookupWithKey - -- ** Delete\/Update + -- * Deletion\/Update , delete , adjust , adjustWithKey @@ -97,6 +106,23 @@ , alter , alterF + -- * Query + -- ** Lookup + , IM.lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , IM.null + , size + -- * Combine -- ** Union @@ -108,6 +134,7 @@ -- ** Difference , difference + , (\\) , differenceWith , differenceWithKey @@ -149,21 +176,13 @@ , keys , assocs , keysSet - , fromSet -- ** Lists , toList - , fromList - , fromListWith - , fromListWithKey -- ** Ordered lists , toAscList , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList -- * Filter , IM.filter @@ -204,22 +223,14 @@ , minViewWithKey , maxViewWithKey +#ifdef __GLASGOW_HASKELL__ -- * Debugging , showTree , showTreeWith +#endif ) where import Data.IntMap.Internal as IM hiding (showTree, showTreeWith) +#ifdef __GLASGOW_HASKELL__ import Data.IntMap.Internal.DeprecatedDebug - --- $strictness --- --- This module satisfies the following strictness property: --- --- * Key arguments are evaluated to WHNF --- --- Here are some examples that illustrate the property: --- --- > insertWith (\ new old -> old) undefined v m == undefined --- > insertWith (\ new old -> old) k undefined m == OK --- > delete undefined m == undefined +#endif diff --git a/Data/IntMap/Merge/Lazy.hs b/Data/IntMap/Merge/Lazy.hs --- a/Data/IntMap/Merge/Lazy.hs +++ b/Data/IntMap/Merge/Lazy.hs @@ -3,7 +3,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 708 diff --git a/Data/IntMap/Merge/Strict.hs b/Data/IntMap/Merge/Strict.hs --- a/Data/IntMap/Merge/Strict.hs +++ b/Data/IntMap/Merge/Strict.hs @@ -3,7 +3,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 708 diff --git a/Data/IntMap/Strict.hs b/Data/IntMap/Strict.hs --- a/Data/IntMap/Strict.hs +++ b/Data/IntMap/Strict.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif @@ -15,26 +15,63 @@ -- Maintainer : libraries@haskell.org -- Portability : portable -- --- An efficient implementation of maps from integer keys to values --- (dictionaries). -- --- API of this module is strict in both the keys and the values. --- If you need value-lazy maps, use "Data.IntMap.Lazy" instead. --- The 'IntMap' type itself is shared between the lazy and strict modules, --- meaning that the same 'IntMap' value can be passed to functions in --- both modules (although that is rarely needed). +-- = Finite Int Maps (strict interface) -- --- These modules are intended to be imported qualified, to avoid name --- clashes with Prelude functions, e.g. +-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary) +-- from key of type @Int@ to values of type @v@. -- --- > import Data.IntMap.Strict (IntMap) --- > import qualified Data.IntMap.Strict as IntMap +-- Each function in this module is careful to force values before installing +-- them in a 'Map'. This is usually more efficient when laziness is not +-- necessary. When laziness /is/ required, use the functions in +-- "Data.IntMap.Lazy". -- +-- In particular, the functions in this module obey the following law: +-- +-- - If all values stored in all maps in the arguments are in WHNF, then all +-- values stored in all maps in the results will be in WHNF once those maps +-- are evaluated. +-- +-- For a walkthrough of the most commonly used functions see the +-- . +-- +-- This module is intended to be imported qualified, to avoid name clashes with +-- Prelude functions: +-- +-- > import Data.IntMap.Strict (IntMap) +-- > import qualified Data.IntMap.Strict as IntMap +-- +-- Note that the implementation is generally /left-biased/. Functions that take +-- two maps as arguments and combine them, such as `union` and `intersection`, +-- prefer the values in the first argument to those in the second. +-- +-- +-- == Detailed performance information +-- +-- The amortized running time is given for each operation, with /n/ referring to +-- the number of entries in the map and /W/ referring to the number of bits in +-- an 'Int' (32 or 64). +-- +-- Benchmarks comparing "Data.IntMap.Strict" with other dictionary +-- implementations can be found at https://github.com/haskell-perf/dictionaries. +-- +-- +-- == Warning +-- +-- The 'IntMap' type is shared between the lazy and strict modules, meaning that +-- the same 'IntMap' value can be passed to functions in both modules. This +-- means that the 'Functor', 'Traversable' and 'Data' instances are the same as +-- for the "Data.IntMap.Lazy" module, so if they are used the resulting map may +-- contain suspended values (thunks). +-- +-- +-- == Implementation +-- -- The implementation is based on /big-endian patricia trees/. This data --- structure performs especially well on binary operations like 'union' --- and 'intersection'. However, my benchmarks show that it is also --- (much) faster on insertions and deletions when compared to a generic --- size-balanced map implementation (see "Data.Map"). +-- structure performs especially well on binary operations like 'union' and +-- 'intersection'. Additionally, benchmarks show that it is also (much) faster +-- on insertions and deletions when compared to a generic size-balanced map +-- implementation (see "Data.Map"). -- -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86, @@ -44,24 +81,11 @@ -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), -- October 1968, pages 514-534. -- --- Operation comments contain the operation time complexity in --- the Big-O notation . --- Many operations have a worst-case complexity of /O(min(n,W))/. --- This means that the operation can become linear in the number of --- elements with a maximum of /W/ -- the number of bits in an 'Int' --- (32 or 64). --- --- Be aware that the 'Functor', 'Traversable' and 'Data' instances --- are the same as for the "Data.IntMap.Lazy" module, so if they are used --- on strict maps, the resulting maps will be lazy. ----------------------------------------------------------------------------- -- See the notes at the beginning of Data.IntMap.Internal. module Data.IntMap.Strict ( - -- * Strictness properties - -- $strictness - -- * Map type #if !defined(TESTING) IntMap, Key -- instance Eq,Show @@ -69,32 +93,29 @@ IntMap(..), Key -- instance Eq,Show #endif - -- * Operators - , (!), (!?), (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - -- * Construction , empty , singleton + , fromSet - -- ** Insertion + -- ** From Unordered Lists + , fromList + , fromListWith + , fromListWithKey + + -- ** From Ascending Lists + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Insertion , insert , insertWith , insertWithKey , insertLookupWithKey - -- ** Delete\/Update + -- * Deletion\/Update , delete , adjust , adjustWithKey @@ -104,6 +125,23 @@ , alter , alterF + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , null + , size + -- * Combine -- ** Union @@ -115,6 +153,7 @@ -- ** Difference , difference + , (\\) , differenceWith , differenceWithKey @@ -156,21 +195,13 @@ , keys , assocs , keysSet - , fromSet -- ** Lists , toList - , fromList - , fromListWith - , fromListWithKey - -- ** Ordered lists +-- ** Ordered lists , toAscList , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList -- * Filter , filter @@ -211,9 +242,11 @@ , minViewWithKey , maxViewWithKey +#ifdef __GLASGOW_HASKELL__ -- * Debugging , showTree , showTreeWith +#endif ) where import Prelude hiding (lookup,map,filter,foldr,foldl,null) @@ -300,33 +333,18 @@ , unions , withoutKeys ) +#ifdef __GLASGOW_HASKELL__ import Data.IntMap.Internal.DeprecatedDebug (showTree, showTreeWith) +#endif import qualified Data.IntSet.Internal as IntSet import Utils.Containers.Internal.BitUtil -import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair #if !MIN_VERSION_base(4,8,0) import Data.Functor((<$>)) #endif import Control.Applicative (Applicative (..), liftA2) - --- $strictness --- --- This module satisfies the following strictness properties: --- --- 1. Key arguments are evaluated to WHNF; --- --- 2. Keys and values are evaluated to WHNF before they are stored in --- the map. --- --- Here's an example illustrating the first property: --- --- > delete undefined m == undefined --- --- Here are some examples that illustrate the second property: --- --- > map (\ v -> undefined) m == undefined -- m is not empty --- > mapKeys (\ k -> undefined) m == undefined -- m is not empty +import qualified Data.Foldable as Foldable +import Data.Foldable (Foldable()) {-------------------------------------------------------------------- Query @@ -413,7 +431,7 @@ -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" -- --- If the key exists in the map, this function is lazy in @x@ but strict +-- If the key exists in the map, this function is lazy in @value@ but strict -- in the result of @f@. insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a @@ -625,9 +643,9 @@ -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a +unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a unionsWith f ts - = foldlStrict (unionWith f) empty ts + = Foldable.foldl' (unionWith f) empty ts -- | /O(n+m)/. The union with a combining function. -- @@ -1036,7 +1054,7 @@ fromList :: [(Key,a)] -> IntMap a fromList xs - = foldlStrict ins empty xs + = Foldable.foldl' ins empty xs where ins t (k,x) = insert k x t @@ -1056,7 +1074,7 @@ fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromListWithKey f xs - = foldlStrict ins empty xs + = Foldable.foldl' ins empty xs where ins t (k,x) = insertWithKey f k x t diff --git a/Data/IntSet.hs b/Data/IntSet.hs --- a/Data/IntSet.hs +++ b/Data/IntSet.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif @@ -14,14 +14,31 @@ -- Maintainer : libraries@haskell.org -- Portability : portable -- --- An efficient implementation of integer sets. -- +-- = Finite Int Sets +-- +-- The @'IntSet'@ type represents a set of elements of type @Int@. +-- +-- For a walkthrough of the most commonly used functions see their +-- . +-- -- These modules are intended to be imported qualified, to avoid name -- clashes with Prelude functions, e.g. -- -- > import Data.IntSet (IntSet) -- > import qualified Data.IntSet as IntSet -- +-- +-- == Performance information +-- +-- Many operations have a worst-case complexity of /O(min(n,W))/. +-- This means that the operation can become linear in the number of +-- elements with a maximum of /W/ -- the number of bits in an 'Int' +-- (32 or 64). +-- +-- +-- == Implementation +-- -- The implementation is based on /big-endian patricia trees/. This data -- structure performs especially well on binary operations like 'union' -- and 'intersection'. However, my benchmarks show that it is also @@ -38,14 +55,10 @@ -- -- Additionally, this implementation places bitmaps in the leaves of the tree. -- Their size is the natural size of a machine word (32 or 64 bits) and greatly --- reduce memory footprint and execution times for dense sets, e.g. sets where --- it is likely that many values lie close to each other. The asymptotics are --- not affected by this optimization. +-- reduces the memory footprint and execution times for dense sets, e.g. sets +-- where it is likely that many values lie close to each other. The asymptotics +-- are not affected by this optimization. -- --- Many operations have a worst-case complexity of /O(min(n,W))/. --- This means that the operation can become linear in the number of --- elements with a maximum of /W/ -- the number of bits in an 'Int' --- (32 or 64). ----------------------------------------------------------------------------- module Data.IntSet ( @@ -60,32 +73,37 @@ #endif , Key - -- * Operators - , (\\) + -- * Construction + , empty + , singleton + , fromList + , fromAscList + , fromDistinctAscList + -- * Insertion + , insert + + -- * Deletion + , delete + -- * Query - , IS.null - , size , member , notMember , lookupLT , lookupGT , lookupLE , lookupGE + , IS.null + , size , isSubsetOf , isProperSubsetOf , disjoint - -- * Construction - , empty - , singleton - , insert - , delete - -- * Combine , union , unions , difference + , (\\) , intersection -- * Filter @@ -122,13 +140,8 @@ -- ** List , elems , toList - , fromList - - -- ** Ordered list , toAscList , toDescList - , fromAscList - , fromDistinctAscList -- * Debugging , showTree diff --git a/Data/IntSet/Internal.hs b/Data/IntSet/Internal.hs --- a/Data/IntSet/Internal.hs +++ b/Data/IntSet/Internal.hs @@ -3,7 +3,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 @@ -201,7 +201,6 @@ import Prelude hiding (filter, foldr, foldl, null, map) import Utils.Containers.Internal.BitUtil -import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair #if __GLASGOW_HASKELL__ @@ -217,6 +216,8 @@ import GHC.Prim (indexInt8OffAddr#) #endif +import qualified Data.Foldable as Foldable +import Data.Foldable (Foldable()) infixl 9 \\{-This comment teaches CPP correct behaviour -} @@ -499,9 +500,9 @@ Union --------------------------------------------------------------------} -- | The union of a list of sets. -unions :: [IntSet] -> IntSet +unions :: Foldable f => f IntSet -> IntSet unions xs - = foldlStrict union empty xs + = Foldable.foldl' union empty xs -- | /O(n+m)/. The union of two sets. @@ -642,7 +643,7 @@ subsetCmp Nil _ = LT -- | /O(n+m)/. Is this a subset? --- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. +-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@. isSubsetOf :: IntSet -> IntSet -> Bool isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) @@ -1044,7 +1045,7 @@ -- | /O(n*min(n,W))/. Create a set from a list of integers. fromList :: [Key] -> IntSet fromList xs - = foldlStrict ins empty xs + = Foldable.foldl' ins empty xs where ins t x = insert x t diff --git a/Data/Map.hs b/Data/Map.hs --- a/Data/Map.hs +++ b/Data/Map.hs @@ -1,8 +1,15 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DataKinds, FlexibleContexts #-} +#endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE MonoLocalBinds #-} +#endif + #include "containers.h" ----------------------------------------------------------------------------- @@ -60,72 +67,48 @@ module Data.Map ( module Data.Map.Lazy +#ifdef __GLASGOW_HASKELL__ , insertWith' , insertWithKey' , insertLookupWithKey' , fold , foldWithKey +#endif ) where -import Prelude hiding (foldr) import Data.Map.Lazy -import qualified Data.Map.Strict as Strict --- | /O(log n)/. Same as 'insertWith', but the value being inserted to the map is --- evaluated to WHNF beforehand. --- --- For example, to update a counter: --- --- > insertWith' (+) k 1 m --- -{-# DEPRECATED insertWith' "As of version 0.5, replaced by 'Data.Map.Strict.insertWith'." #-} -insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a -insertWith' = Strict.insertWith -#if __GLASGOW_HASKELL__ -{-# INLINABLE insertWith' #-} -#else -{-# INLINE insertWith' #-} -#endif +#ifdef __GLASGOW_HASKELL__ +import Utils.Containers.Internal.TypeError --- | /O(log n)/. Same as 'insertWithKey', but the value being inserted to the map is --- evaluated to WHNF beforehand. -{-# DEPRECATED insertWithKey' "As of version 0.5, replaced by 'Data.Map.Strict.insertWithKey'." #-} -insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a --- We do not reuse Data.Map.Strict.insertWithKey, because it is stricter -- it --- forces evaluation of the given value. -insertWithKey' = Strict.insertWithKey -#if __GLASGOW_HASKELL__ -{-# INLINABLE insertWithKey' #-} -#else -{-# INLINE insertWithKey' #-} -#endif +-- | This function is being removed and is no longer usable. +-- Use 'Data.Map.Strict.insertWith'. +insertWith' :: Whoops "Data.Map.insertWith' is gone. Use Data.Map.Strict.insertWith." + => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith' _ _ _ _ = undefined --- | /O(log n)/. Same as 'insertLookupWithKey', but the value being inserted to --- the map is evaluated to WHNF beforehand. -{-# DEPRECATED insertLookupWithKey' "As of version 0.5, replaced by 'Data.Map.Strict.insertLookupWithKey'." #-} -insertLookupWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a +-- | This function is being removed and is no longer usable. +-- Use 'Data.Map.Strict.insertWithKey'. +insertWithKey' :: Whoops "Data.Map.insertWithKey' is gone. Use Data.Map.Strict.insertWithKey." + => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWithKey' _ _ _ _ = undefined + +-- | This function is being removed and is no longer usable. +-- Use 'Data.Map.Strict.insertLookupWithKey'. +insertLookupWithKey' :: Whoops "Data.Map.insertLookupWithKey' is gone. Use Data.Map.Strict.insertLookupWithKey." + => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a) --- We do not reuse Data.Map.Strict.insertLookupWithKey, because it is stricter -- it --- forces evaluation of the given value. -insertLookupWithKey' = Strict.insertLookupWithKey -#if __GLASGOW_HASKELL__ -{-# INLINABLE insertLookupWithKey' #-} -#else -{-# INLINE insertLookupWithKey' #-} -#endif +insertLookupWithKey' _ _ _ _ = undefined --- | /O(n)/. Fold the values in the map using the given right-associative --- binary operator. This function is an equivalent of 'foldr' and is present --- for compatibility only. -{-# DEPRECATED fold "As of version 0.5, replaced by 'foldr'." #-} -fold :: (a -> b -> b) -> b -> Map k a -> b -fold = foldr -{-# INLINE fold #-} +-- | This function is being removed and is no longer usable. +-- Use 'foldr'. +fold :: Whoops "Data.Map.fold is gone. Use foldr." + => (a -> b -> b) -> b -> Map k a -> b +fold _ _ _ = undefined --- | /O(n)/. Fold the keys and values in the map using the given right-associative --- binary operator. This function is an equivalent of 'foldrWithKey' and is present --- for compatibility only. -{-# DEPRECATED foldWithKey "As of version 0.4, replaced by 'foldrWithKey'." #-} -foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b -foldWithKey = foldrWithKey -{-# INLINE foldWithKey #-} +-- | This function is being removed and is no longer usable. +-- Use 'foldrWithKey'. +foldWithKey :: Whoops "Data.Map.foldWithKey is gone. Use foldrWithKey." + => (k -> a -> b -> b) -> b -> Map k a -> b +foldWithKey _ _ _ = undefined +#endif diff --git a/Data/Map/Internal.hs b/Data/Map/Internal.hs --- a/Data/Map/Internal.hs +++ b/Data/Map/Internal.hs @@ -4,7 +4,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif -#if __GLASGOW_HASKELL__ >= 703 +#if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 @@ -378,13 +378,13 @@ import Control.DeepSeq (NFData(rnf)) import Data.Bits (shiftL, shiftR) import qualified Data.Foldable as Foldable +import Data.Foldable (Foldable()) import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop) import qualified Data.Set.Internal as Set import Data.Set.Internal (Set) import Utils.Containers.Internal.PtrEquality (ptrEq) -import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair import Utils.Containers.Internal.StrictMaybe import Utils.Containers.Internal.BitQueue @@ -1782,9 +1782,9 @@ -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] -unions :: Ord k => [Map k a] -> Map k a +unions :: (Foldable f, Ord k) => f (Map k a) -> Map k a unions ts - = foldlStrict union empty ts + = Foldable.foldl' union empty ts #if __GLASGOW_HASKELL__ {-# INLINABLE unions #-} #endif @@ -1795,9 +1795,9 @@ -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a +unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a unionsWith f ts - = foldlStrict (unionWith f) empty ts + = Foldable.foldl' (unionWith f) empty ts #if __GLASGOW_HASKELL__ {-# INLINABLE unionsWith #-} #endif @@ -1899,8 +1899,8 @@ -- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Set' from a 'Map'. -- -- @ --- m `'withoutKeys'` s = 'filterWithKey' (\k _ -> k `'Set.notMember'` s) m --- m `'withoutKeys'` s = m `'difference'` 'fromSet' (const ()) s +-- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m +-- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s -- @ -- -- @since 0.5.8 @@ -1981,8 +1981,8 @@ -- found in a 'Set'. -- -- @ --- m `'restrictKeys'` s = 'filterWithKey' (\k _ -> k `'Set.member'` s) m --- m `'restrictKeys'` s = m `'intersect' 'fromSet' (const ()) s +-- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m +-- m \`restrictKeys\` s = m ``intersect`` 'fromSet' (const ()) s -- @ -- -- @since 0.5.8 @@ -3348,7 +3348,7 @@ not_ordered kx ((ky,_) : _) = kx >= ky {-# INLINE not_ordered #-} - fromList' t0 xs = foldlStrict ins t0 xs + fromList' t0 xs = Foldable.foldl' ins t0 xs where ins t (k,x) = insert k x t go !_ t [] = t @@ -3397,7 +3397,7 @@ fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromListWithKey f xs - = foldlStrict ins empty xs + = Foldable.foldl' ins empty xs where ins t (k,x) = insertWithKey f k x t #if __GLASGOW_HASKELL__ @@ -4142,13 +4142,10 @@ go (Bin 1 _ v _ _) = f v go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r) {-# INLINE foldMap #-} - -#if MIN_VERSION_base(4,6,0) foldl' = foldl' {-# INLINE foldl' #-} foldr' = foldr' {-# INLINE foldr' #-} -#endif #if MIN_VERSION_base(4,8,0) length = size {-# INLINE length #-} diff --git a/Data/Map/Internal/DeprecatedShowTree.hs b/Data/Map/Internal/DeprecatedShowTree.hs --- a/Data/Map/Internal/DeprecatedShowTree.hs +++ b/Data/Map/Internal/DeprecatedShowTree.hs @@ -1,56 +1,29 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, FlexibleContexts, DataKinds #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE MonoLocalBinds #-} +#endif +#if __GLASGOW_HASKELL__ < 710 +-- Why do we need this? Guess it doesn't matter; this is all +-- going away soon. +{-# LANGUAGE Trustworthy #-} +#endif #include "containers.h" --- | This module simply holds deprecated copies of functions from +-- | This module simply holds disabled copies of functions from -- Data.Map.Internal.Debug. module Data.Map.Internal.DeprecatedShowTree where -import qualified Data.Map.Internal.Debug as Debug import Data.Map.Internal (Map) - --- | /O(n)/. Show the tree that implements the map. The tree is shown --- in a compressed, hanging format. See 'showTreeWith'. -{-# DEPRECATED showTree "'showTree' is now in \"Data.Map.Internal.Debug\"" #-} -showTree :: (Show k,Show a) => Map k a -> String -showTree = Debug.showTree - -{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows - the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is - 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If - @wide@ is 'True', an extra wide version is shown. +import Utils.Containers.Internal.TypeError -> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]] -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t -> (4,()) -> +--(2,()) -> | +--(1,()) -> | +--(3,()) -> +--(5,()) -> -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t -> (4,()) -> | -> +--(2,()) -> | | -> | +--(1,()) -> | | -> | +--(3,()) -> | -> +--(5,()) -> -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t -> +--(5,()) -> | -> (4,()) -> | -> | +--(3,()) -> | | -> +--(2,()) -> | -> +--(1,()) +-- | This function has moved to 'Data.Map.Internal.Debug.showTree'. +showTree :: Whoops "showTree has moved to Data.Map.Internal.Debug.showTree." + => Map k a -> String +showTree _ = undefined --} -{-# DEPRECATED showTreeWith "'showTreeWith' is now in \"Data.Map.Internal.Debug\"" #-} -showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String -showTreeWith = Debug.showTreeWith +-- | This function has moved to 'Data.Map.Internal.Debug.showTreeWith'. +showTreeWith :: + Whoops "showTreeWith has moved to Data.Map.Internal.Debug.showTreeWith." + => (k -> a -> String) -> Bool -> Bool -> Map k a -> String +showTreeWith _ _ _ _ = undefined diff --git a/Data/Map/Lazy.hs b/Data/Map/Lazy.hs --- a/Data/Map/Lazy.hs +++ b/Data/Map/Lazy.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 703 +#if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif @@ -88,32 +88,35 @@ -- * Map type Map -- instance Eq,Show,Read - -- * Operators - , (!), (!?), (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - -- * Construction , empty , singleton + , fromSet - -- ** Insertion + -- ** From Unordered Lists + , fromList + , fromListWith + , fromListWithKey + + -- ** From Ascending Lists + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- ** From Descending Lists + , fromDescList + , fromDescListWith + , fromDescListWithKey + , fromDistinctDescList + + -- * Insertion , insert , insertWith , insertWithKey , insertLookupWithKey - -- ** Delete\/Update + -- * Deletion\/Update , delete , adjust , adjustWithKey @@ -123,6 +126,23 @@ , alter , alterF + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , null + , size + -- * Combine -- ** Union @@ -134,6 +154,7 @@ -- ** Difference , difference + , (\\) , differenceWith , differenceWithKey @@ -180,25 +201,13 @@ , keys , assocs , keysSet - , fromSet -- ** Lists , toList - , fromList - , fromListWith - , fromListWithKey -- ** Ordered lists , toAscList , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - , fromDescList - , fromDescListWith - , fromDescListWithKey - , fromDistinctDescList -- * Filter , filter @@ -253,8 +262,10 @@ , maxViewWithKey -- * Debugging +#ifdef __GLASGOW_HASKELL__ , showTree , showTreeWith +#endif , valid ) where diff --git a/Data/Map/Lazy/Merge.hs b/Data/Map/Lazy/Merge.hs deleted file mode 100644 --- a/Data/Map/Lazy/Merge.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Safe #-} -#endif - -#include "containers.h" - -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Map.Lazy.Merge --- Copyright : (c) David Feuer 2016 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This module defines an API for writing functions that merge two --- maps. The key functions are 'merge' and 'mergeA'. --- Each of these can be used with several different "merge tactics". --- --- The 'merge' and 'mergeA' functions are shared by --- the lazy and strict modules. Only the choice of merge tactics --- determines strictness. If you use 'Data.Map.Strict.Merge.mapMissing' --- from "Data.Map.Strict.Merge" then the results will be forced before --- they are inserted. If you use 'Data.Map.Lazy.Merge.mapMissing' from --- this module then they will not. --- --- == Efficiency note --- --- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' --- tactics are included because they are valid. However, they are --- inefficient in many cases and should usually be avoided. The instances --- for 'WhenMatched' tactics should not pose any major efficiency problems. - -module Data.Map.Lazy.Merge {-# DEPRECATED "Use \"Data.Map.Merge.Lazy\"." #-} - ( module Data.Map.Merge.Lazy ) where - -import Data.Map.Merge.Lazy diff --git a/Data/Map/Merge/Lazy.hs b/Data/Map/Merge/Lazy.hs --- a/Data/Map/Merge/Lazy.hs +++ b/Data/Map/Merge/Lazy.hs @@ -3,7 +3,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 708 diff --git a/Data/Map/Merge/Strict.hs b/Data/Map/Merge/Strict.hs --- a/Data/Map/Merge/Strict.hs +++ b/Data/Map/Merge/Strict.hs @@ -3,7 +3,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 708 diff --git a/Data/Map/Strict.hs b/Data/Map/Strict.hs --- a/Data/Map/Strict.hs +++ b/Data/Map/Strict.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ >= 703 +#if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif @@ -71,8 +71,8 @@ -- The 'Map' type is shared between the lazy and strict modules, meaning that -- the same 'Map' value can be passed to functions in both modules. This means -- that the 'Functor', 'Traversable' and 'Data' instances are the same as for --- the "Data.Map.Lazy" module, so if they are used on strict maps, the resulting --- maps may contain suspended values (thunks). +-- the "Data.Map.Lazy" module, so if they are used the resulting maps may contain +-- suspended values (thunks). -- -- -- == Implementation @@ -104,32 +104,35 @@ -- * Map type Map -- instance Eq,Show,Read - -- * Operators - , (!), (!?), (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - -- * Construction , empty , singleton + , fromSet - -- ** Insertion + -- ** From Unordered Lists + , fromList + , fromListWith + , fromListWithKey + + -- ** From Ascending Lists + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- ** From Descending Lists + , fromDescList + , fromDescListWith + , fromDescListWithKey + , fromDistinctDescList + + -- * Insertion , insert , insertWith , insertWithKey , insertLookupWithKey - -- ** Delete\/Update + -- * Deletion\/Update , delete , adjust , adjustWithKey @@ -139,6 +142,23 @@ , alter , alterF + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , null + , size + -- * Combine -- ** Union @@ -150,6 +170,7 @@ -- ** Difference , difference + , (\\) , differenceWith , differenceWithKey @@ -196,25 +217,13 @@ , keys , assocs , keysSet - , fromSet -- ** Lists , toList - , fromList - , fromListWith - , fromListWithKey -- ** Ordered lists , toAscList , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - , fromDescList - , fromDescListWith - , fromDescListWithKey - , fromDistinctDescList -- * Filter , filter @@ -270,8 +279,10 @@ , maxViewWithKey -- * Debugging +#ifdef __GLASGOW_HASKELL__ , showTree , showTreeWith +#endif , valid ) where diff --git a/Data/Map/Strict/Internal.hs b/Data/Map/Strict/Internal.hs --- a/Data/Map/Strict/Internal.hs +++ b/Data/Map/Strict/Internal.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ >= 703 +#if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_HADDOCK not-home #-} @@ -292,8 +292,10 @@ , maxViewWithKey -- * Debugging +#if defined(__GLASGOW_HASKELL__) , showTree , showTreeWith +#endif , valid ) where @@ -397,7 +399,9 @@ , unions , withoutKeys ) +#if defined(__GLASGOW_HASKELL__) import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith) +#endif import Data.Map.Internal.Debug (valid) import Control.Applicative (Const (..), liftA3) @@ -406,7 +410,6 @@ #endif import qualified Data.Set.Internal as Set import qualified Data.Map.Internal as L -import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair import Data.Bits (shiftL, shiftR) @@ -418,6 +421,8 @@ import Data.Functor.Identity (Identity (..)) #endif +import qualified Data.Foldable as Foldable +import Data.Foldable (Foldable()) -- $strictness -- @@ -951,9 +956,9 @@ -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a +unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a unionsWith f ts - = foldlStrict (unionWith f) empty ts + = Foldable.foldl' (unionWith f) empty ts #if __GLASGOW_HASKELL__ {-# INLINABLE unionsWith #-} #endif @@ -1374,7 +1379,7 @@ #endif -- | /O(n)/. --- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' `seq` (k,v')) <$> f k v) ('toList' m)@ +-- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' \`seq\` (k,v')) <$> f k v) ('toList' m)@ -- That is, it behaves much like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value and the values are -- forced before they are installed in the result map. @@ -1487,7 +1492,7 @@ not_ordered kx ((ky,_) : _) = kx >= ky {-# INLINE not_ordered #-} - fromList' t0 xs = foldlStrict ins t0 xs + fromList' t0 xs = Foldable.foldl' ins t0 xs where ins t (k,x) = insert k x t go !_ t [] = t @@ -1536,7 +1541,7 @@ fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a fromListWithKey f xs - = foldlStrict ins empty xs + = Foldable.foldl' ins empty xs where ins t (k,x) = insertWithKey f k x t #if __GLASGOW_HASKELL__ diff --git a/Data/Map/Strict/Merge.hs b/Data/Map/Strict/Merge.hs deleted file mode 100644 --- a/Data/Map/Strict/Merge.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Safe #-} -#endif - -#include "containers.h" - -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Map.Strict.Merge --- Copyright : (c) David Feuer 2016 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This module defines an API for writing functions that merge two --- maps. The key functions are 'merge' and 'mergeA'. --- Each of these can be used with several different "merge tactics". --- --- The 'merge' and 'mergeA' functions are shared by --- the lazy and strict modules. Only the choice of merge tactics --- determines strictness. If you use 'Data.Map.Strict.Merge.mapMissing' --- from this module then the results will be forced before they are --- inserted. If you use 'Data.Map.Lazy.Merge.mapMissing' from --- "Data.Map.Lazy.Merge" then they will not. --- --- == Efficiency note --- --- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' --- tactics are included because they are valid. However, they are --- inefficient in many cases and should usually be avoided. The instances --- for 'WhenMatched' tactics should not pose any major efficiency problems. - -module Data.Map.Strict.Merge {-# DEPRECATED "Use \"Data.Map.Merge.Strict\"." #-} - ( module Data.Map.Merge.Strict ) where - -import Data.Map.Merge.Strict diff --git a/Data/Sequence.hs b/Data/Sequence.hs --- a/Data/Sequence.hs +++ b/Data/Sequence.hs @@ -65,7 +65,7 @@ -- -- but -- --- @ (1 :<| undefined) `index` 0 = undefined @ +-- @ (1 :<| undefined) ``index`` 0 = undefined @ -- -- Sequences may also be compared to immutable -- [arrays](https://hackage.haskell.org/package/array) diff --git a/Data/Sequence/Internal.hs b/Data/Sequence/Internal.hs --- a/Data/Sequence/Internal.hs +++ b/Data/Sequence/Internal.hs @@ -3,17 +3,13 @@ {-# LANGUAGE BangPatterns #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -#endif -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif #ifdef DEFINE_PATTERN_SYNONYMS {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} @@ -214,11 +210,7 @@ import Data.Monoid (Monoid(..)) import Data.Functor (Functor(..)) import Utils.Containers.Internal.State (State(..), execState) -#if MIN_VERSION_base(4,6,0) import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList) -#else -import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap), foldl', toList) -#endif #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Semigroup @@ -235,10 +227,8 @@ import Data.Data import Data.String (IsString(..)) #endif -#if __GLASGOW_HASKELL__ >= 706 +#if __GLASGOW_HASKELL__ import GHC.Generics (Generic, Generic1) -#elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) #endif -- Array stuff, with GHC.Arr on GHC @@ -248,6 +238,7 @@ import qualified GHC.Arr #endif +import Utils.Containers.Internal.Coercions ((.#), (.^#)) -- Coercion on GHC 7.8+ #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce @@ -265,9 +256,7 @@ #endif import Utils.Containers.Internal.StrictPair (StrictPair (..), toPair) -#if MIN_VERSION_base(4,4,0) import Control.Monad.Zip (MonadZip (..)) -#endif import Control.Monad.Fix (MonadFix (..), fix) default () @@ -385,20 +374,26 @@ #-} #endif +getSeq :: Seq a -> FingerTree (Elem a) +getSeq (Seq xs) = xs + instance Foldable Seq where - foldMap f (Seq xs) = foldMap (foldMap f) xs -#if __GLASGOW_HASKELL__ >= 708 - foldr f z (Seq xs) = foldr (coerce f) z xs - foldr' f z (Seq xs) = foldr' (coerce f) z xs -#else - foldr f z (Seq xs) = foldr (flip (foldr f)) z xs -#if MIN_VERSION_base(4,6,0) - foldr' f z (Seq xs) = foldr' (flip (foldr' f)) z xs -#endif + foldMap f = foldMap (f .# getElem) .# getSeq + foldr f z = foldr (f .# getElem) z .# getSeq + foldl f z = foldl (f .^# getElem) z .# getSeq + +#if __GLASGOW_HASKELL__ + {-# INLINABLE foldMap #-} + {-# INLINABLE foldr #-} + {-# INLINABLE foldl #-} #endif - foldl f z (Seq xs) = foldl (foldl f) z xs -#if MIN_VERSION_base(4,6,0) - foldl' f z (Seq xs) = foldl' (foldl' f) z xs + + foldr' f z = foldr' (f .# getElem) z .# getSeq + foldl' f z = foldl' (f .^# getElem) z .# getSeq + +#if __GLASGOW_HASKELL__ + {-# INLINABLE foldr' #-} + {-# INLINABLE foldl' #-} #endif foldr1 f (Seq xs) = getElem (foldr1 f' xs) @@ -414,29 +409,81 @@ {-# INLINE null #-} #endif -#if __GLASGOW_HASKELL__ >= 708 --- The natural definition of traverse, used for implementations that don't --- support coercions, `fmap`s into each `Elem`, then `fmap`s again over the --- result to turn it from a `FingerTree` to a `Seq`. None of this mapping is --- necessary! We could avoid it without coercions, I believe, by writing a --- bunch of traversal functions to deal with the `Elem` stuff specially (for --- FingerTrees, Digits, and Nodes), but using coercions we only need to --- duplicate code at the FingerTree level. We coerce the `Seq a` to a --- `FingerTree a`, stripping off all the Elem junk, then use a weird FingerTree --- traversing function that coerces back to Seq within the functor. instance Traversable Seq where - traverse f xs = traverseFTE f (coerce xs) - -traverseFTE :: Applicative f => (a -> f b) -> FingerTree a -> f (Seq b) -traverseFTE _f EmptyT = pure empty -traverseFTE f (Single x) = Seq . Single . Elem <$> f x -traverseFTE f (Deep s pr m sf) = - liftA3 (\pr' m' sf' -> coerce $ Deep s pr' m' sf') - (traverse f pr) (traverse (traverse f) m) (traverse f sf) -#else -instance Traversable Seq where - traverse f (Seq xs) = Seq <$> traverse (traverse f) xs +#if __GLASGOW_HASKELL__ + {-# INLINABLE traverse #-} #endif + traverse _ (Seq EmptyT) = pure (Seq EmptyT) + traverse f' (Seq (Single (Elem x'))) = + (\x'' -> Seq (Single (Elem x''))) <$> f' x' + traverse f' (Seq (Deep s' pr' m' sf')) = + liftA3 + (\pr'' m'' sf'' -> Seq (Deep s' pr'' m'' sf'')) + (traverseDigitE f' pr') + (traverseTree (traverseNodeE f') m') + (traverseDigitE f' sf') + where + traverseTree + :: Applicative f + => (Node a -> f (Node b)) + -> FingerTree (Node a) + -> f (FingerTree (Node b)) + traverseTree _ EmptyT = pure EmptyT + traverseTree f (Single x) = Single <$> f x + traverseTree f (Deep s pr m sf) = + liftA3 + (Deep s) + (traverseDigitN f pr) + (traverseTree (traverseNodeN f) m) + (traverseDigitN f sf) + traverseDigitE + :: Applicative f + => (a -> f b) -> Digit (Elem a) -> f (Digit (Elem b)) + traverseDigitE f (One (Elem a)) = + (\a' -> One (Elem a')) <$> + f a + traverseDigitE f (Two (Elem a) (Elem b)) = + liftA2 + (\a' b' -> Two (Elem a') (Elem b')) + (f a) + (f b) + traverseDigitE f (Three (Elem a) (Elem b) (Elem c)) = + liftA3 + (\a' b' c' -> + Three (Elem a') (Elem b') (Elem c')) + (f a) + (f b) + (f c) + traverseDigitE f (Four (Elem a) (Elem b) (Elem c) (Elem d)) = + liftA3 + (\a' b' c' d' -> Four (Elem a') (Elem b') (Elem c') (Elem d')) + (f a) + (f b) + (f c) <*> + (f d) + traverseDigitN + :: Applicative f + => (Node a -> f (Node b)) -> Digit (Node a) -> f (Digit (Node b)) + traverseDigitN f t = traverse f t + traverseNodeE + :: Applicative f + => (a -> f b) -> Node (Elem a) -> f (Node (Elem b)) + traverseNodeE f (Node2 s (Elem a) (Elem b)) = + liftA2 + (\a' b' -> Node2 s (Elem a') (Elem b')) + (f a) + (f b) + traverseNodeE f (Node3 s (Elem a) (Elem b) (Elem c)) = + liftA3 + (\a' b' c' -> + Node3 s (Elem a') (Elem b') (Elem c')) + (f a) + (f b) + (f c) + traverseNodeN + :: Applicative f + => (Node a -> f (Node b)) -> Node (Node a) -> f (Node (Node b)) + traverseNodeN f t = traverse f t instance NFData a => NFData (Seq a) where rnf (Seq xs) = rnf xs @@ -885,6 +932,14 @@ deriving Show #endif +#ifdef __GLASGOW_HASKELL__ +-- | @since 0.6.1 +deriving instance Generic1 FingerTree + +-- | @since 0.6.1 +deriving instance Generic (FingerTree a) +#endif + instance Sized a => Sized (FingerTree a) where {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-} {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-} @@ -894,34 +949,125 @@ instance Foldable FingerTree where foldMap _ EmptyT = mempty - foldMap f (Single x) = f x - foldMap f (Deep _ pr m sf) = - foldMap f pr <> foldMap (foldMap f) m <> foldMap f sf + foldMap f' (Single x') = f' x' + foldMap f' (Deep _ pr' m' sf') = + foldMapDigit f' pr' <> + foldMapTree (foldMapNode f') m' <> + foldMapDigit f' sf' + where + foldMapTree :: Monoid m => (Node a -> m) -> FingerTree (Node a) -> m + foldMapTree _ EmptyT = mempty + foldMapTree f (Single x) = f x + foldMapTree f (Deep _ pr m sf) = + foldMapDigitN f pr <> + foldMapTree (foldMapNodeN f) m <> + foldMapDigitN f sf - foldr _ z EmptyT = z - foldr f z (Single x) = x `f` z - foldr f z (Deep _ pr m sf) = - foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr + foldMapDigit :: Monoid m => (a -> m) -> Digit a -> m + foldMapDigit f t = foldDigit (<>) f t - foldl _ z EmptyT = z - foldl f z (Single x) = z `f` x - foldl f z (Deep _ pr m sf) = - foldl f (foldl (foldl f) (foldl f z pr) m) sf + foldMapDigitN :: Monoid m => (Node a -> m) -> Digit (Node a) -> m + foldMapDigitN f t = foldDigit (<>) f t -#if MIN_VERSION_base(4,6,0) - foldr' _ z EmptyT = z - foldr' f z (Single x) = f x z - foldr' f z (Deep _ pr m sf) = foldr' f mres pr - where !sfRes = foldr' f z sf - !mres = foldr' (flip (foldr' f)) sfRes m + foldMapNode :: Monoid m => (a -> m) -> Node a -> m + foldMapNode f t = foldNode (<>) f t - foldl' _ z EmptyT = z - foldl' f z (Single x) = z `f` x - foldl' f z (Deep _ pr m sf) = foldl' f mres sf - where !prRes = foldl' f z pr - !mres = foldl' (foldl' f) prRes m + foldMapNodeN :: Monoid m => (Node a -> m) -> Node (Node a) -> m + foldMapNodeN f t = foldNode (<>) f t +#if __GLASGOW_HASKELL__ + {-# INLINABLE foldMap #-} #endif + foldr _ z' EmptyT = z' + foldr f' z' (Single x') = x' `f'` z' + foldr f' z' (Deep _ pr' m' sf') = + foldrDigit f' (foldrTree (foldrNode f') (foldrDigit f' z' sf') m') pr' + where + foldrTree :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b + foldrTree _ z EmptyT = z + foldrTree f z (Single x) = x `f` z + foldrTree f z (Deep _ pr m sf) = + foldrDigitN f (foldrTree (foldrNodeN f) (foldrDigitN f z sf) m) pr + + foldrDigit :: (a -> b -> b) -> b -> Digit a -> b + foldrDigit f z t = foldr f z t + + foldrDigitN :: (Node a -> b -> b) -> b -> Digit (Node a) -> b + foldrDigitN f z t = foldr f z t + + foldrNode :: (a -> b -> b) -> Node a -> b -> b + foldrNode f t z = foldr f z t + + foldrNodeN :: (Node a -> b -> b) -> Node (Node a) -> b -> b + foldrNodeN f t z = foldr f z t + {-# INLINE foldr #-} + + + foldl _ z' EmptyT = z' + foldl f' z' (Single x') = z' `f'` x' + foldl f' z' (Deep _ pr' m' sf') = + foldlDigit f' (foldlTree (foldlNode f') (foldlDigit f' z' pr') m') sf' + where + foldlTree :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b + foldlTree _ z EmptyT = z + foldlTree f z (Single x) = z `f` x + foldlTree f z (Deep _ pr m sf) = + foldlDigitN f (foldlTree (foldlNodeN f) (foldlDigitN f z pr) m) sf + + foldlDigit :: (b -> a -> b) -> b -> Digit a -> b + foldlDigit f z t = foldl f z t + + foldlDigitN :: (b -> Node a -> b) -> b -> Digit (Node a) -> b + foldlDigitN f z t = foldl f z t + + foldlNode :: (b -> a -> b) -> b -> Node a -> b + foldlNode f z t = foldl f z t + + foldlNodeN :: (b -> Node a -> b) -> b -> Node (Node a) -> b + foldlNodeN f z t = foldl f z t + {-# INLINE foldl #-} + + foldr' _ z' EmptyT = z' + foldr' f' z' (Single x') = f' x' z' + foldr' f' z' (Deep _ pr' m' sf') = + (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr' + where + foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b + foldrTree' _ z EmptyT = z + foldrTree' f z (Single x) = f x $! z + foldrTree' f z (Deep _ pr m sf) = + (foldr' f $! (foldrTree' (foldrNodeN' f) $! (foldr' f $! z) sf) m) pr + + foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b + foldrDigit' f z t = foldr' f z t + + foldrNode' :: (a -> b -> b) -> Node a -> b -> b + foldrNode' f t z = foldr' f z t + + foldrNodeN' :: (Node a -> b -> b) -> Node (Node a) -> b -> b + foldrNodeN' f t z = foldr' f z t + {-# INLINE foldr' #-} + + foldl' _ z' EmptyT = z' + foldl' f' z' (Single x') = f' z' x' + foldl' f' z' (Deep _ pr' m' sf') = + (foldlDigit' f' $! + (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m') + sf' + where + foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b + foldlTree' _ z EmptyT = z + foldlTree' f z (Single xs) = f z xs + foldlTree' f z (Deep _ pr m sf) = + (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf + + foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b + foldlDigit' f z t = foldl' f z t + + foldlNode' :: (b -> a -> b) -> b -> Node a -> b + foldlNode' f z t = foldl' f z t + {-# INLINE foldl' #-} + foldr1 _ EmptyT = error "foldr1: empty sequence" foldr1 _ (Single x) = x foldr1 f (Deep _ pr m sf) = @@ -977,6 +1123,14 @@ deriving Show #endif +#ifdef __GLASGOW_HASKELL__ +-- | @since 0.6.1 +deriving instance Generic1 Digit + +-- | @since 0.6.1 +deriving instance Generic (Digit a) +#endif + foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b foldDigit _ f (One a) = f a foldDigit (<+>) f (Two a b) = f a <+> f b @@ -991,23 +1145,25 @@ foldr f z (Two a b) = a `f` (b `f` z) foldr f z (Three a b c) = a `f` (b `f` (c `f` z)) foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z))) + {-# INLINE foldr #-} foldl f z (One a) = z `f` a foldl f z (Two a b) = (z `f` a) `f` b foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d + {-# INLINE foldl #-} -#if MIN_VERSION_base(4,6,0) - foldr' f z (One a) = a `f` z + foldr' f z (One a) = f a z foldr' f z (Two a b) = f a $! f b z foldr' f z (Three a b c) = f a $! f b $! f c z foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z + {-# INLINE foldr' #-} foldl' f z (One a) = f z a foldl' f z (Two a b) = (f $! f z a) b foldl' f z (Three a b c) = (f $! (f $! f z a) b) c foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d -#endif + {-# INLINE foldl' #-} foldr1 _ (One a) = a foldr1 f (Two a b) = a `f` b @@ -1068,6 +1224,14 @@ deriving Show #endif +#ifdef __GLASGOW_HASKELL__ +-- | @since 0.6.1 +deriving instance Generic1 Node + +-- | @since 0.6.1 +deriving instance Generic (Node a) +#endif + foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b foldNode (<+>) f (Node2 _ a b) = f a <+> f b foldNode (<+>) f (Node3 _ a b c) = f a <+> f b <+> f c @@ -1078,17 +1242,19 @@ foldr f z (Node2 _ a b) = a `f` (b `f` z) foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z)) + {-# INLINE foldr #-} foldl f z (Node2 _ a b) = (z `f` a) `f` b foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c + {-# INLINE foldl #-} -#if MIN_VERSION_base(4,6,0) foldr' f z (Node2 _ a b) = f a $! f b z foldr' f z (Node3 _ a b c) = f a $! f b $! f c z + {-# INLINE foldr' #-} foldl' f z (Node2 _ a b) = (f $! f z a) b foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c -#endif + {-# INLINE foldl' #-} instance Functor Node where {-# INLINE fmap #-} @@ -1127,6 +1293,14 @@ deriving Show #endif +#ifdef __GLASGOW_HASKELL__ +-- | @since 0.6.1 +deriving instance Generic1 Elem + +-- | @since 0.6.1 +deriving instance Generic (Elem a) +#endif + instance Sized (Elem a) where size _ = 1 @@ -1147,10 +1321,8 @@ #else foldMap f (Elem x) = f x foldl f z (Elem x) = f z x -#if MIN_VERSION_base(4,6,0) foldl' f z (Elem x) = f z x #endif -#endif instance Traversable Elem where traverse f (Elem x) = Elem <$> f x @@ -1698,14 +1870,12 @@ | a :< Seq a -- ^ leftmost element and the rest of the sequence deriving (Eq, Ord, Show, Read) -#if __GLASGOW_HASKELL__ +#ifdef __GLASGOW_HASKELL__ deriving instance Data a => Data (ViewL a) -#endif -#if __GLASGOW_HASKELL__ >= 706 + -- | @since 0.5.8 deriving instance Generic1 ViewL -#endif -#if __GLASGOW_HASKELL__ >= 702 + -- | @since 0.5.8 deriving instance Generic (ViewL a) #endif @@ -1765,14 +1935,12 @@ -- and the rightmost element deriving (Eq, Ord, Show, Read) -#if __GLASGOW_HASKELL__ +#ifdef __GLASGOW_HASKELL__ deriving instance Data a => Data (ViewR a) -#endif -#if __GLASGOW_HASKELL__ >= 706 + -- | @since 0.5.8 deriving instance Generic1 ViewR -#endif -#if __GLASGOW_HASKELL__ >= 702 + -- | @since 0.5.8 deriving instance Generic (ViewR a) #endif @@ -4168,8 +4336,6 @@ -- Zipping ------------------------------------------------------------------------ --- MonadZip appeared in base 4.4.0 -#if MIN_VERSION_base(4,4,0) -- We use a custom definition of munzip to avoid retaining -- memory longer than necessary. Using the default definition, if -- we write @@ -4188,12 +4354,11 @@ instance MonadZip Seq where mzipWith = zipWith munzip = unzip -#endif -- | Unzip a sequence of pairs. -- -- @ --- unzip ps = ps `'seq'` ('fmap' 'fst' ps) ('fmap' 'snd' ps) +-- unzip ps = ps ``seq`` ('fmap' 'fst' ps) ('fmap' 'snd' ps) -- @ -- -- Example: diff --git a/Data/Sequence/Internal/Sorting.hs b/Data/Sequence/Internal/Sorting.hs --- a/Data/Sequence/Internal/Sorting.hs +++ b/Data/Sequence/Internal/Sorting.hs @@ -78,12 +78,16 @@ -- | \( O(n \log n) \). 'sort' sorts the specified 'Seq' by the natural -- ordering of its elements. The sort is stable. If stability is not -- required, 'unstableSort' can be slightly faster. +-- +-- @since 0.3.0 sort :: Ord a => Seq a -> Seq a sort = sortBy compare -- | \( O(n \log n) \). 'sortBy' sorts the specified 'Seq' according to the -- specified comparator. The sort is stable. If stability is not required, -- 'unstableSortBy' can be slightly faster. +-- +-- @since 0.3.0 sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a sortBy cmp (Seq xs) = maybe @@ -110,6 +114,8 @@ -- If @f@ is very cheap (for example a record selector, or 'fst'), -- @'sortBy' ('compare' ``Data.Function.on`` f)@ will be faster than -- @'sortOn' f@. +-- +-- @since 0.5.11 sortOn :: Ord b => (a -> b) -> Seq a -> Seq a sortOn f (Seq xs) = maybe @@ -123,6 +129,8 @@ -- Notes on the implementation and choice of heap are available in -- the file sorting.md (in this directory). +-- +-- @since 0.3.0 unstableSort :: Ord a => Seq a -> Seq a unstableSort = unstableSortBy compare @@ -130,6 +138,8 @@ -- takes an arbitrary comparator and sorts the specified sequence. -- The sort is not stable. This algorithm is frequently faster and -- uses less memory than 'sortBy'. +-- +-- @since 0.3.0 unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a unstableSortBy cmp (Seq xs) = maybe @@ -156,6 +166,8 @@ -- If @f@ is very cheap (for example a record selector, or 'fst'), -- @'unstableSortBy' ('compare' ``Data.Function.on`` f)@ will be faster than -- @'unstableSortOn' f@. +-- +-- @since 0.5.11 unstableSortOn :: Ord b => (a -> b) -> Seq a -> Seq a unstableSortOn f (Seq xs) = maybe diff --git a/Data/Set.hs b/Data/Set.hs --- a/Data/Set.hs +++ b/Data/Set.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif @@ -72,33 +72,40 @@ Set(..) #endif - -- * Operators - , (\\) + -- * Construction + , empty + , singleton + , fromList + , fromAscList + , fromDescList + , fromDistinctAscList + , fromDistinctDescList + , powerSet + -- * Insertion + , insert + + -- * Deletion + , delete + -- * Query - , S.null - , size , member , notMember , lookupLT , lookupGT , lookupLE , lookupGE + , S.null + , size , isSubsetOf , isProperSubsetOf , disjoint - -- * Construction - , empty - , singleton - , insert - , delete - , powerSet - -- * Combine , union , unions , difference + , (\\) , intersection , cartesianProduct , disjointUnion @@ -152,15 +159,8 @@ -- ** List , elems , toList - , fromList - - -- ** Ordered list , toAscList , toDescList - , fromAscList - , fromDescList - , fromDistinctAscList - , fromDistinctDescList -- * Debugging , showTree diff --git a/Data/Set/Internal.hs b/Data/Set/Internal.hs --- a/Data/Set/Internal.hs +++ b/Data/Set/Internal.hs @@ -4,7 +4,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 @@ -246,7 +246,6 @@ import Data.Typeable import Control.DeepSeq (NFData(rnf)) -import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair import Utils.Containers.Internal.PtrEquality @@ -318,13 +317,10 @@ go (Bin 1 k _ _) = f k go (Bin _ k l r) = go l `mappend` (f k `mappend` go r) {-# INLINE foldMap #-} - -#if MIN_VERSION_base(4,6,0) foldl' = foldl' {-# INLINE foldl' #-} foldr' = foldr' {-# INLINE foldr' #-} -#endif #if MIN_VERSION_base(4,8,0) length = size {-# INLINE length #-} @@ -604,7 +600,7 @@ -- | /O(n+m)/. Is this a subset? --- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. +-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@. isSubsetOf :: Ord a => Set a -> Set a -> Bool isSubsetOf t1 t2 = (size t1 <= size t2) && (isSubsetOfX t1 t2) @@ -705,8 +701,8 @@ Union. --------------------------------------------------------------------} -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). -unions :: Ord a => [Set a] -> Set a -unions = foldlStrict union empty +unions :: (Foldable f, Ord a) => f (Set a) -> Set a +unions = Foldable.foldl' union empty #if __GLASGOW_HASKELL__ {-# INLINABLE unions #-} #endif @@ -715,8 +711,8 @@ -- equal elements are encountered. union :: Ord a => Set a -> Set a -> Set a union t1 Tip = t1 -union t1 (Bin _ x Tip Tip) = insertR x t1 -union (Bin _ x Tip Tip) t2 = insert x t2 +union t1 (Bin 1 x _ _) = insertR x t1 +union (Bin 1 x _ _) t2 = insert x t2 union Tip t2 = t2 union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of (l2 :*: r2) @@ -973,7 +969,7 @@ not_ordered x (y : _) = x >= y {-# INLINE not_ordered #-} - fromList' t0 xs = foldlStrict ins t0 xs + fromList' t0 xs = Foldable.foldl' ins t0 xs where ins t x = insert x t go !_ t [] = t @@ -1695,7 +1691,7 @@ -- | Calculate the power set of a set: the set of all its subsets. -- -- @ --- t `member` powerSet s == t `isSubsetOf` s +-- t ``member`` powerSet s == t ``isSubsetOf`` s -- @ -- -- Example: @@ -1748,9 +1744,9 @@ mappend (MergeSet xs) (MergeSet ys) = MergeSet (merge xs ys) #endif --- | Calculate the disjoin union of two sets. +-- | Calculate the disjoint union of two sets. -- --- @ disjointUnion xs ys = map Left xs `union` map Right ys @ +-- @ disjointUnion xs ys = map Left xs ``union`` map Right ys @ -- -- Example: -- diff --git a/Data/Tree.hs b/Data/Tree.hs --- a/Data/Tree.hs +++ b/Data/Tree.hs @@ -2,11 +2,7 @@ {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} -#endif -#if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif @@ -21,20 +17,38 @@ -- Maintainer : libraries@haskell.org -- Portability : portable -- --- Multi-way trees (/aka/ rose trees) and forests. +-- = Multi-way Trees and Forests -- +-- The @'Tree' a@ type represents a lazy, possibly infinite, multi-way tree +-- (also known as a /rose tree/). +-- +-- The @'Forest' a@ type represents a forest of @'Tree' a@s. +-- ----------------------------------------------------------------------------- module Data.Tree( - Tree(..), Forest, - -- * Two-dimensional drawing - drawTree, drawForest, - -- * Extraction - flatten, levels, foldTree, - -- * Building trees - unfoldTree, unfoldForest, - unfoldTreeM, unfoldForestM, - unfoldTreeM_BF, unfoldForestM_BF, + + -- * Trees and Forests + Tree(..) + , Forest + + -- * Construction + , unfoldTree + , unfoldForest + , unfoldTreeM + , unfoldForestM + , unfoldTreeM_BF + , unfoldForestM_BF + + -- * Elimination + , foldTree + , flatten + , levels + + -- * Ascii Drawings + , drawTree + , drawForest + ) where #if MIN_VERSION_base(4,8,0) @@ -56,16 +70,10 @@ #ifdef __GLASGOW_HASKELL__ import Data.Data (Data) -#endif -#if __GLASGOW_HASKELL__ >= 706 import GHC.Generics (Generic, Generic1) -#elif __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) #endif -#if MIN_VERSION_base(4,4,0) import Control.Monad.Zip (MonadZip (..)) -#endif #if MIN_VERSION_base(4,8,0) import Data.Coerce @@ -80,13 +88,12 @@ import Data.Functor ((<$)) #endif --- | Multi-way trees, also known as /rose trees/. +-- | Non-empty, possibly infinite, multi-way trees; also known as /rose trees/. data Tree a = Node { rootLabel :: a, -- ^ label value subForest :: Forest a -- ^ zero or more child trees } #ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 802 deriving ( Eq , Read , Show @@ -94,16 +101,10 @@ , Generic -- ^ @since 0.5.8 , Generic1 -- ^ @since 0.5.8 ) -#elif __GLASGOW_HASKELL__ >= 706 - deriving (Eq, Read, Show, Data, Generic, Generic1) -#elif __GLASGOW_HASKELL__ >= 702 - deriving (Eq, Read, Show, Data, Generic) #else - deriving (Eq, Read, Show, Data) -#endif -#else deriving (Eq, Read, Show) #endif + type Forest a = [Tree a] #if MIN_VERSION_base(4,9,0) @@ -204,20 +205,48 @@ instance NFData a => NFData (Tree a) where rnf (Node x ts) = rnf x `seq` rnf ts -#if MIN_VERSION_base(4,4,0) instance MonadZip Tree where mzipWith f (Node a as) (Node b bs) = Node (f a b) (mzipWith (mzipWith f) as bs) munzip (Node (a, b) ts) = (Node a as, Node b bs) where (as, bs) = munzip (map munzip ts) -#endif --- | Neat 2-dimensional drawing of a tree. +-- | 2-dimensional ASCII drawing of a tree. +-- +-- ==== __Examples__ +-- +-- > putStr $ drawTree $ fmap show (Node 1 [Node 2 [], Node 3 []]) +-- +-- @ +-- 1 +-- | +-- +- 2 +-- | +-- `- 3 +-- @ +-- drawTree :: Tree String -> String drawTree = unlines . draw --- | Neat 2-dimensional drawing of a forest. +-- | 2-dimensional ASCII drawing of a forest. +-- +-- ==== __Examples__ +-- +-- > putStr $ drawForest $ map (fmap show) [(Node 1 [Node 2 [], Node 3 []]), (Node 10 [Node 20 []])] +-- +-- @ +-- 1 +-- | +-- +- 2 +-- | +-- `- 3 +-- +-- 10 +-- | +-- `- 20 +-- @ +-- drawForest :: Forest String -> String drawForest = unlines . map drawTree @@ -232,34 +261,112 @@ shift first other = zipWith (++) (first : repeat other) --- | The elements of a tree in pre-order. +-- | Returns the elements of a tree in pre-order. +-- +-- @ +-- +-- a +-- / \\ => [a,b,c] +-- b c +-- @ +-- +-- ==== __Examples__ +-- +-- > flatten (Node 1 [Node 2 [], Node 3 []]) == [1,2,3] flatten :: Tree a -> [a] flatten t = squish t [] where squish (Node x ts) xs = x:Prelude.foldr squish xs ts --- | Lists of nodes at each level of the tree. +-- | Returns the list of nodes at each level of the tree. +-- +-- @ +-- +-- a +-- / \\ => [[a], [b,c]] +-- b c +-- @ +-- +-- ==== __Examples__ +-- +-- > levels (Node 1 [Node 2 [], Node 3 []]) == [[1],[2,3]] +-- levels :: Tree a -> [[a]] levels t = map (map rootLabel) $ takeWhile (not . null) $ iterate (concatMap subForest) [t] --- | Catamorphism on trees. +-- | Fold a tree into a "summary" value in depth-first order. -- +-- For each node in the tree, apply @f@ to the @rootLabel@ and the result +-- of applying @f@ to each @subForent@. +-- +-- This is also known as the catamorphism on trees. +-- +-- ==== __Examples__ +-- +-- Sum the values in a tree: +-- +-- > foldTree (\x xs -> sum (x:xs)) (Node 1 [Node 2 [], Node 3 []]) == 6 +-- +-- Find the maximum value in the tree: +-- +-- > foldTree (\x xs -> maximum (x:xs)) (Node 1 [Node 2 [], Node 3 []]) == 3 +-- +-- -- @since 0.5.8 foldTree :: (a -> [b] -> b) -> Tree a -> b foldTree f = go where go (Node x ts) = f x (map go ts) --- | Build a tree from a seed value +-- | Build a (possibly infinite) tree from a seed value in breadth-first order. +-- +-- @unfoldTree f b@ constructs a tree by starting with the tree +-- @Node { rootLabel=b, subForest=[] }@ and repeatedly applying @f@ to each +-- 'rootLabel' value in the tree's leaves to generate its 'subForest'. +-- +-- For a monadic version see 'unfoldTreeM_BF'. +-- +-- ==== __Examples__ +-- +-- Construct the tree of @Integer@s where each node has two children: +-- @left = 2*x@ and @right = 2*x + 1@, where @x@ is the 'rootLabel' of the node. +-- Stop when the values exceed 7. +-- +-- > let buildNode x = if 2*x + 1 > 7 then (x, []) else (x, [2*x, 2*x+1]) +-- > putStr $ drawTree $ fmap show $ unfoldTree buildNode 1 +-- +-- @ +-- +-- 1 +-- | +-- +- 2 +-- | | +-- | +- 4 +-- | | +-- | `- 5 +-- | +-- `- 3 +-- | +-- +- 6 +-- | +-- `- 7 +-- @ +-- unfoldTree :: (b -> (a, [b])) -> b -> Tree a unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs) --- | Build a forest from a list of seed values +-- | Build a (possibly infinite) forest from a list of seed values in +-- breadth-first order. +-- +-- @unfoldForest f seeds@ invokes 'unfoldTree' on each seed value. +-- +-- For a monadic version see 'unfoldForestM_BF'. +-- unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a unfoldForest f = map (unfoldTree f) --- | Monadic tree builder, in depth-first order +-- | Monadic tree builder, in depth-first order. unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) unfoldTreeM f b = do (a, bs) <- f b @@ -270,10 +377,12 @@ unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a) unfoldForestM f = Prelude.mapM (unfoldTreeM f) --- | Monadic tree builder, in breadth-first order, --- using an algorithm adapted from --- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/, --- by Chris Okasaki, /ICFP'00/. +-- | Monadic tree builder, in breadth-first order. +-- +-- See 'unfoldTree' for more info. +-- +-- Implemented using an algorithm adapted from /Breadth-First Numbering: Lessons +-- from a Small Exercise in Algorithm Design/, by Chris Okasaki, /ICFP'00/. unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b) where @@ -281,15 +390,17 @@ x :< _ -> x EmptyL -> error "unfoldTreeM_BF" --- | Monadic forest builder, in breadth-first order, --- using an algorithm adapted from --- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/, --- by Chris Okasaki, /ICFP'00/. +-- | Monadic forest builder, in breadth-first order +-- +-- See 'unfoldForest' for more info. +-- +-- Implemented using an algorithm adapted from /Breadth-First Numbering: Lessons +-- from a Small Exercise in Algorithm Design/, by Chris Okasaki, /ICFP'00/. unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a) unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList --- takes a sequence (queue) of seeds --- produces a sequence (reversed queue) of trees of the same length +-- Takes a sequence (queue) of seeds and produces a sequence (reversed queue) of +-- trees of the same length. unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a)) unfoldForestQ f aQ = case viewl aQ of EmptyL -> return empty diff --git a/Utils/Containers/Internal/BitQueue.hs b/Utils/Containers/Internal/BitQueue.hs --- a/Utils/Containers/Internal/BitQueue.hs +++ b/Utils/Containers/Internal/BitQueue.hs @@ -51,22 +51,11 @@ import Data.Bits ((.|.), (.&.), testBit) #if MIN_VERSION_base(4,8,0) import Data.Bits (countTrailingZeros) -#elif MIN_VERSION_base(4,5,0) +#else import Data.Bits (popCount) #endif -#if !MIN_VERSION_base(4,5,0) --- We could almost certainly improve this fall-back (copied straight from the --- default definition in Data.Bits), but it hardly seems worth the trouble --- to speed things up on GHC 7.4 and below. -countTrailingZeros :: Word -> Int -countTrailingZeros x = go 0 - where - go i | i >= wordSize = i - | testBit x i = i - | otherwise = go (i+1) - -#elif !MIN_VERSION_base(4,8,0) +#if !MIN_VERSION_base(4,8,0) countTrailingZeros :: Word -> Int countTrailingZeros x = popCount ((x .&. (-x)) - 1) {-# INLINE countTrailingZeros #-} diff --git a/Utils/Containers/Internal/BitUtil.hs b/Utils/Containers/Internal/BitUtil.hs --- a/Utils/Containers/Internal/BitUtil.hs +++ b/Utils/Containers/Internal/BitUtil.hs @@ -2,7 +2,7 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-} #endif -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif @@ -39,11 +39,7 @@ ) where import Data.Bits ((.|.), xor) -#if MIN_VERSION_base(4,5,0) import Data.Bits (popCount, unsafeShiftL, unsafeShiftR) -#else -import Data.Bits ((.&.), shiftL, shiftR) -#endif #if MIN_VERSION_base(4,7,0) import Data.Bits (finiteBitSize) #else @@ -67,13 +63,7 @@ ----------------------------------------------------------------------} bitcount :: Int -> Word -> Int -#if MIN_VERSION_base(4,5,0) bitcount a x = a + popCount x -#else -bitcount a0 x0 = go a0 x0 - where go a 0 = a - go a x = go (a + 1) (x .&. (x-1)) -#endif {-# INLINE bitcount #-} -- The highestBitMask implementation is based on @@ -97,13 +87,8 @@ -- Right and left logical shifts. shiftRL, shiftLL :: Word -> Int -> Word -#if MIN_VERSION_base(4,5,0) shiftRL = unsafeShiftR shiftLL = unsafeShiftL -#else -shiftRL = shiftR -shiftLL = shiftL -#endif {-# INLINE wordSize #-} wordSize :: Int diff --git a/Utils/Containers/Internal/Coercions.hs b/Utils/Containers/Internal/Coercions.hs new file mode 100644 --- /dev/null +++ b/Utils/Containers/Internal/Coercions.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} + +#include "containers.h" + +module Utils.Containers.Internal.Coercions where + +#if __GLASGOW_HASKELL__ >= 708 +import Data.Coerce +#endif + +infixl 8 .# +#if __GLASGOW_HASKELL__ >= 708 +(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c +(.#) f _ = coerce f +#else +(.#) :: (b -> c) -> (a -> b) -> a -> c +(.#) = (.) +#endif +{-# INLINE (.#) #-} + +infix 9 .^# + +-- | Coerce the second argument of a function. Conceptually, +-- can be thought of as: +-- +-- @ +-- (f .^# g) x y = f x (g y) +-- @ +-- +-- However it is most useful when coercing the arguments to +-- 'foldl': +-- +-- @ +-- foldl f b . fmap g = foldl (f .^# g) b +-- @ +#if __GLASGOW_HASKELL__ >= 708 +(.^#) :: Coercible c b => (a -> c -> d) -> (b -> c) -> (a -> b -> d) +(.^#) f _ = coerce f +#else +(.^#) :: (a -> c -> d) -> (b -> c) -> (a -> b -> d) +(f .^# g) x y = f x (g y) +#endif +{-# INLINE (.^#) #-} diff --git a/Utils/Containers/Internal/StrictFold.hs b/Utils/Containers/Internal/StrictFold.hs deleted file mode 100644 --- a/Utils/Containers/Internal/StrictFold.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Safe #-} -#endif - -#include "containers.h" -{-# OPTIONS_HADDOCK hide #-} - -module Utils.Containers.Internal.StrictFold (foldlStrict) where - --- | Same as regular 'Data.List.foldl'', but marked INLINE so that it is always --- inlined. This allows further optimization of the call to f, which can be --- optimized/specialised/inlined. - -foldlStrict :: (a -> b -> a) -> a -> [b] -> a -foldlStrict f = go - where - go z [] = z - go z (x:xs) = let z' = f z x in z' `seq` go z' xs -{-# INLINE foldlStrict #-} diff --git a/Utils/Containers/Internal/StrictPair.hs b/Utils/Containers/Internal/StrictPair.hs --- a/Utils/Containers/Internal/StrictPair.hs +++ b/Utils/Containers/Internal/StrictPair.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif diff --git a/Utils/Containers/Internal/TypeError.hs b/Utils/Containers/Internal/TypeError.hs new file mode 100644 --- /dev/null +++ b/Utils/Containers/Internal/TypeError.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, UndecidableInstances, + KindSignatures, TypeFamilies, CPP #-} + +#if !defined(TESTING) +# if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE Safe #-} +# else +{-# LANGUAGE Trustworthy #-} +#endif +#endif + +-- | Unsatisfiable constraints for functions being removed. + +module Utils.Containers.Internal.TypeError where +import GHC.TypeLits + +-- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s@. +-- Under GHC 8.0 and above, trying to use a function with a @Whoops s@ +-- constraint will lead to a pretty type error explaining how to fix +-- the problem. Under earlier GHC versions, it will produce an extremely +-- ugly type error within which the desired message is buried. +-- +-- ==== Example +-- +-- @ +-- oldFunction :: Whoops "oldFunction is gone now. Use newFunction." +-- => Int -> IntMap a -> IntMap a +-- @ +class Whoops (a :: Symbol) + +#if __GLASGOW_HASKELL__ >= 800 +instance TypeError ('Text a) => Whoops a +#endif + +-- Why don't we just use +-- +-- type Whoops a = TypeError ('Text a) ? +-- +-- When GHC sees the type signature of oldFunction, it will see that it +-- has an unsatisfiable constraint and reject it out of hand. +-- +-- It seems possible to hack around that with a type family: +-- +-- type family Whoops a where +-- Whoops a = TypeError ('Text a) +-- +-- but I don't really trust that to work reliably. What we actually +-- do is pretty much guaranteed to work. Despite the fact that there +-- is a totally polymorphic instance in scope, GHC will refrain from +-- reducing the constraint because it knows someone could (theoretically) +-- define an overlapping instance of Whoops. It doesn't commit to +-- the polymorphic one until it has to, at the call site. diff --git a/benchmarks/Sequence.hs b/benchmarks/Sequence.hs --- a/benchmarks/Sequence.hs +++ b/benchmarks/Sequence.hs @@ -159,15 +159,15 @@ ] , bgroup "unstableSortOn" [ bgroup "already sorted" - [ bench "10" $ nf S.unstableSortOn id s10 - , bench "100" $ nf S.unstableSortOn id s100 - , bench "1000" $ nf S.unstableSortOn id s1000 - , bench "10000" $ nf S.unstableSortOn id s10000] + [ bench "10" $ nf (S.unstableSortOn id) s10 + , bench "100" $ nf (S.unstableSortOn id) s100 + , bench "1000" $ nf (S.unstableSortOn id) s1000 + , bench "10000" $ nf (S.unstableSortOn id) s10000] , bgroup "random" - [ bench "10" $ nf S.unstableSortOn id rs10 - , bench "100" $ nf S.unstableSortOn id rs100 - , bench "1000" $ nf S.unstableSortOn id rs1000 - , bench "10000" $ nf S.unstableSortOn id rs10000] + [ bench "10" $ nf (S.unstableSortOn id) rs10 + , bench "100" $ nf (S.unstableSortOn id) rs100 + , bench "1000" $ nf (S.unstableSortOn id) rs1000 + , bench "10000" $ nf (S.unstableSortOn id) rs10000] ] ] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,61 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 0.6.0.1 + +* Released with GHC 8.6 + +### New functions and class instances + +* Add `Data.Containers.ListUtils` offering `nub`-like functions. (Thanks to + Gershom Bazerman for starting the process of writing these.) + +* Add `Generic` and `Generic1` instances for key `Data.Sequence.Internal` types: + `Node`, `Digit`, `Elem`, and `FingerTree`. + +### Death of deprecated functions + +The following functions have been disabled. As an experiment +in function removal technology, the functions are still temporarily present, +but any attempts to use them will result in type errors advising on +replacement. + +* `Data.IntMap`: `insertWith'`, `insertWithKey'`, `fold`, and `foldWithKey`. + +* `Data.Map`: `insertWith'`, `insertWithKey'`, `insertLookupWithKey'`, + `fold`, and `foldWithKey`. + +The same has been done for the deprecated exports of `showTree` and +`showTreeWith`. These function remain available in the internal `Debug` +modules. + +### Changes to existing functions + +* Generalize the types of `unions` and `unionsWith`. (Thanks, jwaldmann.) + +### Performance improvements + +* Speed up folds and `traverse` on sequences. (Thanks, Donnacha Oisín Kidney.) + +* Speed up `Data.Set.union`. (Thanks, Joachim Breitner.) + +* Speed up several algorithms in `Data.Graph` a bit by using unboxed arrays + where appropriate. + +* Implement `Data.Graph.indegree` directly instead of taking the transpose + and calculating its `outdegree`. This may not lead to an immediate performance + improvement (see [GHC Trac #14785](https://ghc.haskell.org/trac/ghc/ticket/14785)) + but it should be better eventually. + +### Other package changes + +* Drop support for GHC versions before 7.6. + +* Improve `Data.Graph` documentation, and reorganize map and set documentation. + +* Remove the `Data.Map.Lazy.Merge` and `Data.Map.Strict.Merge` modules. These + were renamed and deprecated almost as soon as they were introduced. + + ## 0.5.11 * Released with GHC 8.4. diff --git a/containers.cabal b/containers.cabal --- a/containers.cabal +++ b/containers.cabal @@ -1,5 +1,5 @@ name: containers -version: 0.5.11.0 +version: 0.6.0.1 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -40,7 +40,7 @@ location: http://github.com/haskell/containers.git Library - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5 + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5 if impl(ghc) build-depends: ghc-prim @@ -49,6 +49,7 @@ other-extensions: CPP, BangPatterns exposed-modules: + Data.Containers.ListUtils Data.IntMap Data.IntMap.Lazy Data.IntMap.Strict @@ -60,11 +61,9 @@ Data.IntSet Data.Map Data.Map.Lazy - Data.Map.Lazy.Merge Data.Map.Merge.Lazy Data.Map.Strict.Internal Data.Map.Strict - Data.Map.Strict.Merge Data.Map.Merge.Strict Data.Map.Internal Data.Map.Internal.Debug @@ -81,9 +80,12 @@ other-modules: Utils.Containers.Internal.State - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictMaybe Utils.Containers.Internal.PtrEquality + Utils.Containers.Internal.Coercions + if impl(ghc) + other-modules: + Utils.Containers.Internal.TypeError Data.Map.Internal.DeprecatedShowTree Data.IntMap.Internal.DeprecatedDebug @@ -99,7 +101,7 @@ main-is: IntMap.hs ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3, deepseq >= 1.1.0.0 && < 1.5 @@ -110,7 +112,7 @@ main-is: IntSet.hs ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3, deepseq >= 1.1.0.0 && < 1.5 @@ -121,7 +123,7 @@ main-is: Map.hs ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3, deepseq >= 1.1.0.0 && < 1.5, @@ -133,7 +135,7 @@ main-is: Sequence.hs ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3, deepseq >= 1.1.0.0 && < 1.5, @@ -146,7 +148,7 @@ main-is: Set.hs ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3, deepseq >= 1.1.0.0 && < 1.5 @@ -158,7 +160,7 @@ other-modules: SetOperations ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3 @@ -169,7 +171,7 @@ other-modules: SetOperations ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3 @@ -180,7 +182,7 @@ other-modules: SetOperations ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3 @@ -191,7 +193,7 @@ other-modules: SetOperations ghc-options: -O2 build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3 @@ -207,14 +209,14 @@ Data.IntSet.Internal LookupGE_IntMap Utils.Containers.Internal.BitUtil - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictPair + Utils.Containers.Internal.TypeError ghc-options: -O2 cpp-options: -DTESTING other-modules: Data.IntMap.Internal build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3, deepseq >= 1.1.0.0 && < 1.5, @@ -236,7 +238,6 @@ Utils.Containers.Internal.BitQueue Utils.Containers.Internal.BitUtil Utils.Containers.Internal.PtrEquality - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictMaybe Utils.Containers.Internal.StrictPair ghc-options: -O2 @@ -244,7 +245,7 @@ other-modules: Data.Map.Internal build-depends: - base >= 4.2 && < 5, + base >= 4.6 && < 5, containers, criterion >= 0.4.0 && < 1.3, deepseq >= 1.1.0.0 && < 1.5, @@ -271,13 +272,12 @@ Utils.Containers.Internal.BitQueue Utils.Containers.Internal.BitUtil Utils.Containers.Internal.PtrEquality - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictMaybe Utils.Containers.Internal.StrictPair type: exitcode-stdio-1.0 cpp-options: -DTESTING - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -305,13 +305,12 @@ Utils.Containers.Internal.BitQueue Utils.Containers.Internal.BitUtil Utils.Containers.Internal.PtrEquality - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictMaybe Utils.Containers.Internal.StrictPair type: exitcode-stdio-1.0 cpp-options: -DTESTING -DSTRICT - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -333,7 +332,7 @@ type: exitcode-stdio-1.0 cpp-options: -DTESTING - build-depends: base >= 4.3 && < 5, ghc-prim + build-depends: base >= 4.6 && < 5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -353,12 +352,11 @@ Data.Set.Internal Utils.Containers.Internal.BitUtil Utils.Containers.Internal.PtrEquality - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictPair type: exitcode-stdio-1.0 cpp-options: -DTESTING - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -383,12 +381,12 @@ Data.IntSet.Internal IntMapValidity Utils.Containers.Internal.BitUtil - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictPair + Utils.Containers.Internal.TypeError type: exitcode-stdio-1.0 cpp-options: -DTESTING - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -412,12 +410,12 @@ Data.IntSet.Internal IntMapValidity Utils.Containers.Internal.BitUtil - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictPair + Utils.Containers.Internal.TypeError type: exitcode-stdio-1.0 cpp-options: -DTESTING -DSTRICT - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -440,12 +438,11 @@ IntSetValidity Utils.Containers.Internal.BitUtil Utils.Containers.Internal.PtrEquality - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictPair type: exitcode-stdio-1.0 cpp-options: -DTESTING - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -457,43 +454,6 @@ test-framework-hunit, test-framework-quickcheck2 -Test-suite deprecated-properties - hs-source-dirs: tests, . - main-is: deprecated-properties.hs - other-modules: - Data.IntMap - Data.IntMap.Internal - Data.IntMap.Internal.DeprecatedDebug - Data.IntMap.Lazy - Data.IntMap.Strict - Data.IntSet.Internal - Data.Map - Data.Map.Internal - Data.Map.Internal.Debug - Data.Map.Internal.DeprecatedShowTree - Data.Map.Lazy - Data.Map.Strict - Data.Map.Strict.Internal - Data.Set.Internal - Utils.Containers.Internal.BitQueue - Utils.Containers.Internal.BitUtil - Utils.Containers.Internal.PtrEquality - Utils.Containers.Internal.StrictFold - Utils.Containers.Internal.StrictMaybe - Utils.Containers.Internal.StrictPair - type: exitcode-stdio-1.0 - cpp-options: -DTESTING - - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim - ghc-options: -O2 - other-extensions: CPP, BangPatterns - include-dirs: include - - build-depends: - QuickCheck >= 2.7.1, - test-framework, - test-framework-quickcheck2 - Test-suite seq-properties hs-source-dirs: tests, . main-is: seq-properties.hs @@ -504,7 +464,7 @@ type: exitcode-stdio-1.0 cpp-options: -DTESTING - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -523,7 +483,7 @@ type: exitcode-stdio-1.0 cpp-options: -DTESTING - build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim ghc-options: -O2 other-extensions: CPP, BangPatterns include-dirs: include @@ -547,14 +507,13 @@ Utils.Containers.Internal.BitQueue Utils.Containers.Internal.BitUtil Utils.Containers.Internal.PtrEquality - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictMaybe Utils.Containers.Internal.StrictPair type: exitcode-stdio-1.0 build-depends: - array, - base >= 4.3 && < 5, + array >= 0.4.0.0, + base >= 4.6 && < 5, ChasingBottoms, deepseq >= 1.2 && < 1.5, QuickCheck >= 2.7.1, @@ -575,14 +534,14 @@ Data.IntMap.Strict Data.IntSet.Internal Utils.Containers.Internal.BitUtil - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictPair + Utils.Containers.Internal.TypeError type: exitcode-stdio-1.0 other-extensions: CPP, BangPatterns build-depends: - array, - base >= 4.3 && < 5, + array >= 0.4.0.0, + base >= 4.6 && < 5, ChasingBottoms, deepseq >= 1.2 && < 1.5, QuickCheck >= 2.7.1, @@ -600,14 +559,32 @@ Data.IntSet Data.IntSet.Internal Utils.Containers.Internal.BitUtil - Utils.Containers.Internal.StrictFold Utils.Containers.Internal.StrictPair type: exitcode-stdio-1.0 other-extensions: CPP, BangPatterns build-depends: - array, - base >= 4.3 && < 5, + array >= 0.4.0.0, + base >= 4.6 && < 5, + ChasingBottoms, + deepseq >= 1.2 && < 1.5, + QuickCheck >= 2.7.1, + ghc-prim, + test-framework >= 0.3.3, + test-framework-quickcheck2 >= 0.2.9 + + ghc-options: -Wall + include-dirs: include + +test-suite listutils-properties + hs-source-dirs: tests, . + main-is: listutils-properties.hs + other-modules: + Data.Containers.ListUtils + type: exitcode-stdio-1.0 + + build-depends: + base >= 4.6 && < 5, ChasingBottoms, deepseq >= 1.2 && < 1.5, QuickCheck >= 2.7.1, diff --git a/include/containers.h b/include/containers.h --- a/include/containers.h +++ b/include/containers.h @@ -33,33 +33,9 @@ #define DEFINE_PATTERN_SYNONYMS 1 #endif -/* - * We use cabal-generated MIN_VERSION_base to adapt to changes of base. - * Nevertheless, as a convenience, we also allow compiling without cabal by - * defining an approximate MIN_VERSION_base if needed. The alternative version - * guesses the version of base using the version of GHC. This is usually - * sufficiently accurate. However, it completely ignores minor version numbers, - * and it makes the assumption that a pre-release version of GHC will ship with - * base libraries with the same version numbers as the final release. This - * assumption is violated in certain stages of GHC development, but in practice - * this should very rarely matter, and will not affect any released version. - */ -#ifndef MIN_VERSION_base -#if __GLASGOW_HASKELL__ >= 709 -#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=8))) -#elif __GLASGOW_HASKELL__ >= 707 -#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=7))) -#elif __GLASGOW_HASKELL__ >= 705 -#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=6))) -#elif __GLASGOW_HASKELL__ >= 703 -#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=5))) -#elif __GLASGOW_HASKELL__ >= 701 -#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=4))) -#elif __GLASGOW_HASKELL__ >= 700 -#define MIN_VERSION_base(major1,major2,minor) (((major1)<4)||(((major1) == 4)&&((major2)<=3))) -#else -#define MIN_VERSION_base(major1,major2,minor) (0) -#endif +#ifdef __GLASGOW_HASKELL__ +# define USE_ST_MONAD 1 +# define USE_UNBOXED_ARRAYS 1 #endif #endif diff --git a/tests/IntMapValidity.hs b/tests/IntMapValidity.hs --- a/tests/IntMapValidity.hs +++ b/tests/IntMapValidity.hs @@ -46,10 +46,10 @@ case t of Nil -> True Tip _ _ -> True - b@(Bin p _ _ _) -> all (sharedPrefix p) (keys b) + b@(Bin p _ l r) -> all (sharedPrefix p) (keys b) && commonPrefix l && commonPrefix r where sharedPrefix :: Prefix -> Int -> Bool - sharedPrefix p a = 0 == (p `xor` (p .&. a)) + sharedPrefix p a = p == p .&. a -- Invariant: In Bin prefix mask left right, left consists of the elements that -- don't have the mask bit set; right is all the elements that do. @@ -60,4 +60,6 @@ Tip _ _ -> True Bin _ binMask l r -> all (\x -> zero x binMask) (keys l) && - all (\x -> not (zero x binMask)) (keys r) + all (\x -> not (zero x binMask)) (keys r) && + maskRespected l && + maskRespected r diff --git a/tests/IntSetValidity.hs b/tests/IntSetValidity.hs --- a/tests/IntSetValidity.hs +++ b/tests/IntSetValidity.hs @@ -49,10 +49,10 @@ case t of Nil -> True Tip _ _ -> True - b@(Bin p _ _ _) -> all (sharedPrefix p) (elems b) + b@(Bin p _ l r) -> all (sharedPrefix p) (elems b) && commonPrefix l && commonPrefix r where sharedPrefix :: Prefix -> Int -> Bool - sharedPrefix p a = 0 == (p `xor` (p .&. a)) + sharedPrefix p a = p == p .&. a -- Invariant: In Bin prefix mask left right, left consists of the elements that -- don't have the mask bit set; right is all the elements that do. @@ -63,7 +63,9 @@ Tip _ _ -> True Bin _ binMask l r -> all (\x -> zero x binMask) (elems l) && - all (\x -> not (zero x binMask)) (elems r) + all (\x -> not (zero x binMask)) (elems r) && + maskRespected l && + maskRespected r -- Invariant: The Prefix is zero for the last 5 (on 32 bit arches) or 6 bits -- (on 64 bit arches). The values of the set represented by a tip diff --git a/tests/deprecated-properties.hs b/tests/deprecated-properties.hs deleted file mode 100644 --- a/tests/deprecated-properties.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - --- This module tests the deprecated properties of Data.Map and Data.IntMap, --- because these cannot be tested in either map-properties or --- intmap-properties, as these modules are designed to work with the .Lazy and --- .Strict modules. - -import qualified Data.Map as M -import qualified Data.Map.Strict as SM -import qualified Data.IntMap as IM -import qualified Data.IntMap.Strict as SIM - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck.Function (Fun(..), apply) - -default (Int) - -main :: IO () -main = defaultMain - [ testProperty "Data.Map.insertWith' as Strict.insertWith" prop_mapInsertWith'Strict - , testProperty "Data.Map.insertWith' undefined value" prop_mapInsertWith'Undefined - , testProperty "Data.Map.insertWithKey' as Strict.insertWithKey" prop_mapInsertWithKey'Strict - , testProperty "Data.Map.insertWithKey' undefined value" prop_mapInsertWithKey'Undefined - , testProperty "Data.Map.insertLookupWithKey' as Strict.insertLookupWithKey" prop_mapInsertLookupWithKey'Strict - , testProperty "Data.Map.insertLookupWithKey' undefined value" prop_mapInsertLookupWithKey'Undefined - , testProperty "Data.IntMap.insertWith' as Strict.insertWith" prop_intmapInsertWith'Strict - , testProperty "Data.IntMap.insertWith' undefined value" prop_intmapInsertWith'Undefined - , testProperty "Data.IntMap.insertWithKey' as Strict.insertWithKey" prop_intmapInsertWithKey'Strict - , testProperty "Data.IntMap.insertWithKey' undefined value" prop_intmapInsertWithKey'Undefined - ] - - ----------- Map properties ---------- -apply2 :: Fun (a, b) c -> a -> b -> c -apply2 f a b = apply f (a, b) - -apply3 :: Fun (a, b, c) d -> a -> b -> c -> d -apply3 f a b c = apply f (a, b, c) - -prop_mapInsertWith'Strict :: [(Int, Int)] -> Fun (Int, Int) Int -> [(Int, Int)] -> Bool -prop_mapInsertWith'Strict xs f kxxs = - let m = M.fromList xs - insertList ins = foldr (\(kx, x) -> ins (apply2 f) kx x) m kxxs - in insertList M.insertWith' == insertList SM.insertWith - -prop_mapInsertWith'Undefined :: [(Int, Int)] -> Bool -prop_mapInsertWith'Undefined xs = - let m = M.fromList xs - f _ x = x * 33 - insertList ins = foldr (\(kx, _) -> ins f kx undefined) m xs - in insertList M.insertWith' == insertList M.insertWith - -prop_mapInsertWithKey'Strict :: [(Int, Int)] -> Fun (Int, Int, Int) Int -> [(Int, Int)] -> Bool -prop_mapInsertWithKey'Strict xs f kxxs = - let m = M.fromList xs - insertList ins = foldr (\(kx, x) -> ins (apply3 f) kx x) m kxxs - in insertList M.insertWithKey' == insertList SM.insertWithKey - -prop_mapInsertWithKey'Undefined :: [(Int, Int)] -> Bool -prop_mapInsertWithKey'Undefined xs = - let m = M.fromList xs - f k _ x = (k + x) * 33 - insertList ins = foldr (\(kx, _) -> ins f kx undefined) m xs - in insertList M.insertWithKey' == insertList M.insertWithKey - -prop_mapInsertLookupWithKey'Strict :: [(Int, Int)] -> Fun (Int, Int, Int) Int -> [(Int, Int)] -> Bool -prop_mapInsertLookupWithKey'Strict xs f kxxs = - let m = M.fromList xs - insertLookupList insLkp = scanr (\(kx, x) (_, mp) -> insLkp (apply3 f) kx x mp) (Nothing, m) kxxs - in insertLookupList M.insertLookupWithKey' == insertLookupList SM.insertLookupWithKey - -prop_mapInsertLookupWithKey'Undefined :: [(Int, Int)] -> Bool -prop_mapInsertLookupWithKey'Undefined xs = - let m = M.fromList xs - f k _ x = (k + x) * 33 - insertLookupList insLkp = scanr (\(kx, _) (_, mp) -> insLkp f kx undefined mp) (Nothing, m) xs - in insertLookupList M.insertLookupWithKey' == insertLookupList M.insertLookupWithKey - - ----------- IntMap properties ---------- - -prop_intmapInsertWith'Strict :: [(Int, Int)] -> Fun (Int, Int) Int -> [(Int, Int)] -> Bool -prop_intmapInsertWith'Strict xs f kxxs = - let m = IM.fromList xs - insertList ins = foldr (\(kx, x) -> ins (apply2 f) kx x) m kxxs - in insertList IM.insertWith' == insertList SIM.insertWith - -prop_intmapInsertWith'Undefined :: [(Int, Int)] -> Bool -prop_intmapInsertWith'Undefined xs = - let m = IM.fromList xs - f _ x = x * 33 - insertList ins = foldr (\(kx, _) -> ins f kx undefined) m xs - in insertList IM.insertWith' == insertList IM.insertWith - -prop_intmapInsertWithKey'Strict :: [(Int, Int)] -> Fun (Int, Int, Int) Int -> [(Int, Int)] -> Bool -prop_intmapInsertWithKey'Strict xs f kxxs = - let m = IM.fromList xs - insertList ins = foldr (\(kx, x) -> ins (apply3 f) kx x) m kxxs - in insertList IM.insertWithKey' == insertList SIM.insertWithKey - -prop_intmapInsertWithKey'Undefined :: [(Int, Int)] -> Bool -prop_intmapInsertWithKey'Undefined xs = - let m = IM.fromList xs - f k _ x = (k + x) * 33 - insertList ins = foldr (\(kx, _) -> ins f kx undefined) m xs - in insertList IM.insertWithKey' == insertList IM.insertWithKey diff --git a/tests/graph-properties.hs b/tests/graph-properties.hs new file mode 100644 --- /dev/null +++ b/tests/graph-properties.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} + +import Data.Graph as G + +import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), liftA2) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck +import Test.QuickCheck.Function (Fun (..), apply) +import Test.QuickCheck.Poly (A, B, C) +import Control.Monad (ap) + +default (Int) + +main :: IO () +main = defaultMain + [ + testProperty "monad_id1" prop_monad_id1 + , testProperty "monad_id2" prop_monad_id2 + , testProperty "monad_assoc" prop_monad_assoc + , testProperty "ap_ap" prop_ap_ap + , testProperty "ap_liftA2" prop_ap_liftA2 + , testProperty "monadFix_ls" prop_monadFix_ls + ] + +{-------------------------------------------------------------------- + Arbitrary trees +--------------------------------------------------------------------} + +newtype G = G Graph + +-- This instance isn't balanced very well; the trees will probably tend +-- to lean left. But it's better than nothing and we can fix it later. +instance Arbitrary a => Arbitrary G where + arbitrary = sized arbgraph + where + arbgraph :: Arbitrary a => Int -> Gen G + arbgraph nv = do + lo <- arbitrary + hi <- (lo+) <$> choose (0, nv) +{- + arbtree 0 = fmap ((,) 1) $ Node <$> arbitrary <*> pure [] + arbtree n = do + root <- arbitrary + num_children <- choose (0, n - 1) + (st, tl) <- go num_children + return (1+st, Node root tl) +-} + + go 0 = pure (0, []) + go n = do + (sh, hd) <- arbtree n + (st, tl) <- go (n - sh) + pure (sh + st, hd : tl) + +-- genericShrink only became available when generics did, so it's +-- not available under GHC 7.0. +#if __GLASGOW_HASKELL__ >= 704 + shrink = genericShrink +#endif + +---------------------------------------------------------------- +-- Unit tests +---------------------------------------------------------------- + +---------------------------------------------------------------- +-- QuickCheck +---------------------------------------------------------------- + +apply2 :: Fun (a, b) c -> a -> b -> c +apply2 f a b = apply f (a, b) + +prop_ap_ap :: Tree (Fun A B) -> Tree A -> Property +prop_ap_ap fs xs = (apply <$> fs <*> xs) === ((apply <$> fs) `ap` xs) + +prop_ap_liftA2 :: Fun (A, B) C -> Tree A -> Tree B -> Property +prop_ap_liftA2 f as bs = (apply2 f <$> as <*> bs) === liftA2 (apply2 f) as bs + +prop_monad_id1 :: Tree A -> Property +prop_monad_id1 t = (t >>= pure) === t + +prop_monad_id2 :: A -> Fun A (Tree B) -> Property +prop_monad_id2 a f = (pure a >>= apply f) === apply f a + +prop_monad_assoc :: Tree A -> Fun A (Tree B) -> Fun B (Tree C) -> Property +prop_monad_assoc ta atb btc = + ((ta >>= apply atb) >>= apply btc) + === + (ta >>= \a -> apply atb a >>= apply btc) + +-- The left shrinking law +-- +-- This test is kind of wonky and unprincipled, because it's +-- rather tricky to construct test cases! +-- This is the most important MonadFix law to test because it's the +-- least intuitive by far, and because it's the only one that's +-- sensitive to the Monad instance. +prop_monadFix_ls :: Int -> Tree Int -> Fun Int (Tree Int) -> Property +prop_monadFix_ls val ta ti = + fmap ($val) (mfix (\x -> ta >>= \y -> f x y)) + === + fmap ($val) (ta >>= \y -> mfix (\x -> f x y)) + where + fact :: Int -> (Int -> Int) -> Int -> Int + fact x _ 0 = x + 1 + fact x f n = x + n * f ((n - 1) `mod` 23) + + f :: (Int -> Int) -> Int -> Tree (Int -> Int) + f q y = let t = apply ti y + in fmap (\w -> fact w q) t diff --git a/tests/intset-properties.hs b/tests/intset-properties.hs --- a/tests/intset-properties.hs +++ b/tests/intset-properties.hs @@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} -#if MIN_VERSION_base(4,5,0) import Data.Bits ((.&.), popCount) import Data.Word (Word) -#else -import Data.Bits ((.&.)) -#endif import Data.IntSet import Data.List (nub,sort) import qualified Data.List as List @@ -72,9 +68,7 @@ , testProperty "prop_splitRoot" prop_splitRoot , testProperty "prop_partition" prop_partition , testProperty "prop_filter" prop_filter -#if MIN_VERSION_base(4,5,0) , testProperty "prop_bitcount" prop_bitcount -#endif ] ---------------------------------------------------------------- @@ -397,7 +391,6 @@ valid evens .&&. parts === (odds, evens) -#if MIN_VERSION_base(4,5,0) prop_bitcount :: Int -> Word -> Bool prop_bitcount a w = bitcount_orig a w == bitcount_new a w where @@ -405,5 +398,3 @@ where go a 0 = a go a x = go (a + 1) (x .&. (x-1)) bitcount_new a x = a + popCount x -#endif - diff --git a/tests/listutils-properties.hs b/tests/listutils-properties.hs new file mode 100644 --- /dev/null +++ b/tests/listutils-properties.hs @@ -0,0 +1,60 @@ +module Main where + +import Data.List (nub, nubBy) +import Data.Containers.ListUtils +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (===)) +import Test.QuickCheck.Function (Fun, apply) +import Test.QuickCheck.Poly (A, OrdA, B, OrdB, C) + +main :: IO () +main = defaultMain + [ testProperty "nubOrd" prop_nubOrd + , testProperty "nubOrdOn" prop_nubOrdOn + , testProperty "nubOrdOn fusion" prop_nubOrdOnFusion + , testProperty "nubInt" prop_nubInt + , testProperty "nubIntOn" prop_nubIntOn + , testProperty "nubIntOn fusion" prop_nubIntOnFusion + ] + + +prop_nubOrd :: [OrdA] -> Property +prop_nubOrd xs = nubOrd xs === nub xs + +prop_nubInt :: [Int] -> Property +prop_nubInt xs = nubInt xs === nub xs + +prop_nubOrdOn :: Fun A OrdB -> [A] -> Property +prop_nubOrdOn f' xs = + nubOrdOn f xs === nubBy (\x y -> f x == f y) xs + where f = apply f' + +prop_nubIntOn :: Fun A Int -> [A] -> Property +prop_nubIntOn f' xs = + nubIntOn f xs === nubBy (\x y -> f x == f y) xs + where f = apply f' + +prop_nubOrdOnFusion :: Fun B C + -> Fun B OrdB + -> Fun A B + -> [A] -> Property +prop_nubOrdOnFusion f' g' h' xs = + (map f . nubOrdOn g . map h $ xs) + === (map f . nubBy (\x y -> g x == g y) . map h $ xs) + where + f = apply f' + g = apply g' + h = apply h' + +prop_nubIntOnFusion :: Fun B C + -> Fun B Int + -> Fun A B + -> [A] -> Property +prop_nubIntOnFusion f' g' h' xs = + (map f . nubIntOn g . map h $ xs) + === (map f . nubBy (\x y -> g x == g y) . map h $ xs) + where + f = apply f' + g = apply g' + h = apply h' diff --git a/tests/seq-properties.hs b/tests/seq-properties.hs --- a/tests/seq-properties.hs +++ b/tests/seq-properties.hs @@ -41,9 +41,7 @@ import Test.QuickCheck.Function import Test.Framework import Test.Framework.Providers.QuickCheck2 -#if MIN_VERSION_base(4,4,0) import Control.Monad.Zip (MonadZip (..)) -#endif import Control.DeepSeq (deepseq) import Control.Monad.Fix (MonadFix (..)) @@ -54,9 +52,11 @@ , testProperty "(<$)" prop_constmap , testProperty "foldr" prop_foldr , testProperty "foldr'" prop_foldr' + , testProperty "lazy foldr'" prop_lazyfoldr' , testProperty "foldr1" prop_foldr1 , testProperty "foldl" prop_foldl , testProperty "foldl'" prop_foldl' + , testProperty "lazy foldl'" prop_lazyfoldl' , testProperty "foldl1" prop_foldl1 , testProperty "(==)" prop_equals , testProperty "compare" prop_compare @@ -95,8 +95,10 @@ , testProperty "partition" prop_partition , testProperty "filter" prop_filter , testProperty "sort" prop_sort + , testProperty "sortStable" prop_sortStable , testProperty "sortBy" prop_sortBy , testProperty "sortOn" prop_sortOn + , testProperty "sortOnStable" prop_sortOnStable , testProperty "unstableSort" prop_unstableSort , testProperty "unstableSortBy" prop_unstableSortBy , testProperty "unstableSortOn" prop_unstableSortOn @@ -131,11 +133,9 @@ , testProperty "zipWith3" prop_zipWith3 , testProperty "zip4" prop_zip4 , testProperty "zipWith4" prop_zipWith4 -#if MIN_VERSION_base(4,4,0) , testProperty "mzip-naturality" prop_mzipNaturality , testProperty "mzip-preservation" prop_mzipPreservation , testProperty "munzip-lazy" prop_munzipLazy -#endif , testProperty "<*>" prop_ap , testProperty "<*> NOINLINE" prop_ap_NOINLINE , testProperty "liftA2" prop_liftA2 @@ -306,6 +306,16 @@ f = (:) z = [] +prop_lazyfoldr' :: Seq () -> Property +prop_lazyfoldr' xs = + not (null xs) ==> + foldr' + (\e _ -> + e) + (error "Data.Sequence.foldr': should be lazy in initial accumulator") + xs === + () + prop_foldr1 :: Seq Int -> Property prop_foldr1 xs = not (null xs) ==> foldr1 f xs == Data.List.foldr1 f (toList xs) @@ -325,6 +335,16 @@ f = flip (:) z = [] +prop_lazyfoldl' :: Seq () -> Property +prop_lazyfoldl' xs = + not (null xs) ==> + foldl' + (\_ e -> + e) + (error "Data.Sequence.foldl': should be lazy in initial accumulator") + xs === + () + prop_foldl1 :: Seq Int -> Property prop_foldl1 xs = not (null xs) ==> foldl1 f xs == Data.List.foldl1 f (toList xs) @@ -538,6 +558,30 @@ prop_sort xs = toList' (sort xs) ~= Data.List.sort (toList xs) +data UnstableOrd = UnstableOrd + { ordKey :: OrdA + , _ignored :: A + } deriving (Show) + +instance Eq UnstableOrd where + x == y = compare x y == EQ + +instance Ord UnstableOrd where + compare (UnstableOrd x _) (UnstableOrd y _) = compare x y + +instance Arbitrary UnstableOrd where + arbitrary = liftA2 UnstableOrd arbitrary arbitrary + shrink (UnstableOrd x y) = + [ UnstableOrd x' y' + | (x',y') <- shrink (x, y) ] + +prop_sortStable :: Seq UnstableOrd -> Bool +prop_sortStable xs = + (fmap . fmap) unignore (toList' (sort xs)) ~= + fmap unignore (Data.List.sort (toList xs)) + where + unignore (UnstableOrd x y) = (x, y) + prop_sortBy :: Seq (OrdA, B) -> Bool prop_sortBy xs = toList' (sortBy f xs) ~= Data.List.sortBy f (toList xs) @@ -553,6 +597,16 @@ listSortOn k = Data.List.sortBy (compare `on` k) #endif +prop_sortOnStable :: Fun A UnstableOrd -> Seq A -> Bool +prop_sortOnStable (Fun _ f) xs = + toList' (sortOn f xs) ~= listSortOn f (toList xs) + where +#if MIN_VERSION_base(4,8,0) + listSortOn = Data.List.sortOn +#else + listSortOn k = Data.List.sortBy (compare `on` k) +#endif + prop_unstableSort :: Seq OrdA -> Bool prop_unstableSort xs = toList' (unstableSort xs) ~= Data.List.sort (toList xs) @@ -732,7 +786,6 @@ toList' (zipWith4 f xs ys zs ts) ~= Data.List.zipWith4 f (toList xs) (toList ys) (toList zs) (toList ts) where f = (,,,) -#if MIN_VERSION_base(4,4,0) -- This comes straight from the MonadZip documentation prop_mzipNaturality :: Fun A C -> Fun B D -> Seq A -> Seq B -> Property prop_mzipNaturality f g sa sb = @@ -759,7 +812,6 @@ firstPieces = fmap (fst . munzip) partialpairs repaired = mapWithIndex (\i s -> update i 10000 s) firstPieces err = error "munzip isn't lazy enough" -#endif -- Applicative operations diff --git a/tests/tree-properties.hs b/tests/tree-properties.hs --- a/tests/tree-properties.hs +++ b/tests/tree-properties.hs @@ -49,9 +49,7 @@ (st, tl) <- go (n - sh) pure (sh + st, hd : tl) --- genericShrink only became available when generics did, so it's --- not available under GHC 7.0. -#if __GLASGOW_HASKELL__ >= 704 +#if defined(__GLASGOW_HASKELL__) shrink = genericShrink #endif