GF.CompileOne: refactoring to reduce code duplication and improve readability

I prefer small functions with descriptive names over large monilithic chunks
of code, so I grouped the compiler passes called from compileSourceModule
into funcitons named frontend, middle and backend. This also makes decisions
about which passes to run clearly visible up front.

Also made some small changes in GF.Compile.

src/compiler/GF/Compile.hs

@@ -14,7 +14,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
                       justModuleName,extendPathEnv,putStrE,putPointE)
 import GF.Data.Operations(raise,(+++),err)
 
-import Control.Monad(foldM,when)
+import Control.Monad(foldM,when,(<=<))
 import GF.System.Directory(doesFileExist,getModificationTime)
 import System.FilePath((</>),isRelative,dropFileName)
 import qualified Data.Map as Map(empty,insert,elems) --lookup
@@ -69,7 +69,7 @@ compileModule opts1 env@(_,rfs) file =
   do file <- getRealFile file
      opts0 <- getOptionsFromFile file
      let curr_dir = dropFileName file
-     lib_dir  <- liftIO $ getLibraryDirectory (addOptions opts0 opts1)
+     lib_dir  <- getLibraryDirectory (addOptions opts0 opts1)
      let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
      ps0 <- extendPathEnv opts
      let ps = nub (curr_dir : ps0)
@@ -85,7 +85,7 @@ compileModule opts1 env@(_,rfs) file =
       if exists
         then return file
         else if isRelative file
-               then do lib_dir <- liftIO $ getLibraryDirectory opts1
+               then do lib_dir <- getLibraryDirectory opts1
                        let file1 = lib_dir </> file
                        exists <- liftIO $ doesFileExist file1
                        if exists
@@ -94,24 +94,21 @@ compileModule opts1 env@(_,rfs) file =
                else raise (render ("File" <+> file <+> "does not exist."))
 
 compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
-compileOne' opts env@(srcgr,_) file =
-    extendCompileEnv env =<< compileOne opts srcgr file
+compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr
 
 -- auxiliaries
 
---reverseModules (MGrammar ms) = MGrammar $ reverse ms
-
 -- | The environment
 type CompileEnv = (SourceGrammar,ModEnv)
 
 emptyCompileEnv :: CompileEnv
 emptyCompileEnv = (emptySourceGrammar,Map.empty)
 
-extendCompileEnv (gr,menv) (mfile,mo) = do
-  menv2 <- case mfile of
-    Just file -> do
-      let (mod,imps) = importsOfModule mo
-      t <- liftIO $ getModificationTime file
-      return $ Map.insert mod (t,imps) menv
-    _ -> return menv
-  return (prependModule gr mo,menv2) --- reverse later
+extendCompileEnv (gr,menv) (mfile,mo) =
+  do menv2 <- case mfile of
+                Just file ->
+                  do let (mod,imps) = importsOfModule mo
+                     t <- liftIO $ getModificationTime file
+                     return $ Map.insert mod (t,imps) menv
+                _ -> return menv
+     return (prependModule gr mo,menv2)

src/compiler/GF/CompileOne.hs

@@ -1,5 +1,5 @@
 module GF.CompileOne(OneOutput,CompiledModule,
-                     compileOne --, compileSourceModule
+                     compileOne --, CompileSource, compileSourceModule
                      ) where
 import Prelude hiding (catch)
 import GF.System.Catch
@@ -19,15 +19,14 @@ import GF.Grammar.Printer(ppModule,TermPrintQual(..))
 import GF.Grammar.Binary(decodeModule,encodeModule)
 
 import GF.Infra.Option
-import GF.Infra.UseIO(FullPath,IOE,gf2gfo,liftIO,ePutStrLn,putPointE,putStrE)
+import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,liftIO,ePutStrLn,putPointE,putStrE)
 import GF.Infra.CheckM(runCheck)
 import GF.Data.Operations(liftErr,(+++))
 
 import GF.System.Directory(doesFileExist,getCurrentDirectory)
-import System.FilePath(dropFileName,dropExtension,takeExtensions)
 import qualified Data.Map as Map
 import GF.Text.Pretty(Doc,render,(<+>),($$))
-
+import Control.Monad((<=<))
 
 type OneOutput = (Maybe FullPath,CompiledModule)
 type CompiledModule = SourceModule
@@ -35,31 +34,27 @@ type CompiledModule = SourceModule
 -- | Compile a given source file (or just load a .gfo file),
 -- given a 'SourceGrammar' containing everything it depends on.
 compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
-compileOne opts srcgr file = do
+compileOne opts srcgr file =
+    if isGFO file
+    then reuseGFO opts srcgr file
+    else do b1 <- liftIO $ doesFileExist file
+            if b1 then useTheSource
+                  else reuseGFO opts srcgr (gf2gfo opts file)
+  where
+    -- | For gf source, do full compilation and generate code
+    useTheSource =
+      do sm <- putpOpt ("- parsing" +++ file)
+                       ("- compiling" +++ file ++ "... ")
+                       (getSourceModule opts file)
+         idump opts Source sm
+         cwd <- liftIO getCurrentDirectory
+         compileSourceModule opts cwd (Just file) srcgr sm
 
-  let putpOpt v m act
+    putpOpt v m act
        | verbAtLeast opts Verbose = putPointE Normal opts v act
        | verbAtLeast opts Normal  = putStrE m >> act
        | otherwise                = putPointE Verbose opts v act
 
-  let path = dropFileName file
-  let name = dropExtension file
-
-  case takeExtensions file of
-    ".gfo" -> reuseGFO opts srcgr file
-    _ -> do
-      -- for gf source, do full compilation and generate code
-      b1 <- liftIO $ doesFileExist file
-      if not b1
-        then compileOne opts srcgr $ (gf2gfo opts file)
-        else do
-
-       sm <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ")
-             $ getSourceModule opts file
-       intermOut opts (Dump Source) (ppModule Internal sm)
-
-       compileSourceModule opts srcgr (Just file) sm
-
 -- | For compiled gf, read the file and update environment
 -- also undo common subexp optimization, to enable normal computations
 reuseGFO opts srcgr file =
@@ -67,7 +62,7 @@ reuseGFO opts srcgr file =
              liftIO (decodeModule file)
      let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts})
 
-     intermOut opts (Dump Source) (ppModule Internal sm0)
+     idump opts Source sm0
 
      let sm1 = unsubexpModule sm0
      cwd <- liftIO getCurrentDirectory
@@ -81,30 +76,31 @@ reuseGFO opts srcgr file =
 
      return (Just file,sm)
 
-compileSourceModule :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE OneOutput
-compileSourceModule opts gr mb_gfFile mo0 = do
+type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput
 
-  cwd <- liftIO getCurrentDirectory
-  mo1 <- runPass Extend "" . extendModule cwd gr
-            =<< runPass Rebuild "" (rebuildModule cwd gr mo0)
-
-  case mo1 of
-    (_,n) | not (isCompleteModule n) -> generateTagsOr generateGFO mo1
-    _ -> do
-      mo2 <- runPass Rename "renaming" $ renameModule cwd gr mo1
-      mo3 <- runPass TypeCheck "type checking" $ checkModule opts cwd gr mo2
-      generateTagsOr compileCompleteModule mo3
+compileSourceModule :: Options -> FilePath -> Maybe FilePath -> CompileSource
+compileSourceModule opts cwd mb_gfFile gr =
+    if flag optTagsOnly opts
+    then generateTags <=< ifComplete middle               <=< frontend
+    else generateGFO  <=< ifComplete (backend <=< middle) <=< frontend
   where
-    compileCompleteModule mo3 = do
-      mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3
-      mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
-             then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
-             else runPass2' "" $ return mo4
-      generateGFO mo5
+    -- Apply to all modules
+    frontend = runPass Extend  "" . extendModule cwd gr
+           <=< runPass Rebuild "" . rebuildModule cwd gr
 
-  ------------------------------
-    generateTagsOr compile =
-       if flag optTagsOnly opts then generateTags else compile
+    -- Apply to complete modules
+    middle   = runPass TypeCheck "type checking" . checkModule opts cwd gr
+           <=< runPass Rename    "renaming"      . renameModule cwd gr
+
+    -- Apply to complete modules when not generating tags
+    backend mo3 =
+      do mo4 <- runPassE id Optimize "optimizing" $ optimizeModule opts gr mo3
+         if isModCnc (snd mo4) && flag optPMCFG opts
+          then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
+          else runPassI "" $ return mo4
+
+    ifComplete yes mo@(_,mi) =
+      if isCompleteModule mi then yes mo else return mo
 
     generateGFO mo =
       do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
@@ -116,30 +112,31 @@ compileSourceModule opts gr mb_gfFile mo0 = do
          return (Nothing,mo)
 
     putpp s = if null s then id else putPointE Verbose opts ("  "++s++" ")
-    idump pass = intermOut opts (Dump pass) . ppModule Internal
 
-    -- * Impedance matching
+    -- * Running a compiler pass, with impedance matching
     runPass = runPass' fst fst snd (liftErr . runCheck)
-    runPass2 = runPass2e liftErr
-    runPass2' = runPass2e id id Canon
+    runPassE = runPass2e liftErr
+    runPassI = runPass2e id id Canon
     runPass2e lift f = runPass' id f (const "") lift
 
     runPass' ret dump warn lift pass pp m =
         do out <- putpp pp $ lift m
            warnOut opts (warn out)
-           idump pass (dump out)
+           idump opts pass (dump out)
            return (ret out)
 
     maybeM f = maybe (return ()) f
 
 
 writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
-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) $ liftIO $ encodeModule file mo2
+writeGFO opts file mo =
+    putPointE Normal opts ("  write file" +++ file) $
+      liftIO $ encodeModule file mo2
+  where
+    mo2 = (m,mi{jments=Map.filter notAnyInd (jments mi)})
+    (m,mi) = subexpModule mo
 
+    notAnyInd x = case x of AnyInd{} -> False; _ -> True
 
 -- to output an intermediate stage
 intermOut :: Options -> Dump -> Doc -> IOE ()
@@ -147,6 +144,8 @@ intermOut opts d doc
   | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
   | otherwise   = return ()
 
+idump opts pass = intermOut opts (Dump pass) . ppModule Internal
+
 warnOut opts warnings
   | null warnings = return ()
   | otherwise     = liftIO $ ePutStrLn ws `catch` oops