[Haskell] Global Variables and IO initializers

[George Russell]

Thanks to the encouraging post

    http://www.haskell.org//pipermail/haskell/2004-November/014748.html

from Benjamin Franksen, I have implemented
my proposal which allows the user to define new global variables without
unsafePerformIO, NOINLINE and other such horrors.

    http://www.haskell.org//pipermail/haskell/2004-November/014748.html

The module itself is in GlobalVariables.hs; a short example of its use and a test case
(generating unique natural numbers) is in TestGlobalVariables.hs.  Both files
are attached to this message.

Here are some things I think people should like about this method.
(1) It's typesafe.
(2) The order in which things happen is well-defined, provided that the
order in which the external functions are called is.
(3) It needs no extensions to the Haskell language, and only fairly
standard hierarchical libraries like Data.IORef.
(4) With withEmptyDict, you can run actions within your program that start with a
completely clean slate and don't clobber your existing global variables.  (This
could be used if you are GHCi and want to run code inside a sandbox, or if you
have separate processors and want each to have its own global variables.)
(5) We avoid any concurrency primitives which might block (no MVars!).

Some things people might not like so much.
(1) You are not allowed to have two global variables with the same type (since they
are indexed by type.
(2) Global variables can only be accessed by an IO action.  (You could not implement
stdout :: Handle, you'd have to implement getstdout :: IO Handle.)
(3) To implement withEmptyDict, it is necessary to (a) use ThreadId's, which means
the code won't work on Hugs; (b) use a special version of forkIO (whose implementation
is included) which makes sure new dictionaries are inherited.
(4) Dictionaries are unnecessarily slow (linear access time in numbers of entries).

Neither (1) or (2) bother me much, because I virtually always use global variables like
that anyway.  I hope (3)(a) will be addressed someday by Hugs implementing ThreadId's,
and for (3)(b) I would suggest either making this the default forkIO action, or
providing a "Who's my parent" primitive.  (4) would be easy to resolve if Data.Dynamic.TypeRep
were made to instance Ord, which I think should be trivial (for GHC at least).

Anyway, it's not perfect, but I think it's the best solution, and I condemn it to
haskell.org ...
-------------- next part --------------
{- Program to test global variables by implementing a source of unique
   natural numbers. -}
module Main where

import Data.Dynamic
import Data.IORef
import Data.GlobalVariables

import Control.Concurrent.MVar

-- --------------------------------------------------------------------
-- Source of unique natural numbers
-- --------------------------------------------------------------------

data UniqueNaturalSource 
   = UniqueNaturalSource (IORef Integer) deriving (Typeable)

mkUniqueNaturalSource :: IO UniqueNaturalSource
mkUniqueNaturalSource =
   do
      ioRef <- newIORef 1
      return (UniqueNaturalSource ioRef)

getNextNatural :: IO Integer
getNextNatural =
   do
      (UniqueNaturalSource ioRef) <- lookupWithRegister mkUniqueNaturalSource
      atomicModifyIORef ioRef (\ i -> (i+1,i))

-- --------------------------------------------------------------------
-- A little test program
-- --------------------------------------------------------------------

main :: IO ()
main =
   do
      let
         p =
            do
               n <- getNextNatural
               putStrLn (show n)

      -- put in lots of forkIO's to make things interesting.
      let
         testNumbers i =
            do
               putStrLn ("Numbers starting at " ++ show i)
               wait <- newEmptyMVar

               forkIO (
                  do
                     p
                     p
                     p
                     forkIO (
                        do
                           p
                           forkIO (
                              do
                                 p
                                 putMVar wait () 
                              )
                           return ()
                        )
                     return ()
                  )
               takeMVar wait
      -- print 5 numbers beginning at 1.
      testNumbers 1
      -- print 5 numbers beginning at 1 again, with a new dictionary.
      withEmptyDict (testNumbers 1)

      -- print 5 numbers beginning at 6, still using the old dictionary
      testNumbers 6
                
-------------- next part --------------
-- |
-- Description: Tool for initialising global variables
--
-- At the moment this is inefficient, mainly because of the pitiful
-- support by the standard libraries for indexing on TypeRep's and ThreadId's.
-- Someone please make TypeRep instance Ord and provide a hash function for
-- ThreadId!!
module Data.GlobalVariables(
   lookupWithRegister,
   withEmptyDict,
   withFreshDict,
   forkIO,
   ) where

import Maybe
import List

import Data.IORef
import Data.Dynamic
import Data.FiniteMap
import System.IO.Unsafe
import Control.Exception
import Control.Concurrent hiding (forkIO)
import qualified Control.Concurrent

-- -----------------------------------------------------------------------
-- The user interface
-- -----------------------------------------------------------------------

-- | Look up some global variable.  The initial action constructs it if
-- necessary.
lookupWithRegister :: Typeable a => IO a -> IO a
lookupWithRegister initialisationAction  =
   do
      let
         updateFn dict =
            case lookupDict dict of
               Just a -> (dict,a)
               Nothing -> 
                  let
                     a = unsafePerformIO initialisationAction
                     Just dict2 = addToDict dict a 
                  in
                     (dict2,a)

      a <- updateDictState updateFn
      seq a (return a)

-- | Perform some action and the child threads it splits off with
-- an alternative dictionary which is initially empty.
withEmptyDict :: IO a -> IO a
withEmptyDict = withOtherDict (\ _ -> emptyDict)

-- | Perform some action and the child threads it splits off with
-- a fresh dictionary split off from the current one.
withFreshDict :: IO a -> IO a
withFreshDict = withOtherDict id

-- | Perform some action and the child threads it splits off with
-- a dictionary computed from the current one.
withOtherDict :: (Dict -> Dict) -> IO a -> IO a
withOtherDict newDictFn action =
   do
      oldDictRefOpt <- getDictRefOpt
      oldDict <- readIORef (case oldDictRefOpt of
         Nothing -> defaultDict theDictState
         Just oldDictRef -> oldDictRef
         )
      let
         newDict = newDictFn oldDict
      newDictRef <- newIORef newDict
      setDictRef newDictRef
      finally 
         action      
         (case oldDictRefOpt of
            Nothing -> forgetDict
            Just oldDictRef -> setDictRef oldDictRef
            )

-- -----------------------------------------------------------------------
-- The Dict type
-- -----------------------------------------------------------------------

-- | Stores a set of elements with distinct types indexed by type
-- NB.  Needs to use a FiniteMap, when TypeRep's instance Ord.
newtype Dict = Dict [(TypeRep,Dynamic)]

-- | Dict with no elements.
emptyDict :: Dict
emptyDict = Dict []

-- | Retrieve an element from the dictionary, if one of that type exists.
lookupDict :: Typeable a => Dict -> Maybe a
lookupDict (Dict list) =
   let
      -- construct a dummy value of the required type so we can get at its
      -- TypeRep.
      Just dummy = (Just undefined) `asTypeOf` aOpt

      -- get at the required result type.
      dynOpt = lookup (typeOf dummy) list 

      aOpt = case dynOpt of
         Nothing -> Nothing
         Just dyn -> 
            Just (
               fromMaybe 
                  (error "Inconsistent type in Dict")
                  (fromDynamic dyn)
               )
   in
      aOpt

-- | Add an element to the dictionary if possible, or return Nothing if it
-- isn't because one of that type already exists.
addToDict :: Typeable a => Dict -> a -> Maybe Dict
addToDict (Dict list) val =
   let
      typeRep = typeOf val
   in
      case lookup typeRep list of
         Just _ -> Nothing
         Nothing -> Just (Dict ((typeRep,toDyn val) : list))
            
-- | Delete an element from the dictionary, if one is in it, or return Nothing
-- if it isn't.
delFromDict :: Typeable a 
   => Dict 
   -> a -- ^ this value is only interesting for its type, and isn't looked at.
   -> Maybe Dict
delFromDict (Dict list) val =
   let
      typeRep = typeOf val

      dList [] = Nothing
      dList ((hd@(typeRep2,_)):list2) = 
         if typeRep == typeRep2
            then
               Just list2
            else
               fmap (hd:) (dList list2)
   in
      fmap Dict (dList list)

-- -------------------------------------------------------------------------
-- The DictState type.  This should contain all your program's global state.
-- -------------------------------------------------------------------------

data DictState = DictState {
   stateRef :: IORef (FiniteMap ThreadId (IORef Dict)),
   defaultDict :: IORef Dict
      -- this corresponds to the main program and is used when we can't 
      -- determine a dictionary for a thread.
   }

theDictState :: DictState
theDictState = unsafePerformIO (
   do
      stateRef <- newIORef emptyFM
      defaultDict <- newIORef emptyDict

      return (DictState {stateRef = stateRef,defaultDict = defaultDict})
   )
{-# NOINLINE theDictState #-}

-- | Get the current DictRef for a thread
getDictRef :: IO (IORef Dict)
getDictRef =
   do
      dictRefOpt <- getDictRefOpt
      return (fromMaybe (defaultDict theDictState) dictRefOpt)

-- | Update the dictionary for this thread with the given update function
-- and returning the result. 
updateDictState :: (Dict -> (Dict,result)) -> IO result
updateDictState modifyFn = 
   do
      dictRef <- getDictRef
      atomicModifyIORef dictRef modifyFn

-- | Get the dictionary for this thread, if any.
getDictRefOpt :: IO (Maybe (IORef Dict))
getDictRefOpt =
   do
      threadId <- myThreadId
      fm0 <- readIORef (stateRef theDictState)
      return (lookupFM fm0 threadId)

-- | Set the dictionary ref for this thread.
setDictRef :: IORef Dict -> IO ()
setDictRef dictRef =
   do
      threadId <- myThreadId
      atomicModifyIORef (stateRef theDictState)
         (\ fm0 -> (addToFM fm0 threadId dictRef,()))

-- | Forget this thread's dictionary.  (This is necessary for garbage 
-- collection.)
forgetDict :: IO ()
forgetDict =
   do
      threadId <- myThreadId
      atomicModifyIORef (stateRef theDictState)
         (\ fm0 -> (delFromFM fm0 threadId,()))

-- Use as a substitute for normal forkIO, so that dictionaries get 
-- inherited.
forkIO :: IO () -> IO ThreadId
forkIO actToFork =
   do
      dictRefOpt <- getDictRefOpt
      case dictRefOpt of
         Nothing -> Control.Concurrent.forkIO actToFork
         Just dictRef ->
            let
               actToFork2 =
                  finally (
                     do 
                        setDictRef dictRef                     
                        actToFork
                     )
                  forgetDict
            in
               Control.Concurrent.forkIO actToFork2