module Data.Ref.Map (
Map
, Name
, empty
, singleton
, null
, size
, member
, (!)
, lookup
, insert
, delete
, adjust
, hmap
, union
, difference
, intersection
, HideType(..)
, dump
) where
import Control.Applicative ((<$>))
import Data.Ref
import Data.List (find, deleteBy)
import Data.Function (on)
import Unsafe.Coerce
import System.Mem.StableName
import Data.IntMap (IntMap)
import qualified Data.IntMap as M
import Prelude hiding (null, lookup, map, filter)
type Name = StableName
data HideType f
where
Hide :: f a -> HideType f
data Map f = Map (IntMap [(HideType Name, HideType f)])
empty :: Map f
empty = Map M.empty
singleton :: Name a -> f a -> Map f
singleton n v = Map $ M.singleton (hashStableName n) [(Hide n, Hide v)]
null :: Map f -> Bool
null (Map m) = M.null m
size :: Map f -> Int
size (Map m) = M.size m
member :: Name a -> Map f -> Bool
member n (Map m) = M.member (hashStableName n) m
(!) :: Map f -> Name a -> f a
(!) m name = maybe (error "Data.Ref.Map.(!)") id (lookup name m)
lookup :: Name a -> Map f -> Maybe (f a)
lookup n (Map m) = case M.lookup (hashStableName n) m of
Nothing -> Nothing
Just xs -> case find (\(Hide x,_) -> eqStableName x n) xs of
Nothing -> Nothing
Just (_,Hide f) -> Just $ unsafeCoerce f
insert :: Ref a -> f a -> Map f -> Map f
insert (Ref n _) v (Map m) = Map $ M.insertWith (++) (hashStableName n) [(Hide n, Hide v)] m
delete :: Name a -> Map f -> Map f
delete n map@(Map m) = Map $ M.update del (hashStableName n) m
where
del (_:[]) = Nothing
del xs = Just $ deleteBy apa (Hide n, undefined) xs
apa (Hide x, _) (Hide y, _) = eqStableName x y
adjust :: (f a -> f b) -> Name a -> Map f -> Map f
adjust f n (Map m) = Map $ M.adjust fun (hashStableName n) m
where
fun xs = flip fmap xs $ \pair@(Hide x, Hide v) ->
if eqStableName x n
then (Hide x, Hide $ f $ unsafeCoerce v)
else pair
hmap :: (f a -> h a) -> Map f -> Map h
hmap f (Map m) = Map $ M.map (fmap $ fmap h) m
where
h (Hide x) = Hide $ f $ unsafeCoerce x
union :: Map f -> Map f -> Map f
union (Map m) (Map n) = Map $ M.union m n
difference :: Map f -> Map f -> Map f
difference (Map m) (Map n) = Map $ M.difference m n
intersection :: Map f -> Map f -> Map f
intersection (Map m) (Map n) = Map $ M.intersection m n
dump :: Map f -> [[(HideType Name, HideType f)]]
dump (Map m) = M.elems m