dependent-map 0.2.4.0 → 0.4.0.1
raw patch · 8 files changed
Files
- ChangeLog.md +25/−0
- README.md +49/−0
- dependent-map.cabal +28/−25
- src/Data/Dependent/Map.hs +154/−99
- src/Data/Dependent/Map/Internal.hs +33/−41
- src/Data/Dependent/Map/Lens.hs +83/−0
- src/Data/Dependent/Map/PtrEquality.hs +4/−25
- src/Data/Dependent/Map/Typeable.hs +0/−21
+ ChangeLog.md view
@@ -0,0 +1,25 @@+# Revision history for dependent-map++## Unreleased (0.4.0.1)++* Minimum `base` version is now `4.11` (GHC 8.4.x).+* Use canonical `mappend`/`(<>)` definitions.++## 0.4.0.0 - 2020-03-26++* Stop re-exporting `Some(..)`, `GCompare(..)`, and `GOrdering(..)` from `dependent-sum` (which itself re-exports from `some` in some versions).+* Stop re-exporting `DSum(..)` from `dependent-sum`.++## 0.3.1.0 - 2020-03-26++* Drop support for non-GHC compilers.+* Drop support for GHC < 8.+* Update maintainer and GitHub links.+* Support `dependent-sum` 0.7.+* Add `ffor`, `fforWithKey`, `forWithKey`, `forWithKey_`, and `traverseWithKey_` to `Data.Dependent.Map`.+* Enable `PolyKinds` for `Data.Dependent.Map.Lens`.++## 0.3 - 2019-03-21++* Change instances of Eq, Ord, Read, Show to use Has' from constraints-extras instead of *Tag classes.+* This ends support for GHC 7.x.
+ README.md view
@@ -0,0 +1,49 @@+dependent-map [](https://github.com/obsidiansystems/dependent-map/actions/workflows/haskell-ci.yml) [](http://hackage.haskell.org/package/dependent-map)+==============++This library defines a dependently-typed finite map type. It is derived from `Data.Map.Map` in the `containers` package, but rather than (conceptually) storing pairs indexed by the first component, it stores `DSum`s (from the `dependent-sum` package) indexed by tag. For example++```haskell+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Example where++import Data.Constraint.Extras.TH (deriveArgDict)+import Data.Dependent.Map (DMap, fromList, singleton, union, unionWithKey)+import Data.Dependent.Sum ((==>))+import Data.Functor.Identity (Identity(..))+import Data.GADT.Compare.TH (deriveGCompare, deriveGEq)+import Data.GADT.Show.TH (deriveGShow)++data Tag a where+ StringKey :: Tag String+ IntKey :: Tag Int+ DoubleKey :: Tag Double+deriveGEq ''Tag+deriveGCompare ''Tag+deriveGShow ''Tag+deriveArgDict ''Tag++x :: DMap Tag Identity+x = fromList [DoubleKey ==> pi, StringKey ==> "hello there"]++y :: DMap Tag Identity+y = singleton IntKey (Identity 42)++z :: DMap Tag Identity+z = y `union` fromList [DoubleKey ==> -1.1415926535897931]++addFoo :: Tag v -> Identity v -> Identity v -> Identity v+addFoo IntKey (Identity x) (Identity y) = Identity $ x + y+addFoo DoubleKey (Identity x) (Identity y) = Identity $ x + y+addFoo _ x _ = x++main :: IO ()+main = mapM_ print+ [ x, y, z+ , unionWithKey addFoo x z+ ]+```
dependent-map.cabal view
@@ -1,15 +1,15 @@+cabal-version: 3.0 name: dependent-map-version: 0.2.4.0+version: 0.4.0.1 stability: provisional -cabal-version: >= 1.6 build-type: Simple author: James Cook <mokus@deepbondi.net>-maintainer: James Cook <mokus@deepbondi.net>-license: OtherLicense+maintainer: Obsidian Systems, LLC <maintainer@obsidian.systems>+license: BSD-3-Clause license-file: LICENSE-homepage: https://github.com/mokus0/dependent-map+homepage: https://github.com/obsidiansystems/dependent-map category: Data, Dependent Types synopsis: Dependent finite maps (partial dependent products)@@ -17,30 +17,33 @@ @Data.Map.Map@, allowing keys to specify the type of value that can be associated with them. -tested-with: GHC == 7.0.4,- GHC == 7.2.2,- GHC == 7.4.2,- GHC == 7.6.3,- GHC == 7.8.4,- GHC == 7.10.1,- GHC == 7.11+extra-source-files: ChangeLog.md+ README.md +tested-with: 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.5,+ GHC == 9.8.2,+ GHC == 9.10.1+ source-repository head type: git- location: git://github.com/mokus0/dependent-map.git+ location: https://github.com/obsidiansystems/dependent-map Library hs-source-dirs: src ghc-options: -fwarn-unused-imports -fwarn-unused-binds- exposed-modules: Data.Dependent.Map- other-modules: Data.Dependent.Map.Internal,- Data.Dependent.Map.PtrEquality- if impl(ghc < 7.8)- other-modules: Data.Dependent.Map.Typeable- if impl(ghc < 8)- build-depends: semigroups- build-depends: base >= 3 && < 5,- containers,- dependent-sum >= 0.3.2- if impl(ghc >= 7.2) && impl(ghc < 7.8)- ghc-options: -trust base -trust dependent-sum+ exposed-modules: Data.Dependent.Map,+ Data.Dependent.Map.Lens,+ Data.Dependent.Map.Internal+ other-modules: Data.Dependent.Map.PtrEquality+ build-depends: base >= 4.11 && < 5,+ containers >= 0.5.7.1 && <0.8,+ dependent-sum >= 0.6.1 && < 0.8,+ constraints-extras >= 0.2.3.0 && < 0.5+ default-language: Haskell2010
src/Data/Dependent/Map.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE GADTs, RankNTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE PolyKinds #-}-#endif+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Dependent.Map ( DMap- , DSum(..), Some(..)- , GCompare(..), GOrdering(..)- + -- * Operators , (!), (\\) @@ -24,7 +22,7 @@ , notMember , lookup , findWithDefault- + -- * Construction , empty , singleton@@ -37,7 +35,7 @@ , insertWithKey' , insertLookupWithKey , insertLookupWithKey'- + -- ** Delete\/Update , delete , adjust@@ -47,11 +45,12 @@ , updateWithKey , updateLookupWithKey , alter+ , alterF -- * Combine -- ** Union- , union + , union , unionWithKey , unions , unionsWithKey@@ -59,16 +58,21 @@ -- ** Difference , difference , differenceWithKey- + -- ** Intersection- , intersection + , intersection , intersectionWithKey -- * Traversal -- ** Map , map+ , ffor , mapWithKey+ , fforWithKey+ , traverseWithKey_+ , forWithKey_ , traverseWithKey+ , forWithKey , mapAccumLWithKey , mapAccumRWithKey , mapKeysWith@@ -83,7 +87,7 @@ -- * Conversion , keys , assocs- + -- ** Lists , toList , fromList@@ -96,22 +100,23 @@ , fromAscListWithKey , fromDistinctAscList - -- * Filter + -- * Filter , filter , filterWithKey , partitionWithKey + , mapMaybe , mapMaybeWithKey , mapEitherWithKey - , split - , splitLookup + , split+ , splitLookup -- * Submap , isSubmapOf, isSubmapOfBy , isProperSubmapOf, isProperSubmapOfBy - -- * Indexed + -- * Indexed , lookupIndex , findIndex , elemAt@@ -131,7 +136,7 @@ , updateMaxWithKey , minViewWithKey , maxViewWithKey- + -- * Debugging , showTree , showTreeWith@@ -140,37 +145,30 @@ import Prelude hiding (null, lookup, map) import qualified Prelude-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative(..), (<$>))-#endif-import Data.Dependent.Map.Internal-#if !MIN_VERSION_base(4,7,0)-import Data.Dependent.Map.Typeable ({- instance Typeable ... -})-#endif--import Data.Dependent.Sum-import Data.GADT.Compare+import Data.Constraint.Extras (Has', has')+import Data.Dependent.Sum (DSum((:=>)))+import Data.GADT.Compare (GCompare, GEq, GOrdering(..), gcompare, geq)+import Data.GADT.Show (GRead, GShow) import Data.Maybe (isJust)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif-import Data.Semigroup-import Data.Some-import Text.Read-import Data.Dependent.Map.PtrEquality+import Data.Some (Some, mkSome)+import Data.Typeable ((:~:)(Refl))+import Text.Read (Lexeme(Ident), lexP, parens, prec, readListPrec,+ readListPrecDefault, readPrec) +import Data.Dependent.Map.Internal+import Data.Dependent.Map.PtrEquality (ptrEq)+ instance (GCompare k) => Monoid (DMap k f) where mempty = empty- mappend = union mconcat = unions instance (GCompare k) => Semigroup (DMap k f) where- (<>) = mappend+ (<>) = union {-------------------------------------------------------------------- Operators --------------------------------------------------------------------}-infixl 9 !,\\ --+infixl 9 \\,! -- \\ at the end of the line means line continuation -- | /O(log n)/. Find the value at a key. -- Calls 'error' when the element can not be found.@@ -186,21 +184,21 @@ m1 \\ m2 = difference m1 m2 -- #if __GLASGOW_HASKELL__--- +-- -- {----------------------------------------------------------------------- A Data instance +-- A Data instance -- --------------------------------------------------------------------}--- +-- -- -- This instance preserves data abstraction at the cost of inefficiency. -- -- We omit reflection services for the sake of data abstraction.--- +-- -- instance (Data k, Data a, GCompare k) => Data (DMap k) where -- gfoldl f z m = z fromList `f` toList m -- toConstr _ = error "toConstr" -- gunfold _ _ = error "gunfold" -- dataTypeOf _ = mkNoRepType "Data.Map.Map" -- dataCast2 f = gcast2 f--- +-- -- #endif {--------------------------------------------------------------------@@ -277,7 +275,7 @@ GEQ -> t -- | /O(log n)/. Insert with a function, combining new value and old value.--- @'insertWith' f key value mp@ +-- @'insertWith' f key value mp@ -- will insert the entry @key :=> value@ into @mp@ if key does -- not exist in the map. If the key does exist, the function will -- insert the entry @key :=> f new_value old_value@.@@ -290,7 +288,7 @@ insertWith' f = insertWithKey' (\_ x' y' -> f x' y') -- | /O(log n)/. Insert with a function, combining key, new value and old value.--- @'insertWithKey' f key value mp@ +-- @'insertWithKey' f key value mp@ -- will insert the entry @key :=> value@ into @mp@ if key does -- not exist in the map. If the key does exist, the function will -- insert the entry @key :=> f key new_value old_value@.@@ -425,7 +423,7 @@ -- | /O(log n)/. Lookup and update. See also 'updateWithKey'. -- The function returns changed value, if it is updated.--- Returns the original key value if the map entry is deleted. +-- Returns the original key value if the map entry is deleted. updateLookupWithKey :: forall k f v. GCompare k => (k v -> f v -> Maybe (f v)) -> k v -> DMap k f -> (Maybe (f v), DMap k f) updateLookupWithKey f k = k `seq` go where@@ -434,7 +432,7 @@ go (Bin sx kx x l r) = case gcompare k kx of GLT -> let (found,l') = go l in (found,balance kx x l' r)- GGT -> let (found,r') = go r in (found,balance kx x l r') + GGT -> let (found,r') = go r in (found,balance kx x l r') GEQ -> case f kx x of Just x' -> (Just x',Bin sx kx x' l r) Nothing -> (Just x,glue l r)@@ -457,6 +455,19 @@ Just x' -> Bin sx kx x' l r Nothing -> glue l r +-- | Works the same as 'alter' except the new value is returned in some 'Functor' @f@.+-- In short : @(\v' -> alter (const v') k dm) <$> f (lookup k dm)@+alterF :: forall k f v g. (GCompare k, Functor f) => k v -> (Maybe (g v) -> f (Maybe (g v))) -> DMap k g -> f (DMap k g)+alterF k f = go+ where+ go :: DMap k g -> f (DMap k g)+ go Tip = maybe Tip (singleton k) <$> f Nothing++ go (Bin sx kx x l r) = case gcompare k kx of+ GLT -> (\l' -> balance kx x l' r) <$> go l+ GGT -> (\r' -> balance kx x l r') <$> go r+ GEQ -> maybe (glue l r) (\x' -> Bin sx kx x' l r) <$> f (Just x)+ {-------------------------------------------------------------------- Indexing --------------------------------------------------------------------}@@ -480,7 +491,7 @@ go !idx (Bin _ kx _ l r) = case gcompare k kx of GLT -> go idx l- GGT -> go (idx + size l + 1) r + GGT -> go (idx + size l + 1) r GEQ -> Just (idx + size l) -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an@@ -507,7 +518,7 @@ EQ -> case f kx x of Just x' -> Bin sx kx x' l r Nothing -> glue l r- where + where sizeL = size l -- | /O(log n)/. Delete the element at /index/.@@ -584,7 +595,7 @@ go Tip = Tip {--------------------------------------------------------------------- Union. + Union. --------------------------------------------------------------------} -- | The union of a list of maps:@@ -600,7 +611,7 @@ = foldlStrict (unionWithKey f) empty ts -- | /O(m*log(n\/m + 1)), m <= n/.--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. -- It prefers @t1@ when duplicate keys are encountered, -- i.e. (@'union' == 'unionWith' 'const'@). union :: GCompare k => DMap k f -> DMap k f -> DMap k f@@ -635,7 +646,7 @@ Difference --------------------------------------------------------------------} --- | /O(m * log (n\/m + 1)), m <= n/. Difference of two maps. +-- | /O(m * log (n\/m + 1)), m <= n/. Difference of two maps. -- Return elements of the first map not existing in the second map. difference :: GCompare k => DMap k f -> DMap k g -> DMap k f difference Tip _ = Tip@@ -651,7 +662,7 @@ -- | /O(n+m)/. Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. +-- it returns (@'Just' y@), the element is updated with a new value @y@. differenceWithKey :: GCompare k => (forall v. k v -> f v -> g v -> Maybe (f v)) -> DMap k f -> DMap k g -> DMap k f differenceWithKey _ Tip _ = Tip differenceWithKey _ t1 Tip = t1@@ -702,8 +713,11 @@ -- | /O(n+m)/. -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' 'eqTagged')@). ---isSubmapOf :: (GCompare k, EqTag k f) => DMap k f -> DMap k f -> Bool-isSubmapOf m1 m2 = isSubmapOfBy eqTagged m1 m2+isSubmapOf+ :: forall k f+ . (GCompare k, Has' Eq k f)+ => DMap k f -> DMap k f -> Bool+isSubmapOf m1 m2 = isSubmapOfBy (\k _ x0 x1 -> has' @Eq @f k (x0 == x1)) m1 m2 {- | /O(n+m)/. The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if@@ -724,17 +738,20 @@ where (lt,found,gt) = splitLookupWithKey kx t --- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' 'eqTagged'@).-isProperSubmapOf :: (GCompare k, EqTag k f) => DMap k f -> DMap k f -> Bool+isProperSubmapOf+ :: forall k f+ . (GCompare k, Has' Eq k f)+ => DMap k f -> DMap k f -> Bool isProperSubmapOf m1 m2- = isProperSubmapOfBy eqTagged m1 m2+ = isProperSubmapOfBy (\k _ x0 x1 -> has' @Eq @f k (x0 == x1)) m1 m2 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective keys and values. + applied to their respective keys and values. -} isProperSubmapOfBy :: GCompare k => (forall v. k v -> k v -> f v -> g v -> Bool) -> DMap k f -> DMap k g -> Bool isProperSubmapOfBy f t1 t2@@ -772,6 +789,10 @@ (l1 :*: l2) = go p l (r1 :*: r2) = go p r +-- | /O(n)/. Map values and collect the 'Just' results.+mapMaybe :: GCompare k => (forall v. f v -> Maybe (g v)) -> DMap k f -> DMap k g+mapMaybe f = mapMaybeWithKey (const f)+ -- | /O(n)/. Map keys\/values and collect the 'Just' results. mapMaybeWithKey :: GCompare k => (forall v. k v -> f v -> Maybe (g v)) -> DMap k f -> DMap k g mapMaybeWithKey f = go@@ -808,6 +829,12 @@ go Tip = Tip go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r) +-- | /O(n)/.+-- @'ffor' == 'flip' 'map'@ except we cannot actually use+-- 'flip' because of the lack of impredicative types.+ffor :: DMap k f -> (forall v. f v -> g v) -> DMap k g+ffor m f = map f m+ -- | /O(n)/. Map a function over all values in the map. mapWithKey :: (forall v. k v -> f v -> g v) -> DMap k f -> DMap k g mapWithKey f = go@@ -816,9 +843,32 @@ go (Bin sx kx x l r) = Bin sx kx (f kx x) (go l) (go r) -- | /O(n)/.+-- @'fforWithKey' == 'flip' 'mapWithKey'@ except we cannot actually use+-- 'flip' because of the lack of impredicative types.+fforWithKey :: DMap k f -> (forall v. k v -> f v -> g v) -> DMap k g+fforWithKey m f = mapWithKey f m++-- | /O(n)/. -- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ -- That is, behaves exactly like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value.+traverseWithKey_ :: Applicative t => (forall v. k v -> f v -> t ()) -> DMap k f -> t ()+traverseWithKey_ f = go+ where+ go Tip = pure ()+ go (Bin 1 k v _ _) = f k v+ go (Bin s k v l r) = go l *> f k v *> go r++-- | /O(n)/.+-- @'forWithKey' == 'flip' 'traverseWithKey'@ except we cannot actually use+-- 'flip' because of the lack of impredicative types.+forWithKey_ :: Applicative t => DMap k f -> (forall v. k v -> f v -> t ()) -> t ()+forWithKey_ m f = traverseWithKey_ f m++-- | /O(n)/.+-- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value. traverseWithKey :: Applicative t => (forall v. k v -> f v -> t (g v)) -> DMap k f -> t (DMap k g) traverseWithKey f = go where@@ -826,8 +876,14 @@ go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v go (Bin s k v l r) = flip (Bin s k) <$> go l <*> f k v <*> go r +-- | /O(n)/.+-- @'forWithKey' == 'flip' 'traverseWithKey'@ except we cannot actually use+-- 'flip' because of the lack of impredicative types.+forWithKey :: Applicative t => DMap k f -> (forall v. k v -> f v -> t (g v)) -> t (DMap k g)+forWithKey m f = traverseWithKey f m+ -- | /O(n)/. The function 'mapAccumLWithKey' threads an accumulating--- argument throught the map in ascending order of keys.+-- argument through the map in ascending order of keys. mapAccumLWithKey :: (forall v. a -> k v -> f v -> (a, g v)) -> a -> DMap k f -> (a, DMap k g) mapAccumLWithKey f = go where@@ -852,7 +908,7 @@ -- | /O(n*log n)/. -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.--- +-- -- The size of the result may be smaller if @f@ maps two or more distinct -- keys to the same new key. In this case the associated values will be -- combined using @c@.@@ -867,8 +923,8 @@ -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. -- /The precondition is not checked./ -- Semi-formally, we have:--- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] +--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls] -- > ==> mapKeysMonotonic f s == mapKeys f s -- > where ls = keys s --@@ -880,7 +936,7 @@ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r) {--------------------------------------------------------------------- Folds + Folds --------------------------------------------------------------------} -- | /O(n)/. Fold the keys and values in the map, such that@@ -918,7 +974,7 @@ -} {--------------------------------------------------------------------- List variations + List variations --------------------------------------------------------------------} -- | /O(n)/. Return all keys of the map in ascending order.@@ -928,7 +984,7 @@ keys :: DMap k f -> [Some k] keys m- = [This k | (k :=> _) <- assocs m]+ = [mkSome k | (k :=> _) <- assocs m] -- | /O(n)/. Return all key\/value pairs in the map in ascending key order. assocs :: DMap k f -> [DSum k f]@@ -936,7 +992,7 @@ = toList m {--------------------------------------------------------------------- Lists + Lists use [foldlStrict] to reduce demand on the control-stack --------------------------------------------------------------------} @@ -944,7 +1000,7 @@ -- If the list contains more than one value for the same key, the last value -- for the key is retained. fromList :: GCompare k => [DSum k f] -> DMap k f-fromList xs +fromList xs = foldlStrict ins empty xs where ins :: GCompare k => DMap k f -> DSum k f -> DMap k f@@ -952,7 +1008,7 @@ -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. fromListWithKey :: GCompare k => (forall v. k v -> f v -> f v -> f v) -> [DSum k f] -> DMap k f-fromListWithKey f xs +fromListWithKey f xs = foldlStrict (ins f) empty xs where ins :: GCompare k => (forall v. k v -> f v -> f v -> f v) -> DMap k f -> DSum k f -> DMap k f@@ -972,8 +1028,8 @@ {-------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time.- - Note that if [xs] is ascending that: ++ Note that if [xs] is ascending that: fromAscList xs == fromList xs fromAscListWith f xs == fromListWith f xs --------------------------------------------------------------------}@@ -987,7 +1043,7 @@ -- | /O(n)/. Build a map from an ascending list in linear time with a -- combining function for equal keys. -- /The precondition (input list is ascending) is not checked./-fromAscListWithKey :: GEq k => (forall v. k v -> f v -> f v -> f v) -> [DSum k f] -> DMap k f +fromAscListWithKey :: GEq k => (forall v. k v -> f v -> f v -> f v) -> [DSum k f] -> DMap k f fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) where@@ -1013,12 +1069,12 @@ = build const (length xs) xs where -- 1) use continutations so that we use heap space instead of stack space.- -- 2) special case for n==5 to build bushier trees. - + -- 2) special case for n==5 to build bushier trees.+ build :: (DMap k f -> [DSum k f] -> b) -> Int -> [DSum k f] -> b build c 0 xs' = c Tip xs' build c 5 xs' = case xs' of- ((k1:=>x1):(k2:=>x2):(k3:=>x3):(k4:=>x4):(k5:=>x5):xx) + ((k1:=>x1):(k2:=>x2):(k3:=>x3):(k4:=>x4):(k5:=>x5):xx) -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx _ -> error "fromDistinctAscList build" build c n xs' = seq nr $ build (buildR nr c) nl xs'@@ -1029,10 +1085,10 @@ buildR :: Int -> (DMap k f -> [DSum k f] -> b) -> DMap k f -> [DSum k f] -> b buildR n c l ((k:=>x):ys) = build (buildB l k x c) n ys buildR _ _ _ [] = error "fromDistinctAscList buildR []"- + buildB :: DMap k f -> k v -> f v -> (DMap k f -> a -> b) -> DMap k f -> a -> b buildB l k x c r zs = c (bin k x l r) zs- + {-------------------------------------------------------------------- Split --------------------------------------------------------------------}@@ -1087,25 +1143,25 @@ GEQ -> Triple' l (Just (kx, x)) r {--------------------------------------------------------------------- Eq converts the tree to a list. In a lazy setting, this - actually seems one of the faster methods to compare two trees + Eq converts the tree to a list. In a lazy setting, this+ actually seems one of the faster methods to compare two trees and it is certainly the simplest :-) --------------------------------------------------------------------}-instance EqTag k f => Eq (DMap k f) where+instance (GEq k, Has' Eq k f) => Eq (DMap k f) where t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) {--------------------------------------------------------------------- Ord + Ord --------------------------------------------------------------------} -instance OrdTag k f => Ord (DMap k f) where- compare m1 m2 = compare (toAscList m1) (toAscList m2)+instance (GCompare k, Has' Eq k f, Has' Ord k f) => Ord (DMap k f) where+ compare m1 m2 = compare (toAscList m1) (toAscList m2) {-------------------------------------------------------------------- Read --------------------------------------------------------------------} -instance (GCompare k, ReadTag k f) => Read (DMap k f) where+instance (GCompare k, GRead k, Has' Read k f) => Read (DMap k f) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec@@ -1116,7 +1172,7 @@ {-------------------------------------------------------------------- Show --------------------------------------------------------------------}-instance ShowTag k f => Show (DMap k f) where+instance (GShow k, Has' Show k f) => Show (DMap k f) where showsPrec p m = showParen (p>10) ( showString "fromList " . showsPrec 11 (toList m)@@ -1124,11 +1180,11 @@ -- | /O(n)/. Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. See 'showTreeWith'.-showTree :: ShowTag k f => DMap k f -> String+showTree :: (GShow k, Has' Show k f) => DMap k f -> String showTree m = showTreeWith showElem True False m where- showElem :: ShowTag k f => k v -> f v -> String+ showElem :: (GShow k, Has' Show k f) => k v -> f v -> String showElem k x = show (k :=> x) @@ -1147,7 +1203,7 @@ = case t of Tip -> showsBars lbars . showString "|\n" Bin _ kx x Tip Tip- -> showsBars lbars . showString (showelem kx x) . showString "\n" + -> showsBars lbars . showString (showelem kx x) . showString "\n" Bin _ kx x l r -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r . showWide wide rbars .@@ -1158,19 +1214,19 @@ showsTreeHang :: (forall v. k v -> f v -> String) -> Bool -> [String] -> DMap k f -> ShowS showsTreeHang showelem wide bars t = case t of- Tip -> showsBars bars . showString "|\n" + Tip -> showsBars bars . showString "|\n" Bin _ kx x Tip Tip- -> showsBars bars . showString (showelem kx x) . showString "\n" + -> showsBars bars . showString (showelem kx x) . showString "\n" Bin _ kx x l r- -> showsBars bars . showString (showelem kx x) . showString "\n" . + -> showsBars bars . showString (showelem kx x) . showString "\n" . showWide wide bars . showsTreeHang showelem wide (withBar bars) l . showWide wide bars . showsTreeHang showelem wide (withEmpty bars) r showWide :: Bool -> [String] -> String -> String-showWide wide bars - | wide = showString (concat (reverse bars)) . showString "|\n" +showWide wide bars+ | wide = showString (concat (reverse bars)) . showString "|\n" | otherwise = id showsBars :: [String] -> ShowS@@ -1203,7 +1259,7 @@ bounded lo hi t' = case t' of Tip -> True- Bin _ kx _ l r -> (lo (This kx)) && (hi (This kx)) && bounded lo (< This kx) l && bounded (> This kx) hi r+ Bin _ kx _ l r -> lo (mkSome kx) && hi (mkSome kx) && bounded lo (< mkSome kx) l && bounded (> mkSome kx) hi r -- | Exported only for "Debug.QuickCheck" balanced :: DMap k f -> Bool@@ -1231,4 +1287,3 @@ where go z [] = z go z (x:xs) = z `seq` go (f z x) xs-
src/Data/Dependent/Map/Internal.hs view
@@ -1,28 +1,21 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe #-}-#endif-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE PolyKinds #-}-#endif module Data.Dependent.Map.Internal where -import Data.Dependent.Sum-import Data.GADT.Compare-import Data.Some-#if MIN_VERSION_base(4,7,0)+import Data.Dependent.Sum (DSum((:=>)))+import Data.GADT.Compare (GCompare, GOrdering(..), gcompare)+import Data.Some (Some, mkSome, withSome) import Data.Typeable (Typeable)-#endif --- |Dependent maps: 'k' is a GADT-like thing with a facility for +-- |Dependent maps: 'k' is a GADT-like thing with a facility for -- rediscovering its type parameter, elements of which function as identifiers -- tagged with the type of the thing they identify. Real GADTs are one--- useful instantiation of @k@, as are 'Tag's from "Data.Unique.Tag" in the +-- useful instantiation of @k@, as are 'Tag's from "Data.Unique.Tag" in the -- 'prim-uniq' package. -- -- Semantically, @'DMap' k f@ is equivalent to a set of @'DSum' k f@ where no two@@ -39,9 +32,7 @@ -> {- left -} !(DMap k f) -> {- right -} !(DMap k f) -> DMap k f-#if MIN_VERSION_base(4,7,0) deriving Typeable-#endif {-------------------------------------------------------------------- Construction@@ -84,15 +75,15 @@ where go :: DMap k f -> Maybe (f v) go Tip = Nothing- go (Bin _ kx x l r) = + go (Bin _ kx x l r) = case gcompare k kx of GLT -> go l GGT -> go r GEQ -> Just x lookupAssoc :: forall k f v. GCompare k => Some k -> DMap k f -> Maybe (DSum k f)-lookupAssoc (This k) = k `seq` go- where+lookupAssoc sk = withSome sk $ \k ->+ let go :: DMap k f -> Maybe (DSum k f) go Tip = Nothing go (Bin _ kx x l r) =@@ -100,12 +91,13 @@ GLT -> go l GGT -> go r GEQ -> Just (kx :=> x)+ in k `seq` go {-------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree. All constructors assume that all values in [l] < [k] and all values in [r] > [k], and that [l] and [r] are valid trees.- + In order of sophistication: [Bin sz k x l r] The type constructor. [bin k x l r] Maintains the correct size, assumes that both [l]@@ -113,7 +105,7 @@ [balance k x l r] Restores the balance and size. Assumes that the original tree was balanced and that [l] or [r] has changed by at most one element.- [combine k x l r] Restores balance and size. + [combine k x l r] Restores balance and size. Furthermore, we can construct a new tree from two trees. Both operations assume that all values in [l] < all values in [r] and that [l] and [r]@@ -123,10 +115,10 @@ [merge l r] Merges two trees and restores balance. Note: in contrast to Adam's paper, we use (<=) comparisons instead- of (<) comparisons in [combine], [merge] and [balance]. - Quickcheck (on [difference]) showed that this was necessary in order - to maintain the invariants. It is quite unsatisfactory that I haven't - been able to find out why this is actually the case! Fortunately, it + of (<) comparisons in [combine], [merge] and [balance].+ Quickcheck (on [difference]) showed that this was necessary in order+ to maintain the invariants. It is quite unsatisfactory that I haven't+ been able to find out why this is actually the case! Fortunately, it doesn't hurt to be a bit more conservative. --------------------------------------------------------------------} @@ -149,13 +141,13 @@ Tip -> singleton kx x Bin _ ky y l r -> balance ky y l (insertMax kx x r)- + insertMin kx x t = case t of Tip -> singleton kx x Bin _ ky y l r -> balance ky y (insertMin kx x l) r- + {-------------------------------------------------------------------- [merge l r]: merges two trees. --------------------------------------------------------------------}@@ -174,13 +166,13 @@ glue :: DMap k f -> DMap k f -> DMap k f glue Tip r = r glue l Tip = l-glue l r +glue l r | size l > size r = case deleteFindMax l of (km :=> m,l') -> balance km m l' r | otherwise = case deleteFindMin r of (km :=> m,r') -> balance km m l r' -- | /O(log n)/. Delete and find the minimal element. ----- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) +-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) -- > deleteFindMin Error: can not return the minimal element of an empty map deleteFindMin :: DMap k f -> (DSum k f, DMap k f)@@ -251,13 +243,13 @@ [ratio] is the ratio between an outer and inner sibling of the heavier subtree in an unbalanced setting. It determines whether a double or single rotation should be performed- to restore balance. It is correspondes with the inverse+ to restore balance. It corresponds with the inverse of $\alpha$ in Adam's article. Note that: - [delta] should be larger than 4.646 with a [ratio] of 2. - [delta] should be larger than 3.745 with a [ratio] of 1.534.- + - A lower [delta] leads to a more 'perfectly' balanced tree. - A higher [delta] performs less rebalancing. @@ -267,7 +259,7 @@ [delta] may perform better than smaller one. Note: in contrast to Adam's paper, we use a ratio of (at least) [2]- to decide whether a single or double rotation is needed. Allthough+ to decide whether a single or double rotation is needed. Although he actually proves that this ratio is needed to maintain the invariants, his implementation uses an invalid ratio of [1]. --------------------------------------------------------------------}@@ -344,17 +336,17 @@ trim :: (Some k -> Ordering) -> (Some k -> Ordering) -> DMap k f -> DMap k f trim _ _ Tip = Tip trim cmplo cmphi t@(Bin _ kx _ l r)- = case cmplo (This kx) of- LT -> case cmphi (This kx) of+ = case cmplo (mkSome kx) of+ LT -> case cmphi (mkSome kx) of GT -> t _ -> trim cmplo cmphi l _ -> trim cmplo cmphi r- + trimLookupLo :: GCompare k => Some k -> (Some k -> Ordering) -> DMap k f -> (Maybe (DSum k f), DMap k f) trimLookupLo _ _ Tip = (Nothing,Tip) trimLookupLo lo cmphi t@(Bin _ kx x l r)- = case compare lo (This kx) of- LT -> case cmphi (This kx) of+ = case compare lo (mkSome kx) of+ LT -> case cmphi (mkSome kx) of GT -> (lookupAssoc lo t, t) _ -> trimLookupLo lo cmphi l GT -> trimLookupLo lo cmphi r@@ -369,7 +361,7 @@ filterGt cmp = go where go Tip = Tip- go (Bin _ kx x l r) = case cmp (This kx) of+ go (Bin _ kx x l r) = case cmp (mkSome kx) of LT -> combine kx x (go l) r GT -> go r EQ -> r@@ -378,7 +370,7 @@ filterLt cmp = go where go Tip = Tip- go (Bin _ kx x l r) = case cmp (This kx) of+ go (Bin _ kx x l r) = case cmp (mkSome kx) of LT -> go l GT -> combine kx x l (go r) EQ -> l
+ src/Data/Dependent/Map/Lens.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE PolyKinds #-}+-- |+-- Some functions for using lenses with 'DMap'.+module Data.Dependent.Map.Lens+ ( -- * At+ dmat+ -- * Ix+ , dmix+ )+ where++import Prelude hiding (lookup)++import Data.Dependent.Map (DMap, alterF, insert, lookup)++import Data.GADT.Compare (GCompare)++-- |+-- These functions have been specialised for use with 'DMap' but without any of the+-- specific 'lens' types used so that we have compatibility without needing the+-- dependency just for these functions.+--++-- |+-- This is equivalent to the <https://hackage.haskell.org/package/lens-4.16.1/docs/Control-Lens-At.html#v:at at> <https://hackage.haskell.org/package/lens-4.16.1/docs/Control-Lens-Type.html#t:Lens-39- Lens'> from <https://hackage.haskell.org/package/lens-4.16.1/docs/Control-Lens-At.html Control.Lens.At>:+--+-- @+-- type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t+--+-- at :: Index m -> Lens' m (Maybe (IxValue m))+-- @+--+-- So the type of 'dmat' is equivalent to:+--+-- @+-- dmat :: GCompare k => Lens' (DMap k f) (Maybe (f v))+-- @+--+-- >>> DMap.fromList [AInt :=> Identity 33, AFloat :=> Identity 3.5] & dmat AString ?~ "Hat"+-- DMap.fromList [AString :=> Identity "Hat", AInt :=> Identity 33, AFloat :=> Identity 3.5]+--+-- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] ^? dmat AFloat+-- Just (AFloat :=> 3.5)+--+dmat :: (GCompare k, Functor f) => k v -> (Maybe (g v) -> f (Maybe (g v))) -> DMap k g -> f (DMap k g)+dmat k f = alterF k f+{-# INLINE dmat #-}++-- |+-- This is equivalent to the <https://hackage.haskell.org/package/lens-4.16.1/docs/Control-Lens-At.html#v:ix ix> <https://hackage.haskell.org/package/lens-4.16.1/docs/Control-Lens-Type.html#t:Traversal-39- Traversal'> from <https://hackage.haskell.org/package/lens-4.16.1/docs/Control-Lens-At.html Control.Lens.At>:+--+-- @+-- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t+--+-- ix :: Index m -> Traversal' m (IxValue m)+-- @+--+-- So the type of 'dmix' is equivalent to:+--+-- @+-- dmix :: GCompare k => k v -> Traversal' (DMap k f) (f v)+-- @+--+-- /NB:/ Setting the value of this+-- <https://hackage.haskell.org/package/lens-4.16.1/docs/Control-Lens-Type.html#t:Traversal Traversal>+-- will only set the value in 'dmix' if it is already present.+--+-- If you want to be able to insert /missing/ values, you want 'dmat'.+--+-- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] & dmix AInt %~ f+-- DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity (f 33), AFloat :=> Identity 3.5]+--+-- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] & dmix AString .~ "Hat"+-- DMap.fromList [AString :=> Identity "Hat", AInt :=> Identity 33, AFloat :=> Identity 3.5]+--+-- >>> DMap.fromList [AString :=> Identity "Shoe", AInt :=> Identity 33, AFloat :=> Identity 3.5] ^? dmix AFloat+-- Just (AFloat :=> 3.5)+--+-- >>> DMap.fromList [AString :=> Identity "Shoe", AFloat :=> Identity 3.5] ^? dmix AInt+-- Nothing+dmix :: (GCompare k, Applicative f) => k v -> (g v -> f (g v)) -> DMap k g -> f (DMap k g)+dmix k f dmap = maybe (pure dmap) (fmap (flip (insert k) dmap) . f) $ lookup k dmap+{-# INLINE dmix #-}
src/Data/Dependent/Map/PtrEquality.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-#endif {-# OPTIONS_HADDOCK hide #-} @@ -13,7 +10,7 @@ -- -- The Package Versioning Policy __does not apply__. ----- This contents of this module may change __in any way whatsoever__+-- The contents of this module may change __in any way whatsoever__ -- and __without any warning__ between minor versions of this package. -- -- Authors importing this module are expected to track development@@ -21,16 +18,10 @@ module Data.Dependent.Map.PtrEquality (ptrEq, hetPtrEq) where -#ifdef __GLASGOW_HASKELL__-import GHC.Exts ( reallyUnsafePtrEquality# )-import Unsafe.Coerce ( unsafeCoerce )-#if __GLASGOW_HASKELL__ < 707-import GHC.Exts ( (==#) )-#else-import GHC.Exts ( isTrue# )-#endif-#endif+import Unsafe.Coerce (unsafeCoerce)+import GHC.Exts (isTrue#, reallyUnsafePtrEquality#) + -- | Checks if two pointers are equal. Yes means yes; -- no means maybe. The values should be forced to at least -- WHNF before comparison to get moderately reliable results.@@ -42,20 +33,8 @@ -- reliable results. hetPtrEq :: a -> b -> Bool -#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ < 707-ptrEq x y = reallyUnsafePtrEquality# x y ==# 1#-hetPtrEq x y = unsafeCoerce reallyUnsafePtrEquality# x y ==# 1#-#else ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y) hetPtrEq x y = isTrue# (unsafeCoerce reallyUnsafePtrEquality# x y)-#endif--#else--- Not GHC-ptrEq _ _ = False-hetPtrEq _ _ = False-#endif {-# INLINE ptrEq #-} {-# INLINE hetPtrEq #-}
− src/Data/Dependent/Map/Typeable.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-module Data.Dependent.Map.Typeable where--import Data.Dependent.Map.Internal-import Data.Typeable--instance (Typeable1 k, Typeable1 f) => Typeable (DMap k f) where- typeOf ds = mkTyConApp dMapCon [typeOfK, typeOfF]- where- typeOfK = typeOf1 $ (undefined :: DMap k f -> k a) ds- typeOfF = typeOf1 $ (undefined :: DMap k f -> f a) ds- -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702- dMapCon = mkTyCon3 "dependent-map" "Data.Dependent.Map" "DMap"-#else- dMapCon = mkTyCon "Data.Dependent.Map.DMap"--#endif