[Haskell-cafe] Safely polymorphic unsafePerformIO

[Joel Reymont]

On Dec 12, 2005, at 11:31 AM, Bulat Ziganshin wrote:
> Hello Joel,
>
> this code really looks strange: you asks to create global veriable,
> but don't say its type :)  polymorhism is for functions definitions,
> any concrete data in Haskell have concrete type

It's a long story but I'll try to explain. I would also emphasize  
that the code works and the type checker complains if I try to use,  
say, Event String once Event Int has been used.

So this is how I do it...

This chunk lives in my internal libraries that I deliver to the  
client. I have some pre-defined events and let the user of the  
library come up with custom ones.

data Event a
     = Go
     | Quit
     | ForcedQuit
     | NetworkError Exception
     | Timeout String
     | Cmd Command
     | Custom a
     deriving Show

Yes, this looks bad but keep reading! The 'a' is the same throughout.

type Child a = (MVar (), TMVar (ClockTime, (Event a)), MVar ThreadId)

{-# NOINLINE children #-}
children :: MVar [Child a]
children = unsafePerformIO $ newMVar []

forkChild :: Show a => (TMVar (ClockTime, (Event a)) -> IO ()) -> IO  
ThreadId
forkChild io =
     do mvar <- newEmptyMVar
        mbx <- atomically $ newEmptyTMVar
        childs <- takeMVar children
        thread <- newEmptyMVar
        putMVar children ((mvar, mbx, thread):childs)
        tid <- forkIO (io mbx `finally` putMVar mvar ())
        putMVar thread tid
        return tid

This is the poker bot state. I use the 'b' for the user data type.

data World a b = World
     {
...
      dispatchers :: ![(String, Dispatcher a b)],
      trace_filter:: Event a -> Bool,
...
      user_data :: !(Maybe b)
     }

The monad...

type ScriptState a b = ErrorT String (StateT (World a b) IO)
type ScriptResult a b = IO (Either String (), World a b)

This is the type signature for the bot fun...

type Dispatcher a b = Event a -> ((ScriptState a b) (Status a))

data Status a
     = Start
     | Eat (Maybe (Event a))
     | Skip
     deriving Show

What each bot should return. Eat means do not process any further  
dispatchers in the list of dispatchers kept in the bot state (World  
above). Skip will continue processing by calling dispatchers upstream  
with the same event.

Dispatchers can fail thus they are in the ScriptState monad.

This bit is actually exported

getdata :: Show b => (ScriptState a b) b
getdata =
     do w <- get
        return $ fromJust $ user_data w

setdata :: b -> (ScriptState a b) ()
setdata b =
     do w <- get
        put_ $ w { user_data = Just $ b }

launch :: (Show a, Show b) =>
           HostInfo -> Dispatcher a b -> IO ()
launch hi script =
     do forkChild $ run hi script
        liftIO $ sleep_ 10
        return ()

This is what a user "script" looks like. We are almost there, I promise!

data CustomEvent
     = Tables [TableInfo]
     | LoggedIn
     | JoinedTable Word32
     | SeatTaken Word8
     | SeatNotTaken Word8
     | DealerChip
     | Quorum
     deriving Show

main =
     do initSnippets
        launch host script
        sleep_ 2000 -- 2 seconds
        waitToFinish

Notice the call to setdata (). The type of 'b' will not be known  
without it and ghc will not compile the program.

script Go =
     do startScript
        setdata ()
        trace 10 "Kicking off"
        push "goToLobby" $ goToLobby [28]
        return $ Eat $ Just Go

script (Custom (JoinedTable 0)) =
     do trace 10 "We are in the lobby"
        return $ Eat $ Just Quit

script (Timeout _) =
     fail $ "Script: Timeout received"

script event =
     do fail $ "script: event: " ++ show event
        return Skip

Now, as soom as I use my custom event in the script, 'a' in the  
dispatcher signature and everywhere else will be "bound" to  
CustomEvent and thus the chunk of code below will be resolved.

{-# NOINLINE children #-}
children :: MVar [Child a]
children = unsafePerformIO $ newMVar []

As soon as you try to post a different event somewhere in the script  
ghc will complain of a type mismatch and suggest that you use  
CustomEvent instead. Problem solved, everything works.

Did I explain this to everyone's satisfaction? Have I supplied enough  
context?  Is my code beautiful and efficient?

Finally, does anyone have _constructive_ criticism to offer? :D

	Thanks, Joel

--
http://wagerlabs.com/