hblock (empty) → 0.1.0.0
raw patch · 8 files changed
+1482/−0 lines, 8 filesdep +aesondep +basedep +blaze-markupsetup-changed
Dependencies added: aeson, base, blaze-markup, bytestring, cereal, containers, deepseq, hashable, path-pieces, safecopy, text, unordered-containers, uuid, vector
Files
- Data/HBlock.hs +163/−0
- Data/Indexation/Constraints.hs +134/−0
- Data/Indexation/NormalIx.hs +561/−0
- Data/Indexation/SimpleIx.hs +421/−0
- Data/Indexation/UUID.hs +125/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hblock.cabal +46/−0
+ Data/HBlock.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE BangPatterns #-}+module Data.HBlock where+import Prelude hiding (foldr, foldl)+import Data.Foldable (Foldable(..))+import Control.Monad.ST+import Data.Vector (Vector)+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import Data.SafeCopy+import GHC.Exts (build)+import qualified Data.List as L+-- import Data.Indexation.IxData (IxData(IxData, ixDataPos, ixData))++data HBlock a = HBlock { set :: !IntSet+ , values :: (Vector a)+ , size :: !Int+ , numItems :: !Int+ , blockLen :: !Int+ , emptyVal :: !a+ } ++instance Functor HBlock where+ fmap f (HBlock s v len num blen e) = + if num == 0 + then emptyhb+ else IS.foldl transf emptyhb s+ where + emptyhb = empty len blen (f e)+ transf hb pos = insert (f $ V.unsafeIndex v pos) hb++instance Foldable HBlock where+ foldr f z (HBlock s v _ num _ _) =+ if num == 0 then z else IS.foldr' foldit z s+ where + foldit pos item = f (V.unsafeIndex v pos) item+ foldl f z (HBlock s v _ num _ _) = + if num == 0 then z else IS.foldl foldit z s+ where + foldit item pos = f item (V.unsafeIndex v pos) ++instance (SafeCopy a) => SafeCopy (HBlock a) where+ version = 0+ kind = base+ putCopy h@(HBlock _ _ _ n bl e) = contain $ do safePut n+ safePut bl+ safePut e+ safePut (toList h)+ return ()+ getCopy = contain $ do n <- safeGet + bl <- safeGet+ e <- safeGet + lst <- safeGet + return $ fromList n bl e lst++-- | Creates a new HBlock +-- receives the initial size, the ammount of items that the vector gets +-- incremented when it is almost full, and an empty item to place on the growth+-- vector+empty :: Int -> Int -> a -> HBlock a+empty initSize blockSize e = + HBlock { set = IS.empty+ , values = V.replicate initSize e+ , size = initSize+ , numItems = 0+ , blockLen = blockSize+ , emptyVal = e+ }+{-# INLINABLE empty #-}++length :: HBlock a -> Int+length b = numItems b+{-# INLINE length#-}++-- | similar to insert but returns the index where the item was placed+insertGetIx :: a -> HBlock a -> (Int, HBlock a)+insertGetIx item b = + (pos, b { set = IS.insert pos (set b)+ , values = newvec+ , size = if growthNeeded then blockLen b else (size b) - 1+ , numItems = numItems b + 1+ })+ where+ pos = if IS.null (set b) then 0 else IS.findMax (set b) + 1+ oldvec = values b+ growthNeeded = size b == 0+ growthSize = blockLen b+ newvec = runST $ + do v <- V.unsafeThaw oldvec+ -- grow the vector by the extendAmmount+ let extendIxs = [pos..(pos+growthSize)]+ v' <- if growthNeeded+ then do newv <- VM.unsafeGrow v growthSize+ (mapM_ (\i -> VM.write newv i (emptyVal b)) extendIxs)+ return newv+ else return v+ VM.write v' pos item+ V.unsafeFreeze v'+{-# INLINABLE insertGetIx #-}++insert :: a -> HBlock a -> HBlock a+insert i b = snd $ insertGetIx i b+{-# INLINE insert #-}++adjust :: (a -> a) -> Int -> HBlock a -> HBlock a+adjust f pos b = b { values = adjusted }+ where+ oldvec = values b+ adjusted = runST $ + do v <- V.unsafeThaw oldvec+ val <- VM.read v pos+ VM.write v pos (f val)+ V.unsafeFreeze v+{-# INLINABLE adjust #-}++update :: a -> Int -> HBlock a -> HBlock a+update new pos b = b { values = adjusted }+ where+ oldvec = values b+ adjusted = runST $ + do v <- V.unsafeThaw oldvec+ VM.write v pos new+ V.unsafeFreeze v+{-# INLINABLE update #-}++occupied :: Int -> HBlock a -> Bool+occupied pos b = IS.member pos (set b)+{-# INLINE occupied #-}++getPos :: HBlock a -> Int -> Maybe a+getPos hb pos = if occupied pos hb then Just $ V.unsafeIndex (values hb) pos+ else Nothing+{-# INLINABLE getPos #-}++getSet :: HBlock a -> IntSet -> HBlock a+getSet hb s = hb { set = newSet+ , numItems = IS.size newSet+ }+ where+ newSet = IS.intersection s (set hb)+ -- ^TODO map and copy the whole vector into the new hb ?+ -- test growing the vector and then using the returned HB from this function++delete :: Int -> HBlock a -> HBlock a+delete pos b = b { set = IS.delete pos (set b) + , numItems = if occupied pos b then numItems b - 1 + else numItems b+ }+{-# INLINABLE delete #-}++-- | /O(n)/ Return a list of this hblock's elements. The list is+-- produced lazily.+-- toList :: HashMap k v -> [(k, v)]+-- toList t = build (\ c z -> foldrWithKey (curry c) z t)+toList :: HBlock a -> [a]+toList hb = build (\c z -> foldr c z hb)+{-# INLINE toList #-}++-- | /O(n)/ Construct a hblock with the values from a list.+fromList :: Int -> Int -> a -> [a] -> HBlock a+fromList s bs e lst = L.foldl' (flip insert) (empty s bs e) lst+{-# INLINABLE fromList #-}
+ Data/Indexation/Constraints.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE RankNTypes, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+module Data.Indexation.Constraints+ ( Text128+ , Text256+ , Text512+ , Text1024+ , Text2048+ , Text4096+ , TextConstraint(..)+ , t128+ , t256+ , t512+ , t1024+ , t2048+ , t4096) where+import Prelude+import qualified Data.Text as T+import Data.Data+import Data.String+import Data.Monoid+import Control.Monad+import Control.DeepSeq+import Data.SafeCopy+import Data.Serialize+import Data.Text.Encoding+import Data.Hashable+import Data.Aeson+import qualified Data.Aeson as Aeson++-- | Text with a maximum of 128 characters+newtype Text128 = Text128 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text256 = Text256 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text512 = Text512 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text1024 = Text1024 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text2048 = Text2048 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text4096 = Text4096 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)++class TextConstraint a where+ txtConstraint :: T.Text -> a+ getTxt :: a -> T.Text+ fromText :: T.Text -> a+ fromText = txtConstraint+ toText :: a -> T.Text+ toText = getTxt++instance TextConstraint Text128 where txtConstraint = t128+ getTxt (Text128 t) = t+instance TextConstraint Text256 where txtConstraint = t256+ getTxt (Text256 t) = t+instance TextConstraint Text512 where txtConstraint = t512+ getTxt (Text512 t) = t+instance TextConstraint Text1024 where txtConstraint = t1024+ getTxt (Text1024 t) = t+instance TextConstraint Text2048 where txtConstraint = t2048+ getTxt (Text2048 t) = t+instance TextConstraint Text4096 where txtConstraint = t4096+ getTxt (Text4096 t) = t++instance (TextConstraint a) => TextConstraint (Maybe a) where+ txtConstraint t = Just $ txtConstraint t+ getTxt t = case t of+ Just a -> getTxt a+ Nothing -> T.empty++instance Hashable Text128 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text256 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text512 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text1024 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text2048 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text4096 where hashWithSalt s d = hashWithSalt s (getTxt d)++instance Serialize Text128 where put (Text128 t) = put $ encodeUtf8 t+ get = (Text128 . decodeUtf8) `fmap` get+instance Serialize Text256 where put (Text256 t) = put $ encodeUtf8 t+ get = (Text256 . decodeUtf8) `fmap` get+instance Serialize Text512 where put (Text512 t) = put $ encodeUtf8 t+ get = (Text512 . decodeUtf8) `fmap` get+instance Serialize Text1024 where put (Text1024 t) = put $ encodeUtf8 t+ get = (Text1024 . decodeUtf8) `fmap` get+instance Serialize Text2048 where put (Text2048 t) = put $ encodeUtf8 t+ get = (Text2048 . decodeUtf8) `fmap` get+instance Serialize Text4096 where put (Text4096 t) = put $ encodeUtf8 t+ get = (Text4096 . decodeUtf8) `fmap` get++instance SafeCopy Text128 where putCopy (Text128 t) = putCopy t+ getCopy = contain $ Text128 `fmap` safeGet+instance SafeCopy Text256 where putCopy (Text256 t) = putCopy t+ getCopy = contain $ Text256 `fmap` safeGet+instance SafeCopy Text512 where putCopy (Text512 t) = putCopy t+ getCopy = contain $ Text512 `fmap` safeGet+instance SafeCopy Text1024 where putCopy (Text1024 t) = putCopy t+ getCopy = contain $ Text1024 `fmap` safeGet+instance SafeCopy Text2048 where putCopy (Text2048 t) = putCopy t+ getCopy = contain $ Text2048 `fmap` safeGet+instance SafeCopy Text4096 where putCopy (Text4096 t) = putCopy t+ getCopy = contain $ Text4096 `fmap` safeGet++instance FromJSON Text128 where parseJSON (Aeson.String s) = return $ t128 s+ parseJSON _ = mzero+instance FromJSON Text256 where parseJSON (Aeson.String s) = return $ t256 s+ parseJSON _ = mzero+instance FromJSON Text512 where parseJSON (Aeson.String s) = return $ t512 s+ parseJSON _ = mzero+instance FromJSON Text1024 where parseJSON (Aeson.String s) = return $ t1024 s+ parseJSON _ = mzero+instance FromJSON Text2048 where parseJSON (Aeson.String s) = return $ t2048 s+ parseJSON _ = mzero+instance FromJSON Text4096 where parseJSON (Aeson.String s) = return $ t4096 s+ parseJSON _ = mzero+instance ToJSON Text128 where toJSON s = Aeson.String (getTxt s)+instance ToJSON Text256 where toJSON s = Aeson.String (getTxt s)+instance ToJSON Text512 where toJSON s = Aeson.String (getTxt s)+instance ToJSON Text1024 where toJSON s = Aeson.String (getTxt s)+instance ToJSON Text2048 where toJSON s = Aeson.String (getTxt s)+instance ToJSON Text4096 where toJSON s = Aeson.String (getTxt s)++t128 :: T.Text -> Text128+t128 = Text128 . T.take 128++t256 :: T.Text -> Text256+t256 = Text256 . T.take 256++t512 :: T.Text -> Text512+t512 = Text512 . T.take 512 ++t1024 :: T.Text -> Text1024+t1024 = Text1024 . T.take 1024++t2048 :: T.Text -> Text2048+t2048 = Text2048 . T.take 2048++t4096 :: T.Text -> Text4096+t4096 = Text4096 . T.take 4096+
+ Data/Indexation/NormalIx.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+module Data.Indexation.NormalIx+( SimpleIx(..)+, Indexed(..)+, createIndexed+, withUnique1+, withUnique2+, withIndex1+, withIndex2+, withIndex3+, withIndex4+, withFilters+, insertGetIx+, insert+, deleteIndex+, deleteU1+, deleteU2+, getU1+, getU2+, getI1+, getI2+, getI3+, getI4+, getFilter+, adjust+, adjustWithU1+, adjustWithU2+, update+, updateWithU1+, updateWithU2+) where++import Data.HBlock (HBlock)+import qualified Data.HBlock as HB+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import Data.Vector (Vector, (!?))+import qualified Data.Vector as V+import Data.SafeCopy+import Data.Hashable+import qualified Data.Foldable as Fold+-- import Data.Indexation.IxData (IxData(ixDataPos, ixData))+import Data.Maybe (fromMaybe)++data Indexed a u1 u2 i1 i2 i3 i4 + = Indexed !(HBlock a) + -- ^ Where all the data is+ !(Maybe (IndexU a u1 u2))+ -- ^ Unique indexation structures+ !(Maybe (IndexI a i1 i2 i3 i4))+ -- ^ Indexation structures+ !(Vector (a -> Bool)) + -- ^ Filters (i.e. >= 30)+ !(Vector IntSet)+ -- ^ Filters results++-- | IndexCore is the index structures for a given data+data IndexU a u1 u2 + = IxHasU1 !(HashMap u1 Int) !(a -> u1)+ | IxHasU2 !(HashMap u1 Int) !(a -> u1)+ !(HashMap u2 Int) !(a -> u2)+data IndexI a i1 i2 i3 i4+ = IxHasI1 !(HashMap i1 IntSet) !(a -> i1)+ | IxHasI2 !(HashMap i1 IntSet) !(a -> i1)+ !(HashMap i2 IntSet) !(a -> i2)+ | IxHasI3 !(HashMap i1 IntSet) !(a -> i1)+ !(HashMap i2 IntSet) !(a -> i2)+ !(HashMap i3 IntSet) !(a -> i3)+ | IxHasI4 !(HashMap i1 IntSet) !(a -> i1)+ !(HashMap i2 IntSet) !(a -> i2)+ !(HashMap i3 IntSet) !(a -> i3)+ !(HashMap i4 IntSet) !(a -> i4)++-- * +-- * Creation functions+-- * +class SimpleIx a where+ -- | Creates your indexed dataype+ type U1 a+ type U2 a+ type I1 a+ type I2 a+ type I3 a+ type I4 a+ create :: Indexed a (U1 a) (U2 a) (I1 a) (I2 a) (I3 a) (I4 a)++defSlots :: Int+defSlots = 4096+defBlockLen :: Int+defBlockLen = 4096++-- | createIndexed is a helper function to create the base Indexed datatype+-- it is used in the "createdUxIx" functions to avoid repetition+createIndexed :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4)+ => a -> Indexed a u1 u2 i1 i2 i3 i4+createIndexed e = Indexed (HB.empty defSlots defBlockLen e) + Nothing Nothing V.empty V.empty++withUnique1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> u1) + -> Indexed a u1 u2 i1 i2 i3 i4+withUnique1 i@(Indexed v uis iis vf vs) f = + case uis of + Nothing -> Indexed v (Just $ IxHasU1 HM.empty f) iis vf vs+ _ -> i++withUnique2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> u2) + -> Indexed a u1 u2 i1 i2 i3 i4+withUnique2 i@(Indexed v uis iis vf vs) f = + case uis of+ Just (IxHasU1 m1 f1) -> + Indexed v (Just $ IxHasU2 m1 f1 HM.empty f) iis vf vs+ _ -> i++withIndex1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i1) + -> Indexed a u1 u2 i1 i2 i3 i4+withIndex1 i@(Indexed v uis iis vf vs) f = + case iis of+ Nothing -> Indexed v uis (Just $ IxHasI1 HM.empty f) vf vs+ _ -> i++withIndex2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i2) + -> Indexed a u1 u2 i1 i2 i3 i4+withIndex2 i@(Indexed v uis iis vf vs) f = + case iis of+ Just (IxHasI1 m1 f1) -> + let niis = Just $ IxHasI2 m1 f1 HM.empty f in + Indexed v uis niis vf vs+ _ -> i+ ++withIndex3 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i3) + -> Indexed a u1 u2 i1 i2 i3 i4+withIndex3 i@(Indexed v uis iis vf vs) f = + case iis of+ Just (IxHasI2 m1 f1 m2 f2) -> + let niis = Just $ IxHasI3 m1 f1 m2 f2 HM.empty f in+ Indexed v uis niis vf vs+ _ -> i+ ++withIndex4 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i4) + -> Indexed a u1 u2 i1 i2 i3 i4+withIndex4 i@(Indexed v uis iis vf vs) f = + case iis of+ Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> + let niis = Just $ IxHasI4 m1 f1 m2 f2 m3 f3 HM.empty f in+ Indexed v uis niis vf vs+ _ -> i++withFilters :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> [(a -> Bool)]+ -> Indexed a u1 u2 i1 i2 i3 i4 +withFilters (Indexed v uis iis _ _) lst = + Indexed v uis iis flst vlst+ where+ flst = V.fromList lst+ vlst = V.replicate (V.length flst) IS.empty+++-- * +-- * Insertion functions+-- * +insertGetIx :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> a + -> (Int, Indexed a u1 u2 i1 i2 i3 i4)+insertGetIx (Indexed hb uis iis vf vi) item = + (pos, Indexed newhb newuis newiis vf newvi)+ where + (pos, newhb) = HB.insertGetIx item hb+ newuis = + case uis of + Nothing -> Nothing+ Just (IxHasU1 m1 f1) -> Just $ + IxHasU1 (HM.insert (f1 item) pos m1) f1+ Just (IxHasU2 m1 f1 m2 f2) -> Just $+ IxHasU2 (HM.insert (f1 item) pos m1) f1+ (HM.insert (f2 item) pos m2) f2+ newiis = + case iis of+ Nothing -> Nothing+ Just (IxHasI1 m1 f1) -> Just $+ IxHasI1 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ Just (IxHasI2 m1 f1 m2 f2) -> Just $ + IxHasI2 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ (HM.adjust (IS.insert pos) (f2 item) m2) f2+ Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> Just $ + IxHasI3 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ (HM.adjust (IS.insert pos) (f2 item) m2) f2+ (HM.adjust (IS.insert pos) (f3 item) m3) f3+ Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4) -> Just $ + IxHasI4 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ (HM.adjust (IS.insert pos) (f2 item) m2) f2+ (HM.adjust (IS.insert pos) (f3 item) m3) f3+ (HM.adjust (IS.insert pos) (f4 item) m4) f4+ newvi = V.imap fvi vi+ -- check if the filter applies to this element, if it applies insert+ -- the element index into the intset+ fvi i e = if V.unsafeIndex vf i $ item then IS.insert pos e else e+{-# INLINABLE insertGetIx #-}++insert :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> a -> Indexed a u1 u2 i1 i2 i3 i4+insert i item = snd $ insertGetIx i item+{-# INLINE insert #-}++-- * +-- * Deletion functions+-- * +deleteIndex :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> Indexed a u1 u2 i1 i2 i3 i4+deleteIndex (Indexed hb uis iis vf vi) ix = + Indexed (HB.delete ix hb) uis iis vf vi+{-# INLINE deleteIndex #-}+ -- ^ TODO: delete from the indices and vi ?++deleteU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+deleteU1 i@(Indexed hb uis _ _ _) u1 = do+ u <- uis+ pos <- f u+ return $ deleteIndex i pos+ where+ f (IxHasU1 m _) = HM.lookup u1 m+ f (IxHasU2 m _ _ _) = HM.lookup u1 m++deleteU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+deleteU2 i@(Indexed hb uis _ _ _) u2 = do+ u <- uis+ pos <- f u+ return $ deleteIndex i pos+ where+ f (IxHasU1 _ _) = Nothing+ f (IxHasU2 _ _ m _) = HM.lookup u2 m++++-- deleteIxData+{-+delete :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> a -> Indexed a u1 u2 i1 i2 i3 i4+delete (Indexed hb uis iis vf vi) a = +-}++-- * +-- * Accessor (getters) functions+-- * +getU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> Maybe a+getU1 (Indexed hb uis _ _ _) u1 = do + u <- uis+ pos <- f u+ HB.getPos hb pos+ where+ f (IxHasU1 m _) = HM.lookup u1 m+ f (IxHasU2 m _ _ _) = HM.lookup u1 m+{-# INLINABLE getU1 #-}++getU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> Maybe a+getU2 (Indexed hb uis _ _ _) u2 = do + u <- uis+ pos <- f u+ HB.getPos hb pos+ where+ f (IxHasU1 _ _) = Nothing+ f (IxHasU2 _ _ m _) = HM.lookup u2 m+{-# INLINABLE getU2 #-}++getI1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> i1 -> Maybe (HBlock a)+getI1 (Indexed hb _ iis _ _) i = do + iis' <- iis+ set <- f iis'+ return $ HB.getSet hb set+ where+ f (IxHasI1 m _) = HM.lookup i m+ f (IxHasI2 m _ _ _) = HM.lookup i m+ f (IxHasI3 m _ _ _ _ _) = HM.lookup i m+ f (IxHasI4 m _ _ _ _ _ _ _) = HM.lookup i m+{-# INLINABLE getI1 #-}++getI2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> i2 -> Maybe (HBlock a)+getI2 (Indexed hb _ iis _ _) i = do + iis' <- iis+ set <- f iis'+ return $ HB.getSet hb set+ where+ f (IxHasI2 _ _ m _) = HM.lookup i m+ f (IxHasI3 _ _ m _ _ _) = HM.lookup i m+ f (IxHasI4 _ _ m _ _ _ _ _) = HM.lookup i m+ f _ = Nothing+{-# INLINABLE getI2 #-}++getI3 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> i3 -> Maybe (HBlock a)+getI3 (Indexed hb _ iis _ _) i = do + iis' <- iis+ set <- f iis'+ return $ HB.getSet hb set+ where+ f (IxHasI3 _ _ _ _ m _) = HM.lookup i m+ f (IxHasI4 _ _ _ _ m _ _ _) = HM.lookup i m+ f _ = Nothing+{-# INLINABLE getI3 #-}++getI4 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> i4 -> Maybe (HBlock a)+getI4 (Indexed hb _ iis _ _) i = do + iis' <- iis+ set <- f iis'+ return $ HB.getSet hb set+ where+ f (IxHasI4 _ _ _ _ _ _ m _) = HM.lookup i m+ f _ = Nothing+{-# INLINABLE getI4 #-}++getFilter :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> Maybe (HBlock a)+getFilter (Indexed hb _ _ _ vi) filterPos = do+ set <- vi !? filterPos+ return $ HB.getSet hb set+{-# INLINABLE getFilter #-}++-- * +-- * Setter functions+-- * ++-- | helper function, updates the hash of a unique index+_updateUHash :: (Eq u, Hashable u) => HashMap u Int -> Int -> u -> u + -> HashMap u Int+_updateUHash m val old new = HM.insert new val $ HM.delete old m++_updateIHash :: (Eq u, Hashable u) => HashMap u IntSet -> Int -> u -> u + -> HashMap u IntSet+_updateIHash m val old new = + HM.insertWith insSet new valSet $ HM.adjust (IS.delete val) old m+ where+ insSet _ o = IS.insert val o+ valSet = IS.singleton val+-- | helper function, updates the unique indices +_updateU :: (Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2) + => Maybe (IndexU a u1 u2) -> Int -> a -> a -> Maybe (IndexU a u1 u2)+_updateU (Just (IxHasU1 m f)) val old new = + Just $ IxHasU1 (_updateUHash m val (f old) (f new)) f+_updateU (Just (IxHasU2 m1 f1 m2 f2)) val old new = + Just $ IxHasU2 (_updateUHash m1 val (f1 old) (f1 new)) f1+ (_updateUHash m2 val (f2 old) (f2 new)) f2+_updateU Nothing _ _ _ = Nothing++-- | helper function, updates the normal indices+_updateI :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2+ , Eq i3, Hashable i3, Eq i4, Hashable i4)+ => Maybe (IndexI a i1 i2 i3 i4) -> Int -> a -> a + -> Maybe (IndexI a i1 i2 i3 i4)+_updateI (Just (IxHasI1 m f)) val old new = + Just $ IxHasI1 (_updateIHash m val (f old) (f new)) f+_updateI (Just (IxHasI2 m1 f1 m2 f2)) val old new = + Just $ IxHasI2 (_updateIHash m1 val (f1 old) (f1 new)) f1+ (_updateIHash m2 val (f2 old) (f2 new)) f2+_updateI (Just (IxHasI3 m1 f1 m2 f2 m3 f3)) val old new = + Just $ IxHasI3 (_updateIHash m1 val (f1 old) (f1 new)) f1+ (_updateIHash m2 val (f2 old) (f2 new)) f2+ (_updateIHash m3 val (f3 old) (f3 new)) f3+_updateI (Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4)) val old new = + Just $ IxHasI4 (_updateIHash m1 val (f1 old) (f1 new)) f1+ (_updateIHash m2 val (f2 old) (f2 new)) f2+ (_updateIHash m3 val (f3 old) (f3 new)) f3+ (_updateIHash m4 val (f4 old) (f4 new)) f4+_updateI Nothing _ _ _ = Nothing++-- | helper function, updates the normal indices+_updateF :: Vector (a -> Bool) -> Vector IntSet -> Int -> a -> a + -> Vector IntSet+_updateF vf v value old new = V.imap applyF vf+ -- map the vf, apply the function to the old and the new, if diff, change the v+ -- because it is faster to check for indexation in a vector than to check+ -- membership in a intset+ where+ applyF pos f = let f1 = f old+ f2 = f new+ iset = V.unsafeIndex v pos+ in if f1 == f2 + then iset+ else if f2 then IS.insert value iset + else IS.delete value iset ++adjust :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> (a -> a) + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+adjust i@(Indexed hb ius iis vf vi) pos f = do+ e <- HB.getPos hb pos+ let newe = f e+ return $ Indexed (HB.update newe pos hb) + (_updateU ius pos e newe)+ (_updateI iis pos e newe)+ vf (_updateF vf vi pos e newe)+{-# INLINABLE adjust #-}++adjustWithU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> (a -> a)+ -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+adjustWithU1 i@(Indexed hb uis iis vf vi) u1 af = do + u <- uis+ pos <- f u+ e <- HB.getPos hb pos+ let newe = af e+ return $ Indexed (HB.update newe pos hb) + (_updateU uis pos e newe)+ (_updateI iis pos e newe)+ vf (_updateF vf vi pos e newe)+ where+ f (IxHasU1 m _) = HM.lookup u1 m+ f (IxHasU2 m _ _ _) = HM.lookup u1 m+{-# INLINABLE adjustWithU1 #-}++adjustWithU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> (a -> a)+ -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+adjustWithU2 i@(Indexed hb uis iis vf vi) u2 af = do + u <- uis+ pos <- f u+ e <- HB.getPos hb pos+ let newe = af e+ return $ Indexed (HB.update newe pos hb) + (_updateU uis pos e newe)+ (_updateI iis pos e newe)+ vf (_updateF vf vi pos e newe)+ where+ f (IxHasU1 _ _) = Nothing+ f (IxHasU2 _ _ m _) = HM.lookup u2 m+{-# INLINABLE adjustWithU2 #-}++update :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> a + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+update i p a = adjust i p (const a)+{-# INLINABLE update #-}++updateWithU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> a + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+updateWithU1 i u1 a = adjustWithU1 i u1 (const a)+{-# INLINABLE updateWithU1 #-}++updateWithU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> a + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4)+updateWithU2 i u2 a = adjustWithU2 i u2 (const a)+{-# INLINABLE updateWithU2 #-}++instance ( SafeCopy a, Eq a, SimpleIx a+ , Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ , u1 ~ U1 a, u2 ~ U2 a, i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a, i4 ~ I4 a+ ) => SafeCopy (Indexed a u1 u2 i1 i2 i3 i4) where+ version = 0+ kind = base+ putCopy (Indexed hb _ _ _ _) = contain $ safePut hb+ getCopy = contain $ fmap withData safeGet+ where+ withData :: (SafeCopy a, Eq a, SimpleIx a+ , Eq u1, Hashable u1, Eq u2, Hashable u2+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3+ , Hashable i3, Eq i4, Hashable i4+ , u1 ~ U1 a, u2 ~ U2 a, i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a+ , i4 ~ I4 a) => HBlock a -> Indexed a u1 u2 i1 i2 i3 i4+ withData h = Fold.foldl insert create h+
+ Data/Indexation/SimpleIx.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+module Data.Indexation.SimpleIx+( SimpleIx(..)+, Indexed(..)+, createIndexed+, withFunction+, withIndex1+, withIndex2+, withIndex3+, withIndex4+, withFilters+, insert+, deleteIndex+, delete+, size+, getPos+, getI1+, getI2+, getI3+, getI4+, getFilter+, member+, adjust+, update+) where++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import Data.IntMap.Strict (IntMap, (!))+import qualified Data.IntMap.Strict as IM+import Data.Vector (Vector, (!?))+import qualified Data.Vector as V+import Data.SafeCopy+import Data.Hashable+-- import Data.Indexation.IxData (IxData(ixDataPos, ixData))++data Indexed a i1 i2 i3 i4 + = Indexed !(IntMap a) + -- ^ Where all the data is+ !(a -> Int) + -- ^ How to access the data + !(Maybe (IndexI a i1 i2 i3 i4))+ -- ^ Indexation structures+ !(Vector (a -> Bool)) + -- ^ Filters (i.e. >= 30, == "foo")+ !(Vector IntSet)+ -- ^ Filters results+ !IntSet+ -- ^ helper set to speed index lookup+ !Int+ -- ^ Number of items++-- TODO: the function should be (a -> b), where b is Hashable+-- this should be the "ID" function, and it should be used to check if+-- the id was changed in "adjust" and update it++data IndexI a i1 i2 i3 i4+ = IxHasI1 !(HashMap i1 IntSet) !(a -> i1)+ | IxHasI2 !(HashMap i1 IntSet) !(a -> i1)+ !(HashMap i2 IntSet) !(a -> i2)+ | IxHasI3 !(HashMap i1 IntSet) !(a -> i1)+ !(HashMap i2 IntSet) !(a -> i2)+ !(HashMap i3 IntSet) !(a -> i3)+ | IxHasI4 !(HashMap i1 IntSet) !(a -> i1)+ !(HashMap i2 IntSet) !(a -> i2)+ !(HashMap i3 IntSet) !(a -> i3)+ !(HashMap i4 IntSet) !(a -> i4)++-- * +-- * Creation functions+-- * +class SimpleIx a where+ -- | Creates your indexed dataype+ type I1 a+ type I2 a+ type I3 a+ type I4 a+ create :: Indexed a (I1 a) (I2 a) (I3 a) (I4 a)++-- | createIndexed is a helper function to create the base Indexed datatype+-- it is used in the "createdUxIx" functions to avoid repetition+createIndexed :: ( Eq a, Eq i1, Hashable i1, Eq i2, Hashable i2+ , Eq i3, Hashable i3, Eq i4, Hashable i4)+ => Indexed a i1 i2 i3 i4+createIndexed = Indexed IM.empty (const 0) Nothing V.empty V.empty IS.empty 0++withFunction :: ( Eq a, Eq i1, Hashable i1, Eq i2, Hashable i2+ , Eq i3, Hashable i3, Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> (a -> Int) + -> Indexed a i1 i2 i3 i4+withFunction (Indexed d _ iis vf vs is s) f = Indexed d f iis vf vs is s++withIndex1 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> (a -> i1) + -> Indexed a i1 i2 i3 i4+withIndex1 i@(Indexed d a iis vf vs is s) f = + case iis of+ Nothing -> Indexed d a (Just $ IxHasI1 HM.empty f) vf vs is s+ _ -> i++withIndex2 :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> (a -> i2) + -> Indexed a i1 i2 i3 i4+withIndex2 i@(Indexed d a iis vf vs is s) f = + case iis of+ Just (IxHasI1 m1 f1) -> + let niis = Just $ IxHasI2 m1 f1 HM.empty f in + Indexed d a niis vf vs is s+ _ -> i+ ++withIndex3 :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> (a -> i3) + -> Indexed a i1 i2 i3 i4+withIndex3 i@(Indexed d a iis vf vs is s) f = + case iis of+ Just (IxHasI2 m1 f1 m2 f2) -> + let niis = Just $ IxHasI3 m1 f1 m2 f2 HM.empty f in+ Indexed d a niis vf vs is s+ _ -> i+ ++withIndex4 :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> (a -> i4) + -> Indexed a i1 i2 i3 i4+withIndex4 i@(Indexed d a iis vf vs is s) f = + case iis of+ Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> + let niis = Just $ IxHasI4 m1 f1 m2 f2 m3 f3 HM.empty f in+ Indexed d a niis vf vs is s+ _ -> i++withFilters :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> [(a -> Bool)]+ -> Indexed a i1 i2 i3 i4 +withFilters (Indexed d f iis _ _ is s) lst = + Indexed d f iis flst vlst is s+ where+ flst = V.fromList lst+ vlst = V.replicate (V.length flst) IS.empty++-- * +-- * Insertion functions+-- * +insert :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> a + -> Indexed a i1 i2 i3 i4+insert (Indexed d f iis vf vi is s) item = + Indexed newd f newiis vf newvi newis (s + 1)+ where + pos = f item+ newd = IM.insert pos item d+ newis = IS.insert pos is+ newiis = + case iis of+ Nothing -> Nothing+ Just (IxHasI1 m1 f1) -> Just $+ IxHasI1 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ Just (IxHasI2 m1 f1 m2 f2) -> Just $ + IxHasI2 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ (HM.adjust (IS.insert pos) (f2 item) m2) f2+ Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> Just $ + IxHasI3 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ (HM.adjust (IS.insert pos) (f2 item) m2) f2+ (HM.adjust (IS.insert pos) (f3 item) m3) f3+ Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4) -> Just $ + IxHasI4 (HM.adjust (IS.insert pos) (f1 item) m1) f1+ (HM.adjust (IS.insert pos) (f2 item) m2) f2+ (HM.adjust (IS.insert pos) (f3 item) m3) f3+ (HM.adjust (IS.insert pos) (f4 item) m4) f4+ newvi = V.imap fvi vi+ -- check if the filter applies to this element, if it applies insert+ -- the element index into the intset+ fvi i e = if V.unsafeIndex vf i $ item then IS.insert pos e else e+{-# INLINABLE insert #-}++-- * +-- * Deletion functions+-- * +deleteIndex :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> Int -> Indexed a i1 i2 i3 i4+deleteIndex i@(Indexed d a iis vf vi is s) ix = + case old of+ Nothing -> i+ Just _ -> Indexed newd a iis vf vi (IS.delete ix is) (s - 1)+ where+ deleteKey _ _ = Nothing+ (old, newd) = IM.updateLookupWithKey deleteKey ix d+++{-# INLINE deleteIndex #-}+ -- ^ TODO: delete from the indices and vi ?++delete :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> a -> Indexed a i1 i2 i3 i4+delete i@(Indexed _ f _ _ _ _ _) item = deleteIndex i (f item)+{-# INLINE delete #-}++-- * +-- * Accessor (getters) functions+-- * +size :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> Int +size (Indexed _ _ _ _ _ _ s) = s +{-# INLINE size #-}++getPos :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> Int -> Maybe a+getPos (Indexed d _ _ _ _ _ _) pos = IM.lookup pos d+{-# INLINE getPos #-}++getSet :: IntMap a -> IntSet -> IntSet -> IntMap a+getSet im imkis is = IM.fromSet (\k -> im ! k) (IS.intersection imkis is)+{-# INLINE getSet #-}++getI1 :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> i1 -> Maybe (IntMap a)+getI1 (Indexed d _ iis _ _ is _) i = do + iis' <- iis+ set <- f iis'+ return $ getSet d is set+ where+ f (IxHasI1 m _) = HM.lookup i m+ f (IxHasI2 m _ _ _) = HM.lookup i m+ f (IxHasI3 m _ _ _ _ _) = HM.lookup i m+ f (IxHasI4 m _ _ _ _ _ _ _) = HM.lookup i m+{-# INLINABLE getI1 #-}++getI2 :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> i2 -> Maybe (IntMap a)+getI2 (Indexed d _ iis _ _ is _) i = do + iis' <- iis+ set <- f iis'+ return $ getSet d is set+ where+ f (IxHasI2 _ _ m _) = HM.lookup i m+ f (IxHasI3 _ _ m _ _ _) = HM.lookup i m+ f (IxHasI4 _ _ m _ _ _ _ _) = HM.lookup i m+ f _ = Nothing+{-# INLINABLE getI2 #-}++getI3 :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> i3 -> Maybe (IntMap a)+getI3 (Indexed d _ iis _ _ is _) i = do + iis' <- iis+ set <- f iis'+ return $ getSet d is set+ where+ f (IxHasI3 _ _ _ _ m _) = HM.lookup i m+ f (IxHasI4 _ _ _ _ m _ _ _) = HM.lookup i m+ f _ = Nothing+{-# INLINABLE getI3 #-}++getI4 :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> i4 -> Maybe (IntMap a)+getI4 (Indexed d _ iis _ _ is _) i = do + iis' <- iis+ set <- f iis'+ return $ getSet d is set+ where+ f (IxHasI4 _ _ _ _ _ _ m _) = HM.lookup i m+ f _ = Nothing+{-# INLINABLE getI4 #-}++getFilter :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> Int -> Maybe (IntMap a)+getFilter (Indexed d _ _ _ vi is _) filterPos = do+ set <- vi !? filterPos+ return $ getSet d is set+{-# INLINABLE getFilter #-}++member :: ( Eq a, Hashable b+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> b -> Bool+member (Indexed _ _ _ _ _ is _) b = IS.member (hash b) is+{-# INLINE member #-}++-- * +-- * Setter functions+-- * ++-- | helper function, updates the normal indices+_updateIHash :: (Eq u, Hashable u) => HashMap u IntSet -> Int -> u -> u + -> HashMap u IntSet+_updateIHash m val old new = + HM.insertWith insSet new valSet $ HM.adjust (IS.delete val) old m+ where+ insSet _ o = IS.insert val o+ valSet = IS.singleton val+-- | helper function, updates the normal indices+_updateI :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2+ , Eq i3, Hashable i3, Eq i4, Hashable i4)+ => Maybe (IndexI a i1 i2 i3 i4) -> Int -> a -> a + -> Maybe (IndexI a i1 i2 i3 i4)+_updateI (Just (IxHasI1 m f)) val old new = + Just $ IxHasI1 (_updateIHash m val (f old) (f new)) f+_updateI (Just (IxHasI2 m1 f1 m2 f2)) val old new = + Just $ IxHasI2 (_updateIHash m1 val (f1 old) (f1 new)) f1+ (_updateIHash m2 val (f2 old) (f2 new)) f2+_updateI (Just (IxHasI3 m1 f1 m2 f2 m3 f3)) val old new = + Just $ IxHasI3 (_updateIHash m1 val (f1 old) (f1 new)) f1+ (_updateIHash m2 val (f2 old) (f2 new)) f2+ (_updateIHash m3 val (f3 old) (f3 new)) f3+_updateI (Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4)) val old new = + Just $ IxHasI4 (_updateIHash m1 val (f1 old) (f1 new)) f1+ (_updateIHash m2 val (f2 old) (f2 new)) f2+ (_updateIHash m3 val (f3 old) (f3 new)) f3+ (_updateIHash m4 val (f4 old) (f4 new)) f4+_updateI Nothing _ _ _ = Nothing++-- | helper function, updates the normal indices+_updateF :: Vector (a -> Bool) -> Vector IntSet -> Int -> a -> a + -> Vector IntSet+_updateF vf v value old new = V.imap applyF vf+ -- map the vf, apply the function to the old and the new, if diff, change + -- the v because it is faster to check for indexation in a vector than + -- to check membership in a intset+ where+ applyF pos f = let f1 = f old+ f2 = f new+ iset = V.unsafeIndex v pos+ in if f1 == f2 + then iset+ else if f2 then IS.insert value iset + else IS.delete value iset ++adjust :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> Int -> (a -> a) + -> Maybe (Indexed a i1 i2 i3 i4)+adjust (Indexed d a iis vf vi is s) pos f = do+ e <- me+ let newe = f e+ return $ Indexed newdata a+ (_updateI iis pos e newe)+ vf (_updateF vf vi pos e newe)+ is s+ where+ (me, newdata) = IM.updateLookupWithKey (\_ v -> Just $ f v) pos d+{-# INLINABLE adjust #-}++update :: ( Eq a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ )+ => Indexed a i1 i2 i3 i4 -> Int -> a + -> Maybe (Indexed a i1 i2 i3 i4)+update i p a = adjust i p (const a)+{-# INLINABLE update #-}++instance ( SafeCopy a, Eq a, SimpleIx a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3+ , Eq i4, Hashable i4+ , i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a, i4 ~ I4 a+ ) => SafeCopy (Indexed a i1 i2 i3 i4) where+ version = 0+ kind = base+ putCopy (Indexed d _ _ _ _ _ _) = contain $ safePut $ IM.elems d+ getCopy = contain $ fmap withData safeGet+ where+ withData :: (SafeCopy a, Eq a, SimpleIx a+ , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3+ , Hashable i3, Eq i4, Hashable i4+ , i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a+ , i4 ~ I4 a) => IntMap a -> Indexed a i1 i2 i3 i4+ withData h = IM.foldl insert create h+
+ Data/Indexation/UUID.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, TypeFamilies, GeneralizedNewtypeDeriving #-}+module Data.Indexation.UUID where++import Data.UUID (fromString)+import Data.UUID.V4 (nextRandom)+import qualified Data.UUID as U +import Data.SafeCopy+import Data.Text (unpack, Text)+import qualified Data.Text as T+import Control.Applicative ((<$>))+import Web.PathPieces+import Data.Aeson+import qualified Data.Aeson as Aeson+import Text.Blaze(ToMarkup(..))+import Data.Bits (shiftR, (.&.), (.|.), shiftL)+import Control.Monad (mzero)+import Data.Char (intToDigit, isHexDigit, digitToInt)+import Data.Word(Word32)+-- Imports for deriving+import Data.Data+import Data.Hashable+import Control.DeepSeq (NFData(..))+import Foreign.Storable+import Data.Serialize+import Data.ByteString.Lazy (ByteString)++newtype UUID = UUID U.UUID+ deriving(Ord, Eq, Data, Typeable, Storable, NFData, Show, Read)++rndUUID :: IO UUID+rndUUID = nextRandom >>= return . UUID++unUUID :: UUID -> U.UUID+unUUID (UUID u) = u++nil :: UUID+nil = UUID U.nil++fromLazyASCIIBytes :: ByteString -> Maybe UUID+fromLazyASCIIBytes bs = UUID `fmap` U.fromLazyASCIIBytes bs++toLazyASCIIBytes :: UUID -> ByteString+toLazyASCIIBytes (UUID u) = U.toLazyASCIIBytes u++toText :: UUID -> Text+toText = txtUUID++fromText :: Text -> Maybe UUID+fromText = uuidTxt++fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID+fromWords w1 w2 w3 w4 = UUID (U.fromWords w1 w2 w3 w4)++toWords :: UUID -> (Word32, Word32, Word32, Word32)+toWords (UUID u) = U.toWords u++txtUUID :: UUID -> Text+txtUUID (UUID u) = uuidToText (U.toWords u) + where+ uuidToText :: (Word32, Word32, Word32, Word32) -> Text+ uuidToText (w0, w1, w2, w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 T.empty+ hexw :: Word32 -> Text -> Text+ hexw w s = hexn w 28 `T.cons` hexn w 24 `T.cons` hexn w 20 `T.cons` hexn w 16+ `T.cons` hexn w 12 `T.cons` hexn w 8 `T.cons` hexn w 4 `T.cons` hexn w 0 `T.cons` s++ hexw' :: Word32 -> Text -> Text + hexw' w s = '-' `T.cons` hexn w 28 `T.cons` hexn w 24 `T.cons` hexn w 20 `T.cons` hexn w 16+ `T.cons` '-' `T.cons` hexn w 12 `T.cons` hexn w 8 `T.cons` hexn w 4 `T.cons` hexn w 0 `T.cons` s++ hexn :: Word32 -> Int -> Char+ hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)++uuidTxt :: Text -> Maybe UUID+uuidTxt t0 = do + (w0, t1) <- hexWord t0+ (w1, t2) <- hexWord t1+ (w2, t3) <- hexWord t2+ (w3, t4) <- hexWord t3+ if T.null t4 + then Just $ UUID $ U.fromWords w0 w1 w2 w3+ else Nothing+ where hexWord :: Text -> Maybe (Word32, Text)+ hexWord s = Just (0, s) >>= hexByte >>= hexByte+ >>= hexByte >>= hexByte++ hexByte :: (Word32, Text) -> Maybe (Word32, Text)+ hexByte (w, txt) = if T.null txt then Nothing else + if T.head txt == '-'+ then hexByte (w, T.tail txt)+ else let hi = T.head txt+ lo = T.head $ T.tail txt+ ds = T.tail $ T.tail txt+ bothHex = isHexDigit hi && isHexDigit lo+ octet = fromIntegral (16 * digitToInt hi + digitToInt lo)+ in if bothHex then Just ((w `shiftL` 8) .|. octet, ds)+ else Nothing++instance Hashable UUID where+ hash (UUID u) = hash u+ hashWithSalt s (UUID u) = hashWithSalt s u++instance SafeCopy UUID where+ putCopy (UUID u) = contain $ safePut $ U.toWords u+ getCopy = contain $ (UUID . (\(a,b,c,d) -> U.fromWords a b c d) <$> safeGet)++instance PathPiece UUID where+ fromPathPiece t = UUID <$> (fromString $ unpack t)+ toPathPiece = txtUUID++instance ToMarkup UUID where+ toMarkup u = toMarkup $ txtUUID u++instance ToJSON UUID where+ toJSON u = Aeson.String (txtUUID u)+instance FromJSON UUID where+ parseJSON (Aeson.String s) = case fromString (T.unpack s) of+ Just u -> return $ UUID u+ Nothing -> mzero+ parseJSON _ = mzero++instance Serialize UUID where+ put (UUID u) = put $ U.toWords u+ get = (UUID . (\(w1,w2,w3,w4) -> U.fromWords w1 w2 w3 w4)) `fmap` get++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, HugoDaniel++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of HugoDaniel nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hblock.cabal view
@@ -0,0 +1,46 @@+-- Initial hblock.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: hblock+version: 0.1.0.0+synopsis: A mutable vector that provides indexation on the datatype fields it stores+-- description: +license: BSD3+license-file: LICENSE+author: HugoDaniel+maintainer: mr.hugo.gomes@gmail.com+-- copyright: +category: Data+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Data.HBlock+ , Data.Indexation.SimpleIx+ , Data.Indexation.NormalIx+ , Data.Indexation.Constraints+ , Data.Indexation.UUID+ -- other-modules: + other-extensions: BangPatterns+ , TypeFamilies+ , RankNTypes+ , DeriveDataTypeable+ , GeneralizedNewtypeDeriving+ ghc-options: -Wall -O2+ build-depends: base >=4.6 && <4.7+ , vector >=0.10 && <0.11+ , containers >=0.5 && <0.6+ , safecopy >=0.8 && <0.9+ , unordered-containers >=0.2 && <0.3+ , hashable >=1.2 && <1.3+ , uuid >=1.3.3+ , blaze-markup+ , path-pieces+ , text+ , aeson+ , deepseq+ , cereal+ , bytestring+ -- hs-source-dirs: + default-language: Haskell2010