Some more monadic lifting changes

src/compiler/GF/Compile.hs

@@ -98,17 +98,17 @@ compileModule :: Options -- ^ Options from program command line and shell comman
 compileModule opts1 env file = do
   file <- getRealFile file
   opts0 <- getOptionsFromFile file
-  curr_dir <- return $ dropFileName file
+  let curr_dir = dropFileName file
   lib_dir  <- liftIO $ getLibraryDirectory (addOptions opts0 opts1)
   let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
-  ps0 <- liftIO $ extendPathEnv opts
+  ps0 <- extendPathEnv opts
   let ps = nub (curr_dir : ps0)
-  liftIO $ putIfVerb opts $ "module search path:" +++ show ps ----
+  putIfVerb opts $ "module search path:" +++ show ps ----
   let (_,sgr,rfs) = env
   files <- getAllFiles opts ps rfs file
-  liftIO $ putIfVerb opts $ "files to read:" +++ show files ----
+  putIfVerb opts $ "files to read:" +++ show files ----
   let names = map justModuleName files
-  liftIO $ putIfVerb opts $ "modules to include:" +++ show names ----
+  putIfVerb opts $ "modules to include:" +++ show names ----
   foldM (compileOne opts) (0,sgr,rfs) files
   where
     getRealFile file = do

src/compiler/GF/Compile/ReadFiles.hs

@@ -212,11 +212,11 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
 -- | options can be passed to the compiler by comments in @--#@, in the main file
 getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
 getOptionsFromFile file = do
-  s <- handle (liftIO $ BS.readFile file)
-              (\_ -> raise $ "File " ++ file ++ " does not exist")
+  s <- either (\_ -> raise $ "File " ++ file ++ " does not exist") return =<<
+       liftIO (try $ BS.readFile file)
   let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
       fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
-  liftErr $ parseModuleOptions fs
+  parseModuleOptions fs
 
 getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
 getFilePath paths file = liftIO $ get paths

src/compiler/GF/Infra/Option.hs

@@ -38,7 +38,7 @@ import GF.Grammar.Predef
 import System.FilePath
 --import System.IO
 
-import GF.Data.ErrM
+import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -68,8 +68,8 @@ helpMessage = usageInfo usageHeader optDescr
 
 
 -- FIXME: do we really want multi-line errors?
-errors :: [String] -> Err a
-errors = fail . unlines
+errors :: ErrorMonad err => [String] -> err a
+errors = raise . unlines
 
 -- Types
 
@@ -185,17 +185,19 @@ instance Show Options where
 
 -- Option parsing
 
-parseOptions :: [String]                   -- ^ list of string arguments
-             -> Err (Options, [FilePath])
+parseOptions :: ErrorMonad err =>
+                [String]                   -- ^ list of string arguments
+             -> err (Options, [FilePath])
 parseOptions args 
   | not (null errs) = errors errs
-  | otherwise       = do opts <- liftM concatOptions $ sequence optss
+  | otherwise       = do opts <- concatOptions `fmap` liftErr (sequence optss)
                          return (opts, files)
   where
     (optss, files, errs) = getOpt RequireOrder optDescr args
 
-parseModuleOptions :: [String]                   -- ^ list of string arguments
-                   -> Err Options
+parseModuleOptions :: ErrorMonad err =>
+                      [String]                   -- ^ list of string arguments
+                   -> err Options
 parseModuleOptions args = do
   (opts,nonopts) <- parseOptions args
   if null nonopts 

src/compiler/GF/Infra/UseIO.hs

@@ -38,21 +38,21 @@ import Control.Exception(evaluate)
 --putShow' :: Show a => (c -> a) -> c -> IO ()
 --putShow' f = putStrLn . show . length . show . f
 
-putIfVerb :: Options -> String -> IO ()
+putIfVerb :: MonadIO io => Options -> String -> io ()
 putIfVerb opts msg =
-      when (verbAtLeast opts Verbose) $ putStrLn msg
+      when (verbAtLeast opts Verbose) $ liftIO $ putStrLn msg
 
-putIfVerbW :: Options -> String -> IO ()
+putIfVerbW :: MonadIO io => Options -> String -> io ()
 putIfVerbW opts msg =
-      when (verbAtLeast opts Verbose) $ putStr (' ' : msg)
-
+      when (verbAtLeast opts Verbose) $ liftIO $ putStr (' ' : msg)
+{-
 errOptIO :: Options -> a -> Err a -> IO a
 errOptIO os e m = case m of
   Ok x  -> return x
   Bad k -> do  
     putIfVerb os k
     return e
-
+-}
 type FileName = String
 type InitPath = String
 type FullPath = String
@@ -60,13 +60,12 @@ type FullPath = String
 gfLibraryPath    = "GF_LIB_PATH"
 gfGrammarPathVar = "GF_GRAMMAR_PATH"
 
-getLibraryDirectory :: Options -> IO FilePath
+getLibraryDirectory :: MonadIO io => Options -> io FilePath
 getLibraryDirectory opts =
   case flag optGFLibPath opts of
     Just path -> return path
-    Nothing   -> catch
-                   (getEnv gfLibraryPath)
-                   (\ex -> getDataDir >>= \path -> return (path </> "lib"))
+    Nothing   -> liftIO $ catch (getEnv gfLibraryPath)
+                                (\ex -> fmap (</> "lib") getDataDir)
 
 getGrammarPath :: FilePath -> IO [FilePath]
 getGrammarPath lib_dir = do
@@ -76,9 +75,9 @@ getGrammarPath lib_dir = do
 -- | extends the search path with the
 -- 'gfLibraryPath' and 'gfGrammarPathVar'
 -- environment variables. Returns only existing paths.
-extendPathEnv :: Options -> IO [FilePath]
-extendPathEnv opts = do
-  opt_path <- return $ flag optLibraryPath opts         -- e.g. paths given as options
+extendPathEnv :: MonadIO io => Options -> io [FilePath]
+extendPathEnv opts = liftIO $ do
+  let opt_path = flag optLibraryPath opts         -- e.g. paths given as options
   lib_dir  <- getLibraryDirectory opts                  -- e.g. GF_LIB_PATH
   grm_path <- getGrammarPath lib_dir                   -- e.g. GF_GRAMMAR_PATH
   let paths = opt_path ++ [lib_dir] ++ grm_path