[Haskell] Dynamic database updated by list using existential types

[Rene de Visser]

The following code took me several hours to work out.
I post it here, so perhaps other can avoid the difficulties of working out 
how to use existential types.

Improvements welcome.

If anyone thinks it is worth it I could add it to the wiki under existential 
types (I didn't find the examples there very helpful).

Hopefully my newreader won't destroy the layout.

Rene.

{-# OPTIONS -fglasgow-exts #-}
module Record where
-- Demo of an extensible updatable database using Data.Dynamic and Data.Map
-- which can be updated by a list of updates which are implemented
-- using existential types.

import Control.Concurrent.MVar
import qualified Data.Map as M
import Data.Dynamic

type Tables = M.Map Int Dynamic -- the dynamic database

-- look up a table in the database based on it's type
class Typeable a => GetType a where
  getValue :: Tables -> MVar a
  getValue tables  = case M.lookup index tables of
                              Just d -> case fromDynamic d of
                                           Just e -> e
                              _ -> error $ "Table with index " ++ show index 
++ " not in database."
                   where index = tabIndex (undefined::a)
  tabIndex :: a -> Int

-- Manually create indexes for each table. This could be probably done 
automatically
-- using Oleg's type to integer  code.
instance GetType IntColl where
  tabIndex _ = 1

instance GetType CatString where
  tabIndex _ = 2

-- Define the update function for the table
class (GetType m) => Table m where
   apply :: (m ->m) -> Tables ->  IO ()
   apply f tables = modifyMVar_ table (\v -> return $! f v)
      where table :: MVar m
            table = getValue tables

-- Existential type to allow updates to various tables
data SRec = forall m. Table m => SRec (m -> m)

update_db tables (SRec f) = apply f tables -- helper function

-- Define how the update is done to each table
class Mod_def r m | r -> m where
  apply_record :: r -> m -> m

-- Define a type for each table
data IntColl = IntColl Int deriving (Typeable, Show)
data CatString = CatString String deriving (Typeable, Show)

instance Mod_def Int IntColl where
  apply_record i (IntColl j) = IntColl (i + j)

instance Mod_def String CatString where
  apply_record i (CatString j) = CatString (i ++ j)

-- Register the tables
instance Table IntColl
instance Table CatString

-- Create an update record
updater :: forall r m. (Table m, Mod_def r m) => r -> SRec
updater rec = SRec ((\db -> apply_record rec db) :: (m -> m))

-- Some simple tests to get the typing right
newDB :: (GetType a) => a -> IO Tables
newDB x = do var <- newMVar x
             return $! M.singleton (tabIndex x) $ toDyn var
test2 :: SRec -> IO ()
test2 f = newDB (IntColl 3) >>= (\ db -> update_db db f)
test3 = test2 (updater (1::Int))

newTable :: (Typeable (MVar a), GetType a) => a -> IO (Int, Dynamic)
newTable x = do mv <- newMVar x
                return (tabIndex x, toDyn mv)

test4 = do initial_db <- sequence [newTable $ IntColl 5, newTable $ 
CatString " again"]
           let db = M.fromList initial_db
           mapM (update_db db) [updater (1::Int), updater "hello"]
           content <- readMVar (getValue db :: MVar IntColl)
           print content