Typesafe MRef with a regular monad

[oleg@pobox.com]

> update  :: (Typable b) => FM k -> Key k a -> b -> (FM ...)

I didn't know constraints on values are allowed... Given below is the
implementation of the required interface, in Haskell98

   module TypedFM where
        data FM k     -- Abstract; finite map indexed bykeys of type k
        data Key k a  -- Abstract; a key of type k, indexing a value of type a
 
        empty :: FM k
        insert :: Ord k => FM k -> k -> a -> (FM k, Key k a)
        lookup :: Ord k => FM k -> Key k a -> Maybe a
        update :: Ord k => FM k -> Key k a -> a -> FM k


Implementation:

import Monad

data U =  LBool Bool 
        | LChar Char
	| LInt Int
	| LL [U]  -- Lists of any kind
	| LA (U->U) -- monomorophic functions of any kind


class UNIV a where
    inj:: a -> U
    prj:: U -> Maybe a
    

instance UNIV Bool where
    inj = LBool
    prj (LBool a) = Just a
    prj _         = Nothing
    
instance UNIV Char where
    inj = LChar
    prj (LChar a) = Just a
    prj _         = Nothing

instance UNIV Int where
    inj = LInt
    prj (LInt a) = Just a
    prj _         = Nothing
    
instance (UNIV a) => UNIV [a] where
    inj = LL . map inj
    prj (LL as) = foldr f (Just []) as
        where f e (Just s) = case prj e of
	                     Just x -> Just $ x:s
			     _      -> Nothing
	      f _ _ = Nothing
    prj _         = Nothing

instance (UNIV a,UNIV b) => UNIV (a->b) where
    inj f = LA $ \ua -> let (Just x) = prj ua in inj $ f x
    prj (LA f) = Just $ \x -> let Just y = prj$f$inj x in y
    prj _         = Nothing

data FM k = FM [U]

data Key k a = Key Int a

empty = FM []

insert (FM l) _ a = (FM $(inj a):l, Key (length l) a)

lookp:: (UNIV a) => FM k -> Key k a -> Maybe a
lookp (FM l) (Key i a) = prj $ (reverse l)!!i

update:: (UNIV a) => FM k -> Key k a -> a -> FM k
update (FM l) (Key i _) a = FM $ reverse (lb ++ ((inj a):(tail lafter)))
    where (lb,lafter) = splitAt i (reverse l)

	  
test1 = do
	let heap = empty
	let (heap1,xref) = insert heap () 'a'
  	let (heap2,yref) = insert heap1 () [(1::Int),2,3]
  	let (heap3,zref) = insert heap2 () "abcd"
 	putStrLn "\nAfter allocations"
-- 	print heap3

 	putStr "x is "; print $ lookp heap3 xref
 	putStr "y is "; print $ lookp heap3 yref
 	putStr "z is "; print $ lookp heap3 zref
	
 	let heap31 = update heap3  xref 'z'
 	let heap32 = update heap31 yref []
 	let heap33 = update heap32 zref "new string"
 	putStrLn "\nAfter updates"

 	putStr "x is "; print $ lookp heap33 xref
 	putStr "y is "; print $ lookp heap33 yref
 	putStr "z is "; print $ lookp heap33 zref

 	putStrLn "\nFunctional values"
 	let (heap4,gref) = insert heap33 () (\x->x+(1::Int))
 	putStr "g 1 is "; print $ liftM2 ($) (lookp heap4 gref) $ Just (1::Int)
	return ()