GFI.hs: some refactoring for readability

Also some minor changes in how Ctrl-C is handled and how CPU time is measured.

src/compiler/GFI.hs

@@ -47,7 +47,6 @@ import GF.System.Signal
 #ifdef SERVER_MODE
 import GFServer(server)
 #endif
---import System.IO.Error (try)
 #ifdef mingw32_HOST_OS
 import System.Win32.Console
 import System.Win32.NLS
@@ -85,25 +84,64 @@ loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv
 readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv)
 readAndExecute1 opts gfenv = execute1 opts gfenv =<< readCommand opts gfenv
 
+-- | Read a command
+readCommand :: Options -> GFEnv -> IO String
 readCommand opts gfenv0 =
     case flag optMode opts of
       ModeRun -> tryGetLine
       _       -> fetchCommand gfenv0
 
+-- | Optionally show how much CPU time was used to run an IO action
+optionallyShowCPUTime :: Options -> IO a -> IO a
+optionallyShowCPUTime opts act 
+  | not (verbAtLeast opts Normal) = act
+  | otherwise = do t0 <- getCPUTime
+                   r <- act
+                   t1 <- getCPUTime
+                   let dt = t1-t0
+                   putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
+                   return r
+
+{-
 loopOptNewCPU opts gfenv' 
  | not (verbAtLeast opts Normal) = return gfenv'
  | otherwise = do 
      cpu' <- getCPUTime
      putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
      return $ gfenv' {cputime = cpu'}
+-}
 
 -- | Execute a given command, returning Just an updated environment for
 -- | the next command, or Nothing when it is time to quit
 execute1 :: Options -> GFEnv -> String -> IO (Maybe GFEnv)
-execute1 opts gfenv0 s0 = do
+execute1 opts gfenv0 s0 =
-  let loopNewCPU = fmap Just . loopOptNewCPU opts
+  interruptible $ optionallyShowCPUTime opts $
-      isv = verbAtLeast opts Normal
+  case pwords of
-      ifv act = if isv then act else return ()
+ -- special commands, requiring source grammar in env
+  {-"eh":w:_ -> do
+             cs <- readFile w >>= return . map words . lines
+             gfenv' <- foldM (flip (process False benv)) gfenv cs
+             loopNewCPU gfenv' -}
+    "q" :_   -> quit
+    "!" :ws  -> system_command ws
+    "cc":ws  -> compute_concrete ws
+    "so":ws  -> show_operations ws
+    "dg":ws  -> dependency_graph ws
+    "eh":ws  -> eh ws
+    "i" :ws  -> import_ ws
+ -- other special commands, working on GFEnv
+    "e" :_   -> empty
+    "dc":ws  -> define_command ws
+    "dt":ws  -> define_tree ws
+    "ph":_   -> print_history
+    "se":ws  -> set_encoding ws
+ -- ordinary commands, working on CommandEnv
+    _        -> do interpretCommandLine env s0
+                   continue gfenv
+  where
+--  loopNewCPU = fmap Just . loopOptNewCPU opts
+    continue = return . Just
+    stop = return Nothing
     env = commandenv gfenv0
     sgr = sourcegrammar gfenv0
     gfenv = gfenv0 {history = s0 : history gfenv0}
@@ -111,25 +149,18 @@ execute1 opts gfenv0 s0 = do
                w:ws -> getCommandOp w :ws
                ws -> ws
 
-  -- special commands, requiring source grammar in env
+    interruptible act =
+      either (\e -> printException e >> return (Just gfenv)) return
+        =<< runInterruptibly act 
 
-  case pwords of
+  -- Special commands:
-{-
-    "eh":w:_ -> do
-             cs <- readFile w >>= return . map words . lines
-             gfenv' <- foldM (flip (process False benv)) gfenv cs
-             loopNewCPU gfenv'
--}
 
-      "q":_  -> ifv (putStrLn "See you.") >> return Nothing
+    quit = do when (verbAtLeast opts Normal) $ putStrLn "See you."
+              stop
 
-      _ -> do
+    system_command ws = do restrictedSystem $ unwords ws ; continue gfenv
-        r <- runInterruptibly $ case pwords of
 
-          "!":ws -> do
+    compute_concrete ws = do
-             restrictedSystem $ unwords ws
-             loopNewCPU gfenv
-          "cc":ws -> do
       let
         pOpts style q ("-table"  :ws) = pOpts TermPrintTable   q           ws
         pOpts style q ("-all"    :ws) = pOpts TermPrintAll     q           ws
@@ -147,10 +178,11 @@ execute1 opts gfenv0 s0 = do
         Right t      -> case checkComputeTerm sgr (unLoc (codeTerm (decodeUnicode utf8 . BS.pack) (L (0,0) t))) of
                           Ok  x -> putStrLn $ showTerm sgr style q x
                           Bad s -> putStrLn $ s
-             loopNewCPU gfenv
+      continue gfenv
 
-          "so":ws -> case greatestResource sgr of
+    show_operations ws =
-             Nothing -> putStrLn "no source grammar in scope" >> loopNewCPU gfenv
+      case greatestResource sgr of
+        Nothing -> putStrLn "no source grammar in scope" >> continue gfenv
         Just mo -> do
           let (os,ts) = partition (isPrefixOf "-") ws
           let greps = [drop 6 o | o <- os, take 6 o == "-grep="]
@@ -167,22 +199,24 @@ execute1 opts gfenv0 s0 = do
                           else (render . GF.Compile.TypeCheck.Concrete.ppType)
           let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
           mapM_ putStrLn [l | l <- printed, all (flip isInfixOf l) greps]
-               loopNewCPU gfenv
+          continue gfenv
 
-
+    dependency_graph ws =
-          "dg":ws -> do
+      do let stop = case ws of
-             let stop = case ws of
                ('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs
                _ -> Nothing
          restricted $ writeFile "_gfdepgraph.dot" (depGraph stop sgr)
          putStrLn "wrote graph in file _gfdepgraph.dot"
-             loopNewCPU gfenv
+         continue gfenv
-          "eh":w:_ -> do
-             cs <- readFile w >>= return . map (interpretCommandLine env) . lines
-             loopNewCPU gfenv
 
-          "i":args -> do
+    eh [w] = -- Ehhh? Reads commands from a file, but does not execute them
-              gfenv' <- case parseOptions args of
+      do cs <- readFile w >>= return . map (interpretCommandLine env) . lines
+         continue gfenv
+    eh _   = do putStrLn "eh command not parsed"
+                continue gfenv
+
+    import_ args = 
+      do gfenv' <- case parseOptions args of
                      Ok (opts',files) -> do
                        curr_dir <- getCurrentDirectory
                        lib_dir  <- getLibraryDirectory (addOptions opts opts')
@@ -190,35 +224,40 @@ execute1 opts gfenv0 s0 = do
                      Bad err -> do 
                        putStrLn $ "Command parse error: " ++ err
                        return gfenv
-              loopNewCPU gfenv'
+         continue gfenv'
 
-  -- other special commands, working on GFEnv
+    empty = continue $ gfenv {
-          "e":_ -> loopNewCPU $ gfenv {
               commandenv=emptyCommandEnv, sourcegrammar = emptySourceGrammar
              }
 
-          "dc":f:ws -> do
+    define_command (f:ws) =
         case readCommandLine (unwords ws) of
-               Just comm -> loopNewCPU $ gfenv {
+           Just comm -> continue $ gfenv {
              commandenv = env {
                commandmacros = Map.insert f comm (commandmacros env)
                }
              }
-               _ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv
+           _ -> dc_not_parsed
+    define_command _ = dc_not_parsed
 
-          "dt":f:ws -> do
+    dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv
+
+    define_tree (f:ws) =
         case readExpr (unwords ws) of
-               Just exp -> loopNewCPU $ gfenv {
+          Just exp -> continue $ gfenv {
             commandenv = env {
               expmacros = Map.insert f exp (expmacros env)
               }
             }
-               _ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv
+          _ -> dt_not_parsed
+    define_tree _ = dt_not_parsed
 
-          "ph":_ -> 
+    dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv
-            mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
+
-          "se":c:_ -> do
+    print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv
-             let cod = renameEncoding c
+
+    set_encoding [c] =
+      do let cod = renameEncoding c
 #ifdef mingw32_HOST_OS
          case cod of
            'C':'P':c -> case reads c of
@@ -233,14 +272,9 @@ execute1 opts gfenv0 s0 = do
          hSetEncoding stdin  enc
          hSetEncoding stdout enc
          hSetEncoding stderr enc
-             loopNewCPU gfenv
+         continue gfenv
+    set_encoding _ = putStrLn "se command not parsed" >> continue gfenv
 
-  -- ordinary commands, working on CommandEnv
-          _ -> do
-            interpretCommandLine env s0
-            loopNewCPU gfenv
---        gfenv' <- return $ either (const gfenv) id r
-        either (\e -> (printException e >> return (Just gfenv))) return r
 
 printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
 
@@ -313,13 +347,13 @@ prompt env
 data GFEnv = GFEnv {
   sourcegrammar :: SourceGrammar, -- gfo grammar -retain
   commandenv :: CommandEnv,
-  history    :: [String],
+  history    :: [String]--,
-  cputime    :: Integer
+--cputime    :: Integer
   }
 
 emptyGFEnv :: GFEnv
 emptyGFEnv =
-  GFEnv emptySourceGrammar{modules=[(identW,emptyModInfo)]} (mkCommandEnv emptyPGF) [] 0
+  GFEnv emptySourceGrammar{modules=[(identW,emptyModInfo)]} (mkCommandEnv emptyPGF) [] {-0-}
 
 wordCompletion gfenv (left,right) = do
   case wc_type (reverse left) of