when in server mode reuse the NGF cache in the shell as well

src/compiler/GF/Command/Importing.hs

@@ -23,8 +23,8 @@ import Control.Monad(foldM)
 import Control.Exception(catch,throwIO)
 
 -- import a grammar in an environment where it extends an existing grammar
-importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
-importGrammar pgf0 opts  _
+importGrammar :: (FilePath -> IO PGF) -> Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
+importGrammar readNGF pgf0 opts  _
   | Just name <- flag optBlank opts = do
         mb_ngf_file <- if snd (flag optLinkTargets opts)
                          then do let fname = name <.> ".ngf"
@@ -33,14 +33,14 @@ importGrammar pgf0 opts  _
                          else do return Nothing
         pgf <- newNGF name mb_ngf_file
         return (Just pgf)
-importGrammar pgf0 _    [] = return pgf0
-importGrammar pgf0 opts fs
+importGrammar readNGF pgf0 _    [] = return pgf0
+importGrammar readNGF pgf0 opts fs
   | all (extensionIs ".cf")   fs = fmap Just $ importCF opts fs getBNFCRules bnfc2cf
   | all (extensionIs ".ebnf") fs = fmap Just $ importCF opts fs getEBNFRules ebnf2cf
   | all (extensionIs ".gfm")  fs = do
         ascss <- mapM readMulti fs
         let cs = concatMap snd ascss
-        importGrammar pgf0 opts cs
+        importGrammar readNGF pgf0 opts cs
   | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs = do
         res <- tryIOE $ compileToPGF opts pgf0 fs
         case res of

src/compiler/GF/Infra/SIO.hs

@@ -131,7 +131,7 @@ getLibraryDirectory  = lift0 . IO.getLibraryDirectory
 newStdGen            = lift0   IO.newStdGen
 runInterruptibly     = lift1   IO.runInterruptibly
 
-importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
+importGrammar readNGF pgf opts files = lift0 $ GF.importGrammar readNGF pgf opts files
 importSource      opts files = lift0 $ GF.importSource      opts files
 link opts pgf src = lift0 $ GF.link opts pgf src
 

src/compiler/GF/Interactive.hs

@@ -36,10 +36,12 @@ import System.Directory(getAppUserDataDirectory)
 import Control.Exception(SomeException,fromException,evaluate,try)
 import Control.Monad.State hiding (void)
 import qualified GF.System.Signal as IO(runInterruptibly)
+import GF.Command.Messages(welcome)
 #ifdef SERVER_MODE
 import GF.Server(server)
 #endif
-import GF.Command.Messages(welcome)
+
+type ReadNGF = FilePath -> IO PGF
 
 -- | Run the GF Shell in quiet mode (@gf -run@).
 mainRunGFI :: Options -> [FilePath] -> IO ()
@@ -53,39 +55,36 @@ mainGFI opts files = do
   P.putStrLn welcome
   shell opts files
 
-shell opts files = flip evalStateT (emptyGFEnv opts) $
-                   do mapStateT runSIO $ importInEnv opts files
-                      modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
-                      loop
+shell opts files =
+  flip evalStateT (emptyGFEnv opts) $
+  do mapStateT runSIO $ importInEnv readNGF opts files
+     modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
+     repeatM (mapStateT runSIO . execute1 readNGF =<< readCommand)
+
 
 #ifdef SERVER_MODE
 -- | Run the GF Server (@gf -server@).
 -- The 'Int' argument is the port number for the HTTP service.
 mainServerGFI opts0 port files =
-    server jobs port root execute1' . snd
-      =<< runSIO (runStateT (importInEnv opts files) (emptyGFEnv opts))
+  server jobs port root init execute
   where
     root = flag optDocumentRoot opts
     opts = beQuiet opts0
     jobs = join (flag optJobs opts)
 
-    execute1' gfenv0 cmd =
-       do (continue,gfenv) <- runStateT (execute1 cmd) gfenv0
-          return $ if continue then Just gfenv else Nothing
+    init readNGF = do
+      (_, gfenv) <- runSIO (runStateT (importInEnv readNGF opts files) (emptyGFEnv opts))
+      return gfenv
+
+    execute readNGF gfenv0 cmd = do
+      (continue,gfenv) <- runStateT (execute1 readNGF cmd) gfenv0
+      return $ if continue then Just gfenv else Nothing
+
 #else
-mainServerGFI opts port files =
+mainServerGFI readNGF opts port files =
   fail "GF has not been compiled with server mode support"
 #endif
 
--- | Read end execute commands until it is time to quit
-loop :: StateT GFEnv IO ()
-loop = repeatM readAndExecute1
-
--- | Read and execute one command, returning 'True' to continue execution,
--- | 'False' when it is time to quit
-readAndExecute1 :: StateT GFEnv IO Bool
-readAndExecute1 = mapStateT runSIO . execute1 =<< readCommand
-
 -- | Read a command
 readCommand :: StateT GFEnv IO String
 readCommand =
@@ -113,13 +112,13 @@ type ShellM = StateT GFEnv SIO
 
 -- | Execute a given command line, returning 'True' to continue execution,
 -- | 'False' when it is time to quit
-execute1, execute1' :: String -> ShellM Bool
-execute1 s0 =
+execute1, execute1' :: ReadNGF -> String -> ShellM Bool
+execute1 readNGF s0 =
   do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0}
-     execute1' s0
+     execute1' readNGF s0
 
 -- | Execute a given command line, without adding it to the history
-execute1' s0 =
+execute1' readNGF s0 =
   do opts <- gets startOpts
      interruptible $ optionallyShowCPUTime opts $
        case pwords s0 of
@@ -128,7 +127,16 @@ execute1' s0 =
          "q" :_   -> quit
          "!" :ws  -> system_command ws
          "eh":ws  -> execute_history ws
-         "i" :ws  -> do import_ ws; continue
+         "i" :ws  -> do import_ readNGF ws; continue
+         "r" :_   -> do gfenv0 <- get
+                        let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
+                        case imports of
+                          (s,ws):_ -> do
+                            putStrLnE $ "repeating latest import: " ++ s
+                            import_ readNGF ws
+                            continue
+                          _ -> do putStrLnE $ "no import in history"
+                                  continue
          (w  :ws) | w == "c" || w == "d" -> do
                         case readTransactionCommand s0 of
                           Just cmd -> do checkout
@@ -178,7 +186,7 @@ execute1' s0 =
          continue
       where
         execute []           = return ()
-        execute (line:lines) = whenM (execute1' line) (execute lines)
+        execute (line:lines) = whenM (execute1' readNGF line) (execute lines)
 
     execute_history _   =
        do putStrLnE "eh command not parsed"
@@ -219,13 +227,13 @@ pwords s = case words s of
              w:ws -> getCommandOp w :ws
              ws -> ws
 
-import_ args =
+import_ readNGF args =
   do case parseOptions args of
        Ok (opts',files) -> do
          opts <- gets startOpts
          curr_dir <- lift getCurrentDirectory
          lib_dir  <- lift $ getLibraryDirectory (addOptions opts opts')
-         importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
+         importInEnv readNGF (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
        Bad err -> putStrLnE $ "Command parse error: " ++ err
 
 transactionCommand :: TransactionCommand -> PGF -> ShellM ()
@@ -353,17 +361,7 @@ moreCommands = [
      }),
   ("r",  emptyCommandInfo {
      longname = "reload",
-     synopsis = "repeat the latest import command",
-     exec = \ _ _ ->
-       do gfenv0 <- get
-          let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
-          case imports of
-            (s,ws):_ -> do
-              putStrLnE $ "repeating latest import: " ++ s
-              import_ ws
-              return void
-            _ -> do putStrLnE $ "no import in history"
-                    return void
+     synopsis = "repeat the latest import command"
      })
   ]
 
@@ -385,8 +383,8 @@ fetchCommand gfenv = do
     Right Nothing  -> return "q"
     Right (Just s) -> return s
 
-importInEnv :: Options -> [FilePath] -> ShellM ()
-importInEnv opts files =
+importInEnv :: ReadNGF -> Options -> [FilePath] -> ShellM ()
+importInEnv readNGF opts files =
   do pgf0 <- gets multigrammar
      case flag optRetainResource opts of
        RetainAll      -> do src <- lift $ importSource opts files
@@ -399,7 +397,7 @@ importInEnv opts files =
   where
     importPGF pgf0 =
       do let opts' = addOptions (setOptimization OptCSE False) opts
-         pgf1 <- importGrammar pgf0 opts' files
+         pgf1 <- importGrammar readNGF pgf0 opts' files
          if (verbAtLeast opts Normal)
            then case pgf1 of
                   Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)

src/compiler/GF/Main.hs

@@ -14,7 +14,6 @@ import System.Directory
 import System.Environment (getArgs)
 import System.Exit
 import GHC.IO.Encoding
--- import GF.System.Console (setConsoleEncoding)
 
 -- | Run the GF main program, taking arguments from the command line.
 -- (It calls 'setConsoleEncoding' and 'getOptions', then 'mainOpts'.)

src/compiler/GF/Server.hs

@@ -1,13 +1,13 @@
 -- | GF server mode
 {-# LANGUAGE CPP #-}
 module GF.Server(server) where
+
 import Data.List(partition,stripPrefix,isInfixOf)
 import qualified Data.Map as M
 import Control.Monad(when)
 import Control.Monad.State(StateT(..),get,gets,put)
 import Control.Monad.Except(ExceptT(..),runExceptT)
 import System.Random(randomRIO)
---import System.IO(stderr,hPutStrLn)
 import GF.System.Catch(try)
 import Control.Exception(bracket_)
 import System.IO.Error(isAlreadyExistsError)
@@ -30,11 +30,9 @@ import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink,
 import GF.Infra.Concurrency(newMVar,modifyMVar,newLog)
 import Network.URI(URI(..))
 import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
---import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
 import Network.CGI(handleErrors,liftIO)
 import CGIUtils(handleCGIErrors)
 import Text.JSON(encode,showJSON,makeObj)
---import System.IO.Silently(hCapture)
 import System.Process(readProcessWithExitCode)
 import System.Exit(ExitCode(..))
 import Codec.Binary.UTF8.String(decodeString,encodeString)
@@ -49,61 +47,30 @@ import GF.Server.SimpleEditor.Convert(parseModule)
 import GF.Server.RunHTTP(cgiHandler)
 import URLEncoding(decodeQuery)
 
---logFile :: FilePath
---logFile = "pgf-error.log"
-
 debug s = logPutStrLn s
 
 -- | Combined FastCGI and HTTP server
-server jobs port optroot execute1 state0 =
-  do --stderrToFile logFile
-     state <- newMVar M.empty
-     cache <- PS.newPGFCache jobs
-     datadir <- getDataDir
-     let root = maybe (datadir</>"www") id optroot
---   debug $ "document root="++root
-     setDir root
---   FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache)
-     -- if acceptLoop returns, then GF was not invoked as a FastCGI script
-     http_server execute1 state0 state cache root
+server jobs port optroot init execute1 = do
+  state <- newMVar M.empty
+  datadir <- getDataDir
+  let root = maybe (datadir</>"www") id optroot
+  cache <- PS.newPGFCache root jobs
+  setDir root
+  let readNGF = PS.readCachedNGF cache
+  state0 <- init readNGF
+  http_server (execute1 readNGF) state0 state cache root
   where
     -- | HTTP server
-    http_server execute1 state0 state cache root =
+    http_server execute state0 state cache root =
       do logLn <- newLog ePutStrLn -- to avoid intertwined log messages
          logLn gf_version
          logLn $ "Document root = "++root
          logLn $ "Starting HTTP server, open http://localhost:"
                  ++show port++"/ in your web browser."
-         initServer port (handle logLn root state0 cache execute1 state)
+         initServer port (handle logLn root state0 cache execute state)
 
 gf_version = "This is GF version "++showVersion version++".\n"++buildInfo
 
-{-
--- | FastCGI request handler
-handle_fcgi execute1 state0 stateM cache =
-  do Just method <- FCGI.getRequestMethod
-     debug $ "request method="++method
-     Just path <- FCGI.getPathInfo
---   debug $ "path info="++path
-     query <- maybe (return "") return =<< FCGI.getQueryString
---   debug $ "query string="++query
-     let uri = URI "" Nothing path query ""
-     headers <- fmap (mapFst show) FCGI.getAllRequestHeaders
-     body <- fmap BS.unpack FCGI.fGetContents
-     let req = Request method uri headers body
---   debug (show req)
-     (output,resp) <- liftIO $ hCapture [stdout] $ modifyMVar stateM $ handle state0 cache execute1 req
-     let Response code headers body = resp
---   debug output
-     debug $ "    "++show code++" "++show headers
-     FCGI.setResponseStatus code
-     mapM_ (uncurry (FCGI.setResponseHeader . toHeader)) headers
-     let pbody = BS.pack body
-         n = BS.length pbody
-     FCGI.fPut pbody
-     debug $ "done "++show n
--}
-
 -- * Request handler
 -- | Handler monad
 type HM s a = StateT (Q,s) (ExceptT Response IO) a
@@ -132,7 +99,7 @@ hmbracket_ pre post m =
          Right (a,s) -> do put s;return a
 
 -- | HTTP request handler
-handle logLn documentroot state0 cache execute1 stateVar
+handle logLn documentroot state0 cache execute stateVar
        rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) =
     addDate $
     case method of
@@ -141,7 +108,6 @@ handle logLn documentroot state0 cache execute1 stateVar
       _ -> return (resp501 $ "method "++method)
   where
     logPutStrLn msg = liftIO $ logLn msg
---  debug msg = logPutStrLn msg
 
     addDate m =
       do t <- getCurrentTime
@@ -157,8 +123,6 @@ handle logLn documentroot state0 cache execute1 stateVar
            "/new"     -> stateful $ new
            "/gfshell" -> stateful $ inDir command
            "/cloud"   -> stateful $ inDir cloud
---         "/stop"    ->
---         "/start"   ->
            "/parse"   -> parse (decoded qs)
            "/version" -> versionInfo `fmap` PS.listPGFCache cache
            "/flush"   -> do PS.flushPGFCache cache; return (ok200 "flushed")
@@ -229,7 +193,7 @@ handle logLn documentroot state0 cache execute1 stateVar
       do cmd <- look "command"
          state <- get_state
          let st = maybe state0 id $ M.lookup dir state
-         (output,st') <- liftIO $ captureSIO $ execute1 st cmd
+         (output,st') <- liftIO $ captureSIO $ execute st cmd
          let state' = maybe state (flip (M.insert dir) state) st'
          put_state state'
          return $ ok200 output