diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,24 +1,84 @@ +0.6 (2026-08-19) +================ + +* BREAKING CHANGE to the semantics of interval selection operators (`getRange`, + `(@><)`, `(@>=<)`, `(@><=)`, `(@>=<=)`): if an index has multiple values, it + will now be returned by interval selection only if a single value falls in the + range (see [#3](https://github.com/well-typed/ixset-typed/issues/3)). + Previously, these operators used two ordinal lookups and rebuilt the index in + between, meaning that an element would be returned by `getRange` if one of its + index values was greater than or equal to the lower bound and a different + index value was below the upper bound. If you still need the old behaviour, + replace calls to these functions with the alternatives given in the Haddocks. + +* Add various new API functions: + + - Lookup: `lookupIx`, `lookupIxMany`, `lookupOne` + + - Bulk modification: `insertSet`, `insertMany`, `deleteSet`, `deleteMany`, `deleteIxMany` + + - Set operations: `filter`, `difference`, `(\\\)` + + - Project out indices from values of an `Indexable` type: `project` + +* Significant performance-related changes, including changes to + strictness/laziness and removal of intermediate datastructures, which should + generally improve performance, but may have performance downsides or lead to + space leaks in some cases: + + - An `IxSet` is no longer always strict in the head of the `IxList`. This + means queries are more lazy, and avoid rebuilding the first index if it is + not needed. Updates continue to be strict, to prevent thunk leaks as the + `IxSet` is updated. + + - `fromSet` and `fromList` now compute the indices lazily (but remain + spine-strict in the elements). + + - The existing `union` and `intersection` set operations, and the new `filter` + and `difference`, compute the indices lazily (waiting until the index is + accessed, then it is computed in full). Previously `union` and + `intersection` would compute the indices partially (walking the index list + strictly, but then using lazy `Map` operations). + +* Add `forceIndices`, which can be used to ensure the indices are evaluated + after using operations that are now lazy in the index construction. + +* Generalise `@+` and `@*` so they work on any `Foldable` structure, not just lists. + +* Various documentation and performance improvements. + +* Rename `Data.IxSet.Typed.Ix` to `Data.IxSet.Typed.Internal.Ix`, change its API + and add other `.Internal` modules. These modules should not normally be + needed and are subject to change. + +* Remove various redundant constraints. + +* Limit supported versions to GHC 9.2 and later. + +* Drop dependency on `syb`. + + 0.5.1.1 (2026-07-13) ==================== -- GHC 9.4 through to 9.14 compatibility. +* GHC 9.4 through to 9.14 compatibility. 0.5.1.0 (2022-05-10) ==================== -- GHC 9.0 and 9.2 compatibility. +* GHC 9.0 and 9.2 compatibility. 0.5 (2020-03-18) ================ -- GHC 8.8 (and possibly 8.10) compatibility. +* GHC 8.8 (and possibly 8.10) compatibility. -- safecopy-0.10 compatibility. +* safecopy-0.10 compatibility. 0.4.0.1 (2018-10-01) ==================== -- containers-0.6 compatibility. +* containers-0.6 compatibility. 0.4 (2018-03-18) ================ diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -1,4 +1,4 @@ -Copyright (c) 2014, Well-Typed LLP +Copyright (c) 2014-2026, Well-Typed LLP Copyright (c) 2006, HAppS.org All rights reserved. diff --git a/bench/Bench/Types.hs b/bench/Bench/Types.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Types.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Sample data type and index declarations used by the benchmarks. +-- +module Bench.Types + ( -- * Element type + Entry(..) + , EntryId(..) + , Author(..) + , Updated(..) + , Tag(..) + , Priority(..) + , GenEntry(..) + -- * Index sets + , EntryIxs + , Entries + , Entries1 + , Entries2 + , Entries3 + , SmallEntries + , GenEntries + -- * Deterministic test data + , mkEntries + , mkEntriesFrom + , mkEntry + , primaryTag + ) where + +import Control.DeepSeq (NFData(..)) +import Data.Data (Data) +import Data.Proxy (Proxy(..)) +import Data.IxSet.Typed + +newtype EntryId = EntryId Int deriving (Eq, Ord, Show, Data) +newtype Author = Author String deriving (Eq, Ord, Show, Data) +newtype Updated = Updated Int deriving (Eq, Ord, Show, Data) +newtype Tag = Tag String deriving (Eq, Ord, Show, Data) +newtype Priority = Priority Int deriving (Eq, Ord, Show, Data) + +-- The @Entry@ type is indexed on five keys with deliberately different +-- characteristics: +-- +-- * 'EntryId' is unique (one element per key), +-- * 'Author' has moderate cardinality, +-- * 'Updated' has high cardinality and is queried with ranges, +-- * 'Tag' is multi-valued (each element occurs under several keys), +-- * 'Priority' has very low cardinality (few keys, huge buckets). +-- +data Entry = Entry + { eId :: EntryId + , eAuthor :: Author + , eUpdated :: Updated + , eTags :: [Tag] + , ePriority :: Priority + } + deriving (Eq, Ord, Show, Data) + +-- | Same payload as 'Entry', but indexed via 'ixGen' rather than 'ixFun', +-- so that the cost of the SYB-based index extraction can be compared. +newtype GenEntry = GenEntry Entry + deriving (Eq, Ord, Show, Data) + +instance NFData EntryId where rnf (EntryId i) = rnf i +instance NFData Author where rnf (Author s) = rnf s +instance NFData Updated where rnf (Updated i) = rnf i +instance NFData Tag where rnf (Tag s) = rnf s +instance NFData Priority where rnf (Priority i) = rnf i + +instance NFData Entry where + rnf (Entry i a u ts p) = rnf i `seq` rnf a `seq` rnf u `seq` rnf ts `seq` rnf p + +instance NFData GenEntry where + rnf (GenEntry e) = rnf e + +type EntryIxs = '[EntryId, Author, Updated, Tag, Priority] +type Entries = IxSet EntryIxs Entry + +instance Indexable EntryIxs Entry where + indices = ixList + (ixFun (\ e -> [eId e])) + (ixFun (\ e -> [eAuthor e])) + (ixFun (\ e -> [eUpdated e])) + (ixFun eTags) + (ixFun (\ e -> [ePriority e])) + +-- | Prefixes of 'EntryIxs', for measuring how the cost of the various +-- operations scales with the number of declared indices. +type Entries1 = IxSet '[EntryId] Entry +type Entries2 = IxSet '[EntryId, Author] Entry +type Entries3 = IxSet '[EntryId, Author, Updated] Entry + +instance Indexable '[EntryId] Entry where + indices = ixList (ixFun (\ e -> [eId e])) + +instance Indexable '[EntryId, Author] Entry where + indices = ixList + (ixFun (\ e -> [eId e])) + (ixFun (\ e -> [eAuthor e])) + +instance Indexable '[EntryId, Author, Updated] Entry where + indices = ixList + (ixFun (\ e -> [eId e])) + (ixFun (\ e -> [eAuthor e])) + (ixFun (\ e -> [eUpdated e])) + +-- | Two indices declared with 'ixFun', to be compared against 'GenEntries'. +type SmallEntries = IxSet '[Author, Priority] Entry + +instance Indexable '[Author, Priority] Entry where + indices = ixList + (ixFun (\ e -> [eAuthor e])) + (ixFun (\ e -> [ePriority e])) + +-- | The same two indices declared with 'ixGen'. +type GenEntries = IxSet '[Author, Priority] GenEntry + +instance Indexable '[Author, Priority] GenEntry where + indices = ixList + (ixGen (Proxy :: Proxy Author)) + (ixGen (Proxy :: Proxy Priority)) + +-------------------------------------------------------------------------- +-- Deterministic test data +-------------------------------------------------------------------------- + +-- | A cheap linear congruential generator. Benchmark data is generated +-- from a fixed seed so that runs are comparable across machines, without +-- depending on the @random@ package. +lcgs :: Int -> [Int] +lcgs = drop 1 . iterate step + where + step s = (s * 1103515245 + 12345) `mod` 2147483648 + +-- | @mkEntries n@ produces @n@ entries with distinct 'EntryId's, and +-- pseudo-random values for all other fields. +mkEntries :: Int -> [Entry] +mkEntries = mkEntriesFrom 0 + +-- | As 'mkEntries', but with 'EntryId's starting at the given offset. +-- Two calls with disjoint offsets produce disjoint sets of entries. +mkEntriesFrom :: Int -> Int -> [Entry] +mkEntriesFrom offset n = + zipWith mkEntry [offset .. offset + n - 1] (lcgs (offset + 1)) + +-- | @mkEntry i r@ is the entry with 'EntryId' @i@, with its remaining +-- fields derived from the seed @r@. +mkEntry :: Int -> Int -> Entry +mkEntry i r = Entry + { eId = EntryId i + , eAuthor = Author ("author-" ++ show (r `mod` 64)) + , eUpdated = Updated ((r `div` 64) `mod` 100000) + -- Multi-valued index: three tags per entry, occasionally coinciding. + , eTags = [ Tag ("tag-" ++ show ((r `div` k) `mod` 256)) | k <- [1, 11, 101] ] + , ePriority = Priority (r `mod` 5) + } + +-- | The first tag of an entry. Entries built by 'mkEntry' always have some. +primaryTag :: Entry -> Tag +primaryTag e = case eTags e of + t : _ -> t + [] -> Tag "tag-0" diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Benchmarks for @ixset-typed@. +-- +-- Run with: +-- +-- > cabal bench +-- +-- and, to compare against a previous run: +-- +-- > cabal bench --benchmark-options='--csv before.csv' +-- > ... apply patch ... +-- > cabal bench --benchmark-options='--baseline before.csv' +-- +-- Both 'nf' and 'whnf' results are reported, because an 'IxSet' is spine-strict +-- in some places and lazy in others, so how much of the result of an operation +-- is demanded matters significantly. For an operation that is already strict, +-- the 'nf' measurement is simply the 'whnf' one plus a traversal of the result, +-- so the absolute size of the difference is not interesting in itself. Rather, +-- it is useful to compare /changes/ in the difference between runs. +-- +-- Allocation figures reported alongside the timings (the suite is built with +-- @-with-rtsopts=-T@) and are usually more useful than wall-clock time as they +-- are less subject to noise. +-- +module Main (main) where + +import Control.DeepSeq (NFData(..), force) +import Control.Exception (evaluate) +import qualified Data.List as List +import Data.Proxy (Proxy(..)) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) + +import Data.IxSet.Typed ((@=), (@<), (@>=), (@>=<=), (@+), (@*), (&&&), (|||), (\\\)) +import qualified Data.IxSet.Typed as IxSet +import Test.Tasty.Bench + ( bench, + bgroup, + defaultMain, + env, + nf, + whnf, + Benchmark, + Benchmarkable + ) + +import Bench.Types + +main :: IO () +main = defaultMain [ benchmarks n | n <- sizes ] + +-- | Element counts at which the whole suite is run. +sizes :: [Int] +sizes = [500, 1000] + +-------------------------------------------------------------------------- +-- Forcing +-------------------------------------------------------------------------- + +-- | How much of the result of an operation to force. This is 'whnf' or +-- 'nf', abstracted over so that each benchmark can be run at both. +type Forcer = forall a b. NFData b => (a -> b) -> a -> Benchmarkable + +-- | Run a group of benchmarks once per 'Forcer'. +byForcing :: String -> (Forcer -> [(String, Benchmarkable)]) -> Benchmark +byForcing name benches = + bgroup name + [ bgroup "whnf" (map (uncurry bench) (benches whnf)) + , bgroup "nf" (map (uncurry bench) (benches nf)) + ] + +-------------------------------------------------------------------------- +-- Fixtures +-------------------------------------------------------------------------- + +-- | Everything a benchmark group needs, generated (and forced) once per +-- size by 'env', so that data generation is not measured. +data Fixture = Fixture + { fxSize :: Int + , fxEntries :: [Entry] + , fxGenEntries :: [GenEntry] + , fxIxSet :: Entries + , fxIxSet1 :: Entries1 + , fxIxSet2 :: Entries2 + , fxIxSet3 :: Entries3 + , fxIxSetB :: Entries -- ^ overlaps 'fxIxSet' in half its elements + , fxSet :: Set Entry + , fxMember :: Entry -- ^ an element of 'fxIxSet' + , fxFresh :: Entry -- ^ not an element of 'fxIxSet' + , fxId :: EntryId + , fxAuthor :: Author + , fxTag :: Tag + , fxTags :: [Tag] + , fxPriority :: Priority + , fxLo :: Updated + , fxHi :: Updated + -- | Subsets to be removed in bulk, scattered across the indices + -- rather than contiguous in any one of them. + , fxDeleteOne :: Set Entry + , fxDeleteFew :: Set Entry -- ^ a tenth of the elements + , fxDeleteHalf :: Set Entry -- ^ half of the elements + , fxDeleteList :: [Entry] -- ^ 'fxDeleteFew' as a list + , fxIxSetFew :: Entries -- ^ 'fxDeleteFew' as an 'IxSet' + } + deriving Generic + +instance NFData Fixture + +mkFixture :: Int -> Fixture +mkFixture n = Fixture + { fxSize = n + , fxEntries = entries + , fxGenEntries = map GenEntry entries + , fxIxSet = ixs + , fxIxSet1 = IxSet.fromList entries + , fxIxSet2 = IxSet.fromList entries + , fxIxSet3 = IxSet.fromList entries + , fxIxSetB = IxSet.fromList (drop half entries ++ mkEntriesFrom n half) + , fxSet = Set.fromList entries + , fxMember = member + , fxFresh = mkEntry (2 * n) (2 * n) + , fxId = eId member + , fxAuthor = eAuthor member + , fxTag = primaryTag member + , fxTags = take 3 tagKeys + , fxPriority = ePriority member + , fxLo = updKeys !! (length updKeys `div` 4) + , fxHi = updKeys !! (3 * length updKeys `div` 4) + , fxDeleteOne = Set.singleton member + , fxDeleteFew = Set.fromList few + , fxDeleteHalf = Set.fromList (everyNth 2 entries) + , fxDeleteList = few + , fxIxSetFew = IxSet.fromList few + } + where + half = n `div` 2 + entries = mkEntries n + few = everyNth 10 entries + ixs = IxSet.fromList entries :: Entries + member = entries !! half + tagKeys = IxSet.indexKeys ixs :: [Tag] + updKeys = IxSet.indexKeys ixs :: [Updated] + +-- | Every @k@th element, so that a selection is spread over all of the +-- indices instead of being contiguous in any one of them. +everyNth :: Int -> [a] -> [a] +everyNth k xs = [ x | (i, x) <- zip [0 :: Int ..] xs, i `mod` k == 0 ] + +-------------------------------------------------------------------------- +-- The benchmarks +-------------------------------------------------------------------------- + +benchmarks :: Int -> Benchmark +benchmarks n = + env (evaluate (force (mkFixture n))) $ \ fx -> + bgroup (show n ++ " elements") + [ byForcing "construction" (construction fx) + , byForcing "update" (update fx) + , byForcing "bulk delete" (bulkDelete fx) + , byForcing "query" (query fx) + , byForcing "set operations" (setOperations fx) + , byForcing "conversion" (conversion fx) + , byForcing "index count" (indexCount fx) + , byForcing "ixFun vs ixGen" (indexKind fx) + ] + +-- | Building an 'IxSet' from scratch, i.e. the price of the indices. +construction :: Fixture -> Forcer -> [(String, Benchmarkable)] +construction fx forcer = + [ ("fromList", forcer (IxSet.fromList :: [Entry] -> Entries) es) + , ("fromSet", forcer (IxSet.fromSet :: Set Entry -> Entries) (fxSet fx)) + , ("fromList (seq ixs)", forcer (IxSet.forceIndices . IxSet.fromList :: [Entry] -> Entries) es) + , ("fromSet (seq ixs)", forcer (IxSet.forceIndices . IxSet.fromSet :: Set Entry -> Entries) (fxSet fx)) + , ("insertList", forcer (\ xs -> IxSet.insertList xs IxSet.empty :: Entries) es) + , ("repeated insert", forcer (List.foldl' (flip IxSet.insert) (IxSet.empty :: Entries)) es) + , ("Set.fromList (ref)", forcer Set.fromList es) + ] + where + es = fxEntries fx + +-- | Incremental modification of an existing 'IxSet'. +update :: Fixture -> Forcer -> [(String, Benchmarkable)] +update fx forcer = + [ ("insert (new element)", forcer (\ e -> IxSet.insert e ixs) (fxFresh fx)) + , ("insert (existing element)", forcer (\ e -> IxSet.insert e ixs) (fxMember fx)) + , ("delete", forcer (\ e -> IxSet.delete e ixs) (fxMember fx)) + , ("delete (absent element)", forcer (\ e -> IxSet.delete e ixs) (fxFresh fx)) + , ("updateIx", forcer (\ i -> IxSet.updateIx i (fxFresh fx) ixs) (fxId fx)) + , ("deleteIx", forcer (\ i -> IxSet.deleteIx i ixs) (fxId fx)) + , ("Set.insert (ref)", forcer (\ e -> Set.insert e (fxSet fx)) (fxFresh fx)) + ] + where + ixs = fxIxSet fx + +-- | Bulk removal. 'IxSet.deleteSet', 'IxSet.difference' and +-- 'IxSet.filter' all work through the indices of the part being removed, +-- instead of deleting element by element; the repeated 'IxSet.delete' +-- benchmark is the baseline they are meant to improve on, and the +-- selectivity sweep shows what each of them costs as a function of how +-- much is removed. +-- +-- Note that 'IxSet.filter' is defined by removing the complement of the +-- predicate, so it is the elements it /discards/, not the ones it keeps, +-- that determine its cost. +bulkDelete :: Fixture -> Forcer -> [(String, Benchmarkable)] +bulkDelete fx forcer = + [ ("deleteSet (1 element)", forcer (\ s -> IxSet.deleteSet s ixs) (fxDeleteOne fx)) + , ("deleteSet (10%)", forcer (\ s -> IxSet.deleteSet s ixs) (fxDeleteFew fx)) + , ("deleteSet (50%)", forcer (\ s -> IxSet.deleteSet s ixs) (fxDeleteHalf fx)) + , ("deleteSet (all)", forcer (\ s -> IxSet.deleteSet s ixs) (fxSet fx)) + , ("repeated delete (10%)", forcer (List.foldl' (flip IxSet.delete) ixs) (fxDeleteList fx)) + , ("difference (10%)", forcer (IxSet.difference ixs) (fxIxSetFew fx)) + , ("filter (keep all)", forcer (\ p -> IxSet.filter p ixs) (const True)) + , ("filter (keep 90%)", forcer (\ p -> IxSet.filter p ixs) keep90) + , ("filter (keep 50%)", forcer (\ p -> IxSet.filter p ixs) keep50) + , ("filter (keep none)", forcer (\ p -> IxSet.filter p ixs) (const False)) + , ("Set.filter (ref, keep 50%)", forcer (\ p -> Set.filter p (fxSet fx)) keep50) + ] + where + ixs = fxIxSet fx + -- The ids run from 0, so a threshold on the id keeps a known fraction. + keep90 = \ e -> eId e >= EntryId (fxSize fx `div` 10) + keep50 = \ e -> eId e >= EntryId (fxSize fx `div` 2) + +-- | Queries. These are currently lazy in the indices of their result, so +-- the gap between the two forcings is at its widest here: WHNF computes +-- the element set only, NF additionally rebuilds every index of the +-- result. +query :: Fixture -> Forcer -> [(String, Benchmarkable)] +query fx forcer = + [ ("getEQ (unique key)", forcer (\ s -> s @= fxId fx) ixs) + , ("getEQ (medium cardinality)", forcer (\ s -> s @= fxAuthor fx) ixs) + , ("getEQ (low cardinality)", forcer (\ s -> s @= fxPriority fx) ixs) + , ("getEQ (multi-valued index)", forcer (\ s -> s @= fxTag fx) ixs) + , ("getLT", forcer (\ s -> s @< fxHi fx) ixs) + , ("getGTE", forcer (\ s -> s @>= fxLo fx) ixs) + , ("getRange (@>=<=)", forcer (\ s -> s @>=<= (fxLo fx, fxHi fx)) ixs) + , ("union of keys (@+)", forcer (\ s -> s @+ fxTags fx) ixs) + , ("intersection of keys (@*)", forcer (\ s -> s @* fxTags fx) ixs) + , ("chained (@= then range)", forcer (\ s -> s @= fxAuthor fx @>=<= (fxLo fx, fxHi fx)) ixs) + , ("chained (three keys)", forcer (\ s -> s @= fxAuthor fx @= fxPriority fx @= fxTag fx) ixs) + , ("Set.filter (ref, unique key)", + forcer (\ i -> Set.filter ((== i) . eId) set) (fxId fx)) + , ("Set.filter (ref, low cardinality key)", + forcer (\ p -> Set.filter ((== p) . ePriority) set) (fxPriority fx)) + , ("Set.filter (ref, range)", + forcer (\ (lo, hi) -> Set.filter (\ e -> eUpdated e >= lo && eUpdated e <= hi) set) + (fxLo fx, fxHi fx)) + ] + where + ixs = fxIxSet fx + set = fxSet fx + +-- | 'IxSet.union', 'IxSet.intersection' and 'IxSet.difference' operate on +-- the indices directly, rather than rebuilding them from the elements. +-- Both arguments here are of the same size, overlapping in half of their +-- elements. +setOperations :: Fixture -> Forcer -> [(String, Benchmarkable)] +setOperations fx forcer = + [ ("union", forcer (IxSet.union ixs) ixs') + , ("union (seq ixs)", forcer (IxSet.forceIndices . IxSet.union ixs) ixs') + , ("intersection", forcer (IxSet.intersection ixs) ixs') + , ("intersection (seq ixs)", forcer (IxSet.forceIndices . IxSet.intersection ixs) ixs') + , ("difference", forcer (IxSet.difference ixs) ixs') + , ("difference (seq ixs)", forcer (IxSet.forceIndices . IxSet.difference ixs) ixs') + , ("(|||)", forcer (ixs |||) ixs') + , ("(&&&)", forcer (ixs &&&) ixs') + , ("(\\\\\\)", forcer (ixs \\\) ixs') + , ("Set.union (ref)", forcer (Set.union (fxSet fx)) (IxSet.toSet ixs')) + , ("Set.intersection (ref)", forcer (Set.intersection (fxSet fx)) (IxSet.toSet ixs')) + , ("Set.difference (ref)", forcer (Set.difference (fxSet fx)) (IxSet.toSet ixs')) + ] + where + ixs = fxIxSet fx + ixs' = fxIxSetB fx + +-- | Getting data back out again. +conversion :: Fixture -> Forcer -> [(String, Benchmarkable)] +conversion fx forcer = + [ ("toList", forcer IxSet.toList ixs) + , ("toSet", forcer IxSet.toSet ixs) + , ("toAscList", forcer (IxSet.toAscList (Proxy :: Proxy Updated)) ixs) + , ("toDescList", forcer (IxSet.toDescList (Proxy :: Proxy Updated)) ixs) + , ("groupBy", forcer (\ s -> IxSet.groupBy s :: [(Author, [Entry])]) ixs) + , ("groupAscBy", forcer (\ s -> IxSet.groupAscBy s :: [(Author, [Entry])]) ixs) + , ("groupDescBy", forcer (\ s -> IxSet.groupDescBy s :: [(Author, [Entry])]) ixs) + , ("indexKeys", forcer (\ s -> IxSet.indexKeys s :: [Updated]) ixs) + , ("getOne", forcer (\ i -> IxSet.getOne (ixs @= i)) (fxId fx)) + , ("size", forcer IxSet.size ixs) + , ("null", forcer IxSet.null ixs) + , ("stats", forcer IxSet.stats ixs) + ] + where + ixs = fxIxSet fx + +-- | How the cost of construction and of a single update scales with the +-- number of declared indices. +indexCount :: Fixture -> Forcer -> [(String, Benchmarkable)] +indexCount fx forcer = + [ ("fromList (1 index)", forcer (IxSet.fromList :: [Entry] -> Entries1) es) + , ("fromList (2 indices)", forcer (IxSet.fromList :: [Entry] -> Entries2) es) + , ("fromList (3 indices)", forcer (IxSet.fromList :: [Entry] -> Entries3) es) + , ("fromList (5 indices)", forcer (IxSet.fromList :: [Entry] -> Entries) es) + , ("insert (1 index)", forcer (\ e -> IxSet.insert e (fxIxSet1 fx)) fresh) + , ("insert (2 indices)", forcer (\ e -> IxSet.insert e (fxIxSet2 fx)) fresh) + , ("insert (3 indices)", forcer (\ e -> IxSet.insert e (fxIxSet3 fx)) fresh) + , ("insert (5 indices)", forcer (\ e -> IxSet.insert e (fxIxSet fx)) fresh) + , ("getEQ (1 index)", forcer (\ i -> fxIxSet1 fx @= i) (fxId fx)) + , ("getEQ (2 indices)", forcer (\ i -> fxIxSet2 fx @= i) (fxId fx)) + , ("getEQ (3 indices)", forcer (\ i -> fxIxSet3 fx @= i) (fxId fx)) + , ("getEQ (5 indices)", forcer (\ i -> fxIxSet fx @= i) (fxId fx)) + ] + where + es = fxEntries fx + fresh = fxFresh fx + +-- | 'ixGen' uses an SYB traversal to extract keys, 'ixFun' a supplied +-- function. Same data, same two indices, so this measures the difference +-- between the two ways of declaring them. +indexKind :: Fixture -> Forcer -> [(String, Benchmarkable)] +indexKind fx forcer = + [ ("ixFun", forcer (IxSet.fromList :: [Entry] -> SmallEntries) (fxEntries fx)) + , ("ixGen", forcer (IxSet.fromList :: [GenEntry] -> GenEntries) (fxGenEntries fx)) + ] diff --git a/ixset-typed.cabal b/ixset-typed.cabal --- a/ixset-typed.cabal +++ b/ixset-typed.cabal @@ -1,5 +1,5 @@ name: ixset-typed -version: 0.5.1.1 +version: 0.6 synopsis: Efficient relational queries on Haskell sets. description: This Haskell package provides a data structure of sets that are indexed @@ -17,7 +17,9 @@ . At the moment, the two packages are relatively compatible. As a consequence of the more precise types, a few manual tweaks are necessary when switching - from one to the other, but the interface is mostly the same. + from one to the other, but the interface is mostly the same. The main other + differences are strictness behaviour, and the semantics of `getRange` and + similar interval selection operators (see the Haddocks). license: BSD3 license-file: COPYING author: Andres Löh, Happstack team, HAppS LLC @@ -26,41 +28,59 @@ build-type: Simple cabal-version: >= 1.10 extra-source-files: CHANGELOG.md -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.2, GHC == 9.12.4, GHC == 9.14.1 +tested-with: GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.2, GHC == 9.12.4, GHC == 9.14.1 source-repository head type: git location: https://github.com/well-typed/ixset-typed.git library - build-depends: base >= 4.9 && < 5, - containers >= 0.5 && < 1, + build-depends: base >= 4.11 && < 5, + containers >= 0.5.9 && < 1, deepseq >= 1.3 && < 2, safecopy >= 0.8 && < 0.11, - syb >= 0.4 && < 1, - template-haskell >= 2.8 && < 2.25 + template-haskell >= 2.17 && < 2.25 hs-source-dirs: src exposed-modules: Data.IxSet.Typed - Data.IxSet.Typed.Ix + Data.IxSet.Typed.Internal.Ix + Data.IxSet.Typed.Internal.IxList + Data.IxSet.Typed.Internal.IxSet - ghc-options: -Wall -fno-warn-unused-do-bind + ghc-options: -Wall -Wredundant-constraints default-language: Haskell2010 test-suite test-ixset-typed type: exitcode-stdio-1.0 build-depends: ixset-typed, - base >= 4.9 && < 5, - containers >= 0.5 && < 1, + base, + containers, tasty, tasty-hunit, - tasty-quickcheck + tasty-quickcheck, + time hs-source-dirs: tests main-is: TestIxSetTyped.hs other-modules: Data.IxSet.Typed.Tests + Example ghc-options: -Wall + + default-language: Haskell2010 + +benchmark bench-ixset-typed + type: exitcode-stdio-1.0 + build-depends: ixset-typed, + base, + containers, + deepseq, + tasty-bench >= 0.3 && < 0.6 + hs-source-dirs: bench + main-is: Main.hs + other-modules: Bench.Types + + ghc-options: -Wall "-with-rtsopts=-A32m -T -N1" -threaded -fproc-alignment=64 default-language: Haskell2010 diff --git a/src/Data/IxSet/Typed.hs b/src/Data/IxSet/Typed.hs --- a/src/Data/IxSet/Typed.hs +++ b/src/Data/IxSet/Typed.hs @@ -1,30 +1,24 @@ -{-# LANGUAGE UndecidableInstances, FlexibleInstances, - MultiParamTypeClasses, TemplateHaskell, RankNTypes, - FunctionalDependencies, DeriveDataTypeable, - GADTs, CPP, ScopedTypeVariables, KindSignatures, - DataKinds, TypeOperators, StandaloneDeriving, - TypeFamilies, ScopedTypeVariables, ConstraintKinds, - FunctionalDependencies, FlexibleContexts, BangPatterns #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + {- | An efficient implementation of queryable sets. Assume you have a family of types such as: > data Entry = Entry Author [Author] Updated Id Content -> deriving (Show, Eq, Ord, Data, Typeable) +> deriving (Show, Eq, Ord, Data) > newtype Updated = Updated UTCTime -> deriving (Show, Eq, Ord, Data, Typeable) +> deriving (Show, Eq, Ord, Data) > newtype Id = Id Int64 -> deriving (Show, Eq, Ord, Data, Typeable) +> deriving (Show, Eq, Ord, Data) > newtype Content = Content String -> deriving (Show, Eq, Ord, Data, Typeable) +> deriving (Show, Eq, Ord, Data) > newtype Author = Author Email -> deriving (Show, Eq, Ord, Data, Typeable) +> deriving (Show, Eq, Ord, Data) > type Email = String > data Test = Test -> deriving (Show, Eq, Ord, Data, Typeable) +> deriving (Show, Eq, Ord, Data) 1. Decide what parts of your type you want indexed and make your type an instance of 'Indexable'. Use 'ixFun' and 'ixGen' to build indices: @@ -39,7 +33,7 @@ > (ixGen (Proxy :: Proxy Updated)) > (ixGen (Proxy :: Proxy Test)) -- bogus index - The use of 'ixGen' requires the 'Data' and 'Typeable' instances above. + The use of 'ixGen' requires the 'Data' instances above. You can build indices manually using 'ixFun'. You can also use the Template Haskell function 'inferIxSet' to generate an 'Indexable' instance automatically. @@ -102,6 +96,30 @@ > entries @= (FirstAuthor "john@doe.com") -- guess what this does += Strictness + +An 'IxSet' is "mostly" spine-strict: it is generally spine-strict +in the set itself, but tries to avoid building the indices until they are +needed. Thus: + + * Construction operations ('fromSet' and 'fromList') will evaluate the elements + to build the underlying set, but will build the indices lazily. Since the + only data the index construction retains are elements of the set, this should not + cause a significant space leak. However, if you wish to perform the index + construction up front rather than deferring it until the indices are forced, + use 'forceIndices'. + + * Index lookups (such as 'getEQ') and other query operations (including 'filter', + 'union' and 'intersection') are lazy in the indices, so querying a number of + times and subsequently selecting the result will not unnecessarily rebuild all + indices. This could result in a space leak if you repeatedly query and then + retain the resulting 'IxSet' without looking at the results. Again, you can + use 'forceIndices' to avoid this. + + * Operations that modify 'IxSet' (e.g. 'insert', 'delete', 'updateIx') are + spine-strict in the indices as well. This avoids retaining old copies of the + 'IxSet' as it is modified. There are currently no lazy modification operations. + -} module Data.IxSet.Typed @@ -109,15 +127,20 @@ -- * Set type IxSet(), IxList(), + + -- ** Indexable types Indexable(..), IsIndexOf(), All, + project, + -- ** Declaring indices Ix(), ixList, MkIxList(), ixFun, ixGen, + -- ** TH derivation of indices noCalcs, inferIxSet, @@ -128,9 +151,14 @@ change, insert, insertList, + insertSet, + insertMany, delete, + deleteSet, + deleteMany, updateIx, deleteIx, + deleteIxMany, -- * Creation empty, @@ -152,8 +180,11 @@ -- * Set operations (&&&), (|||), + (\\\), union, intersection, + difference, + filter, -- * Indexing (@=), @@ -173,6 +204,13 @@ getLTE, getGTE, getRange, + + -- * Lookup + lookupIx, + lookupIxMany, + lookupOne, + + -- * Grouping groupBy, groupAscBy, groupDescBy, @@ -183,302 +221,27 @@ flattenWithCalcs, -- * Debugging and optimization + forceIndices, stats ) where -import Data.Kind -import Prelude hiding (null) - -import Control.Arrow (first, second) -import Control.DeepSeq -import qualified Data.Foldable as Fold -import Data.Generics (Data, gmapQ) --- import qualified Data.Generics.SYB.WithClass.Basics as SYBWC -import qualified Data.IxSet.Typed.Ix as Ix -import Data.IxSet.Typed.Ix (Ix(Ix)) +import Data.Data (Data, gmapQ) +import Data.IxSet.Typed.Internal.Ix (Ix(Ix)) +import Data.IxSet.Typed.Internal.IxList +import Data.IxSet.Typed.Internal.IxSet import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.SafeCopy (SafeCopy(..), contain, safeGet, safePut) -import Data.Semigroup (Semigroup(..)) import Data.Set (Set) -import qualified Data.Set as Set -import Data.Typeable (Typeable, cast {- , typeOf -}) -import Language.Haskell.TH as TH hiding (Type) - --------------------------------------------------------------------------- --- The main 'IxSet' datatype. --------------------------------------------------------------------------- - --- | Set with associated indices. --- --- The type-level list 'ixs' contains all types that are valid index keys. --- The type 'a' is the type of elements in the indexed set. --- --- On strictness: An 'IxSet' is "mostly" spine-strict. It is generally --- spine-strict in the set itself. All operations on 'IxSet' with the --- exception of queries are spine-strict in the indices as well. Query --- operations, however, are lazy in the indices, so querying a number of --- times and subsequently selecting the result will not unnecessarily --- rebuild all indices. --- -data IxSet (ixs :: [Type]) (a :: Type) where - IxSet :: !(Set a) -> !(IxList ixs a) -> IxSet ixs a - -data IxList (ixs :: [Type]) (a :: Type) where - Nil :: IxList '[] a - (:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a - -infixr 5 ::: - --- | A strict variant of ':::'. -(!:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a -(!:::) !ix !ixs = ix ::: ixs - -infixr 5 !::: - --- TODO: --- --- We cannot currently derive Typeable for 'IxSet': --- --- * In ghc-7.6, Typeable isn't supported for non-* kinds. --- * In ghc-7.8, see bug #8950. We can work around this, but I rather --- would wait for a proper fix. - --- deriving instance Data (IxSet ixs a) --- deriving instance Typeable IxSet - - --------------------------------------------------------------------------- --- Type-level tools for dealing with indexed sets. --- --- These are partially internal. TODO: Move to different module? --------------------------------------------------------------------------- - --- | The constraint @All c xs@ says the @c@ has to hold for all --- elements in the type-level list @xs@. --- --- Example: --- --- > All Ord '[Int, Char, Bool] --- --- is equivalent to --- --- > (Ord Int, Ord Char, Ord Bool) --- -type family All (c :: Type -> Constraint) (xs :: [Type]) :: Constraint -type instance All c '[] = () -type instance All c (x ': xs) = (c x, All c xs) - --- | Associate indices with a given type. The constraint --- @'Indexable' ixs a@ says that we know how to build index sets --- of type @'IxSet' ixs a@. --- --- In order to use an 'IxSet' on a particular type, you have to --- make it an instance of 'Indexable' yourself. There are no --- predefined instances of 'IxSet'. --- -class (All Ord ixs, Ord a) => Indexable ixs a where - - -- | Define how the indices for this particular type should look like. - -- - -- Use the 'ixList' function to construct the list of indices, and use - -- 'ixFun' (or 'ixGen') for individual indices. - indices :: IxList ixs a - --- | Constraint for membership in the type-level list. Says that 'ix' --- is contained in the index list 'ixs'. -class Ord ix => IsIndexOf (ix :: Type) (ixs :: [Type]) where - - -- | Provide access to the selected index in the list. - access :: IxList ixs a -> Ix ix a - - -- | Map over the index list, treating the selected different - -- from the rest. - -- - -- The function 'mapAt' is lazy in the index list structure, - -- because it is used by query operations. - mapAt :: (All Ord ixs) - => (Ix ix a -> Ix ix a) - -- ^ what to do with the selected index - -> (forall ix'. Ord ix' => Ix ix' a -> Ix ix' a) - -- ^ what to do with the other indices - -> IxList ixs a -> IxList ixs a - -instance - {-# OVERLAPPING #-} - Ord ix => IsIndexOf ix (ix ': ixs) where - access (x ::: _xs) = x - mapAt fh ft (x ::: xs) = fh x ::: mapIxList ft xs - -instance - {-# OVERLAPPABLE #-} - IsIndexOf ix ixs => IsIndexOf ix (ix' ': ixs) where - access (_x ::: xs) = access xs - mapAt fh ft (x ::: xs) = ft x ::: mapAt fh ft xs - --- | Return the length of an index list. --- --- TODO: Could be statically unrolled. -lengthIxList :: forall ixs a. IxList ixs a -> Int -lengthIxList = go 0 - where - go :: forall ixs'. Int -> IxList ixs' a -> Int - go !acc Nil = acc - go !acc (_ ::: xs) = go (acc + 1) xs - --- | Turn an index list into a normal list, given a function that --- turns an arbitrary index into an element of a fixed type @r@. -ixListToList :: All Ord ixs - => (forall ix. Ord ix => Ix ix a -> r) - -- ^ what to do with each index - -> IxList ixs a -> [r] -ixListToList _ Nil = [] -ixListToList f (x ::: xs) = f x : ixListToList f xs - --- | Map over an index list. -mapIxList :: All Ord ixs - => (forall ix. Ord ix => Ix ix a -> Ix ix a) - -- ^ what to do with each index - -> IxList ixs a -> IxList ixs a -mapIxList _ Nil = Nil -mapIxList f (x ::: xs) = f x ::: mapIxList f xs - --- | Map over an index list (spine-strict). -mapIxList' :: All Ord ixs - => (forall ix. Ord ix => Ix ix a -> Ix ix a) - -- ^ what to do with each index - -> IxList ixs a -> IxList ixs a -mapIxList' _ Nil = Nil -mapIxList' f (x ::: xs) = f x !::: mapIxList' f xs - --- | Zip two index lists of compatible type (spine-strict). -zipWithIxList' :: All Ord ixs - => (forall ix. Ord ix => Ix ix a -> Ix ix a -> Ix ix a) - -- ^ how to combine two corresponding indices - -> IxList ixs a -> IxList ixs a -> IxList ixs a -zipWithIxList' _ Nil Nil = Nil -zipWithIxList' f (x ::: xs) (y ::: ys) = f x y !::: zipWithIxList' f xs ys -#if __GLASGOW_HASKELL__ < 800 -zipWithIxList' _ _ _ = error "Data.IxSet.Typed.zipWithIxList: impossible" - -- the line above is actually impossible by the types; it's just there - -- to please avoid the warning resulting from the exhaustiveness check -#endif - --------------------------------------------------------------------------- --- Various instances for 'IxSet' --------------------------------------------------------------------------- - -instance Indexable ixs a => Eq (IxSet ixs a) where - IxSet a _ == IxSet b _ = a == b - -instance Indexable ixs a => Ord (IxSet ixs a) where - compare (IxSet a _) (IxSet b _) = compare a b - -instance (Indexable ixs a, Show a) => Show (IxSet ixs a) where - showsPrec prec = showsPrec prec . toSet - -instance (Indexable ixs a, Read a) => Read (IxSet ixs a) where - readsPrec n = map (first fromSet) . readsPrec n - -instance (Indexable ixs a, Typeable ixs, SafeCopy a, Typeable a) => SafeCopy (IxSet ixs a) where - putCopy = contain . safePut . toList - getCopy = contain $ fmap fromList safeGet - -instance (All NFData ixs, NFData a) => NFData (IxList ixs a) where - rnf Nil = () - rnf (x ::: xs) = rnf x `seq` rnf xs - -instance (All NFData ixs, NFData a) => NFData (IxSet ixs a) where - rnf (IxSet a ixs) = rnf a `seq` rnf ixs - -instance Indexable ixs a => Semigroup (IxSet ixs a) where - (<>) = union - -instance Indexable ixs a => Monoid (IxSet ixs a) where - mempty = empty - mappend = (<>) - -instance Foldable (IxSet ixs) where - fold = Fold.fold . toSet - foldMap f = Fold.foldMap f . toSet - foldr f z = Fold.foldr f z . toSet - foldl f z = Fold.foldl f z . toSet - --- TODO: Do we need SYBWC? -{- -instance ( SYBWC.Data ctx a - , SYBWC.Data ctx [a] - , SYBWC.Sat (ctx (IxSet a)) - , SYBWC.Sat (ctx [a]) - , Indexable a - , Data a - , Ord a - ) - => SYBWC.Data ctx (IxSet a) where - gfoldl _ f z ixset = z fromList `f` toList ixset - toConstr _ (IxSet _) = ixSetConstr - gunfold _ k z c = case SYBWC.constrIndex c of - 1 -> k (z fromList) - _ -> error "IxSet.SYBWC.Data.gunfold unexpected match" - dataTypeOf _ _ = ixSetDataType - -ixSetConstr :: SYBWC.Constr -ixSetConstr = SYBWC.mkConstr ixSetDataType "IxSet" [] SYBWC.Prefix -ixSetDataType :: SYBWC.DataType -ixSetDataType = SYBWC.mkDataType "IxSet" [ixSetConstr] --} - --- TODO: Do we need Default? -{- FIXME -instance (Indexable a, Ord a,Data a, Default a) => Default (IxSet a) where - defaultValue = empty --} +import Data.Typeable (Typeable, cast) +import Language.Haskell.TH as TH hiding (Type) +import Prelude hiding (filter, null) -------------------------------------------------------------------------- -- 'IxSet' construction -------------------------------------------------------------------------- --- | An empty 'IxSet'. -empty :: Indexable ixs a => IxSet ixs a -empty = IxSet Set.empty indices - --- | Create an (empty) 'IxList' from a number of indices. Useful in the 'Indexable' --- 'indices' method. Use 'ixFun' and 'ixGen' for the individual indices. --- --- Note that this function takes a variable number of arguments. --- Here are some example types at which the function can be used: --- --- > ixList :: Ix ix1 a -> IxList '[ix1] a --- > ixList :: Ix ix1 a -> Ix ix2 a -> IxList '[ix1, ix2] a --- > ixList :: Ix ix1 a -> Ix ix2 a -> Ix ix3 a -> IxList '[ix1, ix2, ix3] a --- > ixList :: ... --- --- Concrete example use: --- --- > instance Indexable '[..., Index1Type, Index2Type] Type where --- > indices = ixList --- > ... --- > (ixFun getIndex1) --- > (ixGen (Proxy :: Proxy Index2Type)) --- -ixList :: MkIxList ixs ixs a r => r -ixList = ixList' id - --- | Class that allows a variable number of arguments to be passed to the --- 'ixSet' and 'mkEmpty' functions. See the documentation of these functions --- for more information. -class MkIxList ixs ixs' a r | r -> a ixs ixs' where - ixList' :: (IxList ixs a -> IxList ixs' a) -> r - -instance MkIxList '[] ixs a (IxList ixs a) where - ixList' acc = acc Nil - -instance MkIxList ixs ixs' a r => MkIxList (ix ': ixs) ixs' a (Ix ix a -> r) where - ixList' acc ix = ixList' (\ x -> acc (ix ::: x)) - -- | Create a functional index. Provided function should return a list -- of indices where the value should be found. -- @@ -490,11 +253,11 @@ -- -- This is the recommended way to create indices. -- -ixFun :: Ord ix => (a -> [ix]) -> Ix ix a +ixFun :: (a -> [ix]) -> Ix ix a ixFun = Ix Map.empty --- | Create a generic index. Provided example is used only as type source --- so you may use a 'Proxy'. This uses flatten to traverse values using +-- | Create a generic index. Provided argument is used only as type source +-- so you may use a 'Proxy'. This uses 'flatten' to traverse values using -- their 'Data' instances. -- -- > instance Indexable '[IndexType] Type where @@ -503,7 +266,7 @@ -- In production systems consider using 'ixFun' in place of 'ixGen' as -- the former one is much faster. -- -ixGen :: forall proxy a ix. (Ord ix, Data a, Typeable ix) => proxy ix -> Ix ix a +ixGen :: forall proxy a ix. (Data a, Typeable ix) => proxy ix -> Ix ix a ixGen _proxy = ixFun (flatten :: a -> [ix]) -------------------------------------------------------------------------- @@ -519,7 +282,7 @@ -- 'Indexable' instance from a data type, e.g. -- -- > data Foo = Foo Int String --- > deriving (Eq, Ord, Data, Typeable) +-- > deriving (Eq, Ord, Data) -- -- and -- @@ -548,35 +311,23 @@ = do calInfo <- reify calName typeInfo <- reify typeName let (context,binders) = case typeInfo of -#if MIN_VERSION_template_haskell(2,11,0) TyConI (DataD ctxt _ nms _ _ _) -> (ctxt,nms) TyConI (NewtypeD ctxt _ nms _ _ _) -> (ctxt,nms) -#else - TyConI (DataD ctxt _ nms _ _) -> (ctxt,nms) - TyConI (NewtypeD ctxt _ nms _ _) -> (ctxt,nms) -#endif - TyConI (TySynD _ nms _) -> ([],nms) _ -> error "IxSet.inferIxSet typeInfo unexpected match" names = map tyVarBndrToName binders typeCon = List.foldl' appT (conT typeName) (map varT names) -#if MIN_VERSION_template_haskell(2,10,0) + mkCtx c = List.foldl' appT (conT c) -#else - mkCtx = classP -#endif + dataCtxConQ = concat [[mkCtx ''Data [varT name], mkCtx ''Ord [varT name]] | name <- names] fullContext = do dataCtxCon <- sequence dataCtxConQ return (context ++ dataCtxCon) case calInfo of -#if MIN_VERSION_template_haskell(2,11,0) VarI _ _t _ -> -#else - VarI _ _t _ _ -> -#endif let {- calType = getCalType t getCalType (ForallT _names _ t') = getCalType t' @@ -585,11 +336,7 @@ -} mkEntryPoint n = (conE 'Ix) `appE` (sigE (varE 'Map.empty) (forallT -#if MIN_VERSION_template_haskell(2,17,0) (map (SpecifiedSpec <$) binders) -#else - binders -#endif (return context) $ appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) typeCon))) `appE` @@ -606,21 +353,15 @@ return $ [i, ixType'] -- ++ d _ -> error "IxSet.inferIxSet calInfo unexpected match" -#if MIN_VERSION_template_haskell(2,17,0) tyVarBndrToName :: TyVarBndr flag -> Name tyVarBndrToName (PlainTV nm _) = nm tyVarBndrToName (KindedTV nm _ _) = nm -#else -tyVarBndrToName :: TyVarBndr -> Name -tyVarBndrToName (PlainTV nm) = nm -tyVarBndrToName (KindedTV nm _) = nm -#endif -- | Generically traverses the argument to find all occurences of -- values of type @b@ and returns them as a list. -- -- This function properly handles 'String' as 'String' not as @['Char']@. -flatten :: (Typeable a, Data a, Typeable b) => a -> [b] +flatten :: (Data a, Typeable b) => a -> [b] flatten x = case cast x of Just y -> case cast (y :: String) of Just v -> [v] @@ -636,415 +377,5 @@ -- > flatten (x,calcs x) -- -- This function properly handles 'String' as 'String' not as @['Char']@. -flattenWithCalcs :: (Data c,Typeable a, Data a, Typeable b) => (a -> c) -> a -> [b] +flattenWithCalcs :: (Data c, Data a, Typeable b) => (a -> c) -> a -> [b] flattenWithCalcs calcs x = flatten (x,calcs x) - --------------------------------------------------------------------------- --- Modification of 'IxSet's --------------------------------------------------------------------------- - -type SetOp = - forall a. Ord a => a -> Set a -> Set a - -type IndexOp = - forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a) - --- | Higher order operator for modifying 'IxSet's. Use this when your --- final function should have the form @a -> 'IxSet' a -> 'IxSet' a@, --- e.g. 'insert' or 'delete'. -change :: forall ixs a. Indexable ixs a - => SetOp -> IndexOp -> a -> IxSet ixs a -> IxSet ixs a -change opS opI x (IxSet a indexes) = IxSet (opS x a) v - where - v :: IxList ixs a - v = mapIxList' update indexes - - update :: forall ix. Ord ix => Ix ix a -> Ix ix a - update (Ix index f) = Ix index' f - where - ds :: [ix] - ds = f x - ii :: forall k. Ord k => Map k (Set a) -> k -> Map k (Set a) - ii m dkey = opI dkey x m - index' :: Map ix (Set a) - index' = List.foldl' ii index ds - -insertList :: forall ixs a. Indexable ixs a - => [a] -> IxSet ixs a -> IxSet ixs a -insertList xs (IxSet a indexes) = IxSet (List.foldl' (\ b x -> Set.insert x b) a xs) v - where - v :: IxList ixs a - v = mapIxList' update indexes - - update :: forall ix. Ord ix => Ix ix a -> Ix ix a - update (Ix index f) = Ix index' f - where - dss :: [(ix, a)] - dss = [(k, x) | x <- xs, k <- f x] - - index' :: Map ix (Set a) - index' = Ix.insertList dss index - --- | Internal helper function that takes a partial index from one index --- set and rebuilds the rest of the structure of the index set. --- --- Slightly rewritten comment from original version regarding dss / index': --- --- We try to be really clever here. The partialindex is a Map of Sets --- from original index. We want to reuse it as much as possible. If there --- was a guarantee that each element is present at at most one key we --- could reuse originalindex as it is. But there can be more, so we need to --- add remaining ones (in updateh). Anyway we try to reuse old structure and --- keep new allocations low as much as possible. -fromMapOfSets :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs) - => Map ix (Set a) -> IxSet ixs a -fromMapOfSets partialindex = - IxSet a (mapAt updateh updatet indices) - where - a :: Set a - a = Set.unions (Map.elems partialindex) - - xs :: [a] - xs = Set.toList a - - -- Update function for the index corresponding to partialindex. - updateh :: Ix ix a -> Ix ix a - updateh (Ix _ f) = Ix ix f - where - dss :: [(ix, a)] - dss = [(k, x) | x <- xs, k <- f x, not (Map.member k partialindex)] - - ix :: Map ix (Set a) - ix = Ix.insertList dss partialindex - - -- Update function for all other indices. - updatet :: forall ix'. Ord ix' => Ix ix' a -> Ix ix' a - updatet (Ix _ f) = Ix ix f - where - dss :: [(ix', a)] - dss = [(k, x) | x <- xs, k <- f x] - - ix :: Map ix' (Set a) - ix = Ix.fromList dss - --- | Inserts an item into the 'IxSet'. If your data happens to have --- a primary key this function might not be what you want. See --- 'updateIx'. -insert :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a -insert = change Set.insert Ix.insert - --- | Removes an item from the 'IxSet'. -delete :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a -delete = change Set.delete Ix.delete - --- | Will replace the item with the given index of type 'ix'. --- Only works if there is at most one item with that index in the 'IxSet'. --- Will not change 'IxSet' if you have more than one item with given index. -updateIx :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> a -> IxSet ixs a -> IxSet ixs a -updateIx i new ixset = insert new $ - maybe ixset (flip delete ixset) $ - getOne $ ixset @= i - --- | Will delete the item with the given index of type 'ix'. --- Only works if there is at most one item with that index in the 'IxSet'. --- Will not change 'IxSet' if you have more than one item with given index. -deleteIx :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> IxSet ixs a -> IxSet ixs a -deleteIx i ixset = maybe ixset (flip delete ixset) $ - getOne $ ixset @= i - - --------------------------------------------------------------------------- --- Conversions --------------------------------------------------------------------------- - --- | Converts an 'IxSet' to a 'Set' of its elements. -toSet :: IxSet ixs a -> Set a -toSet (IxSet a _) = a - --- | Converts a 'Set' to an 'IxSet'. -fromSet :: (Indexable ixs a) => Set a -> IxSet ixs a -fromSet = fromList . Set.toList - --- | Converts a list to an 'IxSet'. -fromList :: (Indexable ixs a) => [a] -> IxSet ixs a -fromList list = insertList list empty - --- | Returns the number of unique items in the 'IxSet'. -size :: IxSet ixs a -> Int -size = Set.size . toSet - --- | Converts an 'IxSet' to its list of elements. -toList :: IxSet ixs a -> [a] -toList = Set.toList . toSet - --- | Converts an 'IxSet' to its list of elements. --- --- List will be sorted in ascending order by the index 'ix'. --- --- The list may contain duplicate entries if a single value produces multiple keys. -toAscList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a] -toAscList _ ixset = concatMap snd (groupAscBy ixset :: [(ix, [a])]) - --- | Converts an 'IxSet' to its list of elements. --- --- List will be sorted in descending order by the index 'ix'. --- --- The list may contain duplicate entries if a single value produces multiple keys. -toDescList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a] -toDescList _ ixset = concatMap snd (groupDescBy ixset :: [(ix, [a])]) - --- | If the 'IxSet' is a singleton it will return the one item stored in it. --- If 'IxSet' is empty or has many elements this function returns 'Nothing'. -getOne :: Ord a => IxSet ixs a -> Maybe a -getOne ixset = case toList ixset of - [x] -> Just x - _ -> Nothing - --- | Like 'getOne' with a user-provided default. -getOneOr :: Ord a => a -> IxSet ixs a -> a -getOneOr def = fromMaybe def . getOne - --- | Return 'True' if the 'IxSet' is empty, 'False' otherwise. -null :: IxSet ixs a -> Bool -null (IxSet a _) = Set.null a - --------------------------------------------------------------------------- --- Set operations --------------------------------------------------------------------------- - --- | An infix 'intersection' operation. -(&&&) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a -(&&&) = intersection - --- | An infix 'union' operation. -(|||) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a -(|||) = union - -infixr 5 &&& -infixr 5 ||| - --- | Takes the union of the two 'IxSet's. -union :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a -union (IxSet a1 x1) (IxSet a2 x2) = - IxSet (Set.union a1 a2) - (zipWithIxList' (\ (Ix a f) (Ix b _) -> Ix (Ix.union a b) f) x1 x2) --- TODO: function is taken from the first - --- | Takes the intersection of the two 'IxSet's. -intersection :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a -intersection (IxSet a1 x1) (IxSet a2 x2) = - IxSet (Set.intersection a1 a2) - (zipWithIxList' (\ (Ix a f) (Ix b _) -> Ix (Ix.intersection a b) f) x1 x2) --- TODO: function is taken from the first - --------------------------------------------------------------------------- --- Query operations --------------------------------------------------------------------------- - --- | Infix version of 'getEQ'. -(@=) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> ix -> IxSet ixs a -ix @= v = getEQ v ix - --- | Infix version of 'getLT'. -(@<) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> ix -> IxSet ixs a -ix @< v = getLT v ix - --- | Infix version of 'getGT'. -(@>) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> ix -> IxSet ixs a -ix @> v = getGT v ix - --- | Infix version of 'getLTE'. -(@<=) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> ix -> IxSet ixs a -ix @<= v = getLTE v ix - --- | Infix version of 'getGTE'. -(@>=) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> ix -> IxSet ixs a -ix @>= v = getGTE v ix - --- | Returns the subset with indices in the open interval (k,k). -(@><) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> (ix, ix) -> IxSet ixs a -ix @>< (v1,v2) = getLT v2 $ getGT v1 ix - --- | Returns the subset with indices in [k,k). -(@>=<) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> (ix, ix) -> IxSet ixs a -ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix - --- | Returns the subset with indices in (k,k]. -(@><=) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> (ix, ix) -> IxSet ixs a -ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix - --- | Returns the subset with indices in [k,k]. -(@>=<=) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> (ix, ix) -> IxSet ixs a -ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix - --- | Creates the subset that has an index in the provided list. -(@+) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> [ix] -> IxSet ixs a -ix @+ list = List.foldl' union empty $ map (ix @=) list - --- | Creates the subset that matches all the provided indices. -(@*) :: (Indexable ixs a, IsIndexOf ix ixs) - => IxSet ixs a -> [ix] -> IxSet ixs a -ix @* list = List.foldl' intersection ix $ map (ix @=) list - --- | Returns the subset with an index equal to the provided key. The --- set must be indexed over key type, doing otherwise results in --- runtime error. -getEQ :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> IxSet ixs a -> IxSet ixs a -getEQ = getOrd EQ - --- | Returns the subset with an index less than the provided key. The --- set must be indexed over key type, doing otherwise results in --- runtime error. -getLT :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> IxSet ixs a -> IxSet ixs a -getLT = getOrd LT - --- | Returns the subset with an index greater than the provided key. --- The set must be indexed over key type, doing otherwise results in --- runtime error. -getGT :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> IxSet ixs a -> IxSet ixs a -getGT = getOrd GT - --- | Returns the subset with an index less than or equal to the --- provided key. The set must be indexed over key type, doing --- otherwise results in runtime error. -getLTE :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> IxSet ixs a -> IxSet ixs a -getLTE = getOrd2 True True False - --- | Returns the subset with an index greater than or equal to the --- provided key. The set must be indexed over key type, doing --- otherwise results in runtime error. -getGTE :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> IxSet ixs a -> IxSet ixs a -getGTE = getOrd2 False True True - --- | Returns the subset with an index within the interval provided. --- The bottom of the interval is closed and the top is open, --- i. e. [k1;k2). The set must be indexed over key type, doing --- otherwise results in runtime error. -getRange :: (Indexable ixs a, IsIndexOf ix ixs) - => ix -> ix -> IxSet ixs a -> IxSet ixs a -getRange k1 k2 ixset = getGTE k1 (getLT k2 ixset) - --- | Returns lists of elements paired with the indices determined by --- type inference. -groupBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] -groupBy (IxSet _ indexes) = f (access indexes) - where - f :: Ix ix a -> [(ix, [a])] - f (Ix index _) = map (second Set.toList) (Map.toList index) - --- | Returns the list of index keys being used for a particular index. -indexKeys :: forall ix ixs a . IsIndexOf ix ixs => IxSet ixs a -> [ix] -indexKeys (IxSet _ indexes) = f (access indexes) - where - f :: Ix ix a -> [ix] - f (Ix index _) = Map.keys index - --- | Returns lists of elements paired with the indices determined by --- type inference. --- --- The resulting list will be sorted in ascending order by 'ix'. --- The values in @[a]@ will be sorted in ascending order as well. -groupAscBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] -groupAscBy (IxSet _ indexes) = f (access indexes) - where - f :: Ix ix a -> [(ix, [a])] - f (Ix index _) = map (second Set.toAscList) (Map.toAscList index) - --- | Returns lists of elements paired with the indices determined by --- type inference. --- --- The resulting list will be sorted in descending order by 'ix'. --- --- NOTE: The values in @[a]@ are currently sorted in ascending --- order. But this may change if someone bothers to add --- 'Set.toDescList'. So do not rely on the sort order of the --- resulting list. -groupDescBy :: IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] -groupDescBy (IxSet _ indexes) = f (access indexes) - where - f :: Ix ix a -> [(ix, [a])] - f (Ix index _) = map (second Set.toAscList) (Map.toDescList index) - --- | A function for building up selectors on 'IxSet's. Used in the --- various get* functions. The set must be indexed over key type, --- doing otherwise results in runtime error. - -getOrd :: (Indexable ixs a, IsIndexOf ix ixs) - => Ordering -> ix -> IxSet ixs a -> IxSet ixs a -getOrd LT = getOrd2 True False False -getOrd EQ = getOrd2 False True False -getOrd GT = getOrd2 False False True - --- | A function for building up selectors on 'IxSet's. Used in the --- various get* functions. The set must be indexed over key type, --- doing otherwise results in runtime error. -getOrd2 :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs) - => Bool -> Bool -> Bool -> ix -> IxSet ixs a -> IxSet ixs a -getOrd2 inclt inceq incgt v (IxSet _ ixs) = f (access ixs) - where - f :: Ix ix a -> IxSet ixs a - f (Ix index _) = fromMapOfSets result - where - lt', gt' :: Map ix (Set a) - eq' :: Maybe (Set a) - (lt', eq', gt') = Map.splitLookup v index - - lt, gt :: Map ix (Set a) - lt = if inclt then lt' else Map.empty - gt = if incgt then gt' else Map.empty - eq :: Maybe (Set a) - eq = if inceq then eq' else Nothing - - ltgt :: Map ix (Set a) - ltgt = Map.unionWith Set.union lt gt - - result :: Map ix (Set a) - result = case eq of - Just eqset -> Map.insertWith Set.union v eqset ltgt - Nothing -> ltgt - --- Optimization todo: --- --- * can we avoid rebuilding the collection every time we query? --- does laziness take care of everything? --- --- * nicer operators? --- --- * nice way to do updates that doesn't involve reinserting the entire data --- --- * can we index on xpath rather than just type? - --- | Statistics about 'IxSet'. This function returns quadruple --- consisting of --- --- 1. total number of elements in the set --- 2. number of declared indices --- 3. number of keys in all indices --- 4. number of values in all keys in all indices. --- --- This can aid you in debugging and optimisation. --- -stats :: Indexable ixs a => IxSet ixs a -> (Int,Int,Int,Int) -stats (IxSet a ixs) = (no_elements,no_indexes,no_keys,no_values) - where - no_elements = Set.size a - no_indexes = lengthIxList ixs - no_keys = sum (ixListToList (\ (Ix m _) -> Map.size m) ixs) - no_values = sum (ixListToList (\ (Ix m _) -> sum [Set.size s | s <- Map.elems m]) ixs) diff --git a/src/Data/IxSet/Typed/Internal/Ix.hs b/src/Data/IxSet/Typed/Internal/Ix.hs new file mode 100644 --- /dev/null +++ b/src/Data/IxSet/Typed/Internal/Ix.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK not-home #-} + + +{- | + +This module defines the t'Ix' type of indices. + += WARNING + +This module exposes internal implementation details of @ixset-typed@. It allows +invariants to be broken via direct access to datatype constructors, and is +subject to change without warning in future releases. + +-} +module Data.IxSet.Typed.Internal.Ix + ( Ix(..) + , IxMap + , insert + , insertMany + , delete + , build + , insertManyWith + , deleteMany + , difference + , union + , intersection + ) + where + +import Control.DeepSeq (NFData(..)) +import Control.Monad (guard) +import qualified Data.Foldable as Fold +import Data.Kind (Type) +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map.Strict as Map.Strict +import qualified Data.Map.Merge.Strict as Map.Strict +import Data.Set (Set) +import qualified Data.Set as Set + +-- the core datatypes + +-- | The map underlying an t'Ix', i.e. a 'Map' from some key (of type @ix@) to a +-- 'Set' of values (of type @a@) for that key. +-- +-- Invariant: the 'Set's are never empty. +-- +type IxMap ix a = Map ix (Set a) + +-- | An index, which consists of an 'Map' from index values to 'Set's of +-- elements with that index value, and a projection function mapping an element +-- to a list of its index values. +-- +-- Forcing an t'Ix' should compute at least the spine of the underlying 'Map'. +-- +data Ix (ix :: Type) (a :: Type) where + Ix :: !(IxMap ix a) -> (a -> [ix]) -> Ix ix a + +instance (NFData ix, NFData a) => NFData (Ix ix a) where + rnf (Ix m f) = rnf m `seq` f `seq` () + +-- modification operations + +-- | Convenience function for inserting into 'Map's of 'Set's as in +-- the case of an t'Ix'. If they key did not already exist in the +-- 'Map', then a new 'Set' is added transparently. +insert :: (Ord a, Ord ix) + => ix -> a -> IxMap ix a -> IxMap ix a +insert k v index = Map.Strict.insertWith Set.union k (Set.singleton v) index + +-- | Insert a 'Foldable' collection of elements into an index, under the +-- keys given for each of them by the indexing function, but ignoring any +-- key that does not satisfy the predicate. +insertManyWith :: (Foldable f, Ord a, Ord ix) + => (ix -> Bool) -> f a -> (a -> [ix]) + -> IxMap ix a -> Ix ix a +insertManyWith p xs f index = + Ix (Fold.foldl' (\ m v -> List.foldl' (ins v) m (f v)) index xs) f + where + ins v m k = if p k then insert k v m else m + +-- | Create a new index from a 'Foldable' collection of elements. +build :: (Foldable f, Ord a, Ord ix) => f a -> (a -> [ix]) -> Ix ix a +build xs f = insertManyWith (const True) xs f Map.Strict.empty + +-- | Insert a 'Foldable' collection of elements into an t'Ix'. +insertMany :: (Foldable f, Ord a, Ord ix) => f a -> Ix ix a -> Ix ix a +insertMany xs (Ix index f) = insertManyWith (const True) xs f index + +-- | Convenience function for deleting from 'Map's of 'Set's. If the +-- resulting 'Set' is empty, then the entry is removed from the 'Map'. +delete :: forall a ix . (Ord a, Ord ix) + => ix -> a -> IxMap ix a -> IxMap ix a +delete k v index = Map.Strict.update remove k index + where + remove :: Set a -> Maybe (Set a) + remove = dropIfEmpty . Set.delete v + +-- | Helper function to delete a collection of elements from an index. +deleteMany :: (Ord a, Ord ix, Foldable f) => f a -> Ix ix a -> Ix ix a +deleteMany deletes (Ix index f) = Ix index' f + where + index' = Fold.foldl' (\ m v -> List.foldl' (\ m' k -> delete k v m') m (f v)) index deletes + +-- | Takes the union of two indices. The projection function is assumed to be +-- the same. +-- +-- This is strict, so that once the index is forced it will be recomputed in +-- full. The caller ('Data.IxSet.Typed.union') will avoid forcing it until +-- needed. +-- +union :: (Ord a, Ord ix) + => Ix ix a -> Ix ix a -> Ix ix a +union (Ix a f) (Ix b _) = Ix (Map.Strict.unionWith Set.union a b) f + +-- | Takes the intersection of two indices. The projection function is assumed +-- to be the same. +-- +-- This is strict, so that once the index is forced it will be recomputed in +-- full. The caller ('Data.IxSet.Typed.intersection') will avoid forcing it +-- until needed. +-- +intersection :: (Ord a, Ord ix) + => Ix ix a -> Ix ix a -> Ix ix a +intersection (Ix a f) (Ix b _) = Ix (intersectionIxMap a b) f + +-- | Takes the intersection of two index maps (strictly). +intersectionIxMap :: (Ord a, Ord ix) + => IxMap ix a -> IxMap ix a -> IxMap ix a +intersectionIxMap = Map.Strict.merge + Map.Strict.dropMissing + Map.Strict.dropMissing + (Map.Strict.zipWithMaybeMatched $ \_ els1 els2 -> + dropIfEmpty (Set.intersection els1 els2) + ) + +-- | Deletes the values in the second index from the first. The projection +-- function is assumed to be the same. +-- +-- This is strict, so that once the index is forced it will be recomputed in +-- full. The caller ('Data.IxSet.Typed.difference') will avoid forcing it until +-- needed. +-- +difference :: (Ord a, Ord ix) + => Ix ix a -> Ix ix a -> Ix ix a +difference (Ix a f) (Ix b _) = Ix (differenceIxMap a b) f + +-- | Deletes the second index map from the first. +differenceIxMap :: (Ord a, Ord ix) + => IxMap ix a -> IxMap ix a -> IxMap ix a +differenceIxMap = Map.Strict.merge + Map.Strict.preserveMissing + Map.Strict.dropMissing + (Map.Strict.zipWithMaybeMatched $ \_ els dels -> + dropIfEmpty (els `Set.difference` dels) + ) + +-- | Check a set is non-empty. This is used to maintain the invariant that an +-- 'IxMap' never contains an empty set. +dropIfEmpty :: Set a -> Maybe (Set a) +dropIfEmpty s = s <$ guard (not (Set.null s)) diff --git a/src/Data/IxSet/Typed/Internal/IxList.hs b/src/Data/IxSet/Typed/Internal/IxList.hs new file mode 100644 --- /dev/null +++ b/src/Data/IxSet/Typed/Internal/IxList.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_HADDOCK not-home #-} + +{- | + +This module defines the 'IxList' type of lists of indices. + += WARNING + +This module exposes internal implementation details of @ixset-typed@. It allows +invariants to be broken via direct access to datatype constructors, and is +subject to change without warning in future releases. + +-} +module Data.IxSet.Typed.Internal.IxList + ( IxList(..) + , (!:::) + , All + , IsIndexOf(..) + , Indexable(..) + , project + , lengthIxList + , foldlIxList' + , mapIxList + , mapIxList' + , zipWithIxList + , forceIxList + , ixList + , MkIxList(..) + ) where + +import Control.DeepSeq (NFData(..)) +import Data.Kind (Type, Constraint) +import Prelude hiding (filter, null) + +import Data.IxSet.Typed.Internal.Ix (Ix(Ix)) + +-- | A term-level list of indices (t'Ix' values), indexed by the type-level list +-- of index types @ixs@ and the element type @a@. +data IxList (ixs :: [Type]) (a :: Type) where + Nil :: IxList '[] a + (:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a + +infixr 5 ::: + +instance (All NFData ixs, NFData a) => NFData (IxList ixs a) where + rnf Nil = () + rnf (x ::: xs) = rnf x `seq` rnf xs + + +-- | A strict variant of ':::'. +(!:::) :: Ix ix a -> IxList ixs a -> IxList (ix ': ixs) a +(!:::) !ix !ixs = ix ::: ixs + +infixr 5 !::: + + +-------------------------------------------------------------------------- +-- Type-level tools for dealing with indexed sets. +-- +-------------------------------------------------------------------------- + +-- | The constraint @All c xs@ says the @c@ has to hold for all +-- elements in the type-level list @xs@. +-- +-- Example: +-- +-- > All Ord '[Int, Char, Bool] +-- +-- is equivalent to +-- +-- > (Ord Int, Ord Char, Ord Bool) +-- +type All :: (Type -> Constraint) -> [Type] -> Constraint +type family All c xs :: Constraint where + All c '[] = () + All c (x ': xs) = (c x, All c xs) + +-- | Associate indices with a given type. The constraint +-- @'Indexable' ixs a@ says that we know how to build index sets +-- of type @'Data.IxSet.Typed.IxSet' ixs a@. +-- +-- In order to use an 'Data.IxSet.Typed.IxSet' on a particular type, you have to +-- make it an instance of 'Indexable' yourself. There are no +-- predefined instances of 'Indexable'. +-- +class (All Ord ixs, Ord a) => Indexable ixs a where + + -- | Define how the indices for this particular type should look like. + -- + -- Use the 'ixList' function to construct the list of indices, and use + -- 'Data.IxSet.Typed.ixFun' (or 'Data.IxSet.Typed.ixGen') for individual indices. + indices :: IxList ixs a + +-- | Constraint for membership in the type-level list. Says that @ix@ +-- is contained in the index list @ixs@. +class Ord ix => IsIndexOf (ix :: Type) (ixs :: [Type]) where + + -- | Provide access to the selected index in the list. + access :: IxList ixs a -> Ix ix a + + -- | Map over the index list, treating the selected different + -- from the rest. + -- + -- The function 'mapAt' is lazy in the index list structure, + -- because it is used by query operations. + mapAt :: (All Ord ixs) + => (Ix ix a -> Ix ix a) + -- ^ what to do with the selected index + -> (forall ix'. Ord ix' => Ix ix' a -> Ix ix' a) + -- ^ what to do with the other indices + -> IxList ixs a -> IxList ixs a + +instance + {-# OVERLAPPING #-} + Ord ix => IsIndexOf ix (ix ': ixs) where + access (x ::: _xs) = x + mapAt fh ft (x ::: xs) = fh x ::: mapIxList ft xs + +instance + {-# OVERLAPPABLE #-} + IsIndexOf ix ixs => IsIndexOf ix (ix' ': ixs) where + access (_x ::: xs) = access xs + mapAt fh ft (x ::: xs) = ft x ::: mapAt fh ft xs + +-- | Project out the indices from a value of an 'Indexable' type. +-- +-- @since 0.6 +-- +project :: forall proxy ixs ix a . (Indexable ixs a, IsIndexOf ix ixs) => proxy ixs -> a -> [ix] +project _ = case access (indices :: IxList ixs a) :: Ix ix a of + Ix _ f -> f + +-- | Return the length of an index list. +-- +-- TODO: Could be statically unrolled. +lengthIxList :: forall ixs a. IxList ixs a -> Int +lengthIxList = foldlIxList' (\ n _ -> succ n) 0 + +-- | Strict left fold over an index list. +foldlIxList' :: forall ixs a b. (forall ix . b -> Ix ix a -> b) -> b -> IxList ixs a -> b +foldlIxList' c = go + where + go :: forall ixs'. b -> IxList ixs' a -> b + go !acc Nil = acc + go !acc (x ::: xs) = go (c acc x) xs + +-- | Map over an index list. +mapIxList :: All Ord ixs + => (forall ix. Ord ix => Ix ix a -> Ix ix a) + -- ^ what to do with each index + -> IxList ixs a -> IxList ixs a +mapIxList _ Nil = Nil +mapIxList f (x ::: xs) = f x ::: mapIxList f xs + +-- | Map over an index list (spine-strict). +mapIxList' :: All Ord ixs + => (forall ix. Ord ix => Ix ix a -> Ix ix a) + -- ^ what to do with each index + -> IxList ixs a -> IxList ixs a +mapIxList' _ Nil = Nil +mapIxList' f (x ::: xs) = f x !::: mapIxList' f xs + +-- | Zip two index lists of compatible type (lazy). +zipWithIxList :: All Ord ixs + => (forall ix. Ord ix => Ix ix a -> Ix ix a -> Ix ix a) + -- ^ how to combine two corresponding indices + -> IxList ixs a -> IxList ixs a -> IxList ixs a +zipWithIxList _ Nil Nil = Nil +zipWithIxList f (x ::: xs) (y ::: ys) = f x y ::: zipWithIxList f xs ys + +-- | Force all the t'Ix' values in the list to WHNF. +forceIxList :: forall ixs a . IxList ixs a -> IxList ixs a +forceIxList Nil = Nil +forceIxList (ix ::: ixs) = ix !::: forceIxList ixs + + +-------------------------------------------------------------------------- +-- 'IxList' construction +-------------------------------------------------------------------------- + +-- | Create an (empty) 'IxList' from a number of indices. Useful in the 'Indexable' +-- 'indices' method. Use 'Data.IxSet.Typed.ixFun' and 'Data.IxSet.Typed.ixGen' for the individual indices. +-- +-- Note that this function takes a variable number of arguments. +-- Here are some example types at which the function can be used: +-- +-- > ixList :: Ix ix1 a -> IxList '[ix1] a +-- > ixList :: Ix ix1 a -> Ix ix2 a -> IxList '[ix1, ix2] a +-- > ixList :: Ix ix1 a -> Ix ix2 a -> Ix ix3 a -> IxList '[ix1, ix2, ix3] a +-- > ixList :: ... +-- +-- Concrete example use: +-- +-- > instance Indexable '[..., Index1Type, Index2Type] Type where +-- > indices = ixList +-- > ... +-- > (ixFun getIndex1) +-- > (ixGen (Proxy :: Proxy Index2Type)) +-- +ixList :: MkIxList ixs ixs a r => r +ixList = ixList' id + +-- | Class that allows a variable number of arguments to be passed to the +-- 'Data.IxSet.Typed.ixSet' and 'Data.IxSet.Typed.mkEmpty' functions. See the +-- documentation of these functions for more information. +class MkIxList ixs ixs' a r | r -> a ixs ixs' where + ixList' :: (IxList ixs a -> IxList ixs' a) -> r + +instance MkIxList '[] ixs a (IxList ixs a) where + ixList' acc = acc Nil + +instance MkIxList ixs ixs' a r => MkIxList (ix ': ixs) ixs' a (Ix ix a -> r) where + ixList' acc ix = ixList' (\ x -> acc (ix ::: x)) diff --git a/src/Data/IxSet/Typed/Internal/IxSet.hs b/src/Data/IxSet/Typed/Internal/IxSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/IxSet/Typed/Internal/IxSet.hs @@ -0,0 +1,815 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +{- | + +This module defines the main 'IxSet' type. + += WARNING + +This module exposes internal implementation details of @ixset-typed@. It allows +invariants to be broken via direct access to datatype constructors, and is +subject to change without warning in future releases. + +-} +module Data.IxSet.Typed.Internal.IxSet + ( + -- * Set type + IxSet(..), + + -- * Changes to set + IndexOp, + SetOp, + change, + insert, + insertList, + insertSet, + insertMany, + delete, + deleteSet, + deleteMany, + updateIx, + deleteIx, + deleteIxMany, + + -- * Creation + empty, + fromSet, + fromList, + + -- * Conversion + toSet, + toList, + toAscList, + toDescList, + getOne, + getOneOr, + + -- * Size checking + size, + null, + + -- * Set operations + (&&&), + (|||), + (\\\), + union, + intersection, + difference, + filter, + + -- * Indexing + (@=), + (@<), + (@>), + (@<=), + (@>=), + (@><), + (@>=<), + (@><=), + (@>=<=), + (@+), + (@*), + getEQ, + getLT, + getGT, + getLTE, + getGTE, + getOrd, + getOrd2, + getRange, + getInterval, + + -- * Lookup + lookupIx, + lookupIxMany, + lookupOne, + + -- * Grouping + getIxMap, + groupBy, + groupAscBy, + groupDescBy, + indexKeys, + + -- * Debugging and optimization + forceIndices, + stats +) +where + +import Data.Kind +import Prelude hiding (filter, null) + +import Control.Arrow (first, second) +import Control.DeepSeq (NFData(..)) +import qualified Data.Foldable as Fold +import qualified Data.IxSet.Typed.Internal.Ix as Ix +import Data.IxSet.Typed.Internal.Ix (Ix(Ix), IxMap) +import Data.IxSet.Typed.Internal.IxList +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.SafeCopy (SafeCopy(..), contain, safeGet, safePut) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) + +-------------------------------------------------------------------------- +-- The main 'IxSet' datatype. +-------------------------------------------------------------------------- + +-- | Set with associated indices. +-- +-- The type-level list @ixs@ contains all types that are valid index keys. The +-- type @a@ is the type of elements in the indexed set. +-- +data IxSet (ixs :: [Type]) (a :: Type) where + IxSet :: !(Set a) -> IxList ixs a -> IxSet ixs a + + +-------------------------------------------------------------------------- +-- Various instances for 'IxSet' +-------------------------------------------------------------------------- + +instance Indexable ixs a => Eq (IxSet ixs a) where + IxSet a _ == IxSet b _ = a == b + +instance Indexable ixs a => Ord (IxSet ixs a) where + compare (IxSet a _) (IxSet b _) = compare a b + +instance (Indexable ixs a, Show a) => Show (IxSet ixs a) where + showsPrec prec = showsPrec prec . toSet + +instance (Indexable ixs a, Read a) => Read (IxSet ixs a) where + readsPrec n = map (first fromSet) . readsPrec n + +instance (Indexable ixs a, Typeable ixs, SafeCopy a, Typeable a) => SafeCopy (IxSet ixs a) where + putCopy = contain . safePut . toList + getCopy = contain $ fmap fromList safeGet + +instance (All NFData ixs, NFData a) => NFData (IxSet ixs a) where + rnf (IxSet a ixs) = rnf a `seq` rnf ixs + +instance Indexable ixs a => Semigroup (IxSet ixs a) where + (<>) = union + +instance Indexable ixs a => Monoid (IxSet ixs a) where + mempty = empty + mappend = (<>) + +instance Foldable (IxSet ixs) where + fold = Fold.fold . toSet + foldMap f = Fold.foldMap f . toSet + foldr f z = Fold.foldr f z . toSet + foldl f z = Fold.foldl f z . toSet + + +-------------------------------------------------------------------------- +-- 'IxSet' construction +-------------------------------------------------------------------------- + +-- | An empty 'IxSet'. +empty :: Indexable ixs a => IxSet ixs a +empty = IxSet Set.empty indices + + +-------------------------------------------------------------------------- +-- Modification of 'IxSet's +-------------------------------------------------------------------------- + +-- | Type of functions that modify the 'Set' underlying an 'IxSet', for use with +-- 'change'. +type SetOp = + forall a. Ord a => a -> Set a -> Set a + +-- | Type of functions that modify the 'Map'-of-'Set's corresponding to a single +-- index, for use with 'change'. Such functions must maintain the invariant +-- that the 'Set's are never empty. +type IndexOp = + forall ix a. (Ord ix, Ord a) => ix -> a -> Map ix (Set a) -> Map ix (Set a) + +-- | Higher order operator for modifying 'IxSet's. Use this when your +-- final function should have the form @a -> 'IxSet' a -> 'IxSet' a@, +-- e.g. 'insert' or 'delete'. +-- +-- This will update the indices strictly. +-- +change :: forall ixs a. Indexable ixs a + => SetOp -> IndexOp -> a -> IxSet ixs a -> IxSet ixs a +change opS opI x = changeAll (opS x) update + where + update :: forall ix. Ord ix => Ix ix a -> Ix ix a + update (Ix index f) = Ix index' f + where + ds :: [ix] + ds = f x + ii :: forall k. Ord k => Map k (Set a) -> k -> Map k (Set a) + ii m dkey = opI dkey x m + index' :: Map ix (Set a) + index' = List.foldl' ii index ds + +-- | Higher-order operator for modifying 'IxSet's. +-- +-- This will update the indices strictly. +-- +changeAll :: All Ord ixs + => (Set a -> Set a) + -> (forall ix. Ord ix => Ix ix a -> Ix ix a) + -> IxSet ixs a -> IxSet ixs a +changeAll f g (IxSet set indexes) = IxSet (f set) $! mapIxList' g indexes + +-- | Insert a list of elements into an 'IxSet'. (See also 'insertMany'.) +-- +-- This will update the indices strictly. +-- +insertList :: forall ixs a. Indexable ixs a + => [a] -> IxSet ixs a -> IxSet ixs a +insertList = insertMany + +-- | Insert a 'Set' of elements into an 'IxSet'. +-- +-- This will update the indices strictly. +-- +-- @since 0.6 +-- +insertSet :: forall ixs a. (Indexable ixs a) + => Set a -> IxSet ixs a -> IxSet ixs a +insertSet xs = changeAll (Set.union xs) (Ix.insertMany xs) + +-- | Insert a 'Foldable' collection of elements into an 'IxSet'. +-- +-- This will update the indices strictly. +-- +-- @since 0.6 +-- +insertMany :: forall ixs f a. (Indexable ixs a, Foldable f) + => f a -> IxSet ixs a -> IxSet ixs a +insertMany xs = changeAll (\ a -> Fold.foldl' (\ b x -> Set.insert x b) a xs) (Ix.insertMany xs) + +-- | Inserts an item into the 'IxSet'. +-- +-- If your data happens to have a primary key this function might not be what +-- you want, because it allows two values to coexist in the set with the same +-- primary key. See 'updateIx'. +-- +-- This will update the indices strictly. +-- +insert :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a +insert = change Set.insert Ix.insert + +-- | Removes an item from the 'IxSet'. +-- +-- This will update the indices strictly. +-- +delete :: Indexable ixs a => a -> IxSet ixs a -> IxSet ixs a +delete = change Set.delete Ix.delete + +-- | Remove every element of a 'Set' from an 'IxSet'. +-- +-- This will update the indices strictly. +-- +deleteSet :: Indexable ixs a => Set a -> IxSet ixs a -> IxSet ixs a +deleteSet deletes = changeAll (`Set.difference` deletes) (Ix.deleteMany deletes) + +-- | Remove every element of a 'Foldable' collection from an 'IxSet'. +-- +-- This will update the indices strictly. +-- +deleteMany :: (Indexable ixs a, Foldable t) => t a -> IxSet ixs a -> IxSet ixs a +deleteMany deletes = changeAll (\ s -> Fold.foldl' (flip Set.delete) s deletes) (Ix.deleteMany deletes) +{-# SPECIALISE deleteMany :: Indexable ixs a => [a] -> IxSet ixs a -> IxSet ixs a #-} + +-- | Replace the item with the given index of type @ix@. Only works if there is +-- at most one item with that index in the 'IxSet'. +-- +-- If you have more than one item with given index, the new item will be +-- inserted in addition to the existing items. (NB: this is contrary to the +-- documentation in previous versions of @ixset-typed@ and @ixset@, which +-- incorrectly claimed the set would not be modified in this case.) +-- +-- This will update the indices strictly. +-- +updateIx :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> a -> IxSet ixs a -> IxSet ixs a +updateIx i new ixset = insert new $ + maybe ixset (flip delete ixset) $ + getOne $ ixset @= i + +-- | Delete the item with the given index of type @ix@. Only works if there is +-- at most one item with that index in the 'IxSet'. +-- +-- Will not change 'IxSet' if you have more than one item with given index. +-- +-- This will update the indices strictly. +-- +deleteIx :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> IxSet ixs a -> IxSet ixs a +deleteIx i ixset = maybe ixset (flip delete ixset) $ + getOne $ ixset @= i + +-- | Delete all values with any of the given indices. Unlike 'deleteIx', this +-- works even if an index matches multiple values. +-- +-- This will update the indices strictly. +-- +-- @since 0.6 +-- +deleteIxMany :: forall ixs ix a f . (Indexable ixs a, IsIndexOf ix ixs, Foldable f) => f ix -> IxSet ixs a -> IxSet ixs a +deleteIxMany is ixset = deleteSet (lookupIxMany is ixset) ixset +{-# SPECIALISE deleteIxMany :: forall ixs ix a . (Indexable ixs a, IsIndexOf ix ixs) => [ix] -> IxSet ixs a -> IxSet ixs a #-} + + +-------------------------------------------------------------------------- +-- Conversions +-------------------------------------------------------------------------- + +-- | Converts an 'IxSet' to a 'Set' of its elements. +toSet :: IxSet ixs a -> Set a +toSet (IxSet a _) = a + +-- | Converts a 'Set' to an 'IxSet'. +-- +-- This is strict in the 'Set' but lazy in the construction of indices, so they +-- are not built until needed. +-- +fromSet :: forall ixs a. (Indexable ixs a) => Set a -> IxSet ixs a +fromSet s = IxSet s makeIndices + where + makeIndices :: IxList ixs a + makeIndices = mapIxList (Ix.insertMany s) indices + +-- | Converts a list to an 'IxSet'. +-- +-- This is spine-strict in the list of elements but lazy in the construction of +-- indices, so they are not built until needed. +-- +fromList :: (Indexable ixs a) => [a] -> IxSet ixs a +fromList = fromSet . Set.fromList + +-- | Returns the number of unique items in the 'IxSet'. +size :: IxSet ixs a -> Int +size = Set.size . toSet + +-- | Converts an 'IxSet' to its list of elements. +-- +-- List will be sorted in ascending order by the @'Ord' a@ instance. +-- +toList :: IxSet ixs a -> [a] +toList = Set.toList . toSet + +-- | Converts an 'IxSet' to its list of elements. +-- +-- List will be sorted in ascending order by the index @ix@. +-- +-- The list may contain duplicate entries if a single value produces multiple keys. +toAscList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a] +toAscList _ ixset = concatMap snd (groupAscBy ixset :: [(ix, [a])]) + +-- | Converts an 'IxSet' to its list of elements. +-- +-- List will be sorted in descending order by the index @ix@. +-- +-- The list may contain duplicate entries if a single value produces multiple keys. +toDescList :: forall proxy ix ixs a. IsIndexOf ix ixs => proxy ix -> IxSet ixs a -> [a] +toDescList _ ixset = concatMap snd (groupDescBy ixset :: [(ix, [a])]) + +-- | If the 'IxSet' is a singleton it will return the one item stored in it. +-- If 'IxSet' is empty or has many elements this function returns 'Nothing'. +getOne :: IxSet ixs a -> Maybe a +getOne ixset = case toList ixset of + [x] -> Just x + _ -> Nothing + +-- | Like 'getOne' with a user-provided default. +getOneOr :: a -> IxSet ixs a -> a +getOneOr def = fromMaybe def . getOne + +-- | Return 'True' if the 'IxSet' is empty, 'False' otherwise. +null :: IxSet ixs a -> Bool +null (IxSet a _) = Set.null a + +-------------------------------------------------------------------------- +-- Set operations +-------------------------------------------------------------------------- + +-- | An infix 'intersection' operation. +(&&&) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a +(&&&) = intersection + +-- | An infix 'union' operation. +(|||) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a +(|||) = union + +-- | An infix 'difference' operation. +(\\\) :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a +(\\\) = difference + +infixr 5 &&& +infixr 5 ||| + +-- | Takes the union of the two 'IxSet's. +-- +-- This will update the indices lazily. +-- +union :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a +union (IxSet a1 x1) (IxSet a2 x2) = + IxSet (Set.union a1 a2) (zipWithIxList Ix.union x1 x2) + +-- | Takes the intersection of the two 'IxSet's. +-- +-- This will update the indices lazily. +-- +intersection :: Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a +intersection (IxSet a1 x1) (IxSet a2 x2) = + IxSet (Set.intersection a1 a2) (zipWithIxList Ix.intersection x1 x2) + +-- | Remove every item in the second 'IxSet' from the first 'IxSet'. +-- +-- This will update the indices lazily. +-- +-- @since 0.6 +-- +difference :: forall ixs a. Indexable ixs a => IxSet ixs a -> IxSet ixs a -> IxSet ixs a +difference (IxSet elements ixs) (IxSet deletes deleteIxs) = + IxSet (elements `Set.difference` deletes) (zipWithIxList Ix.difference ixs deleteIxs) + +-- | Limit elements of an `IxSet` to those matching a predicate. +-- +-- This will update the indices lazily. +-- +-- @since 0.6 +-- +filter :: Indexable ixs a => (a -> Bool) -> IxSet ixs a -> IxSet ixs a +filter p (IxSet elements indexes) = + IxSet good_elements (mapIxList (Ix.deleteMany bad_elements) indexes) + where + (good_elements, bad_elements) = Set.partition p elements + +-------------------------------------------------------------------------- +-- Query operations +-------------------------------------------------------------------------- + +-- | Infix version of 'getEQ'. +(@=) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> ix -> IxSet ixs a +ix @= v = getEQ v ix + +-- | Infix version of 'getLT'. +(@<) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> ix -> IxSet ixs a +ix @< v = getLT v ix + +-- | Infix version of 'getGT'. +(@>) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> ix -> IxSet ixs a +ix @> v = getGT v ix + +-- | Infix version of 'getLTE'. +(@<=) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> ix -> IxSet ixs a +ix @<= v = getLTE v ix + +-- | Infix version of 'getGTE'. +(@>=) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> ix -> IxSet ixs a +ix @>= v = getGTE v ix + +-- | Returns the subset with indices in the open interval (k1,k2). +-- +-- Note: if elements have multiple values for a single index, see caveats on +-- 'getRange'. If you still need the old semantics, use: +-- +-- > getLT k2 (getGT k1 ixset) +-- +(@><) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> (ix, ix) -> IxSet ixs a +ix @>< (v1,v2) = getInterval False False v1 v2 ix + +-- | Returns the subset with indices in the half-open interval [k1,k2). +-- +-- Note: if elements have multiple values for a single index, see caveats on +-- 'getRange'. If you still need the old semantics, use: +-- +-- > getLT k2 (getGTE k1 ixset) +-- +(@>=<) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> (ix, ix) -> IxSet ixs a +ix @>=< (v1,v2) = getInterval True False v1 v2 ix + +-- | Returns the subset with indices in the half-open interval (k1,k2]. +-- +-- Note: if elements have multiple values for a single index, see caveats on +-- 'getRange'. If you still need the old semantics, use: +-- +-- > getLTE k2 (getGT k1 ixset) +-- +(@><=) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> (ix, ix) -> IxSet ixs a +ix @><= (v1,v2) = getInterval False True v1 v2 ix + +-- | Returns the subset with indices in the closed interval [k1,k2]. +-- +-- Note: if elements have multiple values for a single index, see caveats on +-- 'getRange'. If you still need the old semantics, use: +-- +-- > getLTE k2 (getGTE k1 ixset) +-- +(@>=<=) :: (Indexable ixs a, IsIndexOf ix ixs) + => IxSet ixs a -> (ix, ix) -> IxSet ixs a +ix @>=<= (v1,v2) = getInterval True True v1 v2 ix + +-- | Creates the subset that has an index in the provided list. +(@+) :: (Indexable ixs a, IsIndexOf ix ixs, Foldable f) + => IxSet ixs a -> f ix -> IxSet ixs a +ix @+ list = Fold.foldl' (\ s v -> s `union` (ix @= v)) empty list +{-# SPECIALISE (@+) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> [ix] -> IxSet ixs a #-} + +-- | Creates the subset that matches all the provided indices. +(@*) :: (Indexable ixs a, IsIndexOf ix ixs, Foldable f) + => IxSet ixs a -> f ix -> IxSet ixs a +ix @* list = Fold.foldl' (\ s v -> s `intersection` (ix @= v)) ix list +{-# SPECIALISE (@*) :: (Indexable ixs a, IsIndexOf ix ixs) => IxSet ixs a -> [ix] -> IxSet ixs a #-} + +-- | Returns the subset with an index equal to the provided key. +getEQ :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> IxSet ixs a -> IxSet ixs a +getEQ = getOrd EQ + +-- | Returns the subset with an index less than the provided key. +getLT :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> IxSet ixs a -> IxSet ixs a +getLT = getOrd LT + +-- | Returns the subset with an index greater than the provided key. +getGT :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> IxSet ixs a -> IxSet ixs a +getGT = getOrd GT + +-- | Returns the subset with an index less than or equal to the +-- provided key. +getLTE :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> IxSet ixs a -> IxSet ixs a +getLTE = getOrd2 True True False + +-- | Returns the subset with an index greater than or equal to the +-- provided key. +getGTE :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> IxSet ixs a -> IxSet ixs a +getGTE = getOrd2 False True True + +-- | Returns the subset with an index within the interval provided. The bottom +-- of the interval is closed and the top is open, i.e. [k1,k2). +-- +-- Note: if elements have multiple values for a single index, this function +-- behaves differently to the corresponding @ixset@ function (and to +-- @ixset-typed@ versions prior to 0.6). Specifically, elements will be +-- returned only if a single index value falls in the interval, rather than +-- returning elements where one index value satisfies the lower bound and a +-- different value satisfies the upper bound. If you still need the old +-- semantics, use: +-- +-- > getGTE k1 (getLT k2 ixset) +-- +getRange :: (Indexable ixs a, IsIndexOf ix ixs) + => ix -> ix -> IxSet ixs a -> IxSet ixs a +getRange = getInterval True False + +-- | A function for building up selectors on 'IxSet's. Used in the +-- various get* functions. +getOrd :: (Indexable ixs a, IsIndexOf ix ixs) + => Ordering -> ix -> IxSet ixs a -> IxSet ixs a +getOrd LT = getOrd2 True False False +getOrd EQ = getOrd2 False True False +getOrd GT = getOrd2 False False True + +-- | A function for building up selectors on 'IxSet's. Used in the various get* +-- functions. +-- +-- The booleans indicate whether to include values strictly less than, equal to, +-- or strictly greater than the key. +-- +getOrd2 :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs) + => Bool -> Bool -> Bool -> ix -> IxSet ixs a -> IxSet ixs a +getOrd2 inclt inceq incgt v = fromMapOfSets . select . getIxMap + where + select :: IxMap ix a -> IxMap ix a + select index = result + where + lt', gt' :: IxMap ix a + eq' :: Maybe (Set a) + (lt', eq', gt') = Map.splitLookup v index + + lt, gt :: IxMap ix a + lt = if inclt then lt' else Map.empty + gt = if incgt then gt' else Map.empty + eq :: Maybe (Set a) + eq = if inceq then eq' else Nothing + + ltgt :: IxMap ix a + ltgt = Map.unionWith Set.union lt gt + + result :: IxMap ix a + result = case eq of + Just eqset -> Map.insertWith Set.union v eqset ltgt + Nothing -> ltgt + +-- | A function for building up interval selectors on 'IxSet's. Used in +-- 'getRange' and the various interval selection functions. +-- +-- The booleans indicate whether to include the lower and upper bounds of the +-- interval. +-- +-- Note that it is not enough to use 'getOrd2' twice to select an interval, +-- because that amounts to two independent queries, which may match different +-- index values if an index is multi-valued. See further discussion at +-- . +-- +-- We are careful to return the empty set if the lower bound is above the upper +-- bound, or if the interval is open/half-open and the lower and upper bounds +-- are the same. (If the lower bound equals the upper bound and the interval is +-- closed, we fall back on 'getEQ' to look up a single value.) +-- +-- @since 0.6 +-- +getInterval :: forall ix ixs a . (Indexable ixs a, IsIndexOf ix ixs) + => Bool -> Bool -> ix -> ix -> IxSet ixs a -> IxSet ixs a +getInterval inc_lower_bound inc_upper_bound k1 k2 = + case compare k1 k2 of + LT -> fromMapOfSets . select . getIxMap + EQ | inc_lower_bound, inc_upper_bound -> getEQ k1 + | otherwise -> const empty + GT -> const empty + where + select :: IxMap ix a -> IxMap ix a + select index = result + where + gt_lower, open_interval :: IxMap ix a + eq_lower, eq_upper :: Maybe (Set a) + (_, eq_lower, gt_lower) = Map.splitLookup k1 index + (open_interval, eq_upper, _) = Map.splitLookup k2 gt_lower + + lb, ub :: Maybe (Set a) + lb = if inc_lower_bound then eq_lower else Nothing + ub = if inc_upper_bound then eq_upper else Nothing + + result :: IxMap ix a + result = maybe id (Map.insertWith Set.union k1) lb + $ maybe id (Map.insertWith Set.union k2) ub + $ open_interval + +-- | Internal helper function that takes a partial index from one index +-- set and rebuilds the rest of the structure of the index set. +-- +-- We try to be really clever here. The partialindex is a Map of Sets +-- from original index. We want to reuse it as much as possible. If there +-- was a guarantee that each element is present at at most one key we +-- could reuse originalindex as it is. But there can be more, so we need to +-- add remaining ones (in updateh). Anyway we try to reuse old structure and +-- keep new allocations low as much as possible. +-- +-- This is used by queries, so it produces the indices lazily. +-- +fromMapOfSets :: forall ixs ix a. (Indexable ixs a, IsIndexOf ix ixs) + => IxMap ix a -> IxSet ixs a +fromMapOfSets partialindex = + IxSet a (mapAt updateh updatet indices) + where + a :: Set a + a = Set.unions partialindex + + -- Update function for the index corresponding to partialindex. + -- Any key already in the partial index is there with its full + -- set of elements, so only the other keys need adding. + updateh :: Ix ix a -> Ix ix a + updateh (Ix _ f) = Ix.insertManyWith (\ k -> Map.notMember k partialindex) a f partialindex + + -- Update function for all other indices. + updatet :: forall ix'. Ord ix' => Ix ix' a -> Ix ix' a + updatet (Ix _ f) = Ix.build a f + + +-------------------------------------------------------------------------- +-- Lookup +-------------------------------------------------------------------------- + +-- | Look up elements in the 'IxSet' that match the given index exactly, +-- returning the results as a 'Set'. +-- +-- @since 0.6 +-- +lookupIx :: IsIndexOf ix ixs => ix -> IxSet ixs a -> Set.Set a +lookupIx i = Map.findWithDefault Set.empty i . getIxMap + +-- | Look up elements in the 'IxSet' that match at least one of the indices in +-- the given 'Foldable' collection, returning the results as a 'Set'. +-- +-- @since 0.6 +-- +lookupIxMany :: (Indexable ixs a, IsIndexOf ix ixs, Foldable f) => f ix -> IxSet ixs a -> Set.Set a +lookupIxMany is ixset = Fold.foldl' (\ s i -> maybe s (Set.union s) (Map.lookup i m)) Set.empty is + where + m = getIxMap ixset +{-# SPECIALISE lookupIxMany :: (Indexable ixs a, IsIndexOf ix ixs) => [ix] -> IxSet ixs a -> Set.Set a #-} + +-- | Look up the element in the 'IxSet' that matches the given index exactly. +-- +-- This is designed for use with unique indices. If there is one item with the +-- index, it will be returned. If there are no matching items or many results, +-- this function returns 'Nothing'. +-- +-- @since 0.6 +-- +lookupOne :: (Indexable ixs a, IsIndexOf ix ixs) => ix -> IxSet ixs a -> Maybe a +lookupOne i ixs = getOne (ixs @= i) + + +-------------------------------------------------------------------------- +-- Grouping operations +-------------------------------------------------------------------------- + +-- | Extract a single index map from an 'IxSet'. +getIxMap :: forall ixs ix a . IsIndexOf ix ixs => IxSet ixs a -> Ix.IxMap ix a +getIxMap (IxSet _ ixs) = case access ixs of + Ix m _ -> m + +-- | Returns lists of elements paired with the indices determined by +-- type inference. +groupBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] +groupBy = map (second Set.toList) . Map.toList . getIxMap + +-- | Returns the list of index keys being used for a particular index. +indexKeys :: forall ix ixs a . IsIndexOf ix ixs => IxSet ixs a -> [ix] +indexKeys = Map.keys . getIxMap + +-- | Returns lists of elements paired with the indices determined by +-- type inference. +-- +-- The resulting list will be sorted in ascending order by @ix@. +-- The values in @[a]@ will be sorted in ascending order as well. +groupAscBy :: forall ix ixs a. IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] +groupAscBy = map (second Set.toAscList) . Map.toAscList . getIxMap + +-- | Returns lists of elements paired with the indices determined by +-- type inference. +-- +-- The resulting list will be sorted in descending order by @ix@. +-- +-- NOTE: The values in @[a]@ are currently sorted in ascending +-- order. But this may change if someone bothers to add +-- 'Set.toDescList'. So do not rely on the sort order of the +-- resulting list. +groupDescBy :: IsIndexOf ix ixs => IxSet ixs a -> [(ix, [a])] +groupDescBy = map (second Set.toAscList) . Map.toDescList . getIxMap + + +-------------------------------------------------------------------------- +-- Debugging and optimization +-------------------------------------------------------------------------- + +-- | Evaluate the indices contained within an 'IxSet'. Call this after a lazy +-- operation such as 'fromSet', 'fromList' or a query, to perform the work of +-- building the indices immediately rather than deferring it until they are +-- used. The underlying 'Set' does not need to be forced as it is stored +-- spine-strictly. +-- +-- @since 0.6 +-- +forceIndices :: IxSet ixs a -> IxSet ixs a +forceIndices (IxSet set ixlist) = IxSet set $! forceIxList ixlist + + +-- Optimization todo: +-- +-- * nicer operators? +-- +-- * nice way to do updates that doesn't involve reinserting the entire data +-- +-- * can we index on xpath rather than just type? + +-- | Statistics about 'IxSet'. This function returns quadruple +-- consisting of +-- +-- 1. total number of elements in the set +-- 2. number of declared indices +-- 3. number of keys in all indices +-- 4. number of values in all keys in all indices. +-- +-- This can aid you in debugging and optimisation. +-- +-- Evaluating the third or fourth components of the quadruple will +-- cause the indices to be forced (cf. 'forceIndices'). +-- +stats :: IxSet ixs a -> (Int,Int,Int,Int) +stats (IxSet a ixs) = (no_elements,no_indexes,no_keys,no_values) + where + no_elements = Set.size a + no_indexes = lengthIxList ixs + no_keys = foldlIxList' (\ n (Ix m _) -> n + Map.size m) 0 ixs + no_values = foldlIxList' (\ n (Ix m _) -> Fold.foldl' (\ acc s -> acc + Set.size s) n m) 0 ixs diff --git a/src/Data/IxSet/Typed/Ix.hs b/src/Data/IxSet/Typed/Ix.hs deleted file mode 100644 --- a/src/Data/IxSet/Typed/Ix.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE UndecidableInstances, FlexibleInstances, - MultiParamTypeClasses, TemplateHaskell, PolymorphicComponents, - DeriveDataTypeable,ExistentialQuantification, KindSignatures, - StandaloneDeriving, GADTs #-} - -{- | - -This module defines 'Typeable' indexes and convenience functions. Should -probably be considered private to @Data.IxSet.Typed@. - --} -module Data.IxSet.Typed.Ix - ( Ix(..) - , insert - , delete - , fromList - , insertList - , deleteList - , union - , intersection - ) - where - -import Control.DeepSeq --- import Data.Generics hiding (GT) --- import qualified Data.Generics.SYB.WithClass.Basics as SYBWC -import Data.Kind -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as Map.Strict -import Data.Set (Set) -import qualified Data.Set as Set - --- the core datatypes - --- | 'Ix' is a 'Map' from some key (of type 'ix') to a 'Set' of --- values (of type 'a') for that key. -data Ix (ix :: Type) (a :: Type) where - Ix :: !(Map ix (Set a)) -> (a -> [ix]) -> Ix ix a - -instance (NFData ix, NFData a) => NFData (Ix ix a) where - rnf (Ix m f) = rnf m `seq` f `seq` () - --- deriving instance Typeable (Ix ix a) - -{- - -- minimal hacky instance -instance Data a => Data (Ix a) where - toConstr (Ix _ _) = con_Ix_Data - gunfold _ _ = error "gunfold" - dataTypeOf _ = ixType_Data --} - -{- -con_Ix_Data :: Constr -con_Ix_Data = mkConstr ixType_Data "Ix" [] Prefix -ixType_Data :: DataType -ixType_Data = mkDataType "Happstack.Data.IxSet.Ix" [con_Ix_Data] --} - -{- -ixConstr :: SYBWC.Constr -ixConstr = SYBWC.mkConstr ixDataType "Ix" [] SYBWC.Prefix -ixDataType :: SYBWC.DataType -ixDataType = SYBWC.mkDataType "Ix" [ixConstr] --} - -{- -instance (SYBWC.Data ctx a, SYBWC.Sat (ctx (Ix a))) - => SYBWC.Data ctx (Ix a) where - gfoldl = error "gfoldl Ix" - toConstr _ (Ix _ _) = ixConstr - gunfold = error "gunfold Ix" - dataTypeOf _ _ = ixDataType --} - --- modification operations - --- | Convenience function for inserting into 'Map's of 'Set's as in --- the case of an 'Ix'. If they key did not already exist in the --- 'Map', then a new 'Set' is added transparently. -insert :: (Ord a, Ord k) - => k -> a -> Map k (Set a) -> Map k (Set a) -insert k v index = Map.Strict.insertWith Set.union k (Set.singleton v) index - --- | Helper function to 'insert' a list of elements into a set. -insertList :: (Ord a, Ord k) - => [(k,a)] -> Map k (Set a) -> Map k (Set a) -insertList xs index = List.foldl' (\m (k,v)-> insert k v m) index xs - --- | Helper function to create a new index from a list. -fromList :: (Ord a, Ord k) => [(k, a)] -> Map k (Set a) -fromList xs = - Map.fromListWith Set.union (List.map (\ (k, v) -> (k, Set.singleton v)) xs) - --- | Convenience function for deleting from 'Map's of 'Set's. If the --- resulting 'Set' is empty, then the entry is removed from the 'Map'. -delete :: (Ord a, Ord k) - => k -> a -> Map k (Set a) -> Map k (Set a) -delete k v index = Map.update remove k index - where - remove set = let set' = Set.delete v set - in if Set.null set' then Nothing else Just set' - --- | Helper function to 'delete' a list of elements from a set. -deleteList :: (Ord a, Ord k) - => [(k,a)] -> Map k (Set a) -> Map k (Set a) -deleteList xs index = List.foldl' (\m (k,v) -> delete k v m) index xs - --- | Takes the union of two sets. -union :: (Ord a, Ord k) - => Map k (Set a) -> Map k (Set a) -> Map k (Set a) -union index1 index2 = Map.unionWith Set.union index1 index2 - --- | Takes the intersection of two sets. -intersection :: (Ord a, Ord k) - => Map k (Set a) -> Map k (Set a) -> Map k (Set a) -intersection index1 index2 = Map.filter (not . Set.null) $ - Map.intersectionWith Set.intersection index1 index2 - diff --git a/tests/Data/IxSet/Typed/Tests.hs b/tests/Data/IxSet/Typed/Tests.hs --- a/tests/Data/IxSet/Typed/Tests.hs +++ b/tests/Data/IxSet/Typed/Tests.hs @@ -1,65 +1,72 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, TemplateHaskell, UndecidableInstances, TemplateHaskell, DataKinds, FlexibleInstances, MultiParamTypeClasses, TypeOperators, KindSignatures #-} -{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-orphans #-} - --- TODO (only if SYBWC is added again): --- Check that the SYBWC Data instance for IxSet works, by testing --- that going to and from XML works. +{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DeriveGeneric, DerivingStrategies, FlexibleContexts, TemplateHaskell, UndecidableInstances, TemplateHaskell, DataKinds, FlexibleInstances, MultiParamTypeClasses, TypeOperators, KindSignatures #-} +{-# OPTIONS_GHC -Wno-orphans #-} -module Data.IxSet.Typed.Tests where +module Data.IxSet.Typed.Tests + ( allTests + ) where +import Prelude hiding (filter) import Control.Monad import Control.Exception -import Data.Data (Data, Typeable) +import Data.Data (Data) import Data.IxSet.Typed as IxSet import Data.Maybe +import Data.Proxy (Proxy (..)) import qualified Data.Set as Set +import GHC.Generics (Generic) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck data Foo - = Foo String Int - deriving (Eq, Ord, Show, Data, Typeable) + = Foo Char Int + deriving stock (Eq, Generic, Ord, Show, Data) + deriving anyclass (CoArbitrary, Function) data FooX = Foo1 String Int | Foo2 Int - deriving (Eq, Ord, Show, Data, Typeable) + deriving (Eq, Ord, Show, Data) data NoIdxFoo = NoIdxFoo Int - deriving (Eq, Ord, Show, Data, Typeable) + deriving (Eq, Ord, Show, Data) data BadlyIndexed = BadlyIndexed Int - deriving (Eq, Ord, Show, Data, Typeable) + deriving (Eq, Ord, Show, Data) data MultiIndex = MultiIndex String Int Integer (Maybe Int) (Either Bool Char) | MultiIndexSubset Int Bool String - deriving (Eq, Ord, Show, Data, Typeable) + deriving (Eq, Ord, Show, Data) data Triple = Triple Int Int Int - deriving (Eq, Ord, Show, Data, Typeable) + deriving (Eq, Ord, Show, Data) data S = S String - deriving (Eq, Ord, Show, Data, Typeable) + deriving (Eq, Ord, Show, Data) data G a b = G a b - deriving (Eq, Ord, Show, Data, Typeable) + deriving (Eq, Ord, Show, Data) +data Multi + = Multi [String] + deriving (Eq, Ord, Show, Data) + fooCalcs :: Foo -> String -fooCalcs (Foo s _) = s ++ "bar" +fooCalcs (Foo s _) = s : "bar" inferIxSet "FooXs" ''FooX 'noCalcs [''Int, ''String] -inferIxSet "BadlyIndexeds" ''BadlyIndexed 'noCalcs [''String] +-- inferIxSet "BadlyIndexeds" ''BadlyIndexed 'noCalcs [''String] inferIxSet "MultiIndexed" ''MultiIndex 'noCalcs [''String, ''Int, ''Integer, ''Bool, ''Char] inferIxSet "Triples" ''Triple 'noCalcs [''Int] -inferIxSet "Gs" ''G 'noCalcs [''Int] -inferIxSet "Foos" ''Foo 'fooCalcs [''String, ''Int] +-- inferIxSet "Gs" ''G 'noCalcs [''Int] +inferIxSet "Foos" ''Foo 'fooCalcs [''Char, ''Int] +inferIxSet "Multis" ''Multi 'noCalcs [''String] instance Indexable '[Int] S where indices = ixList (ixFun (\ (S x) -> [length x])) @@ -108,8 +115,8 @@ 3 @=? length (toList foox_set_abc) ] -isError :: a -> Assertion -isError x = do +_isError :: a -> Assertion +_isError x = do r <- try (return $! x) case r of Left (ErrorCall _) -> return () @@ -139,10 +146,12 @@ instance Arbitrary Foo where arbitrary = liftM2 Foo arbitrary arbitrary + shrink (Foo x y) = (Foo <$> shrink x <*> shrink y) ++ (Foo <$> shrink x <*> pure y) ++ (Foo x <$> shrink y) instance (Arbitrary a, Indexable (ix ': ixs) a) => Arbitrary (IxSet (ix ': ixs) a) where arbitrary = liftM fromList arbitrary + shrink = fmap fromList . shrink . toList prop_sizeEqToListLength :: Foos -> Bool prop_sizeEqToListLength ixset = size ixset == length (toList ixset) @@ -160,6 +169,42 @@ toSet (ixset1 `intersection` ixset2) == toSet ixset1 `Set.intersection` toSet ixset2 +prop_difference :: Foos -> Foos -> Bool +prop_difference ixset1 ixset2 = + toSet (ixset1 `difference` ixset2) == + toSet ixset1 `Set.difference` toSet ixset2 + +prop_filter :: Fun Foo Bool -> Foos -> Bool +prop_filter p ixset = + toSet (filter (applyFun p) ixset) == + Set.filter (applyFun p) (toSet ixset) + +-- | Two sets have the same indices if grouping by each of them agrees. +sameIndices :: Foos -> Foos -> Bool +sameIndices ixset1 ixset2 = + (groupBy ixset1 :: [(Int, [Foo])]) == groupBy ixset2 && + (groupBy ixset1 :: [(Char, [Foo])]) == groupBy ixset2 + +-- | A set has valid indices if building them afresh (using fromList) leaves +-- them unchanged. +validIndices :: Foos -> Bool +validIndices ixset = sameIndices ixset (fromList (toList ixset)) + +-- | Removing elements should leave the same indices behind as building a +-- set from the remaining elements in the first place. In particular, a +-- key all of whose elements have been removed should be gone from the +-- index, not left behind with an empty set of elements. +prop_differenceIndices :: Fun Foo Bool -> Foos -> Bool +prop_differenceIndices p ixset = validIndices d + where + -- A genuine subset, so that keys really do get emptied. Two + -- independently generated sets would hardly ever overlap. + subset = fromList [ x | x <- toList ixset, applyFun p x ] + d = ixset `difference` subset + +prop_filterIndices :: Fun Foo Bool -> Foos -> Bool +prop_filterIndices p ixset = validIndices (filter (applyFun p) ixset) + prop_any :: Foos -> [Int] -> Bool prop_any ixset idxs = (ixset @+ idxs) == foldr union empty (map ((@=) ixset) idxs) @@ -172,6 +217,12 @@ setOps = testGroup "set operations" $ [ testProperty "distributivity toSet / union" $ prop_union , testProperty "distributivity toSet / intersection" $ prop_intersection + , testProperty "distributivity toSet / difference" $ prop_difference + , testProperty "distributivity toSet / filter" $ prop_filter + , testProperty "indices after union" $ \ x y -> validIndices (x `union` y) + , testProperty "indices after intersection" $ \ x y -> validIndices (x `intersection` y) + , testProperty "indices after difference" $ prop_differenceIndices + , testProperty "indices after filter" $ prop_filterIndices , testProperty "any (@+)" $ prop_any , testProperty "all (@*)" $ prop_all ] @@ -209,22 +260,52 @@ sureelem :: TestTree sureelem = testProperty "query / insert interaction" $ prop_sureelem -prop_ranges :: Foos -> Int -> Int -> Bool -prop_ranges ixset intidx1 intidx2 = - ((ixset @>< (intidx1,intidx2)) == (gt1 &&& lt2)) && - ((ixset @>=< (intidx1,intidx2)) == ((gt1 ||| eq1) &&& lt2)) && - ((ixset @><= (intidx1,intidx2)) == (gt1 &&& (lt2 ||| eq2))) && +-- | The interval (x,y) is (x,+inf) /\ (-inf,y) +prop_ranges1 :: Foos -> Int -> Int -> Bool +prop_ranges1 ixset intidx1 intidx2 = + ((ixset @>< (intidx1,intidx2)) == (gt1 &&& lt2)) + where + gt1 = ixset @> intidx1 + lt2 = ixset @< intidx2 + +-- | The interval [x,y) is ({x} \/ (x,+inf)) /\ (-inf,y) +prop_ranges2 :: Foos -> Int -> Int -> Bool +prop_ranges2 ixset intidx1 intidx2 = + ((ixset @>=< (intidx1,intidx2)) == ((gt1 ||| eq1) &&& lt2)) + where + eq1 = ixset @= intidx1 + gt1 = ixset @> intidx1 + lt2 = ixset @< intidx2 + +-- | The interval (x,y] is (x,+inf) /\ ({y} \/ (-inf,y)) +prop_ranges3 :: Foos -> Int -> Int -> Bool +prop_ranges3 ixset intidx1 intidx2 = + ((ixset @><= (intidx1,intidx2)) == (gt1 &&& (lt2 ||| eq2))) + where + gt1 = ixset @> intidx1 + eq2 = ixset @= intidx2 + lt2 = ixset @< intidx2 + +-- | The interval [x,y] is ({x} \/ (x,+inf)) /\ ({y} \/ (-inf,y)) +prop_ranges4 :: Foos -> Int -> Int -> Bool +prop_ranges4 ixset intidx1 intidx2 = ((ixset @>=<= (intidx1,intidx2)) == ((gt1 ||| eq1) &&& (lt2 ||| eq2))) where eq1 = ixset @= intidx1 - _lt1 = ixset @< intidx1 gt1 = ixset @> intidx1 eq2 = ixset @= intidx2 lt2 = ixset @< intidx2 - _gt2 = ixset @> intidx2 +-- | Test properties for intervals. These all work on the assumption that there +-- is at most one value for each index (see 'multiValued' for tests that cover +-- the possibility of more values). ranges :: TestTree -ranges = testProperty "ranges" $ prop_ranges +ranges = testGroup "ranges" + [ testProperty "@><" prop_ranges1 + , testProperty "@>=<" prop_ranges2 + , testProperty "@><=" prop_ranges3 + , testProperty "@>=<=" prop_ranges4 + ] funSet :: IxSet '[Int] S funSet = IxSet.fromList [S "", S "abc", S "def", S "abcde"] @@ -240,6 +321,72 @@ 3 @=? size (funSet @>=<= (3 :: Int, 7 :: Int)) ] +projectIndices :: TestTree +projectIndices = + testGroup "project indices" $ + [ testCase "projects out length" $ + project (Proxy :: Proxy '[Int]) (S "abc") @=? [3 :: Int] + ] + +lookupIxs :: TestTree +lookupIxs = + testGroup "lookupIx / lookupIxMany" $ + [ testCase "finds both length 3 elements" $ + Set.fromList [S "abc", S "def"] @=? lookupIx (3 :: Int) funSet + , testCase "missing index gives empty set" $ + Set.empty @=? lookupIx (1 :: Int) funSet + , testCase "unions the matching elements" $ + Set.fromList [S "", S "abc", S "def"] + @=? lookupIxMany [0, 3 :: Int] funSet + , testCase "no indices gives empty set" $ + Set.empty @=? lookupIxMany ([] :: [Int]) funSet + , testCase "missing indices are ignored" $ + Set.fromList [S "abcde"] @=? lookupIxMany [1, 5 :: Int] funSet + ] + +deleteIxs :: TestTree +deleteIxs = + testGroup "deleteIxMany" $ + [ testCase "deletes both length 3 elements" $ + IxSet.fromList [S "", S "abcde"] @=? deleteIxMany [3 :: Int] funSet + , testCase "no indices leaves the set alone" $ + funSet @=? deleteIxMany ([] :: [Int]) funSet + , testCase "missing indices leave the set alone" $ + funSet @=? deleteIxMany [1, 2 :: Int] funSet + , testCase "deleting every index empties the set" $ + IxSet.empty @=? deleteIxMany [0, 3, 5 :: Int] funSet + ] + +prop_lookupIx :: Foos -> Int -> Bool +prop_lookupIx ixset intidx = + lookupIx intidx ixset == toSet (ixset @= intidx) + +prop_lookupIxMany :: Foos -> [Int] -> Bool +prop_lookupIxMany ixset idxs = + lookupIxMany idxs ixset == toSet (ixset @+ idxs) + +prop_deleteIxMany :: Foos -> [Int] -> Bool +prop_deleteIxMany ixset idxs = + toSet d == toSet ixset `Set.difference` toSet (ixset @+ idxs) + where + d = deleteIxMany idxs ixset + +-- | The indices are only used as a source of keys that occur in the set, so +-- that deletion really does have something to do. +prop_deleteIxManyIndices :: Foos -> Bool +prop_deleteIxManyIndices ixset = + validIndices (deleteIxMany idxs ixset) + where + idxs = [ i | Foo _ i <- toList ixset, even i ] + +lookupDeleteOps :: TestTree +lookupDeleteOps = testGroup "lookup / delete by index" $ + [ testProperty "lookupIx agrees with (@=)" $ prop_lookupIx + , testProperty "lookupIxMany agrees with (@+)" $ prop_lookupIxMany + , testProperty "deleteIxMany agrees with (@+)" $ prop_deleteIxMany + , testProperty "indices after deleteIxMany" $ prop_deleteIxManyIndices + ] + bigSet :: Int -> MultiIndexed bigSet n = fromList $ [ MultiIndex string int integer maybe_int either_bool_char | @@ -272,6 +419,34 @@ [ testCase "find an element" (True @=? findElement 1 1) ] +multiSet :: Multis +multiSet = fromList [ Multi ["abc", "def", "ghi", "jkl"] + , Multi ["ghi", "jkl"] + , Multi ["def", "ghi"] + , Multi ["def"] + ] + +multiValued :: TestTree +multiValued = + testGroup "MultiValued" $ + [ testCase "find a value" (1 @=? (size $ multiSet @= "abc")) + , testCase "find a value with multiple occurrences" (3 @=? (size $ multiSet @= "ghi")) + , testCase "find a value with different indices" (2 @=? (size $ multiSet @= "ghi" @= "jkl")) + , testCase "find a range" (1 @=? (size $ getRange "aba" "abd" $ multiSet)) + , testCase "find a missing range" (0 @=? (size $ getRange "abd" "abe" $ multiSet)) + , testCase "find a missing range (old getRange)" (1 @=? (size $ getGTE "abd" (getLT "abe" multiSet))) + , testCase "find a @>=<" (1 @=? (size $ multiSet @>=< ("abc","abd"))) + , testCase "find a missing @>=<" (0 @=? (size $ multiSet @>=< ("abd","abe"))) + , testCase "find a @><" (1 @=? (size $ multiSet @>< ("aba","abd"))) + , testCase "find a missing @><" (0 @=? (size $ multiSet @>< ("abc","abe"))) + , testCase "find a @><=" (3 @=? (size $ multiSet @><= ("aba","def"))) + , testCase "find a missing @><=" (0 @=? (size $ multiSet @><= ("abc","abb"))) + , testCase "find a @>=<=" (3 @=? (size $ multiSet @>=<= ("abc","def"))) + , testCase "find a missing @>=<=" (0 @=? (size $ multiSet @>=<= ("abd","dee"))) + , testCase "index of range result" (1 @=? size (multiSet @>< ("abc","ghi") @= "abc")) + , testCase "no empty keys in range result" ([] @=? [k | (k, vs) <- groupBy (multiSet @>< ("abc","ghi")) :: [(String,[Multi])], Prelude.null vs]) + ] + allTests :: TestTree allTests = testGroup "ixset-typed tests" $ @@ -280,12 +455,17 @@ , ixSetCheckSetMethods , badIndexSafeguard , multiIndexed + , multiValued , testTriple , funIndexes + , projectIndices + , lookupIxs + , deleteIxs ] , testGroup "properties" $ [ sizeEqToListLength , setOps + , lookupDeleteOps , opers , sureelem , ranges diff --git a/tests/Example.hs b/tests/Example.hs new file mode 100644 --- /dev/null +++ b/tests/Example.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds, MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +module Example where + +import Data.IxSet.Typed +import Data.Time +import Data.Int +import Data.Data +import Prelude hiding (Word) + +-- Example from the documentation + +data Entry = Entry Author [Author] Updated Id Content deriving (Show, Eq, Ord, Data) +newtype Updated = Updated UTCTime deriving (Show, Eq, Ord, Data) +newtype Id = Id Int64 deriving (Show, Eq, Ord, Data) +newtype Content = Content String deriving (Show, Eq, Ord, Data) +newtype Author = Author Email deriving (Show, Eq, Ord, Data) +type Email = String + +data Test = Test deriving (Show, Eq, Ord, Data) + +type EntryIxs = '[Author, Id, Updated, Test, Word, FirstAuthor] +type IxEntry = IxSet EntryIxs Entry + +instance Indexable EntryIxs Entry where + indices = ixList + (ixGen (Proxy :: Proxy Author)) -- out of order + (ixGen (Proxy :: Proxy Id)) + (ixGen (Proxy :: Proxy Updated)) + (ixGen (Proxy :: Proxy Test)) -- bogus index + (ixFun getWords) + (ixFun getFirstAuthor) + +entries = insertList [e1, e2, e3, e4] (empty :: IxEntry) +entries1 = foldr delete entries [e1,e3] +entries2 = updateIx (Id 4) e5 entries + +e1 = Entry (Author "abc@def.ghi") [] (Updated t1) (Id 1) (Content "word1 word2") +e2 = Entry (Author "john@doe.com") [] (Updated t2) (Id 2) (Content "word2 word3") +e3 = Entry (Author "john@doe.com") [Author "abc@def.ghi"] (Updated t2) (Id 3) (Content "word1 word2 word3") +e4 = Entry (Author "abc@def.com") [Author "john@doe.com"] (Updated t3) (Id 4) (Content "word3") +e5 = Entry (Author "abc@def.com") [Author "john@doe.com"] (Updated t1) (Id 4) (Content "word1 word3 word4") +t1 = UTCTime (fromGregorian 2014 03 06) 0 +t2 = UTCTime (fromGregorian 2012 12 12) 0 +t3 = UTCTime (fromGregorian 1909 09 09) 0 + +entries3 = entries @= Author "john@doe.com" @< Updated t1 + +newtype Word = Word String deriving (Show, Eq, Ord) +newtype FirstAuthor = FirstAuthor Email deriving (Show, Eq, Ord) + +getWords (Entry _ _ _ _ (Content s)) = map Word $ words s +getFirstAuthor (Entry (Author author) _ _ _ _) = [FirstAuthor author] + +entries4 = entries @+ [Word "word1", Word "word2"] +entries5 = entries @* [Word "word1", Word "word2"] +entries6 = entries @= FirstAuthor "john@doe.com"