From 8337a19b40301bfda5dd74c6d975072f168538de Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Mon, 20 Oct 2014 19:32:46 +0000
Subject: [PATCH] type IOE a = IO a

IOE used to be a monad with extra error handling built on top of the IO monad,
But the IO monad already supports error handling, so this construction was a
superfluous.

The new 'instance ErrorMonad IOE' is defined to preserve the previous error
handling behaviour, i.e. the function 'handle' only catches errors thrown with
'raise' (or 'fail') and not other errors in the IO monad.
---
 src/compiler/GF/CompileInParallel.hs |  2 +-
 src/compiler/GF/Infra/UseIO.hs       | 36 +++++++++++++++++-----------
 2 files changed, 23 insertions(+), 15 deletions(-)

diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs
index b0a69019e..52aab40f6 100644
--- a/src/compiler/GF/CompileInParallel.hs
+++ b/src/compiler/GF/CompileInParallel.hs
@@ -79,7 +79,7 @@ batchCompile1 lib_dir (opts,filepaths) =
      deps <- newMVar M.empty
      toLog <- newLog runIOE
      let --logStrLn = toLog . ePutStrLn
-         ok :: CollectOutput IOE a -> IO a
+       --ok :: CollectOutput IO a -> IO a
          ok (CO m) = err bad good =<< appIOE m
            where
               good (o,r) = do toLog o; return r
diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs
index 58010f7f9..80677658a 100644
--- a/src/compiler/GF/Infra/UseIO.hs
+++ b/src/compiler/GF/Infra/UseIO.hs
@@ -32,7 +32,7 @@ import System.Exit
 import System.CPUTime
 --import System.Cmd
 import Text.Printf
-import Control.Applicative(Applicative(..))
+--import Control.Applicative(Applicative(..))
 import Control.Monad
 import Control.Monad.Trans(MonadIO(..))
 import Control.Exception(evaluate)
@@ -125,19 +125,27 @@ splitInModuleSearchPath s = case break isPathSep s of
 
 -- ** IO monad with error; adapted from state monad
 
-newtype IOE a = IOE { appIOE :: IO (Err a) }
+-- | Was: @newtype IOE a = IOE { appIOE :: IO (Err a) }@
+type IOE a = IO a
 
 ioe :: IO (Err a) -> IOE a
-ioe = IOE
+ioe io = err fail return =<< io
 
-runIOE m = err fail return =<< appIOE m
+appIOE :: IOE a -> IO (Err a)
+appIOE ioe = handle (fmap Ok ioe) (return . Bad)
 
-instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
+runIOE :: IOE a -> IO a
+runIOE = id
 
-instance ErrorMonad IOE where
-  raise = ioe . return . Bad
-  handle m h = ioe $ err (appIOE . h) (return . Ok) =<< appIOE m
+-- instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
 
+-- | Make raise and handle mimic behaviour of the old IOE monad
+instance ErrorMonad IO where
+  raise = fail
+  handle m h = catch m $ \ e -> if isUserError e
+                                then h (ioeGetErrorString e)
+                                else ioError e
+{-
 instance Functor IOE where fmap = liftM
 
 instance Applicative IOE where
@@ -150,12 +158,12 @@ instance  Monad IOE where
                   x <- c          -- Err a
                   appIOE $ err raise f x         -- f :: a -> IOE a
   fail = raise
-
+-}
 useIOE :: a -> IOE a -> IO a
-useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return 
+useIOE a ioe = handle ioe (\s -> putStrLn s >> return a)
 
 maybeIO io = either (const Nothing) Just `fmap` liftIO (try io)
-
+{-
 --foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
 foldIOE f s xs = case xs of
   [] -> return (s,Nothing)
@@ -164,7 +172,7 @@ foldIOE f s xs = case xs of
     case ev of 
       Ok v  -> foldIOE f v xx
       Bad m -> return $ (s, Just m)
-
+-}
 die :: String -> IO a
 die s = do hPutStrLn stderr s
            exitFailure
@@ -181,13 +189,13 @@ instance Output IO where
     where oops _ = ePutStrLn "" -- prevent crash on character encoding problem
   putStrLnE s = putStrLn s >> hFlush stdout
   putStrE   s = putStr s >> hFlush stdout
-
+{-
 instance Output IOE where
   ePutStr   = liftIO . ePutStr
   ePutStrLn = liftIO . ePutStrLn
   putStrLnE = liftIO . putStrLnE
   putStrE   = liftIO . putStrE
-
+-}
 --putPointE :: Verbosity -> Options -> String -> IO a -> IO a
 putPointE v opts msg act = do
   when (verbAtLeast opts v) $ putStrE msg