Ticket #6041: Main.hs

File Main.hs, 1.3 KB (added by dsf, 3 years ago)
Line 
1{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances  #-}
2{-
3
4This code hangs when running under Ubuntu Precise. Though a Precise chroot on an Ubuntu Lucid machine works -- indicating it could be kernel specific.
5
6The following changes make the code work:
7
8 1. replacing 'readTVar u' with 'return ()'
9 2. removing the 'Wrapper' monad and just using 'StateT'
10 3. deriving the 'MonadState' instance instead of righting it by hand
11 4. copying the definition of 'modify' into the local module and use that instead of the imported version
12
13-}
14module Main (main) where
15
16import Control.Monad.State    (MonadState, StateT, modify, evalStateT, get, put)
17import Control.Monad.Trans    (MonadIO(liftIO))
18import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar)
19
20newtype Wrapper a = Wrapper { unWrapper :: StateT (TVar ()) IO a }
21    deriving (Functor, MonadIO, Monad)
22
23instance (MonadState (TVar ()) Wrapper) where 
24  get   = Wrapper get
25  put s = Wrapper (put s)
26
27setUnique :: Wrapper ()
28setUnique =
29    do u <- get
30       _ <- liftIO $ atomically $ readTVar u
31       return ()
32
33main :: IO ()
34main =
35      do putStrLn "hello"
36         u <- atomically $ newTVar ()
37         evalStateT (unWrapper (modify id >> setUnique)) u