Add lifted directory operations in GF.System.Directory to eliminate the need for liftIO in various places

src/compiler/GF/Compile.hs

@@ -51,7 +51,7 @@ batchCompile opts files = do
 -- to compile a set of modules, e.g. an old GF or a .cf file
 compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
 compileSourceGrammar opts gr = do
-  cwd <- liftIO getCurrentDirectory
+  cwd <- getCurrentDirectory
   (_,gr',_) <- foldM (\env -> compileSourceModule opts cwd env Nothing)
                      emptyCompileEnv
                      (modules gr)
@@ -81,13 +81,13 @@ compileModule opts1 env@(_,rfs) file =
      foldM (compileOne' opts) env files
   where
     getRealFile file = do
-      exists <- liftIO $ doesFileExist file
+      exists <- doesFileExist file
       if exists
         then return file
         else if isRelative file
                then do lib_dir <- getLibraryDirectory opts1
                        let file1 = lib_dir </> file
-                       exists <- liftIO $ doesFileExist file1
+                       exists <- doesFileExist file1
                        if exists
                          then return file1
                          else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
@@ -108,7 +108,7 @@ extendCompileEnv (gr,menv) (mfile,mo) =
   do menv2 <- case mfile of
                 Just file ->
                   do let (mod,imps) = importsOfModule mo
-                     t <- liftIO $ getModificationTime file
+                     t <- getModificationTime file
                      return $ Map.insert mod (t,imps) menv
                 _ -> return menv
      return (prependModule gr mo,menv2)

src/compiler/GF/Compile/ReadFiles.hs

@@ -139,7 +139,7 @@ findFile gfoDir ps name =
         noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$
                                "searched in:" <+> vcat ps))
 
-modtime path = liftIO $ getModificationTime path
+modtime path = getModificationTime path
 
 gfImports opts file = importsOfModule `fmap` parseModHeader opts file
 

src/compiler/GF/CompileOne.hs

@@ -37,7 +37,7 @@ compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
 compileOne opts srcgr file =
     if isGFO file
     then reuseGFO opts srcgr file
-    else do b1 <- liftIO $ doesFileExist file
+    else do b1 <- doesFileExist file
             if b1 then useTheSource
                   else reuseGFO opts srcgr (gf2gfo opts file)
   where
@@ -47,7 +47,7 @@ compileOne opts srcgr file =
                        ("- compiling" +++ file ++ "... ")
                        (getSourceModule opts file)
          idump opts Source sm
-         cwd <- liftIO getCurrentDirectory
+         cwd <- getCurrentDirectory
          compileSourceModule opts cwd (Just file) srcgr sm
 
     putpOpt v m act
@@ -65,7 +65,7 @@ reuseGFO opts srcgr file =
      idump opts Source sm0
 
      let sm1 = unsubexpModule sm0
-     cwd <- liftIO getCurrentDirectory
+     cwd <- getCurrentDirectory
      (sm,warnings) <- -- putPointE Normal opts "creating indirections" $ 
                       runCheck $ extendModule cwd srcgr sm1
      warnOut opts warnings

src/compiler/GF/System/Directory.hs

@@ -1,7 +1,19 @@
 -- | Isolate backwards incompatible library changes to 'getModificationTime'
-module GF.System.Directory(getModificationTime,module D) where
+-- and provide lifted versions of some directory operations
+module GF.System.Directory(module GF.System.Directory,module D) where
+import Control.Monad.Trans(MonadIO(..))
 import qualified System.Directory as D
-import System.Directory as D hiding (getModificationTime)
+import System.Directory as D
+       hiding (doesDirectoryExist,doesFileExist,getModificationTime,
+               getCurrentDirectory,getDirectoryContents,removeFile)
 import Data.Time.Compat
 
-getModificationTime path = fmap toUTCTime (D.getModificationTime path)
+doesDirectoryExist path = liftIO $ D.doesDirectoryExist path
+doesFileExist path = liftIO $ D.doesFileExist path
+getModificationTime path = liftIO $ fmap toUTCTime (D.getModificationTime path)
+getDirectoryContents path = liftIO $ D.getDirectoryContents path
+
+getCurrentDirectory :: MonadIO io => io FilePath
+getCurrentDirectory = liftIO D.getCurrentDirectory
+
+removeFile path = liftIO $ D.removeFile path

src/compiler/GFServer.hs

@@ -190,8 +190,8 @@ handle logLn documentroot state0 cache execute1 stateVar
     inDir ok = cd =<< look "dir"
       where
         cd ('/':dir@('t':'m':'p':_)) =
-          do cwd <- liftIO $ getCurrentDirectory
+          do cwd <- getCurrentDirectory
-             b <- liftIO $ doesDirectoryExist dir
+             b <- doesDirectoryExist dir
              case b of
                False  -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links
                             case b of
@@ -247,7 +247,7 @@ handle logLn documentroot state0 cache execute1 stateVar
          logPutStrLn cmd
          out@(ecode,_,_) <- liftIO $ readProcessWithExitCode "gf" args ""
          logPutStrLn $ show ecode
-         cwd <- liftIO $ getCurrentDirectory
+         cwd <- getCurrentDirectory
          return $ json200 (jsonresult cwd ('/':dir++"/") cmd out files)
 
     upload skip files =
@@ -265,15 +265,15 @@ handle logLn documentroot state0 cache execute1 stateVar
     jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext)
 
     addTime path =
-        do t <- liftIO $ getModificationTime path
+        do t <- getModificationTime path
            return $ makeObj ["path".=path,"time".=format t]
       where
         format = formatTime defaultTimeLocale rfc822DateFormat
 
     rm path | takeExtension path `elem` ok_to_delete =
-      do b <- liftIO $ doesFileExist path
+      do b <- doesFileExist path
          if b
-           then do liftIO $ removeFile path
+           then do removeFile path
                    return $ ok200 ""
            else err $ resp404 path
     rm path = err $ resp400 $ "unacceptable extension "++path
@@ -306,7 +306,7 @@ handle logLn documentroot state0 cache execute1 stateVar
            return $ jsonp qs pgfs
 
     ls_ext dir ext =
-        do paths <- liftIO $ getDirectoryContents dir
+        do paths <- getDirectoryContents dir
            return [path | path<-paths, takeExtension path==ext]
 
 -- * Dynamic content