{-# OPTIONS -fglasgow-exts -fno-cse #-}
module Data.IO.Dict (
  register,
  standard,
  lookup
  ) where

import Prelude hiding (lookup)
import Foreign
import Data.Dynamic
import Data.Maybe
import Control.Concurrent
import Control.Exception

-- a collection of initialised data.
type Dict = MVar [Dynamic]

thedict :: Dict
{-# NOINLINE thedict #-}
thedict = unsafePerformIO $ newMVar []

-- Each Haskell "main" program will have one of these.
standard :: IO Dict
standard = do
  return thedict

-- register a value of type (a) in the dictionary.  Only one value of each
-- type is allowed in the dictionary; registering the same type twice will
-- cause an exception.
register :: Typeable a => Dict -> a -> IO ()
register dict_var val = modifyMVar_ dict_var register'
  where
    register' :: [Dynamic] -> IO [Dynamic]
    register' d = do
      x <- tryJust errorCalls (lookup' d `asTypeOf` (return val))
      case x of
        Left _ -> return $ (toDyn val):d
        Right val' -> error $ "Dict.register: a value of type (" ++ (show $ typeOf val) ++ ") has already been registered"

-- Get the value of (a) registered in the Dict, or raise an exception if it
-- isn't.
lookup :: Typeable a => Dict -> IO a
lookup dict_var = withMVar dict_var lookup'

lookup' :: Typeable a => [Dynamic] -> IO a
lookup' [] = error "Dict.lookup: not found"
lookup' (dyn:dyns) =
  case fromDynamic dyn of
    Just val -> return val
    Nothing -> lookup' dyns

-- thisThreadDict :: IO Dict

-- newEmptyDict :: IO Dict

-- runWithDifferentDefaultDict :: Dict -> IO a -> IO a