Split B monad into its own module

4 files changed, 183 insertions, 82 deletions

diff --git a/Bustle.hs b/Bustle.hs
index 237477a..99c9c76 100644
--- a/Bustle.hs
+++ b/Bustle.hs
@@ -16,8 +16,7 @@ You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 -}
-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses,
-             ScopedTypeVariables, FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
 module Main (main)
 where
 
@@ -30,18 +29,19 @@ import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Error
 
-import Data.IORef
 import Data.Maybe (isJust, isNothing, fromJust)
 import qualified Data.Set as Set
 import Data.Set (Set)
 import Data.Version (showVersion)
 
 import Paths_bustle
+import Bustle.Application.Monad
 import Bustle.Parser
 import Bustle.Renderer (process)
 import Bustle.Types
 import Bustle.Diagram
 import Bustle.Upgrade (upgrade)
+import Bustle.Util
 
 import System.Glib.GError (GError(..), catchGError)
 
@@ -53,32 +53,8 @@ import Graphics.Rendering.Cairo (withPDFSurface, renderWith)
 import System.Process (runProcess)
 import System.Environment (getArgs)
 import System.FilePath (splitFileName, dropExtension)
-import System.IO (hPutStrLn, stderr)
 
-{-
-Cunning threadable monad. Inspired by Monadic Tunnelling
-<http://www.haskell.org/pipermail/haskell-cafe/2007-July/028501.html>
-
-This is a state monad, secretly implemented with an IORef. The idea is to make
-it possible to reconstitute the monad within a Gtk callback. Given:
-
-  x :: Badger
-  onDance :: Badger -> IO a -> IO ()
-  dancedCB :: B a
-
-  onMeme :: Badger -> (Mushroom -> IO a) -> IO ()
-  memedCB :: Mushroom -> B a
-
-One can write:
-
-  embedIO $ onDance x . makeCallback dancedCB
-
--}
-
-type BEnv = (BConfig, BState)
-
-newtype B a = B (ReaderT (IORef BEnv) IO a)
-  deriving (Functor, Monad, MonadIO)
+type B a = Bustle BConfig BState a
 
 type Details = (FilePath, String, Diagram)
 data WindowInfo = WindowInfo { wiWindow :: Window
@@ -96,40 +72,6 @@ data BState = BState { windows :: Int
                      , initialWindow :: Maybe WindowInfo
                      }
 
-instance MonadState BState B where
-  get = B $ ask >>= fmap snd . liftIO . readIORef
-  put x = B $ ask >>= \r -> liftIO $ modifyIORef r (\(conf, _) -> (conf, x))
-
-instance MonadReader BConfig B where
-    ask = B $ ask >>= fmap fst . liftIO . readIORef
-    -- FIXME: I don't actually think it's possible to implement local without
-    -- keeping two refs or something. I guess I could make a temporary ioref,
-    -- and propagate any changes to the actual state part of the ref to the
-    -- outside world. This would break horribly in the face of threads. Or we
-    -- could do something like:
-    --   MVar (BConfig, MVar BState)
-    local = error "Sorry, Dave, I can't let you do that."
-
-embedIO :: (IORef BEnv -> IO a) -> B a
-embedIO act = B $ do
-  r <- ask
-  liftIO $ act r
-
-makeCallback :: B a -> IORef BEnv -> IO a
-makeCallback (B act) x = runReaderT act x
-
-runB :: BConfig -> B a -> IO a
-runB config (B act) = runReaderT act =<< newIORef (config, initialState)
-  where
-    initialState = BState { windows = 0
-                          , initialWindow = Nothing
-                          }
-
-{- And now, some convenience functions -}
-
-io :: MonadIO m => IO a -> m a
-io = liftIO
-
 modifyWindows :: (Int -> Int) -> B ()
 modifyWindows f = modify $ \s -> s { windows = f (windows s) }
 
@@ -139,13 +81,6 @@ incWindows = modifyWindows (+1)
 decWindows :: B Int
 decWindows = modifyWindows (subtract 1) >> gets windows
 
-{- End of boilerplate. -}
-
--- Used to log warnings which aren't important to the user, but which should
--- probably be noted.
-warn :: String -> IO ()
-warn = hPutStrLn stderr . ("Warning: " ++)
-
 main :: IO ()
 main = do
     initGUI
@@ -159,8 +94,11 @@ main = do
     let config = BConfig { debugEnabled = debug
                          , bustleIcon = icon
                          }
+        initialState = BState { windows = 0
+                              , initialWindow = Nothing
+                              }
 
-    runB config $ mainB (filter (not . isDebug) args)
+    runB config initialState $ mainB (filter (not . isDebug) args)
   where
     isDebug = (== "--debug")
 
@@ -205,15 +143,6 @@ displayError title body = do
   dialog `afterResponse` \_ -> widgetDestroy dialog
   widgetShowAll dialog
 
--- Converts an Either to an action in an ErrorT.
-toET :: (Monad m, Error e') => (e -> e') -> Either e a -> ErrorT e' m a
-toET f = either (throwError . f) return
-
--- Catches IOExceptions , and maps them into ErrorT
-etio :: (Error e', MonadIO io)
-     => (IOException -> e') -> IO a -> ErrorT e' io a
-etio f act = toET f =<< io (try act)
-
 -- This needs FlexibleInstances and I don't know why. It's also an orphan
 -- instance, which is distressing.
 instance Error (String, String) where
@@ -246,8 +175,8 @@ loadLogWith getWindow session maybeSystem = do
       Right () -> return ()
 
   where readLogFile f = do
-            input <- etio (\e -> (f, show e)) $ readFile f
-            toET (\e -> (f, "Parse error " ++ show e)) $ readLog input
+            input <- handleIOExceptions (\e -> (f, show e)) $ readFile f
+            toErrorT (\e -> (f, "Parse error " ++ show e)) $ readLog input
 
 
 maybeQuit :: B ()
diff --git a/Bustle/Application/Monad.hs b/Bustle/Application/Monad.hs
new file mode 100644
index 0000000..68c0721
--- /dev/null
+++ b/Bustle/Application/Monad.hs
@@ -0,0 +1,105 @@
+{-
+Bustle.Application.Monad: Implementation of the monad used for the UI
+Copyright © 2008–2010 Collabora Ltd.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses,
+             FlexibleInstances #-}
+module Bustle.Application.Monad
+  (
+  -- ^ The Bustle monad
+    Bustle
+  , runB
+
+  -- ^ Tunnelling goo
+  , BustleEnv -- but not the internals
+  , embedIO
+  , makeCallback
+  )
+where
+
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Data.IORef
+
+{- The goal is to have the standard Reader/State stack for immutable and
+ - mutable application state, but also be able to reconstitute it inside GLib
+ - callbacks (which are in IO).
+ -
+ - We implement this by storing both the configuration and the state in an
+ - IORef, and provide functions to reconstitute the environment inside a
+ - callback. Inspired by this excellent email, titled Monadic Tunnelling:
+ -   <http://www.haskell.org/pipermail/haskell-cafe/2007-July/028501.html>
+ -
+ - You're intended to write 'type B a = Bustle SomeConfig SomeState a' for
+ - brevity. Then, within a 'B foo' action, if you want to connect to a GLib
+ - signal, you say something like this:
+ -
+ -    onDance :: Badger -> IO a -> IO ()
+ -    dancedCB :: B a
+ -
+ -    embedIO $ onDance x . makeCallback dancedCB
+ -}
+newtype Bustle config state a = B (ReaderT (BustleEnv config state) IO a)
+  deriving (Functor, Monad, MonadIO)
+
+newtype BustleEnv config state =
+    BustleEnv { unBustleEnv :: IORef (config, state) }
+
+readConfig :: MonadIO m
+           => BustleEnv config state
+           -> m config
+readConfig = liftM fst . liftIO . readIORef . unBustleEnv
+
+readState :: MonadIO m
+          => BustleEnv config state
+          -> m state
+readState  = liftM snd . liftIO . readIORef . unBustleEnv
+
+putState :: MonadIO m
+         => state
+         -> BustleEnv config state
+         -> m ()
+putState new e = liftIO $ do
+    modifyIORef (unBustleEnv e) $ \(conf, _) -> (conf, new)
+
+instance MonadState state (Bustle config state) where
+  get = B $ ask >>= readState
+  put x = B $ ask >>= putState x
+
+instance MonadReader config (Bustle config state) where
+    ask = B $ ask >>= readConfig
+    -- FIXME: I don't actually think it's possible to implement local without
+    -- keeping two refs or something. I guess I could make a temporary ioref,
+    -- and propagate any changes to the actual state part of the ref to the
+    -- outside world. This would break horribly in the face of threads. Or we
+    -- could do something like:
+    --   MVar (BConfig, MVar BState)
+    local = error "Sorry, Dave, I can't let you do that."
+
+embedIO :: (BustleEnv config state -> IO a) -> Bustle config state a
+embedIO act = B $ do
+  r <- ask
+  liftIO $ act r
+
+makeCallback :: Bustle config state a -> BustleEnv config state -> IO a
+makeCallback (B act) x = runReaderT act x
+
+runB :: config -> state -> Bustle config state a -> IO a
+runB config state (B act) = do
+    r <- newIORef (config, state)
+    runReaderT act $ BustleEnv r
diff --git a/Bustle/Util.hs b/Bustle/Util.hs
new file mode 100644
index 0000000..099f8cf
--- /dev/null
+++ b/Bustle/Util.hs
@@ -0,0 +1,67 @@
+{-
+Bustle.Util: miscellaneous utility functions
+Copyright © 2008–2010 Collabora Ltd.
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+-}
+module Bustle.Util
+  (
+    io
+  , warn
+
+  , toErrorT
+  , handleIOExceptions
+
+  -- You probably don't actually want to use this function.
+  , traceM
+  )
+where
+
+import Control.Exception
+import Control.Monad.Error
+import Control.Monad.Trans (MonadIO, liftIO)
+import Debug.Trace (trace)
+import System.IO (hPutStrLn, stderr)
+
+-- Escape hatch to log a value from a non-IO monadic context.
+traceM :: (Show a, Monad m) => a -> m ()
+traceM x = trace (show x) $ return ()
+
+-- Log a warning which isn't worth showing to the user, but which might
+-- interest someone debugging the application.
+warn :: String -> IO ()
+warn = hPutStrLn stderr . ("Warning: " ++)
+
+-- Shorthand for liftIO.
+io :: MonadIO m => IO a -> m a
+io = liftIO
+
+-- Converts an Either to an action in an ErrorT.
+toErrorT :: (Monad m, Error e')
+         => (e -> e')     -- ^ Convert a Left value to the error type e'
+         -> Either e a    -- ^ A possibly-erroneous value
+         -> ErrorT e' m a -- ^ A happily-tranformed value
+toErrorT f = either (throwError . f) return
+
+-- Catches IOExceptions , and maps them into ErrorT. Need a better name.
+
+handleIOExceptions :: (Error e', MonadIO io)
+                   => (IOException -> e') -- ^ Transform an IO exception to our
+                                          --   error type
+                   -> IO a -- ^ an action which may throw an IOException
+                   -> ErrorT e' io a -- ^ woo yay
+handleIOExceptions f act = do
+    result <- io $ try act
+    toErrorT f result
diff --git a/bustle.cabal b/bustle.cabal
index 17c8f99..3f34e74 100644
--- a/bustle.cabal
+++ b/bustle.cabal
@@ -21,7 +21,7 @@ Flag PostCabalizedGtk2HS
 Executable bustle
   Main-is:        Bustle.hs
   Other-modules:  Bustle.Types, Bustle.Parser, Bustle.Diagram, Bustle.Renderer,
-                  Bustle.Upgrade
+                  Bustle.Upgrade, Bustle.Application.Monad, Bustle.Util
   Ghc-options:    -Wall -fno-warn-unused-imports -fno-warn-unused-do-bind
 
   if flag(PostCabalizedGtk2HS)