gf -cshell: preliminary support for the C run-time system in the GF shell

Some C run-time functionality is now available in the GF shell, by starting
GF with 'gf -cshell' or 'gf -crun'. Only limited functionality is available
when running the shell in these modes:

- You can only import .pgf files, not source files.
- The -retain flag can not be used and the commands that require it to work
  are not available.
- Only 18 of the 40 commands available in the usual shell have been
  implemented. The 'linearize' and 'parse' commands are the only ones
  that call the C run-time system, and they support only a limited set of
  options and flags. Use the 'help' commmands for details.
- A new command 'generate_all', that calls PGF2.generateAll, has been added.
  Unfortuntaly, using it causes 'segmentation fault'.

This is implemented by adding two new modules: GF.Command.Commands2 and
GF.Interactive2. They are copied and modified versions of GF.Command.Commands
and GF.Interactive, respectively. Code for unimplemented commands and other
code that has not been adapted to the C run-time system has been left in
place, but commented out, pending further work.

gf.cabal

@@ -132,13 +132,14 @@ Library
     PGF.OldBinary
 
   if flag(c-runtime)
-    exposed-modules:     PGF2
+    exposed-modules: PGF2
-    other-modules:       PGF2.FFI
+    other-modules:   PGF2.FFI
-    hs-source-dirs:      src/runtime/haskell-bind
+                     GF.Interactive2 GF.Command.Commands2
-    build-tools:         hsc2hs
+    hs-source-dirs:  src/runtime/haskell-bind
-    extra-libraries:     gu pgf
+    build-tools:     hsc2hs
-    c-sources:           src/runtime/haskell-bind/utils.c
+    extra-libraries: gu pgf
-    cc-options:          -std=c99
+    c-sources:       src/runtime/haskell-bind/utils.c
+    cc-options:      -std=c99
 
 ---- GF compiler as a library:
 

src/compiler/GF/Infra/Option.hs

@@ -73,7 +73,10 @@ errors = raise . unlines
 
 -- Types
 
-data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
+data Mode = ModeVersion | ModeHelp
+          | ModeInteractive | ModeRun
+          | ModeInteractive2 | ModeRun2
+          | ModeCompiler
           | ModeServer {-port::-}Int
   deriving (Show,Eq,Ord)
 
@@ -302,6 +305,8 @@ optDescr =
      Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
      Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
      Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
+     Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.",
+     Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).",
      Option [] ["server"] (OptArg modeServer "port") $
        "Run in HTTP server mode on given port (default "++show defaultPort++").",
      Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")

src/compiler/GF/Infra/SIO.hs

@@ -1,5 +1,6 @@
 -- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the
 -- ability to capture output that normally would be sent to stdout.
+{-# LANGUAGE CPP #-}
 module GF.Infra.SIO(
        -- * The SIO monad
        SIO,
@@ -11,6 +12,9 @@ module GF.Infra.SIO(
        newStdGen,print,putStrLn,
        -- ** Specific to GF
        importGrammar,importSource,
+#ifdef C_RUNTIME
+       readPGF2,
+#endif
        putStrLnFlush,runInterruptibly,lazySIO,
        -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
        -- | If the environment variable GF_RESTRICTED is defined, these
@@ -33,6 +37,9 @@ import qualified System.Random as IO(newStdGen)
 import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
 import qualified GF.System.Signal as IO(runInterruptibly)
 import qualified GF.Command.Importing as GF(importGrammar, importSource)
+#ifdef C_RUNTIME
+import qualified PGF2
+#endif
 
 -- * The SIO monad
 
@@ -96,3 +103,7 @@ lazySIO              = lift1   lazyIO
 
 importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
 importSource      opts files = lift0 $ GF.importSource      opts files
+
+#ifdef C_RUNTIME
+readPGF2 = lift0 . PGF2.readPGF
+#endif

src/compiler/GF/Interactive2.hs

@@ -0,0 +1,538 @@
+{-# LANGUAGE ScopedTypeVariables, CPP #-}
+-- | GF interactive mode (with the C run-time system)
+module GF.Interactive2 (mainGFI,mainRunGFI{-,mainServerGFI-}) where
+import Prelude hiding (putStrLn,print)
+import qualified Prelude as P(putStrLn)
+import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,interpretCommandLine)
+--import GF.Command.Importing(importSource,importGrammar)
+import GF.Command.Commands2(flags,options,PGFEnv,pgfEnv,emptyPGFEnv,allCommands)
+import GF.Command.Abstract
+import GF.Command.Parse(readCommandLine,pCommand)
+import GF.Data.Operations (Err(..),chunks,err,raise,done)
+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 qualified PGF2 as C
+import qualified PGF as H
+import qualified PGF.Internal as H(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 System.FilePath(takeExtensions)
+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)
+
+-- | Run the GF Shell in quiet mode (@gf -run@).
+mainRunGFI :: Options -> [FilePath] -> IO ()
+mainRunGFI opts files = shell (beQuiet opts) files
+
+beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
+
+-- | Run the interactive GF Shell
+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
+-- | 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 opts)
+      =<< runSIO (importInEnv emptyGFEnv opts files)
+  where
+    root = flag optDocumentRoot opts
+    opts = beQuiet opts0
+    jobs = join (flag optJobs opts)
+#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 done (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 = grammar 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 (render 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)): 
+                 [render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
+        _ | elem "-save" os -> mapM_ 
+                 (\ m@(i,_) -> let file = (render 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 --, grammar = ()
+             }
+
+    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 H.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 <- return (CN.normalForm (CN.resourceValues noOptions sgr) (L NoLoc identW) 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 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 =
+  case files of
+    _ | flag optRetainResource opts ->
+          do putStrLn "Flag -retain is not supported in this shell"
+             return gfenv
+    [file] | takeExtensions file == ".pgf" -> importPGF file
+    [] -> return gfenv
+    _ -> do putStrLn "Can only import one .pgf file"
+            return gfenv
+  where
+    importPGF file =
+      do case multigrammar (commandenv gfenv) of
+           Just _ -> putStrLnFlush "Discarding previous grammar"
+           _ -> done
+         pgf1 <- readPGF2 file
+         let gfenv' = gfenv { commandenv = commandEnv pgf1 }
+         when (verbAtLeast opts Normal) $
+           let langs = Map.keys . concretes $ commandenv gfenv'
+           in putStrLnFlush . unwords $ "\nLanguages:":langs
+         return gfenv'
+
+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",
+  "",
+  "This shell uses the C run-time system. See help for available commands."
+  ]
+
+prompt env = abs ++ "> "
+  where
+    abs = maybe "" C.abstractName (multigrammar (commandenv env))
+
+data GFEnv = GFEnv {
+--grammar :: (), -- gfo grammar -retain
+--retain :: (),  -- grammar was imported with -retain flag
+  commandenv :: CommandEnv PGFEnv,
+  history    :: [String]
+  }
+
+emptyGFEnv :: GFEnv
+emptyGFEnv = GFEnv {-() ()-} emptyCommandEnv [] {-0-}
+
+commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands
+emptyCommandEnv = mkCommandEnv emptyPGFEnv allCommands
+multigrammar = fst . pgfenv
+concretes = snd . pgfenv
+
+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 (H.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 = H.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
+      -> case mb_pgf of
+           Just pgf -> ret (length pref)
+                           [Haskeline.simpleCompletion name 
+                            | name <- C.functions pgf,
+                              isPrefixOf pref name]
+           _ -> ret (length pref) []
+
+    _ -> ret 0 []
+  where
+    mb_pgf = multigrammar cmdEnv
+    cmdEnv = commandenv gfenv
+{-
+    optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts
+    optType opts = 
+      let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts
+      in case H.readType str of
+           Just ty -> ty
+           Nothing -> error ("Can't parse '"++str++"' as type")
+
+    loop ps []     = Just ps
+    loop ps (t:ts) = case H.nextState ps (H.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

src/compiler/GF/Main.hs

@@ -1,7 +1,11 @@
 -- | GF main program (grammar compiler, interactive shell, http server)
+{-# LANGUAGE CPP #-}
 module GF.Main where
 import GF.Compiler
-import GF.Interactive
+import qualified GF.Interactive as GFI1
+#ifdef C_RUNTIME
+import qualified GF.Interactive2 as GFI2
+#endif
 import GF.Data.ErrM
 import GF.Infra.Option
 import GF.Infra.UseIO
@@ -43,7 +47,17 @@ mainOpts opts files =
     case flag optMode opts of
       ModeVersion     -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
       ModeHelp        -> putStrLn helpMessage
-      ModeInteractive -> mainGFI opts files
+      ModeServer port -> GFI1.mainServerGFI opts port files
-      ModeRun         -> mainRunGFI opts files
-      ModeServer port -> mainServerGFI opts port files
       ModeCompiler    -> mainGFC opts files
+      ModeInteractive -> GFI1.mainGFI opts files
+      ModeRun         -> GFI1.mainRunGFI opts files
+#ifdef C_RUNTIME
+      ModeInteractive2 -> GFI2.mainGFI opts files
+      ModeRun2         -> GFI2.mainRunGFI opts files
+#else
+      ModeInteractive2 -> noCruntime
+      ModeRun2         -> noCruntime
+  where
+    noCruntime = do ePutStrLn "GF configured without C run-time support"
+                    exitFailure
+#endif

src/runtime/haskell-bind/PGF2.hsc

@@ -15,7 +15,7 @@
 module PGF2 (-- * CId
              CId,
              -- * PGF
-             PGF,readPGF,AbsName,abstractName,startCat,
+             PGF,readPGF,AbsName,abstractName,Cat,startCat,
              -- * Concrete syntax
              ConcName,Concr,languages,parse,parseWithHeuristics,
              hasLinearization,linearize,linearizeAll,alignWords,