module Data.Binary.Defer.Index(
Id,
Index, newIndex,
Lookup, newLookup, lookupKey, lookupIndex,
Link, newLink, fromLink, linkKey, indexLinks,
Index_, newIndex_, getLink, getLookup, indexFreeze
) where
import General.Util
import Data.Binary.Defer
import Data.Binary.Defer.Array
import qualified Data.Map as Map
import Data.Maybe
import Data.List
import Data.Typeable
type Id = Int
newtype Index a = Index (Array a)
typename_Index = mkTyCon "Data.Binary.Defer.Index.Index"
instance Typeable1 Index where typeOf1 _ = mkTyConApp typename_Index []
instance Typeable a => Typeable (Index a) where typeOf = typeOfDefault
newIndex :: [a] -> Index a
newIndex = Index . array
instance BinaryDefer a => BinaryDefer (Index a) where
put (Index x) = put x
get = get1 Index
instance Show a => Show (Index a) where
show (Index xs) = unlines $ zipWith f [0..] (elems xs)
where
f i x = "#" ++ si ++ replicate (width length si + 1) ' ' ++ show x
where si = show i
width = length $ show $ arraySize xs
instance Functor Index where
fmap f (Index x) = Index $ fmap f x
newtype Lookup a = Lookup {lookupKey :: Id}
deriving (Eq,Ord)
newLookup :: Id -> Lookup a
newLookup = Lookup
lookupIndex :: Lookup a -> Index a -> a
lookupIndex (Lookup i) (Index xs) = xs ! i
instance BinaryDefer (Lookup a) where
put (Lookup key) = put key
get = get1 Lookup
size _ = size (0 :: Id)
putFixed (Lookup key) = putFixed key
getFixed = getFixed1 Lookup
instance Show (Lookup a) where
show (Lookup key) = "#" ++ show key
data Link a = Link Id a
newLink :: Id -> a -> Link a
newLink = Link
fromLink :: Link a -> a
fromLink (Link k v) = v
linkKey :: Link a -> Id
linkKey (Link k v) = k
instance Eq (Link a) where
a == b = linkKey a == linkKey b
instance Ord a => Ord (Link a) where
compare a b = compare (fromLink a) (fromLink b)
instance Show a => Show (Link a) where
show = show . fromLink
instance Typeable a => BinaryDefer (Link a) where
put = put . linkKey
get = do
i <- get
Index xs <- getDeferGet
return $ Link i $ xs ! i
size _ = size (0 :: Id)
putFixed = put
getFixed = get
indexLinks :: Index a -> [Link a]
indexLinks (Index x) = zipWith newLink [0..] $ elems x
newtype Index_ a = Index_ (Map.Map a Id)
instance Show a => Show (Index_ a) where
show = show . indexFreeze
newIndex_ :: Index_ a
newIndex_ = Index_ Map.empty
getLookup :: Ord a => a -> Index_ a -> (Index_ a, Lookup a)
getLookup x y = (a, Lookup $ linkKey b)
where (a,b) = getLink x y
getLink :: Ord a => a -> Index_ a -> (Index_ a, Link a)
getLink x (Index_ mp) = (Index_ mp2, newLink (fromMaybe n res) x)
where (res,mp2) = Map.insertLookupWithKey (\_ _ a -> a) x n mp
n = Map.size mp
indexFreeze :: Index_ a -> Index a
indexFreeze (Index_ mp) = newIndex $ map fst $ sortBy (compare `on` snd) $ Map.toList mp