packages feed

union-map 0.0 → 0.1

raw patch · 8 files changed

+147/−249 lines, 8 filesdep +extensibledep ~basedep ~containers

Dependencies added: extensible

Dependency ranges changed: base, containers

Files

− src/Data/OpenUnion.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverlappingInstances  #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}--module Data.OpenUnion (-  -- * UnionType-    Union-  -- * Utility Functions-  , exhaust-  , (||>)-  , picked-  , liftU-  , retractU-  , hoistU-  -- * Constraints-  , Member-  , Include(..)-  , type (∈)-  , type (⊆)-  , type (＝)-  ) where-import Data.OpenUnion.Internal
− src/Data/OpenUnion/Internal.hs 
@@ -1,112 +0,0 @@-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE OverlappingInstances   #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}--module Data.OpenUnion.Internal where-import           Control.Applicative-import           Data.Monoid         hiding (All)-import           GHC.Exts            (Constraint)--data Union (as :: [*]) where-  Single    :: a -> Union (a ': as)-  Union     :: Union as -> Union (a ': as)-  Exhausted :: Union '[] -> Union '[]--exhaust :: Union '[] -> a-exhaust (Exhausted x) = exhaust x-{-# INLINE exhaust #-}--type family All (ca :: * -> Constraint) (as :: [*]) :: Constraint-type instance All ca '[] = ()-type instance All ca (a ': as) = (ca a, All ca as)--instance (All Show r) => Show (Union r) where-  show (Single x) = show x-  show (Union u)  = show u-  show _ = undefined--(||>) :: (a -> r) -> (Union as -> r) -> (Union (a ': as) -> r)-(||>) f _ (Single x) = f x-(||>) _ g (Union u) = g u-infixr 2 ||>-{-# INLINE (||>) #-}--data Position (a :: *) (as :: [*]) where-  Zero :: Position a (a ': as)-  Succ :: Position a as -> Position a (b ': as)--class Member a as | as -> a where-  position :: Position a as--instance Member a (a ': as) where-  position = Zero--instance Member a as => Member a (b ': as) where-  position = Succ position---- | Lift a value into a Union.-liftU :: forall a as. Member a as => a -> Union as-liftU x = go (position :: Position a as)-  where-    go :: Position a bs -> Union bs-    go Zero     = Single x-    go (Succ n) = Union $ go n-{-# INLINE liftU #-}---- | Traversal for a specific element.-picked :: forall a as f. (Applicative f, Member a as) => (a -> f a) -> Union as -> f (Union as)-picked k = go (position :: Position a as)-  where-    go :: Position a bs -> Union bs -> f (Union bs)-    go Zero (Single x)       = Single <$> k x-    go Zero u@(Union _)      = pure u-    go (Succ _) u@(Single _) = pure u-    go (Succ n) (Union u)    = Union <$> go n u-{-# INLINE picked #-}---- | Retrieve the value from a Union.-retractU :: Member a as => Union as -> Maybe a-retractU = getFirst . getConst . picked (Const . First . Just)-{-# INLINE retractU #-}---- | Lift a function into @Union@.-hoistU :: Member a as => (a -> a) -> Union as -> Union as-hoistU f = getId . picked (Id . f)-{-# INLINE hoistU #-}---- | Instead of Identity.-newtype Id a = Id { getId :: a }--instance Functor Id where-  fmap f (Id a) = Id (f a)--instance Applicative Id where-  pure = Id-  Id f <*> Id a = Id (f a)--class Include as bs where-  reunion :: Union as -> Union bs--instance (Member a bs, Include as bs) => Include (a ': as) bs where-  reunion (Single x) = liftU x-  reunion (Union u)  = reunion u--instance (Include '[] bs) where-  reunion = exhaust--type a ∈ as  = Member a as-type as ⊆ bs = Include as bs-type as ＝ bs = (Include as bs, Include bs as)--infix 4 ∈-infix 4 ⊆-infix 4 ＝
src/Data/UnionIntMap.hs view
@@ -1,19 +1,27 @@+----------------------------------------------------------- -- |+-- Module      : Data.UnionIntMap+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+-- -- An implementation of heterogeneous tree-map by open unions. -- This module uses the @Data.IntMap@ inside, -- see also <https://hackage.haskell.org/package/containers>. --+-----------------------------------------------------------+ module Data.UnionIntMap (-  -- * Map type+  -- * Types     UnionIntMap-+  , Key   -- * Operators   , (\\), (!)-   -- * Construction   , empty   , singleton-   -- * Query   , null   , size@@ -35,7 +43,6 @@   , adjustWithKey   , update   , updateWithKey-   -- * Set Operation   , union   , unions
src/Data/UnionIntMap/Internal.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeOperators              #-} module Data.UnionIntMap.Internal where  import           Control.Applicative hiding (empty)@@ -11,11 +11,15 @@ import qualified Data.List           as L import           Data.Maybe import           Data.Monoid-import           Data.OpenUnion+import           Data.Extensible.Inclusion (Include, spread)+import           Data.Extensible.Plain (K0(..))+import           Data.Extensible.Internal  (Member)+import           Data.Extensible.Sum+import           Internal import           Prelude             hiding (lookup) -newtype UnionIntMap r = UnionIntMap (IntMap (Union r))-  deriving (Monoid, Show)+newtype UnionIntMap r = UnionIntMap (IntMap (K0 :| r))+  deriving (Monoid)  type Key = Int @@ -39,57 +43,57 @@ notMember k = not . member k {-# INLINE notMember #-} -singleton :: Member a as => Key -> a -> UnionIntMap as+singleton :: Member as a => Key -> a -> UnionIntMap as singleton k x = insert k x empty {-# INLINE singleton #-} -liftUM :: (IntMap (Union r) -> IntMap (Union s)) -> UnionIntMap r -> UnionIntMap s+liftUM :: (IntMap (K0 :| r) -> IntMap (K0 :| s)) -> UnionIntMap r -> UnionIntMap s liftUM f (UnionIntMap m) = UnionIntMap $ f m {-# INLINE liftUM #-} -liftUM2 :: (IntMap (Union r) -> IntMap (Union s) -> IntMap (Union t)) -> UnionIntMap r -> UnionIntMap s -> UnionIntMap t+liftUM2 :: (IntMap (K0 :| r) -> IntMap (K0 :| s) -> IntMap (K0 :| t)) -> UnionIntMap r -> UnionIntMap s -> UnionIntMap t liftUM2 f (UnionIntMap m1) (UnionIntMap m2) = UnionIntMap $ f m1 m2 {-# INLINE liftUM2 #-} -lookup :: Member a as => Key -> UnionIntMap as -> Maybe a-lookup k (UnionIntMap m) = IM.lookup k m >>= retractU+lookup :: Member as a => Key -> UnionIntMap as -> Maybe a+lookup k (UnionIntMap m) = IM.lookup k m >>= retract {-# INLINE lookup #-} -lookupU :: Key -> UnionIntMap r -> Maybe (Union r)+lookupU :: Key -> UnionIntMap r -> Maybe (K0 :| r) lookupU k (UnionIntMap m) = IM.lookup k m {-# INLINE lookupU #-} -find :: Member a as => Key -> UnionIntMap as -> a+find :: Member as a => Key -> UnionIntMap as -> a find k um = flip fromMaybe (lookup k um)   $ error "UnionIntMap.find: given key is not an element in the map, or is not associated a value of the type expected." {-# INLINE find #-} -findU :: Key -> UnionIntMap r -> Union r+findU :: Key -> UnionIntMap r -> K0 :| r findU k um = flip fromMaybe (lookupU k um)   $ error "UnionIntMap.findU: given key is not an element in the map, or is not associated a value of the type expected." {-# INLINE findU #-} -findWithDefault :: Member a as => a -> Key -> UnionIntMap as -> a+findWithDefault :: Member as a => a -> Key -> UnionIntMap as -> a findWithDefault def k um = fromMaybe def $ lookup k um {-# INLINE findWithDefault #-} -(!) :: Member a as => UnionIntMap as -> Key -> a+(!) :: Member as a => UnionIntMap as -> Key -> a um ! k = flip fromMaybe (lookup k um)   $ error "UnionIntMap.!: given key is not an element in the map, or is not associated a value of the type expected." {-# INLINE (!) #-} -insert :: Member a as => Key -> a -> UnionIntMap as -> UnionIntMap as-insert k x = liftUM (IM.insert k (liftU x))+insert :: Member as a => Key -> a -> UnionIntMap as -> UnionIntMap as+insert k x = liftUM (IM.insert k (embed (K0 x))) {-# INLINE insert #-} -insertWith :: Member a as => (a -> a -> a) -> Key -> a -> UnionIntMap as -> UnionIntMap as+insertWith :: Member as a => (a -> a -> a) -> Key -> a -> UnionIntMap as -> UnionIntMap as insertWith f = insertWithKey (\_ y z -> f y z) {-# INLINE insertWith #-} -insertWithKey :: Member a as => (Key -> a -> a -> a) -> Key -> a -> UnionIntMap as -> UnionIntMap as-insertWithKey f k x = liftUM (IM.insertWithKey go k (liftU x))+insertWithKey :: Member as a => (Key -> a -> a -> a) -> Key -> a -> UnionIntMap as -> UnionIntMap as+insertWithKey f k x = liftUM (IM.insertWithKey go k (embed (K0 x)))   where-    go k' _ s = maybe (liftU x) liftU $ f <$> pure k' <*> return x <*> retractU s+    go k' _ s = maybe (embed (K0 x)) (embed . K0) $ f <$> pure k' <*> return x <*> retract s     {-# INLINE go #-} {-# INLINE insertWithKey #-} @@ -97,20 +101,20 @@ delete = liftUM . IM.delete {-# INLINE delete #-} -adjust :: Member a as => (a -> a) -> Key -> UnionIntMap as -> UnionIntMap as+adjust :: Member as a => (a -> a) -> Key -> UnionIntMap as -> UnionIntMap as adjust f = adjustWithKey (\_ x -> f x) {-# INLINE adjust #-} -adjustWithKey :: Member a as => (Key -> a -> a) -> Key -> UnionIntMap as -> UnionIntMap as-adjustWithKey f k = liftUM (IM.adjust (hoistU (f k)) k)+adjustWithKey :: Member as a => (Key -> a -> a) -> Key -> UnionIntMap as -> UnionIntMap as+adjustWithKey f k = liftUM (IM.adjust (modify (f k)) k) {-# INLINE adjustWithKey #-} -update :: Member a as => (a -> Maybe a) -> Key -> UnionIntMap as -> UnionIntMap as+update :: Member as a => (a -> Maybe a) -> Key -> UnionIntMap as -> UnionIntMap as update f = updateWithKey (\_ x -> f x) {-# INLINE update #-} -updateWithKey :: Member a as => (Key -> a -> Maybe a) -> Key -> UnionIntMap as -> UnionIntMap as-updateWithKey f k = liftUM (IM.update (retractU >=> f k >=> return . liftU) k)+updateWithKey :: Member as a => (Key -> a -> Maybe a) -> Key -> UnionIntMap as -> UnionIntMap as+updateWithKey f k = liftUM (IM.update (retract >=> f k >=> return . embed . K0) k) {-# INLINE updateWithKey #-}  union :: UnionIntMap r -> UnionIntMap r -> UnionIntMap r@@ -137,58 +141,58 @@ keys (UnionIntMap m)  = IM.keys m {-# INLINE keys #-} -map :: Member a as => (a -> a) -> UnionIntMap as -> UnionIntMap as+map :: Member as a => (a -> a) -> UnionIntMap as -> UnionIntMap as map f = mapWithKey (\_ x -> f x) {-# INLINE map #-} -mapWithKey :: Member a as => (Key -> a -> a) -> UnionIntMap as -> UnionIntMap as-mapWithKey f = liftUM (IM.mapWithKey (hoistU . f))+mapWithKey :: Member as a => (Key -> a -> a) -> UnionIntMap as -> UnionIntMap as+mapWithKey f = liftUM (IM.mapWithKey (modify . f)) {-# INLINE mapWithKey #-} -mapU :: (Union r -> Union s) -> UnionIntMap r -> UnionIntMap s+mapU :: (K0 :| r -> K0 :| s) -> UnionIntMap r -> UnionIntMap s mapU f = mapWithKeyU (\_ u -> f u) {-# INLINE mapU #-} -mapWithKeyU :: (Key -> Union r -> Union s) -> UnionIntMap r -> UnionIntMap s+mapWithKeyU :: (Key -> K0 :| r -> K0 :| s) -> UnionIntMap r -> UnionIntMap s mapWithKeyU = liftUM . IM.mapWithKey {-# INLINE mapWithKeyU #-} -mapU' :: (Union r -> a) -> UnionIntMap r -> IntMap a+mapU' :: (K0 :| r -> a) -> UnionIntMap r -> IntMap a mapU' f = mapWithKeyU' (\_ u -> f u) {-# INLINE mapU' #-} -mapWithKeyU' :: (Key -> Union r -> a) -> UnionIntMap r -> IntMap a+mapWithKeyU' :: (Key -> K0 :| r -> a) -> UnionIntMap r -> IntMap a mapWithKeyU' f (UnionIntMap m) = IM.mapWithKey f m {-# INLINE mapWithKeyU' #-} -rebuild :: Include r s => UnionIntMap r -> UnionIntMap s-rebuild = mapU reunion+rebuild :: Include s r => UnionIntMap r -> UnionIntMap s+rebuild = mapU spread {-# INLINE rebuild #-} -filterU :: (Union r -> Bool) -> UnionIntMap r -> UnionIntMap r+filterU :: (K0 :| r -> Bool) -> UnionIntMap r -> UnionIntMap r filterU p = filterWithKeyU (\_ u -> p u) {-# INLINE filterU #-} -filterWithKeyU :: (Key -> Union r -> Bool) -> UnionIntMap r -> UnionIntMap r+filterWithKeyU :: (Key -> K0 :| r -> Bool) -> UnionIntMap r -> UnionIntMap r filterWithKeyU = liftUM . IM.filterWithKey {-# INLINE filterWithKeyU #-} -foldrU :: (Union r -> b -> b) -> b -> UnionIntMap r -> b+foldrU :: (K0 :| r -> b -> b) -> b -> UnionIntMap r -> b foldrU f = foldrWithKeyU (\_ u z -> f u z) {-# INLINE foldrU #-} -foldrWithKeyU :: (Key -> Union r -> b -> b) -> b -> UnionIntMap r -> b+foldrWithKeyU :: (Key -> K0 :| r -> b -> b) -> b -> UnionIntMap r -> b foldrWithKeyU f z (UnionIntMap m) = IM.foldrWithKey f z m {-# INLINE foldrWithKeyU #-} -foldlU' :: (a -> Union r -> a) -> a -> UnionIntMap r -> a+foldlU' :: (a -> K0 :| r -> a) -> a -> UnionIntMap r -> a foldlU' f = foldlWithKeyU' (\z _ u -> f z u) {-# INLINE foldlU' #-} -foldlWithKeyU' :: (a -> Key -> Union r -> a) -> a -> UnionIntMap r -> a+foldlWithKeyU' :: (a -> Key -> K0 :| r -> a) -> a -> UnionIntMap r -> a foldlWithKeyU' f z (UnionIntMap m) = IM.foldlWithKey' f z m {-# INLINE foldlWithKeyU' #-} -showTree :: Show (Union r) => UnionIntMap r -> String+showTree :: Show (K0 :| r) => UnionIntMap r -> String showTree (UnionIntMap m) = IM.showTree m {-# INLINE showTree #-}
src/Data/UnionMap.hs view
@@ -1,19 +1,26 @@+------------------------------------------------------------- -- |+-- Module      : Data.UnionMap+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+-- -- An implementation of heterogeneous tree-map by open unions. -- This module uses the @Data.Map@ module inside, -- see also <https://hackage.haskell.org/package/containers>. --+-----------------------------------------------------------+ module Data.UnionMap (-  -- * Map type+  -- * Types     UnionMap-   -- * Operators   , (\\), (!)-   -- * Construction   , empty   , singleton-   -- * Query   , null   , size@@ -24,7 +31,6 @@   , find   , findU   , findWithDefault-   -- ** Insertion   , insert   , insertWith@@ -35,7 +41,6 @@   , adjustWithKey   , update   , updateWithKey-   -- * Set Operation   , union   , unions@@ -44,7 +49,6 @@   -- * Conversion   , keys   , rebuild-   -- * Map   , mapU   , mapWithKeyU
src/Data/UnionMap/Internal.hs view
@@ -1,22 +1,27 @@ {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TypeOperators              #-} module Data.UnionMap.Internal where -import           Control.Applicative hiding (empty)+import           Control.Applicative       hiding (empty) import           Control.Monad-import qualified Data.List           as L-import           Data.Map            (Map)-import qualified Data.Map            as M+import           Data.Extensible.Inclusion (Include, spread)+import           Data.Extensible.Plain (K0(..))+import           Data.Extensible.Internal  (Member)+import           Data.Extensible.Sum+import qualified Data.List                 as L+import           Data.Map                  (Map)+import qualified Data.Map                  as M import           Data.Maybe import           Data.Monoid-import           Data.OpenUnion-import           Prelude             hiding (lookup)+import           Internal -newtype UnionMap k r = UnionMap (Map k (Union r))-  deriving (Monoid, Show)+import           Prelude                   hiding (lookup) +newtype UnionMap k r = UnionMap (Map k (K0 :| r))+  deriving (Monoid)+ null :: UnionMap k r -> Bool null (UnionMap m) = M.null m {-# INLINE null #-}@@ -37,57 +42,57 @@ notMember k = not . member k {-# INLINE notMember #-} -singleton :: (Ord k, Member a as) => k -> a -> UnionMap k as+singleton :: (Ord k, Member as a) => k -> a -> UnionMap k as singleton k x = insert k x empty {-# INLINE singleton #-} -liftUM :: (Map k (Union r) -> Map k (Union s)) -> UnionMap k r -> UnionMap k s+liftUM :: (Map k (K0 :| r) -> Map k (K0 :| s)) -> UnionMap k r -> UnionMap k s liftUM f (UnionMap m) = UnionMap $ f m {-# INLINE liftUM #-} -liftUM2 :: (Map k (Union r) -> Map k (Union s) -> Map k (Union t)) -> UnionMap k r -> UnionMap k s -> UnionMap k t+liftUM2 :: (Map k (K0 :| r) -> Map k (K0 :| s) -> Map k (K0 :| t)) -> UnionMap k r -> UnionMap k s -> UnionMap k t liftUM2 f (UnionMap m1) (UnionMap m2) = UnionMap $ f m1 m2 {-# INLINE liftUM2 #-} -lookup :: (Ord k, Member a as) => k -> UnionMap k as -> Maybe a-lookup k (UnionMap m) = M.lookup k m >>= retractU+lookup :: (Ord k, Member as a) => k -> UnionMap k as -> Maybe a+lookup k (UnionMap m) = M.lookup k m >>= retract {-# INLINE lookup #-} -lookupU :: Ord k => k -> UnionMap k r -> Maybe (Union r)+lookupU :: Ord k => k -> UnionMap k r -> Maybe (K0 :| r) lookupU k (UnionMap m) = M.lookup k m {-# INLINE lookupU #-} -find :: (Ord k, Member a as) => k -> UnionMap k as -> a+find :: (Ord k, Member as a) => k -> UnionMap k as -> a find k um = flip fromMaybe (lookup k um)   $ error "UnionMap.find: given key is not an element in the map, or is not associated a value of the type expected." {-# INLINE find #-} -findU :: Ord k => k -> UnionMap k r -> Union r+findU :: Ord k => k -> UnionMap k r -> K0 :| r findU k um = flip fromMaybe (lookupU k um)   $ error "UnionMap.findU: given key is not an element in the map, or is not associated a value of the type expected." {-# INLINE findU #-} -findWithDefault :: (Ord k, Member a as) => a -> k -> UnionMap k as -> a+findWithDefault :: (Ord k, Member as a) => a -> k -> UnionMap k as -> a findWithDefault def k um = fromMaybe def $ lookup k um {-# INLINE findWithDefault #-} -(!) :: (Ord k, Member a as) => UnionMap k as -> k -> a+(!) :: (Ord k, Member as a) => UnionMap k as -> k -> a um ! k = flip fromMaybe (lookup k um)   $ error "UnionMap.!: given key is not an element in the map, or is not associated a value of the type expected." {-# INLINE (!) #-} -insert :: (Ord k, Member a as) => k -> a -> UnionMap k as -> UnionMap k as-insert k x = liftUM (M.insert k (liftU x))+insert :: (Ord k, Member as a) => k -> a -> UnionMap k as -> UnionMap k as+insert k x = liftUM (M.insert k (embed (K0 x))) {-# INLINE insert #-} -insertWith :: (Ord k, Member a as) => (a -> a -> a) -> k -> a -> UnionMap k as -> UnionMap k as+insertWith :: (Ord k, Member as a) => (a -> a -> a) -> k -> a -> UnionMap k as -> UnionMap k as insertWith f = insertWithKey (\_ y z -> f y z) {-# INLINE insertWith #-} -insertWithKey :: (Ord k, Member a as) => (k -> a -> a -> a) -> k -> a -> UnionMap k as -> UnionMap k as-insertWithKey f k x = liftUM (M.insertWithKey go k (liftU x))+insertWithKey :: (Ord k, Member as a) => (k -> a -> a -> a) -> k -> a -> UnionMap k as -> UnionMap k as+insertWithKey f k x = liftUM (M.insertWithKey go k (embed (K0 x)))   where-    go k' _ s = maybe (liftU x) liftU $ f <$> pure k' <*> return x <*> retractU s+    go k' _ s = maybe (embed (K0 x)) (embed . K0) $ f <$> pure k' <*> return x <*> retract s     {-# INLINE go #-} {-# INLINE insertWithKey #-} @@ -95,20 +100,20 @@ delete = liftUM . M.delete {-# INLINE delete #-} -adjust :: (Ord k, Member a as) => (a -> a) -> k -> UnionMap k as -> UnionMap k as+adjust :: (Ord k, Member as a) => (a -> a) -> k -> UnionMap k as -> UnionMap k as adjust f = adjustWithKey (\_ x -> f x) {-# INLINE adjust #-} -adjustWithKey :: (Ord k, Member a as) => (k -> a -> a) -> k -> UnionMap k as -> UnionMap k as-adjustWithKey f k = liftUM (M.adjust (hoistU (f k)) k)+adjustWithKey :: (Ord k, Member as a) => (k -> a -> a) -> k -> UnionMap k as -> UnionMap k as+adjustWithKey f k = liftUM (M.adjust (modify (f k)) k) {-# INLINE adjustWithKey #-} -update :: (Ord k, Member a as) => (a -> Maybe a) -> k -> UnionMap k as -> UnionMap k as+update :: (Ord k, Member as a) => (a -> Maybe a) -> k -> UnionMap k as -> UnionMap k as update f = updateWithKey (\_ x -> f x) {-# INLINE update #-} -updateWithKey :: (Ord k, Member a as) => (k -> a -> Maybe a) -> k -> UnionMap k as -> UnionMap k as-updateWithKey f k = liftUM (M.update (retractU >=> f k >=> return . liftU) k)+updateWithKey :: (Ord k, Member as a) => (k -> a -> Maybe a) -> k -> UnionMap k as -> UnionMap k as+updateWithKey f k = liftUM (M.update (retract >=> f k >=> return . embed . K0) k) {-# INLINE updateWithKey #-}  union :: Ord k => UnionMap k r -> UnionMap k r -> UnionMap k r@@ -135,58 +140,58 @@ keys (UnionMap m)  = M.keys m {-# INLINE keys #-} -map :: Member a as => (a -> a) -> UnionMap k as -> UnionMap k as+map :: Member as a => (a -> a) -> UnionMap k as -> UnionMap k as map f = mapWithKey (\_ x -> f x) {-# INLINE map #-} -mapWithKey :: Member a as => (k -> a -> a) -> UnionMap k as -> UnionMap k as-mapWithKey f = liftUM (M.mapWithKey (hoistU . f))+mapWithKey :: Member as a => (k -> a -> a) -> UnionMap k as -> UnionMap k as+mapWithKey f = liftUM (M.mapWithKey (modify . f)) {-# INLINE mapWithKey #-} -mapU :: (Union r -> Union s) -> UnionMap k r -> UnionMap k s+mapU :: (K0 :| r -> K0 :| s) -> UnionMap k r -> UnionMap k s mapU f = mapWithKeyU (\_ u -> f u) {-# INLINE mapU #-} -mapWithKeyU :: (k -> Union r -> Union s) -> UnionMap k r -> UnionMap k s+mapWithKeyU :: (k -> K0 :| r -> K0 :| s) -> UnionMap k r -> UnionMap k s mapWithKeyU = liftUM . M.mapWithKey {-# INLINE mapWithKeyU #-} -mapU' :: (Union r -> a) -> UnionMap k r -> Map k a+mapU' :: (K0 :| r -> a) -> UnionMap k r -> Map k a mapU' f = mapWithKeyU' (\_ u -> f u) {-# INLINE mapU' #-} -mapWithKeyU' :: (k -> Union r -> a) -> UnionMap k r -> Map k a+mapWithKeyU' :: (k -> K0 :| r -> a) -> UnionMap k r -> Map k a mapWithKeyU' f (UnionMap m) = M.mapWithKey f m {-# INLINE mapWithKeyU' #-} -rebuild :: Include r s => UnionMap k r -> UnionMap k s-rebuild = mapU reunion+rebuild :: Include s r => UnionMap k r -> UnionMap k s+rebuild = mapU spread {-# INLINE rebuild #-} -filterU :: (Union r -> Bool) -> UnionMap k r -> UnionMap k r+filterU :: (K0 :| r -> Bool) -> UnionMap k r -> UnionMap k r filterU p = filterWithKeyU (\_ u -> p u) {-# INLINE filterU #-} -filterWithKeyU :: (k -> Union r -> Bool) -> UnionMap k r -> UnionMap k r+filterWithKeyU :: (k -> K0 :| r -> Bool) -> UnionMap k r -> UnionMap k r filterWithKeyU = liftUM . M.filterWithKey {-# INLINE filterWithKeyU #-} -foldrU :: (Union r -> b -> b) -> b -> UnionMap k r -> b+foldrU :: (K0 :| r -> b -> b) -> b -> UnionMap k r -> b foldrU f = foldrWithKeyU (\_ u z -> f u z) {-# INLINE foldrU #-} -foldrWithKeyU :: (k -> Union r -> b -> b) -> b -> UnionMap k r -> b+foldrWithKeyU :: (k -> K0 :| r -> b -> b) -> b -> UnionMap k r -> b foldrWithKeyU f z (UnionMap m) = M.foldrWithKey f z m {-# INLINE foldrWithKeyU #-} -foldlU' :: (a -> Union r -> a) -> a -> UnionMap k r -> a+foldlU' :: (a -> K0 :| r -> a) -> a -> UnionMap k r -> a foldlU' f = foldlWithKeyU' (\z _ u -> f z u) {-# INLINE foldlU' #-} -foldlWithKeyU' :: (a -> k -> Union r -> a) -> a -> UnionMap k r -> a+foldlWithKeyU' :: (a -> k -> K0 :| r -> a) -> a -> UnionMap k r -> a foldlWithKeyU' f z (UnionMap m) = M.foldlWithKey' f z m {-# INLINE foldlWithKeyU' #-} -showTree :: (Show k, Show (Union r)) => UnionMap k r -> String+showTree :: (Show k, Show (K0 :| r)) => UnionMap k r -> String showTree (UnionMap m) = M.showTree m {-# INLINE showTree #-}
+ src/Internal.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TypeOperators          #-}++module Internal where+import           Control.Applicative+import           Data.Extensible.Internal (Member)+import           Data.Extensible.Plain    (K0 (..))+import           Data.Extensible.Sum+import           Data.Monoid++retract :: Member as a => K0 :| as -> Maybe a+retract = fmap getK0 . getFirst . getConst . picked (Const . First . Just)+{-# INLINE retract #-}++modify :: Member as a => (a -> a) -> K0 :| as -> K0 :| as+modify f = getK0 . picked (K0 . fmap f)+{-# INLINE modify #-}
union-map.cabal view
@@ -1,5 +1,5 @@ name:                union-map-version:             0.0+version:             0.1 synopsis:            Heterogeneous map by open unions. description:         Heterogeneous map implementation, not requires IO and Typeable likes license:             BSD3@@ -12,11 +12,14 @@ homepage:            http://github.com/minpou/union-map  library-  exposed-modules:     Data.UnionMap, Data.UnionIntMap-                     , Data.OpenUnion , Data.OpenUnion.Internal-  other-modules:       Data.UnionMap.Internal, Data.UnionIntMap.Internal-  build-depends:       base >= 4.6 && < 5-                     , containers >= 0.4.2+  exposed-modules:     Data.UnionMap +                     , Data.UnionIntMap+  other-modules:       Data.UnionMap.Internal +                     , Data.UnionIntMap.Internal+                     , Internal+  build-depends:       base >=4.7 && <5+                     , containers >=0.4.2 && <0.6+                     , extensible >=0.2.1 && <0.4   hs-source-dirs:      src-  ghc-options:         -Wall+  ghc-options:         -Wall -O2   default-language:    Haskell2010