Rename modules GFI, GFC & GFServer...

... to GF.Interactive, GF.Compiler & GF.Server, respectively.

3 files changed, 1148 insertions, 0 deletions

diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs
new file mode 100644
index 000000000..3be8c6e14
--- /dev/null
+++ b/src/compiler/GF/Compiler.hs
@@ -0,0 +1,143 @@
+module GF.Compiler (mainGFC, writePGF) where
+
+import PGF
+import PGF.Internal(concretes,optimizePGF,unionPGF)
+import PGF.Internal(putSplitAbs,encodeFile,runPut)
+import GF.Compile as S(batchCompile,link,srcAbsName)
+import qualified GF.CompileInParallel as P(batchCompile)
+import GF.Compile.Export
+import GF.Compile.CFGtoPGF
+import GF.Compile.GetGrammar
+import GF.Grammar.CFG
+
+import GF.Infra.Ident(showIdent)
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Data.ErrM
+import GF.System.Directory
+
+import Data.Maybe
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.ByteString.Lazy as BSL
+import System.FilePath
+import Control.Monad(unless,forM_)
+
+mainGFC :: Options -> [FilePath] -> IO ()
+mainGFC opts fs = do
+  r <- appIOE (case () of
+                 _ | null fs -> fail $ "No input files."
+                 _ | all (extensionIs ".cf")  fs -> compileCFFiles opts fs
+                 _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f)  fs -> compileSourceFiles opts fs
+                 _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
+                 _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs)
+  case r of
+    Ok x    -> return x
+    Bad msg -> die $ if flag optVerbosity opts == Normal
+                       then ('\n':msg)
+                       else msg
+ where
+   extensionIs ext = (== ext) .  takeExtension
+
+compileSourceFiles :: Options -> [FilePath] -> IOE ()
+compileSourceFiles opts fs = 
+    do (t_src,~cnc_grs@(~(cnc,gr):_)) <- batchCompile opts fs
+       unless (flag optStopAfterPhase opts == Compile) $
+              do let abs = showIdent (srcAbsName gr cnc)
+                     pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
+                 t_pgf <- if outputJustPGF opts
+                          then maybeIO $ getModificationTime pgfFile
+                          else return Nothing
+                 if t_pgf >= Just t_src
+                   then putIfVerb opts $ pgfFile ++ " is up-to-date."
+                   else do pgfs <- mapM (link opts)
+                                        [(cnc,t_src,gr)|(cnc,gr)<-cnc_grs]
+                           let pgf = foldl1 unionPGF pgfs
+                           writePGF opts pgf
+                           writeOutputs opts pgf
+  where
+    batchCompile = maybe batchCompile' P.batchCompile (flag optJobs opts)
+    batchCompile' opts fs = do (cnc,t,gr) <- S.batchCompile opts fs
+                               return (t,[(cnc,gr)])
+
+compileCFFiles :: Options -> [FilePath] -> IOE ()
+compileCFFiles opts fs = do
+  rules <- fmap concat $ mapM (getCFRules opts) fs
+  startCat <- case rules of
+                (CFRule cat _ _ : _) -> return cat
+                _                    -> fail "empty CFG"
+  let pgf = cf2pgf (last fs) (uniqueFuns (mkCFG startCat Set.empty rules))
+  let cnc = justModuleName (last fs)
+  unless (flag optStopAfterPhase opts == Compile) $
+     do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
+        let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
+        writePGF opts pgf'
+        writeOutputs opts pgf'
+
+unionPGFFiles :: Options -> [FilePath] -> IOE ()
+unionPGFFiles opts fs =
+    if outputJustPGF opts
+    then maybe doIt checkFirst (flag optName opts)
+    else doIt
+  where
+    checkFirst name =
+      do let pgfFile = outputPath opts (name <.> "pgf")
+         sourceTime <- maximum `fmap` mapM getModificationTime fs
+         targetTime <- maybeIO $ getModificationTime pgfFile
+         if targetTime >= Just sourceTime
+           then putIfVerb opts $ pgfFile ++ " is up-to-date."
+           else doIt
+
+    doIt =
+      do pgfs <- mapM readPGFVerbose fs
+         let pgf0 = foldl1 unionPGF pgfs
+             pgf  = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
+             pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
+         if pgfFile `elem` fs
+           then putStrLnE $ "Refusing to overwrite " ++ pgfFile
+           else writePGF opts pgf
+         writeOutputs opts pgf
+
+    readPGFVerbose f =
+        putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f
+
+writeOutputs :: Options -> PGF -> IOE ()
+writeOutputs opts pgf = do
+  sequence_ [writeOutput opts name str 
+                 | fmt <- outputFormats opts,
+                   (name,str) <- exportPGF opts fmt pgf]
+
+writePGF :: Options -> PGF -> IOE ()
+writePGF opts pgf =
+    if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
+  where
+    writeNormalPGF =
+       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
+          writing opts outfile $ encodeFile outfile pgf
+
+    writeSplitPGF =
+      do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
+         writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
+                                --encodeFile_ outfile (putSplitAbs pgf)
+         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
+           let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
+           writing opts outfile $ encodeFile outfile cnc
+
+
+writeOutput :: Options -> FilePath-> String -> IOE ()
+writeOutput opts file str = writing opts path $ writeUTF8File path str
+  where path = outputPath opts file
+
+-- * Useful helper functions
+
+grammarName :: Options -> PGF -> String
+grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
+grammarName' opts abs = fromMaybe abs (flag optName opts)
+
+outputFormats opts = [fmt | fmt <- flag optOutputFormats opts, fmt/=FmtByteCode]
+outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)
+
+outputPath opts file = maybe id (</>) (flag optOutputDir opts) file
+
+writing opts path io =
+    putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO io
diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs
new file mode 100644
index 000000000..745f64f84
--- /dev/null
+++ b/src/compiler/GF/Interactive.hs
@@ -0,0 +1,511 @@
+{-# LANGUAGE ScopedTypeVariables, CPP #-}
+-- | GF interactive mode
+module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where
+import Prelude hiding (putStrLn,print)
+import qualified Prelude as P(putStrLn)
+import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandEnv,interpretCommandLine)
+--import GF.Command.Importing(importSource,importGrammar)
+import GF.Command.Commands(flags,options)
+import GF.Command.Abstract
+import GF.Command.Parse(readCommandLine,pCommand)
+import GF.Data.Operations (Err(..),chunks,err,raise)
+import GF.Grammar hiding (Ident,isPrefixOf)
+import GF.Grammar.Analyse
+import GF.Grammar.Parser (runP, pExp)
+import GF.Grammar.ShowTerm
+import GF.Grammar.Lookup (allOpers,allOpersTo)
+import GF.Compile.Rename(renameSourceTerm)
+--import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError)
+import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues)
+import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
+import GF.Infra.Dependencies(depGraph)
+import GF.Infra.CheckM
+import GF.Infra.UseIO(ioErrorText)
+import GF.Infra.SIO
+import GF.Infra.Option
+import qualified System.Console.Haskeline as Haskeline
+--import GF.Text.Coding(decodeUnicode,encodeUnicode)
+
+--import GF.Compile.Coding(codeTerm)
+
+import PGF
+import PGF.Internal(emptyPGF,abstract,funs,lookStartCat)
+
+import Data.Char
+import Data.List(nub,isPrefixOf,isInfixOf,partition)
+import qualified Data.Map as Map
+--import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.UTF8 as UTF8(fromString)
+import qualified Text.ParserCombinators.ReadP as RP
+--import System.IO(utf8)
+--import System.CPUTime(getCPUTime)
+import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
+import Control.Exception(SomeException,fromException,evaluate,try)
+import Control.Monad
+import GF.Text.Pretty (render)
+import qualified GF.System.Signal as IO(runInterruptibly)
+#ifdef SERVER_MODE
+import GF.Server(server)
+#endif
+import GF.System.Console(changeConsoleEncoding)
+
+import GF.Infra.BuildInfo(buildInfo)
+import Data.Version(showVersion)
+import Paths_gf(version)
+
+mainRunGFI :: Options -> [FilePath] -> IO ()
+mainRunGFI opts files = shell (beQuiet opts) files
+
+beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
+
+mainGFI :: Options -> [FilePath] -> IO ()
+mainGFI opts files = do
+  P.putStrLn welcome
+  shell opts files
+
+shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files)
+
+#ifdef SERVER_MODE
+mainServerGFI opts0 port files =
+    server port root (execute1 opts)
+      =<< runSIO (importInEnv emptyGFEnv opts files)
+  where
+    root = flag optDocumentRoot opts
+    opts = beQuiet opts0
+#else
+mainServerGFI opts files =
+  error "GF has not been compiled with server mode support"
+#endif
+
+-- | Read end execute commands until it is time to quit
+loop :: Options -> GFEnv -> IO ()
+loop opts gfenv = maybe (return ()) (loop opts) =<< readAndExecute1 opts gfenv
+
+-- | Read and execute one command, returning Just an updated environment for
+-- | the next command, or Nothing when it is time to quit
+readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv)
+readAndExecute1 opts gfenv =
+    runSIO . 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 -> SIO a -> SIO 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 -> SIO (Maybe GFEnv)
+execute1 opts gfenv0 s0 =
+  interruptible $ optionallyShowCPUTime opts $
+  case pwords s0 of
+ -- 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
+    "sd":ws  -> show_deps ws
+    "so":ws  -> show_operations ws
+    "ss":ws  -> show_source 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
+    "r" :_   -> reload_last
+    "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}
+    pwords s = case words s of
+                 w:ws -> getCommandOp w :ws
+                 ws -> ws
+
+    interruptible act =
+      either (\e -> printException e >> return (Just gfenv)) return
+        =<< runInterruptibly act 
+
+  -- Special commands:
+
+    quit = do when (verbAtLeast opts Normal) $ putStrLn "See you."
+              stop
+
+    system_command ws = do restrictedSystem $ unwords ws ; continue gfenv
+
+    compute_concrete ws = do
+      let
+        pOpts style q ("-table"  :ws) = pOpts TermPrintTable   q           ws
+        pOpts style q ("-all"    :ws) = pOpts TermPrintAll     q           ws
+        pOpts style q ("-list"   :ws) = pOpts TermPrintList    q           ws
+        pOpts style q ("-one"    :ws) = pOpts TermPrintOne     q           ws
+        pOpts style q ("-default":ws) = pOpts TermPrintDefault q           ws
+        pOpts style q ("-unqual" :ws) = pOpts style            Unqualified ws
+        pOpts style q ("-qual"   :ws) = pOpts style            Qualified   ws
+        pOpts style q             ws  = (style,q,unwords ws)
+
+        (style,q,s) = pOpts TermPrintDefault Qualified ws
+        {-
+        (new,ws') = case ws of
+                      "-new":ws' -> (True,ws')
+                      "-old":ws' -> (False,ws')
+                      _ -> (flag optNewComp opts,ws)
+        -}
+      case runP pExp (UTF8.fromString s) of
+        Left (_,msg) -> putStrLn msg
+        Right t      -> putStrLn . err id (showTerm sgr style q)
+                                 . checkComputeTerm sgr
+                                 $ {-codeTerm (decodeUnicode utf8 . BS.pack)-} t
+      continue gfenv
+
+    show_deps ws = do
+          let (os,xs) = partition (isPrefixOf "-") ws
+          ops <- case xs of
+             _:_ -> do
+               let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
+               err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts
+             _   -> error "expected one or more qualified constants as argument"
+          let prTerm = showTerm sgr TermPrintDefault Qualified
+          let size = sizeConstant sgr
+          let printed 
+                | elem "-size" os =
+                    let sz = map size ops in 
+                    unlines $ ("total: " ++ show (sum sz)) : 
+                              [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz]
+                | otherwise = unwords $ map prTerm ops
+          putStrLn $ printed
+          continue gfenv
+
+    show_operations ws =
+      case greatestResource sgr of
+        Nothing -> putStrLn "no source grammar in scope; did you import with -retain?" >> continue gfenv
+        Just mo -> do
+          let (os,ts) = partition (isPrefixOf "-") ws
+          let greps = [drop 6 o | o <- os, take 6 o == "-grep="]
+          let isRaw = elem "-raw" os 
+          ops <- case ts of
+             _:_ -> do
+               let Right t = runP pExp (UTF8.fromString (unwords ts))
+               ty <- err error return $ checkComputeTerm sgr t
+               return $ allOpersTo sgr ty
+             _   -> return $ allOpers sgr 
+          let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
+          let printer = if isRaw 
+                          then showTerm sgr TermPrintDefault Qualified
+                          else (render . TC.ppType)
+          let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
+          mapM_ putStrLn [l | l <- printed, all (flip isInfixOf l) greps]
+          continue gfenv
+
+    show_source ws = do
+      let (os,ts) = partition (isPrefixOf "-") ws
+      let strip = if elem "-strip" os then stripSourceGrammar else id
+      let mygr = strip $ case ts of
+            _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (showIdent i) ts] 
+            [] -> sgr
+      case 0 of
+        _ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr)
+        _ | elem "-size" os -> do
+               let sz = sizesGrammar mygr
+               putStrLn $ unlines $
+                 ("total\t" ++ show (fst sz)): 
+                 [showIdent j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
+        _ | elem "-save" os -> mapM_ 
+                 (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in 
+                    restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file))
+                 (modules mygr)  
+        _ -> putStrLn $ render mygr
+      continue gfenv
+
+    dependency_graph ws =
+      do 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"
+         continue gfenv
+
+    eh [w] = -- Ehhh? Reads commands from a file, but does not execute them
+      do cs <- restricted (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')
+                       importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
+                     Bad err -> do 
+                       putStrLn $ "Command parse error: " ++ err
+                       return gfenv
+         continue gfenv'
+
+    empty = continue $ gfenv {
+              commandenv=emptyCommandEnv, sourcegrammar = emptySourceGrammar
+             }
+
+    define_command (f:ws) =
+        case readCommandLine (unwords ws) of
+           Just comm -> continue $ gfenv {
+             commandenv = env {
+               commandmacros = Map.insert f comm (commandmacros env)
+               }
+             }
+           _ -> dc_not_parsed
+    define_command _ = dc_not_parsed
+
+    dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv
+
+    define_tree (f:ws) =
+        case readExpr (unwords ws) of
+          Just exp -> continue $ gfenv {
+            commandenv = env {
+              expmacros = Map.insert f exp (expmacros env)
+              }
+            }
+          _ -> dt_not_parsed
+    define_tree _ = dt_not_parsed
+
+    dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv
+
+    print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv
+
+    reload_last = do
+      let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
+      case imports of
+        (s,ws):_ -> do
+          putStrLn $ "repeating latest import: " ++ s
+          import_ ws
+        _ -> do
+          putStrLn $ "no import in history"  
+          continue gfenv
+
+    set_encoding [c] =
+      do let cod = renameEncoding c
+         restricted $ changeConsoleEncoding cod
+         continue gfenv
+    set_encoding _ = putStrLn "se command not parsed" >> continue gfenv
+
+
+printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
+
+checkComputeTerm sgr t = do
+                 mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr
+                 ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
+                                            inferLType sgr [] t
+                 t1 <- {-if new
+                       then-} return (CN.normalForm (CN.resourceValues sgr) (L NoLoc identW) t)
+                       {-else computeConcrete sgr t-}
+                 checkPredefError t1
+
+fetchCommand :: GFEnv -> IO String
+fetchCommand gfenv = do
+  path <- getAppUserDataDirectory "gf_history"
+  let settings =
+        Haskeline.Settings {
+          Haskeline.complete = wordCompletion gfenv,
+          Haskeline.historyFile = Just path,
+          Haskeline.autoAddHistory = True
+        }
+  res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt (commandenv gfenv)))
+  case res of
+    Left  _        -> return ""
+    Right Nothing  -> return "q"
+    Right (Just s) -> return s
+
+importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv
+importInEnv gfenv opts files
+    | flag optRetainResource opts =
+        do src <- importSource (sourcegrammar gfenv) opts files
+           return $ gfenv {sourcegrammar = src}
+    | otherwise =
+        do let opts' = addOptions (setOptimization OptCSE False) opts
+               pgf0 = multigrammar (commandenv gfenv)
+           pgf1 <- importGrammar pgf0 opts' files
+           if (verbAtLeast opts Normal)
+             then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1)
+             else return ()
+           return $ gfenv { commandenv = mkCommandEnv pgf1 }
+
+tryGetLine = do
+  res <- try getLine
+  case res of
+   Left (e :: SomeException) -> return "q"
+   Right l -> return l
+
+welcome = unlines [
+  "                              ",
+  "         *  *  *              ",
+  "      *           *           ",
+  "    *               *         ",
+  "   *                          ",
+  "   *                          ",
+  "   *        * * * * * *       ",
+  "   *        *         *       ",
+  "    *       * * * *  *        ",
+  "      *     *      *          ",
+  "         *  *  *              ",
+  "                              ",
+  "This is GF version "++showVersion version++". ",
+  buildInfo,
+  "License: see help -license.   ",
+  "Bug reports: http://code.google.com/p/grammatical-framework/issues/list"
+  ]
+
+prompt env 
+  | abs == wildCId = "> "
+  | otherwise      = showCId abs ++ "> "
+  where
+    abs = abstractName (multigrammar env)
+
+data GFEnv = GFEnv {
+  sourcegrammar :: SourceGrammar, -- gfo grammar -retain
+  commandenv :: CommandEnv,
+  history    :: [String]
+  }
+
+emptyGFEnv :: GFEnv
+emptyGFEnv =
+  GFEnv emptySourceGrammar (mkCommandEnv emptyPGF) [] {-0-}
+
+wordCompletion gfenv (left,right) = do
+  case wc_type (reverse left) of
+    CmplCmd pref
+      -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
+    CmplStr (Just (Command _ opts _)) s0
+      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts)))
+            case mb_state0 of
+              Right state0 -> let (rprefix,rs) = break isSpace (reverse s0)
+                                  s            = reverse rs
+                                  prefix       = reverse rprefix
+                                  ws           = words s
+                              in case loop state0 ws of
+                                   Nothing    -> ret 0 []
+                                   Just state -> let compls = getCompletions state prefix
+                                                 in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls))
+              Left (_ :: SomeException) -> ret 0 []
+    CmplOpt (Just (Command n _ _)) pref
+      -> case Map.lookup n (commands cmdEnv) of
+           Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags   inf, isPrefixOf pref flg]
+                              opt_compls = [Haskeline.Completion ('-':opt)      ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt]
+                          ret (length pref+1)
+                              (flg_compls++opt_compls)
+           Nothing  -> ret (length pref) []
+    CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
+      -> Haskeline.completeFilename (left,right)
+    CmplIdent _ pref
+      -> do mb_abs <- try (evaluate (abstract pgf))
+            case mb_abs of
+              Right abs -> ret (length pref) [Haskeline.simpleCompletion name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name]
+              Left (_ :: SomeException) -> ret (length pref) []
+    _ -> ret 0 []
+  where
+    pgf    = multigrammar cmdEnv
+    cmdEnv = commandenv gfenv
+    optLang opts = valCIdOpts "lang" (head (languages pgf)) opts
+    optType opts = 
+      let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
+      in case readType str of
+           Just ty -> ty
+           Nothing -> error ("Can't parse '"++str++"' as type")
+
+    loop ps []     = Just ps
+    loop ps (t:ts) = case nextState ps (simpleParseInput t) of
+                       Left  es -> Nothing
+                       Right ps -> loop ps ts
+
+    ret len xs  = return (drop len left,xs)
+
+
+data CompletionType
+  = CmplCmd                   Ident
+  | CmplStr   (Maybe Command) String
+  | CmplOpt   (Maybe Command) Ident
+  | CmplIdent (Maybe Command) Ident
+  deriving Show
+
+wc_type :: String -> CompletionType
+wc_type = cmd_name
+  where
+    cmd_name cs =
+      let cs1 = dropWhile isSpace cs
+      in go cs1 cs1
+      where
+        go x []       = CmplCmd x
+        go x (c:cs)
+          | isIdent c = go x cs
+          | otherwise = cmd x cs
+
+    cmd x []       = ret CmplIdent x "" 0
+    cmd _ ('|':cs) = cmd_name cs
+    cmd _ (';':cs) = cmd_name cs
+    cmd x ('"':cs) = str x cs cs
+    cmd x ('-':cs) = option x cs cs
+    cmd x (c  :cs)
+      | isIdent c  = ident x (c:cs) cs
+      | otherwise  = cmd x cs
+
+    option x y []       = ret CmplOpt x y 1
+    option x y ('=':cs) = optValue x y cs
+    option x y (c  :cs)
+      | isIdent c       = option x y cs
+      | otherwise       = cmd x cs
+      
+    optValue x y ('"':cs) = str x y cs
+    optValue x y cs       = cmd x cs
+
+    ident x y []     = ret CmplIdent x y 0
+    ident x y (c:cs)
+      | isIdent c    = ident x y cs
+      | otherwise    = cmd x cs
+
+    str x y []          = ret CmplStr x y 1
+    str x y ('\"':cs)   = cmd x cs
+    str x y ('\\':c:cs) = str x y cs
+    str x y (c:cs)      = str x y cs
+
+    ret f x y d = f cmd y
+      where
+        x1 = take (length x - length y - d) x
+        x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
+        
+        cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
+	        [x] -> Just x
+                _   -> Nothing
+
+    isIdent c = c == '_' || c == '\'' || isAlphaNum c
diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs
new file mode 100644
index 000000000..0fc7f0388
--- /dev/null
+++ b/src/compiler/GF/Server.hs
@@ -0,0 +1,494 @@
+-- | 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.Error(ErrorT(..),Error(..))
+import System.Random(randomRIO)
+--import System.IO(stderr,hPutStrLn)
+import GF.System.Catch(try)
+import Control.Exception(bracket_)
+import System.IO.Error(isAlreadyExistsError)
+import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
+                           setCurrentDirectory,getCurrentDirectory,
+                           getDirectoryContents,removeFile,removeDirectory,
+                           getModificationTime)
+import Data.Time (getCurrentTime,formatTime)
+import System.Locale(defaultTimeLocale,rfc822DateFormat)
+import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory,
+                       (</>),makeRelative)
+#ifndef mingw32_HOST_OS
+import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink,
+                          createSymbolicLink)
+#endif
+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)--,outputJSONP,stderrToFile
+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)
+import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
+import GF.Infra.SIO(captureSIO)
+import qualified PGFService as PS
+import qualified ExampleService as ES
+import Data.Version(showVersion)
+import Paths_gf(getDataDir,version)
+import GF.Infra.BuildInfo (buildInfo)
+import SimpleEditor.Convert(parseModule)
+import RunHTTP(cgiHandler)
+import URLEncoding(decodeQuery)
+
+--logFile :: FilePath
+--logFile = "pgf-error.log"
+
+debug s = logPutStrLn s
+
+-- | Combined FastCGI and HTTP server
+server port optroot execute1 state0 =
+  do --stderrToFile logFile
+     state <- newMVar M.empty
+     cache <- PS.newPGFCache
+     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
+  where
+    -- | HTTP server
+    http_server execute1 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)
+
+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) (ErrorT Response IO) a
+run :: HM s Response -> (Q,s) -> IO (s,Response)
+run m s = either bad ok =<< runErrorT (runStateT m s)
+  where
+    bad resp = return (snd s,resp)
+    ok (resp,(qs,state)) = return (state,resp)
+
+get_qs :: HM s Q
+get_qs = gets fst
+get_state :: HM s s
+get_state = gets snd
+put_qs qs = do state <- get_state; put (qs,state)
+put_state state = do qs <- get_qs; put (qs,state)
+
+err :: Response -> HM s a
+err e = StateT $ \ s -> ErrorT $ return $ Left e
+
+hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
+hmbracket_ pre post m =
+    do s <- get
+       e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s
+       case e of
+         Left resp -> err resp
+         Right (a,s) -> do put s;return a
+
+-- | HTTP request handler
+handle logLn documentroot state0 cache execute1 stateVar
+       rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) =
+    addDate $
+    case method of
+      "POST" -> normal_request (utf8inputs body)
+      "GET"  -> normal_request (utf8inputs q)
+      _ -> return (resp501 $ "method "++method)
+  where
+    logPutStrLn msg = liftIO $ logLn msg
+    debug msg = logPutStrLn msg
+
+    addDate m =
+      do t <- getCurrentTime
+         r <- m
+         let fmt = formatTime defaultTimeLocale rfc822DateFormat t
+         return r{resHeaders=("Date",fmt):resHeaders r}
+
+    normal_request qs =
+      do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
+         let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s)
+          -- stateful ensures mutual exclusion, so you can use/change the cwd
+         case upath of
+           "/new"     -> stateful $ new
+           "/gfshell" -> stateful $ inDir command
+           "/cloud"   -> stateful $ inDir cloud
+--         "/stop"    ->
+--         "/start"   ->
+           "/parse"   -> parse (decoded qs)
+           "/version" -> do (c1,c2) <- PS.listPGFCache cache
+                            let rel = map (makeRelative documentroot)
+                            return $ ok200 (unlines (gf_version:"":rel c1++"":rel c2))
+           "/flush"   -> do PS.flushPGFCache cache; return (ok200 "flushed")
+           '/':rpath ->
+             -- This code runs without mutual exclusion, so it must *not*
+             -- use/change the cwd. Access files by absolute paths only.
+             case (takeDirectory path,takeFileName path,takeExtension path) of
+               (_  ,_             ,".pgf") -> do --debug $ "PGF service: "++path
+                                                 wrapCGI $ PS.cgiMain' cache path
+               (dir,"grammars.cgi",_     ) -> grammarList dir (decoded qs)
+               (dir  ,"exb.fcgi"  ,_    ) -> wrapCGI $ ES.cgiMain' root dir (fst cache)
+               _ -> serveStaticFile rpath path
+             where path = translatePath rpath
+           _ -> return $ resp400 upath
+
+    root = documentroot
+
+    translatePath rpath = root</>rpath -- hmm, check for ".."
+
+    wrapCGI cgi = cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq
+
+    look field =
+      do qs <- get_qs
+         case partition ((==field).fst) qs of
+           ((_,(value,_)):qs1,qs2) -> do put_qs (qs1++qs2)
+                                         return value
+           _ -> err $ resp400 $ "no "++field++" in request"
+    
+    inDir ok = cd =<< look "dir"
+      where
+        cd ('/':dir@('t':'m':'p':_)) =
+          do cwd <- getCurrentDirectory
+             b <- doesDirectoryExist dir
+             case b of
+               False  -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links
+                            case b of
+                              Left _ -> err $ resp404 dir
+                              Right dir' -> cd dir'
+               True  -> do --logPutStrLn $ "cd "++dir
+                           hmInDir dir (ok dir)
+        cd dir = err $ resp400 $ "unacceptable directory "++dir
+
+    -- First ensure that only one thread that depends on the cwd is running!
+    hmInDir dir = hmbracket_ (setDir dir) (setDir documentroot)
+
+    new = fmap ok200 $ liftIO $ newDirectory
+
+    command dir =
+      do cmd <- look "command"
+         state <- get_state
+         let st = maybe state0 id $ M.lookup dir state
+         (output,st') <- liftIO $ captureSIO $ execute1 st cmd
+         let state' = maybe state (flip (M.insert dir) state) st'
+         put_state state'
+         return $ ok200 output
+
+    parse qs = return $ json200 (makeObj(map parseModule qs))
+
+    cloud dir =
+      do cmd <- look "command"
+         case cmd of
+           "make" -> make id dir . raw =<< get_qs
+           "remake" -> make skip_empty dir . raw =<< get_qs
+           "upload" -> upload id . raw =<< get_qs
+           "ls" -> jsonList . maybe ".json" fst . lookup "ext" =<< get_qs
+           "ls-l" -> jsonListLong . maybe ".json" fst . lookup "ext" =<< get_qs
+           "rm" -> rm =<< look_file
+           "download" -> download =<< look_file
+           "link_directories" ->  link_directories dir =<< look "newdir"
+           _ -> err $ resp400 $ "cloud command "++cmd
+
+    look_file = check =<< look "file"
+      where
+        check path =
+          if ok_access path
+          then return path
+          else err $ resp400 $ "unacceptable path "++path
+
+    make skip dir args =
+      do let (flags,files) = partition ((=="-").take 1.fst) args
+         _ <- upload skip files
+         let args = "-s":"-make":map flag flags++map fst files
+             flag (n,"") = n
+             flag (n,v) = n++"="++v
+             cmd = unwords ("gf":args)
+         logPutStrLn cmd
+         out@(ecode,_,_) <- liftIO $ readProcessWithExitCode "gf" args ""
+         logPutStrLn $ show ecode
+         cwd <- getCurrentDirectory
+         return $ json200 (jsonresult cwd ('/':dir++"/") cmd out files)
+
+    upload skip files =
+        if null badpaths
+        then do liftIO $ mapM_ (uncurry updateFile) (skip okfiles)
+                return resp204
+        else err $ resp404 $ "unacceptable path(s) "++unwords badpaths
+      where
+        (okfiles,badpaths) = apSnd (map fst) $ partition (ok_access.fst) files
+
+    skip_empty = filter (not.null.snd)
+
+    jsonList = jsonList' return
+    jsonListLong = jsonList' (mapM addTime)
+    jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext)
+
+    addTime 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 <- doesFileExist path
+         if b
+           then do removeFile path
+                   return $ ok200 ""
+           else err $ resp404 path
+    rm path = err $ resp400 $ "unacceptable extension "++path
+
+    download path = liftIO $ serveStaticFile' path
+
+    link_directories olddir newdir@('/':'t':'m':'p':'/':_) | old/=new =
+        hmInDir ".." $ liftIO $
+        do logPutStrLn =<< getCurrentDirectory
+           logPutStrLn $ "link_dirs new="++new++", old="++old
+#ifdef mingw32_HOST_OS
+           isDir <- doesDirectoryExist old
+           if isDir then removeDir old else removeFile old
+           writeFile old new -- poor man's symbolic links
+#else
+           isLink <- isSymbolicLink `fmap` getSymbolicLinkStatus old
+           logPutStrLn $ "old is link: "++show isLink
+           if isLink then removeLink old else removeDir old
+           createSymbolicLink new old
+#endif
+           return $ ok200 ""
+      where
+        old = takeFileName olddir
+        new = takeFileName newdir
+    link_directories olddir newdir =
+      err $ resp400 $ "unacceptable directories "++olddir++" "++newdir
+
+    grammarList dir qs =
+        do pgfs <- ls_ext dir ".pgf"
+           return $ jsonp qs pgfs
+
+    ls_ext dir ext =
+        do paths <- getDirectoryContents dir
+           return [path | path<-paths, takeExtension path==ext]
+
+-- * Dynamic content
+
+jsonresult cwd dir cmd (ecode,stdout,stderr) files =
+  makeObj [
+    "errorcode" .= if ecode==ExitSuccess then "OK" else "Error",
+    "command" .= cmd,
+    "output" .= unlines [rel stderr,rel stdout],
+    "minibar_url" .= "/minibar/minibar.html?"++dir++pgf]
+  where
+    pgf = case files of
+            (abstract,_):_ -> "%20"++dropExtension abstract++".pgf"
+            _ -> ""
+
+    rel = unlines . map relative . lines
+
+    -- remove absolute file paths from error messages:
+    relative s = case stripPrefix cwd s of
+                   Just ('/':rest) -> rest
+                   _ -> s
+
+-- * Static content
+
+serveStaticFile rpath path =
+  do --logPutStrLn $ "Serving static file "++path
+     b <- doesDirectoryExist path
+     if b
+       then if rpath `elem` ["","."] || last path=='/'
+            then serveStaticFile' (path </> "index.html")
+            else return (resp301 ('/':rpath++"/"))
+       else serveStaticFile' path
+
+serveStaticFile' path =
+  do let ext = takeExtension path
+         (t,rdFile) = contentTypeFromExt ext
+     if ext `elem` [".cgi",".fcgi",".sh",".php"]
+       then return $ resp400 $ "Unsupported file type: "++ext
+       else do b <- doesFileExist path
+               if b then fmap (ok200' (ct t "")) $ rdFile path
+                    else do cwd <- getCurrentDirectory
+                            logPutStrLn $ "Not found: "++path++" cwd="++cwd
+                            return (resp404 path)
+
+-- * Logging
+logPutStrLn s = ePutStrLn s
+
+-- * JSONP output
+
+jsonp qs =  maybe json200 apply (lookup "jsonp" qs)
+  where
+    apply f = jsonp200' $ \ json -> f++"("++json++")"
+
+-- * Standard HTTP responses
+ok200        = Response 200 [plainUTF8,noCache,xo] . encodeString
+ok200' t     = Response 200 [t,xo]
+json200 x    = json200' id x
+json200' f   = ok200' jsonUTF8 . encodeString . f . encode
+jsonp200' f  = ok200' jsonpUTF8 . encodeString . f . encode
+html200      = ok200' htmlUTF8 . encodeString
+resp204      = Response 204 [xo] "" -- no content
+resp301 url  = Response 301 [plain,xo,location url] $
+               "Moved permanently to "++url
+resp400 msg  = Response 400 [plain,xo] $ "Bad request: "++msg++"\n"
+resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n"
+resp500 msg  = Response 500 [plain,xo] $ "Internal error: "++msg++"\n"
+resp501 msg  = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n"
+
+instance Error Response where
+  noMsg = resp500 "no message"
+  strMsg = resp500
+
+-- * Content types
+plain = ct "text/plain" ""
+plainUTF8 = ct "text/plain" csutf8
+jsonUTF8 = ct "application/json" csutf8 -- http://www.ietf.org/rfc/rfc4627.txt
+jsonpUTF8 = ct "application/javascript" csutf8
+htmlUTF8 = ct "text/html" csutf8
+
+ct t cs = ("Content-Type",t++cs)
+csutf8 = "; charset=UTF-8"
+xo = ("Access-Control-Allow-Origin","*") -- Allow cross origin requests
+     -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS
+location url = ("Location",url)
+
+contentTypeFromExt ext =
+  case ext of
+    ".html" -> text "html"
+    ".htm" -> text "html"
+    ".xml" -> text "xml"
+    ".txt" -> text "plain"
+    ".css" -> text "css"
+    ".js" -> text "javascript"
+    ".png" -> bin "image/png"
+    ".jpg" -> bin "image/jpg"
+    _ -> bin "application/octet-stream"
+  where
+     text subtype = ("text/"++subtype++"; charset=UTF-8",
+                     fmap encodeString . readFile)
+     bin t = (t,readBinaryFile)
+
+-- * IO utilities
+updateFile path new =
+  do old <- try $ readBinaryFile path
+--   let new = encodeString new0
+     when (Right new/=old) $ do logPutStrLn $ "Updating "++path
+                                seq (either (const 0) length old) $
+                                    writeBinaryFile path new
+
+-- | Check that a path is not outside the current directory
+ok_access path =
+    case path of
+      '/':_ -> False
+      '.':'.':'/':_ -> False
+      _ -> not ("/../" `isInfixOf` path)
+
+-- | Only delete files with these extensions
+ok_to_delete = [".json",".gfstdoc",".gfo",".gf",".pgf"]
+
+newDirectory =
+    do debug "newDirectory"
+       loop 10
+  where
+    loop 0 = fail "Failed to create a new directory"
+    loop n = maybe (loop (n-1)) return =<< once
+
+    once =
+      do k <- randomRIO (1,maxBound::Int)
+         let path = "tmp/gfse."++show k
+         b <- try $ createDirectory path
+         case b of
+           Left err -> do debug (show err) ;
+                          if isAlreadyExistsError err
+                             then return Nothing
+                             else ioError err
+           Right _ -> return (Just ('/':path))
+
+-- | Remove a directory and the files in it, but not recursively
+removeDir dir =
+  do files <- filter (`notElem` [".",".."]) `fmap` getDirectoryContents dir
+     mapM (removeFile . (dir</>)) files
+     removeDirectory dir
+
+setDir path =
+  do --logPutStrLn $ "cd "++show path
+     setCurrentDirectory path
+
+{-
+-- * direct-fastcgi deficiency workaround
+
+--toHeader = FCGI.toHeader -- not exported, unfortuntately
+
+toHeader "Content-Type" = FCGI.HttpContentType -- to avoid duplicate headers
+toHeader s = FCGI.HttpExtensionHeader s -- cheating a bit
+-}
+
+-- * misc utils
+
+--utf8inputs = mapBoth decodeString . inputs
+type Q = [(String,(String,String))]
+utf8inputs :: String -> Q
+utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q]
+decoded = mapSnd fst
+raw = mapSnd snd
+
+inputs ('?':q) = decodeQuery q
+inputs q = decodeQuery q
+
+{-
+-- Stay clear of queryToArgument, which uses unEscapeString, which had
+-- backward incompatible changes in network-2.4.1.1, see
+-- https://github.com/haskell/network/commit/f2168b1f8978b4ad9c504e545755f0795ac869ce
+inputs = queryToArguments . fixplus
+  where
+    fixplus = concatMap decode
+    decode '+' = "%20" -- httpd-shed bug workaround
+    decode c   = [c]
+-}
+
+mapFst f xys = [(f x,y)|(x,y)<-xys]
+mapSnd f xys = [(x,f y)|(x,y)<-xys]
+mapBoth = map . apBoth
+apBoth f (x,y) = (f x,f y)
+apSnd f (x,y) = (x,f y)
+
+infix 1 .=
+n .= v = (n,showJSON v)