typerep-map 0.2.0 → 0.3.0
raw patch · 7 files changed
+100/−28 lines, 7 filessetup-changed
Files
- CHANGELOG.md +12/−0
- README.md +3/−0
- Setup.hs +2/−0
- src/Data/TMap.hs +17/−4
- src/Data/TypeRepMap.hs +2/−0
- src/Data/TypeRepMap/Internal.hs +63/−23
- typerep-map.cabal +1/−1
CHANGELOG.md view
@@ -4,6 +4,18 @@ `typerep-map` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. +# 0.3.0++* [#46](https://github.com/kowainik/typerep-map/issues/46):+ Make `Show` instance for `TypeRepMap` show keys.+ Add `keys` function.+* [#48](https://github.com/kowainik/typerep-map/issues/48):+ Add `adjust` function for `TypeRepMap` and `TMap`.+* [#30](https://github.com/kowainik/typerep-map/issues/30):+ Rewrite `fromSortedList` to use `Array` and `MutableArray`+ instead of `IntMap`.++ # 0.2.0 * [#43](https://github.com/kowainik/typerep-map/issues/43):
README.md view
@@ -1,10 +1,13 @@ # typerep-map + [](https://hackage.haskell.org/package/typerep-map) [](https://travis-ci.org/kowainik/typerep-map) [](https://github.com/vrom911/typerep-map/blob/master/LICENSE) `typerep-map` introduces `TMap` and `TypeRepMap` — data structures like [`Map`](http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#t:Map), but where types serve as keys, and values have the types specified in the corresponding key spots.++For the more details on the implementation see [this blog post](https://kowainik.github.io/posts/2018-07-11-typerep-map-step-by-step.html). ## Usage example
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
src/Data/TMap.hs view
@@ -34,11 +34,13 @@ , unionWith , union , map+ , adjust -- * Query , lookup , member , size+ , keys ) where import Prelude hiding (lookup, map)@@ -46,6 +48,7 @@ import Data.Functor.Identity (Identity (..)) import Data.Typeable (Typeable) import GHC.Exts (coerce)+import Type.Reflection (SomeTypeRep) import qualified Data.TypeRepMap as F @@ -148,10 +151,20 @@ size = F.size {-# INLINE size #-} +-- | Returns the list of 'SomeTypeRep's from keys.+keys :: TMap -> [SomeTypeRep]+keys = F.keys+{-# INLINE keys #-}+ -- | Map a function over the values. map :: (forall a. Typeable a => a -> a) -> TMap -> TMap-map f = F.hoistWithKey (fIdentity f)- where- fIdentity :: forall a. Typeable a => (a -> a) -> Identity a -> Identity a- fIdentity = coerce+map f = F.hoistWithKey (liftToIdentity f) {-# INLINE map #-}++-- | Update a value with the result of the provided function.+adjust :: Typeable a => (a -> a) -> TMap -> TMap+adjust f = F.adjust (liftToIdentity f)+{-# INLINE adjust #-}++liftToIdentity :: forall a. Typeable a => (a -> a) -> Identity a -> Identity a+liftToIdentity = coerce
src/Data/TypeRepMap.hs view
@@ -51,6 +51,7 @@ -- * Modification , insert , delete+ , adjust , hoist , hoistA , hoistWithKey@@ -61,6 +62,7 @@ , lookup , member , size+ , keys -- * 'IsList' , WrapTypeable (..)
src/Data/TypeRepMap/Internal.hs view
@@ -23,13 +23,13 @@ import Prelude hiding (lookup) +import Control.Monad.ST (ST, runST) import Control.Monad.Zip (mzip) import Data.Function (on)-import Data.IntMap.Strict (IntMap) import Data.Kind (Type)-import Data.List (nubBy)-import Data.Maybe (fromJust)-import Data.Primitive.Array (Array, indexArray, mapArray')+import Data.List (intercalate, nubBy)+import Data.Primitive.Array (Array, MutableArray, indexArray, mapArray', readArray, sizeofArray,+ thawArray, unsafeFreezeArray, writeArray) import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray) import Data.Semigroup (Semigroup (..)) import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))@@ -37,11 +37,10 @@ import GHC.Fingerprint (Fingerprint (..)) import GHC.Prim (eqWord#, ltWord#) import GHC.Word (Word64 (..))-import Type.Reflection (TypeRep, Typeable, typeRep, withTypeable)+import Type.Reflection (SomeTypeRep (..), TypeRep, Typeable, typeRep, withTypeable) import Type.Reflection.Unsafe (typeRepFingerprint) import Unsafe.Coerce (unsafeCoerce) -import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as Map import qualified GHC.Exts as GHC (fromList, toList) @@ -70,14 +69,17 @@ TypeRepMap { fingerprintAs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ first components of key fingerprints , fingerprintBs :: {-# UNPACK #-} !(PrimArray Word64) -- ^ second components of key fingerprints- , anys :: {-# UNPACK #-} !(Array Any) -- ^ values stored in the map- , keys :: {-# UNPACK #-} !(Array Any) -- ^ typerep keys+ , trAnys :: {-# UNPACK #-} !(Array Any) -- ^ values stored in the map+ , trKeys :: {-# UNPACK #-} !(Array Any) -- ^ typerep keys } -- ^ an unsafe constructor for 'TypeRepMap' --- | Shows only 'Fingerprint's.+-- | Shows only keys. instance Show (TypeRepMap f) where- show = show . toFingerprints+ show TypeRepMap{..} = "TypeRepMap [" ++ showKeys ++ "]"+ where+ showKeys :: String+ showKeys = intercalate ", " $ toList $ mapArray' (show . anyToTypeRep) trKeys -- | Uses 'union' to combine 'TypeRepMap's. instance Semigroup (TypeRepMap f) where@@ -159,6 +161,28 @@ delete = fromTriples . deleteByFst (typeFp @a) . toTriples {-# INLINE delete #-} +{- |+Update a value at a specific key with the result of the provided function. When+the key is not a member of the map, the original map is returned.++>>> trmap = fromList @(TypeRepMap Identity) [WrapTypeable $ Identity "a"]+>>> lookup @String $ adjust (fmap (++ "ww")) trmap+Just (Identity "aww")+-}+adjust :: forall a f . Typeable a => (f a -> f a) -> TypeRepMap f -> TypeRepMap f+adjust fun tr = case cachedBinarySearch (typeFp @a) (fingerprintAs tr) (fingerprintBs tr) of+ Nothing -> tr+ Just i -> tr {trAnys = changeAnyArr i (trAnys tr)}+ where+ changeAnyArr :: Int -> Array Any -> Array Any+ changeAnyArr i trAs = runST $ do+ let n = sizeofArray trAs+ mutArr <- thawArray trAs 0 n+ a <- toAny . fun . fromAny <$> readArray mutArr i+ writeArray mutArr i a+ unsafeFreezeArray mutArr+{-# INLINE adjust #-}+ {- | Map over the elements of a 'TypeRepMap'. >>> tm = insert (Identity True) $ one (Identity 'a')@@ -237,7 +261,7 @@ Nothing -} lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)-lookup tVect = fromAny . (anys tVect `indexArray`)+lookup tVect = fromAny . (trAnys tVect `indexArray`) <$> cachedBinarySearch (typeFp @a) (fingerprintAs tVect) (fingerprintBs tVect)@@ -248,6 +272,11 @@ size = sizeofPrimArray . fingerprintAs {-# INLINE size #-} +-- | Return the list of 'SomeTypeRep' from the keys.+keys :: TypeRepMap f -> [SomeTypeRep]+keys TypeRepMap{..} = SomeTypeRep . anyToTypeRep <$> toList trKeys+{-# INLINE keys #-}+ -- | Binary searched based on this article -- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html -- with modification for our two-vector search case.@@ -281,12 +310,15 @@ fromAny :: Any -> f a fromAny = unsafeCoerce +anyToTypeRep :: Any -> TypeRep f+anyToTypeRep = unsafeCoerce+ typeFp :: forall a . Typeable a => Fingerprint typeFp = typeRepFingerprint $ typeRep @a {-# INLINE typeFp #-} toTriples :: TypeRepMap f -> [(Fingerprint, Any, Any)]-toTriples tm = zip3 (toFingerprints tm) (GHC.toList $ anys tm) (GHC.toList $ keys tm)+toTriples tm = zip3 (toFingerprints tm) (GHC.toList $ trAnys tm) (GHC.toList $ trKeys tm) deleteByFst :: Eq a => a -> [(a, b, c)] -> [(a, b, c)] deleteByFst x = filter ((/= x) . fst3)@@ -315,8 +347,8 @@ Creates 'TypeRepMap' from a list of 'WrapTypeable's. ->>> size $ fromList [WrapTypeable $ Identity True, WrapTypeable $ Identity 'a']-2+>>> show $ fromList [WrapTypeable $ Identity True, WrapTypeable $ Identity 'a']+TypeRepMap [Bool, Char] -}@@ -355,14 +387,22 @@ ---------------------------------------------------------------------------- fromSortedList :: forall a . [a] -> [a]-fromSortedList l = IM.elems $ fst $ go 0 0 mempty (IM.fromList $ zip [0..] l)+fromSortedList l = runST $ do+ let n = length l+ let arrOrigin = fromListN n l+ arrResult <- thawArray arrOrigin 0 n+ go n arrResult arrOrigin+ toList <$> unsafeFreezeArray arrResult where -- state monad could be used here, but it's another dependency- go :: Int -> Int -> IntMap a -> IntMap a -> (IntMap a, Int)- go i first result vector =- if i >= IM.size vector- then (result, first)- else do- let (newResult, newFirst) = go (2 * i + 1) first result vector- let withCur = IM.insert i (fromJust $ IM.lookup newFirst vector) newResult- go (2 * i + 2) (newFirst + 1) withCur vector+ go :: forall s . Int -> MutableArray s a -> Array a -> ST s ()+ go len result origin = () <$ loop 0 0+ where+ loop :: Int -> Int -> ST s Int+ loop i first =+ if i >= len+ then pure first+ else do+ newFirst <- loop (2 * i + 1) first+ writeArray result i (indexArray origin newFirst)+ loop (2 * i + 2) (newFirst + 1)
typerep-map.cabal view
@@ -1,5 +1,5 @@ name: typerep-map-version: 0.2.0+version: 0.3.0 synopsis: Efficient implementation of a dependent map with types as keys description: A dependent map from type representations to values of these types.