--Dfplace 16:19, 12 September 2008 (UTC)

```{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
module IMap where
import Data.FingerTree
import Data.List hiding (insert,delete,lookup)
import Prelude hiding (lookup)
import Data.Monoid

data Elem a b = Elem a b

data Key k v = NoKey | Key k v

instance Eq k => Eq (Key k v) where
(Key j _) == (Key k _) = j == k
NoKey == NoKey         = True
NoKey == (Key _ _)     = False
(Key _ _) == NoKey     = False

instance Ord k => Ord (Key k v) where
compare (Key j _) (Key k _) = compare j k
compare NoKey NoKey         = EQ
compare (Key _ _) NoKey     = GT
compare NoKey (Key _ _ )    = LT

instance Monoid v => Monoid (Key a v) where
mempty                        = NoKey
k `mappend` NoKey             = k
NoKey `mappend` k             = k
(Key _ x) `mappend` (Key k y) = Key k (x `mappend` y)

data IMap a b = IMap (FingerTree (Key a b) (Elem a b))

instance (Monoid b) => Measured (Key a b) (Elem a b) where
measure (Elem x y) = Key x y

insert :: (Ord k, Monoid v) => k -> v -> IMap k v -> IMap k v
insert k v (IMap xs) = insert' \$ viewl r
where
(l,r) = split (>= Key k undefined) xs
new = IMap ( l >< (Elem k v <| r))
insert' ((Elem y _) :< r')
| k == y    = IMap ( l >< (Elem k v <| r'))
| otherwise = new
insert' EmptyL  = new

delete :: (Ord k, Monoid v) => k -> IMap k v -> IMap k v
delete x (IMap xs) = IMap (l >< r')
where
(l,r)  = split (>= Key x undefined) xs
(_,r') = split (> Key x undefined) r

lookup :: (Monad m, Ord t, Monoid v) => t -> IMap t v -> m v
lookup x (IMap xs) = lookup' \$
viewl . snd \$
split (>= Key x undefined) xs
where
lookup' ((Elem y v) :< _)
| y == x    = return v
| otherwise = fail "IMap.lookup failed"
lookup' EmptyL  = fail "IMap.lookup failed"

getValue :: (Monoid v) => IMap k v -> v
getValue (IMap xs) = let (Key _ v) = measure xs in v
```