Reduced clutter in monadic code

+ Eliminated vairous ad-hoc coersion functions between specific monads 
  (IO, Err, IOE, Check) in favor of more general lifting functions
  (liftIO, liftErr).
+ Generalized many basic monadic operations from specific monads to
  arbitrary monads in the appropriate class (MonadIO and/or ErrorMonad),
  thereby completely eliminating the need for lifting functions in lots
  of places.

This can be considered a small step forward towards a cleaner
compiler API and more malleable compiler code in general.

1 files changed, 25 insertions, 24 deletions

diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index 00eec6e30..e22ded71e 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -51,8 +51,8 @@ link opts cnc gr = do
   putPointE Normal opts "linking ... " $ do
     let abs = err (const cnc) id $ abstractOfConcrete gr cnc
     pgf <- mkCanon2pgf opts gr abs
-    probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
-    ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK"     
+    probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
+    when (verbAtLeast opts Normal) $ putStrE "OK"
     return $ setProbabilities probs 
            $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
 
@@ -73,14 +73,14 @@ compileSourceGrammar opts gr = do
 -- to output an intermediate stage
 intermOut :: Options -> Dump -> Doc -> IOE ()
 intermOut opts d doc
-  | dump opts d = ioeIO (hPutStrLn stderr (render (text "\n\n--#" <+> text (show d) $$ doc)))
+  | dump opts d = ePutStrLn (render (text "\n\n--#" <+> text (show d) $$ doc))
   | otherwise   = return ()
 
 warnOut opts warnings
   | null warnings = return ()
-  | otherwise     = ioeIO $ hPutStrLn stderr ws `catch` oops
+  | otherwise     = liftIO $ ePutStrLn ws `catch` oops
   where
-    oops _ = hPutStrLn stderr "" -- prevent crash on character encoding problem
+    oops _ = ePutStrLn "" -- prevent crash on character encoding problem
     ws = if flag optVerbosity opts == Normal
          then '\n':warnings
          else warnings
@@ -99,37 +99,37 @@ compileModule opts1 env file = do
   file <- getRealFile file
   opts0 <- getOptionsFromFile file
   curr_dir <- return $ dropFileName file
-  lib_dir  <- ioeIO $ getLibraryDirectory (addOptions opts0 opts1)
+  lib_dir  <- liftIO $ getLibraryDirectory (addOptions opts0 opts1)
   let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
-  ps0 <- ioeIO $ extendPathEnv opts
+  ps0 <- liftIO $ extendPathEnv opts
   let ps = nub (curr_dir : ps0)
-  ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ----
+  liftIO $ putIfVerb opts $ "module search path:" +++ show ps ----
   let (_,sgr,rfs) = env
   files <- getAllFiles opts ps rfs file
-  ioeIO $ putIfVerb opts $ "files to read:" +++ show files ----
+  liftIO $ putIfVerb opts $ "files to read:" +++ show files ----
   let names = map justModuleName files
-  ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ----
+  liftIO $ putIfVerb opts $ "modules to include:" +++ show names ----
   foldM (compileOne opts) (0,sgr,rfs) files
   where
     getRealFile file = do
-      exists <- ioeIO $ doesFileExist file
+      exists <- liftIO $ doesFileExist file
       if exists
         then return file
         else if isRelative file
-               then do lib_dir <- ioeIO $ getLibraryDirectory opts1
+               then do lib_dir <- liftIO $ getLibraryDirectory opts1
                        let file1 = lib_dir </> file
-                       exists <- ioeIO $ doesFileExist file1
+                       exists <- liftIO $ doesFileExist file1
                        if exists
                          then return file1
-                         else ioeErr $ Bad (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1)))
-               else ioeErr $ Bad (render (text "File" <+> text file <+> text "does not exist."))
+                         else raise (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1)))
+               else raise (render (text "File" <+> text file <+> text "does not exist."))
 
 compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
 compileOne opts env@(_,srcgr,_) file = do
 
   let putpOpt v m act
        | verbAtLeast opts Verbose = putPointE Normal opts v act
-       | verbAtLeast opts Normal  = ioeIO (putStrFlush m) >> act
+       | verbAtLeast opts Normal  = putStrE m >> act
        | otherwise                = putPointE Verbose opts v act
 
   let path = dropFileName file
@@ -140,13 +140,14 @@ compileOne opts env@(_,srcgr,_) file = do
     -- for compiled gf, read the file and update environment
     -- also undo common subexp optimization, to enable normal computations
     ".gfo" -> do
-       sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ ioeIO (decodeModule file)
+       sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ liftIO (decodeModule file)
        let sm0 = (fst sm00, (snd sm00) {mflags = mflags (snd sm00) `addOptions` opts})
 
        intermOut opts (Dump Source) (ppModule Internal sm0)
 
        let sm1 = unsubexpModule sm0
-       (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ runCheck $ extendModule srcgr sm1
+       (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -}
+                        runCheck $ extendModule srcgr sm1
        warnOut opts warnings
 
        if flag optTagsOnly opts
@@ -158,14 +159,14 @@ compileOne opts env@(_,srcgr,_) file = do
     -- for gf source, do full compilation and generate code
     _ -> do
 
-      b1 <- ioeIO $ doesFileExist file
+      b1 <- liftIO $ doesFileExist file
       if not b1
         then compileOne opts env $ (gf2gfo opts file)
         else do
 
        sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ 
                                            getSourceModule opts file
-       enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00))))
+       enc <- liftIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00))))
        let sm = decodeStringsInModule enc sm00
 
        intermOut opts (Dump Source) (ppModule Internal sm)
@@ -215,8 +216,8 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
     idump pass = intermOut opts (Dump pass) . ppModule Internal
 
     -- * Impedance matching
-    runPass = runPass' fst fst snd (ioeErr . runCheck)
-    runPass2 = runPass2e ioeErr
+    runPass = runPass' fst fst snd (liftErr . runCheck)
+    runPass2 = runPass2e liftErr
     runPass2' = runPass2e id id Canon
     runPass2e lift f = runPass' id f (const "") lift
 
@@ -234,7 +235,7 @@ writeGFO opts file mo = do
   let mo1 = subexpModule mo
       mo2 = case mo1 of
               (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
-  putPointE Normal opts ("  write file" +++ file) $ ioeIO $ encodeModule file mo2
+  putPointE Normal opts ("  write file" +++ file) $ liftIO $ encodeModule file mo2
 
 -- auxiliaries
 
@@ -247,7 +248,7 @@ extendCompileEnvInt (_,gr,menv) k mfile mo = do
   menv2 <- case mfile of
     Just file -> do
       let (mod,imps) = importsOfModule mo
-      t <- ioeIO $ getModificationTime file
+      t <- liftIO $ getModificationTime file
       return $ Map.insert mod (t,imps) menv
     _ -> return menv
   return (k,prependModule gr mo,menv2) --- reverse later