[Haskell-cafe] Execution Contexts

[Benjamin Franksen]

I finally understood that George Russell's Library is not really about global 
variables. Rather it is about what I want to call 'execution contexts', which 
are -- as Marcin Kowalczyk observed -- a restricted form of dynamically 
scoped variables.

[NB: Another (maybe better) name would have been 'execution environment' but 
the name "environment" is too heavily associated with the related concept of 
process environment (the string to string map given to user processes as an 
implicit argument).]

An execution context is a mutable finite map from types to (monomorphic) 
values. Each IO action implicitly carries exactly one such map and by default 
passes it on to the actions that follow. A function is provided to 
(implicitly) create a new mapping and run a given IO action with the new 
mapping as its execution context, instead of the default one.

[NB: I also understand now why the library uses ThreadIds. This was obscure to 
me at first because in principle all this has nothing to do with concurrency 
(beside the requirement that accessing the context should be thread safe). 
ThreadIds are used simply because they are available as an index and nothing 
else is. Its just a hack.]

Seen this way, the whole thing smells very much of monads. Indeed, the monadic 
implementation is trivial. I attached a proof-of concept implementation, 
using George Russel's 'Dict' as an abstract data type in a separate module 
(copied verbatim from GlobalVariables.hs, see attached file Dict.hs). The 
idea: we define

type Context = MVar Dict

and introduce an eXtended version of the IO monad

type XIO a = StateT Context IO a

together with a small number of simple functions that implement the same 
interface as the original GlobalVariables.hs; no unsafe operations are used, 
everything is Haskell98 + Dynamics. Also ThreadIds do not appear and it is 
not necessary to change forkIO (apart from lifting it, of course). (code is 
in ExecutionContext.hs)

I modified George's test program so that it works with ExecutionContexts. The 
program is completely isomorphic to the original (and does the same, too ;). 
The only major difference is that all IO operations are lifted into the XIO 
monad. Again, almost everything is Haskell98, -fglasgow-exts is only needed 
to derive Typeable (which can also be done manually). (Code is in 
TestExecutionContext.hs)

The only task that remains to support this programming style so that it can be 
used practically, is to redefine IO as XIO in the kernel libraries. The 
annoying liftIOs everywhere (and the necessity to invent higher order lifts 
along the way) would be gone. I am almost sure that even the trick of 
indexing the dictionary via types (and thus the dependency on Data.Typeable 
and ghc extensions) can be avoided with a little more effort.

Ben
-------------- next part --------------
-- -----------------------------------------------------------------------
-- The Dict type
-- -----------------------------------------------------------------------
module Dict (
  Dict,
  emptyDict,
  lookupDict,
  addToDict,
  delFromDict
  ) where

import Data.Dynamic
import Data.Maybe

-- | 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)
-------------- next part --------------
module ExecutionContext where

import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Data.Typeable

import Dict

type Context = MVar Dict

type XIO a = StateT Context IO a

-- evalStateT :: Monad m => StateT s m a -> s -> m a
runWithContext :: Context -> XIO a -> IO a
runWithContext ctx xio = evalStateT xio ctx

runWithEmptyContext :: XIO a -> IO a
runWithEmptyContext xio = do
  ctx <- newMVar emptyDict
  runWithContext ctx xio

lookupWithRegister :: Typeable a => IO a -> XIO a
lookupWithRegister xio = do
  ctx <- get
  -- modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b
  r <- liftIO $ modifyMVar ctx $ \dict -> do
    case lookupDict dict of
      Nothing -> do
        v <- xio
        let (Just dict') = addToDict dict v
        return (dict', v)
      Just v -> do
        return (dict, v)
  put ctx
  return r

withEmptyContext :: XIO a -> XIO a
withEmptyContext xio = liftIO $ runWithEmptyContext xio

liftIO2 :: (IO a -> IO b) -> XIO a -> XIO b
liftIO2 f xio = do
  ctx <- get
  liftIO $ f (runWithContext ctx xio)
-------------- next part --------------
module Main where

import Data.Typeable
import Data.IORef
import Control.Concurrent
import Control.Monad.Trans

import ExecutionContext

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

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

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

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

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

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

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

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

      -- print 5 numbers beginning at 6, still using the old dictionary
      testNumbers 6