complete word completion in the shell. works for commands, flags, options, abstract syntax identifiers and NL strings

1 files changed, 97 insertions, 1 deletions

diff --git a/src-3.0/GFI.hs b/src-3.0/GFI.hs
index 92c835123..74ebaf90b 100644
--- a/src-3.0/GFI.hs
+++ b/src-3.0/GFI.hs
@@ -3,15 +3,24 @@ module GFI (mainGFI) where
 import GF.Command.Interpreter
 import GF.Command.Importing
 import GF.Command.Commands
+import GF.Command.Abstract
+import GF.Command.Parse
 import GF.Data.ErrM
 import GF.Grammar.API  -- for cc command
 import GF.Infra.UseIO
 import GF.Infra.Option
-import GF.System.Readline (fetchCommand)
+import GF.System.Readline
+
 import PGF
 import PGF.Data
+import PGF.Macros
 
+import Data.Char
+import Data.List(isPrefixOf)
+import qualified Data.Map as Map
+import qualified Text.ParserCombinators.ReadP as RP
 import System.CPUTime
+import Control.Exception
 
 import Data.Version
 import Paths_gf
@@ -28,6 +37,7 @@ loop :: Options -> GFEnv -> IO GFEnv
 loop opts gfenv0 = do
   let env = commandenv gfenv0
   let sgr = sourcegrammar gfenv0
+  setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
   s <- fetchCommand (prompt env)
   let gfenv = gfenv0 {history = s : history gfenv0}
   let loopNewCPU gfenv' = do cpu' <- getCPUTime
@@ -102,3 +112,89 @@ data GFEnv = GFEnv {
 
 emptyGFEnv :: GFEnv
 emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
+
+
+wordCompletion cmdEnv line prefix p = do
+  case wc_type (take p line) of
+    CmplCmd pref
+      -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
+    CmplStr (Just (Command _ opts _)) s
+      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat  opts)))
+            case mb_state0 of
+              Right state0 -> let ws     = words (take (length s - length prefix) s)
+                                  state  = foldl nextState state0 ws
+                                  compls = getCompletions state prefix
+                              in ret ' ' (Map.keys compls)
+              Left  _      -> ret ' ' []
+    CmplOpt (Just (Command n _ _)) pref
+      -> case Map.lookup n (commands cmdEnv) of
+           Just inf -> do let flg_compls = ['-':flg | flg <- flags   inf, isPrefixOf pref flg]
+                              opt_compls = ['-':opt | opt <- options inf, isPrefixOf pref opt]
+                          ret (if null flg_compls then ' ' else '=')
+                              (flg_compls++opt_compls)
+           Nothing  -> ret ' ' []
+    CmplIdent _ pref
+      -> ret ' ' [name | cid <- Map.keys (funs (abstract pgf)), let name = prCId cid, isPrefixOf pref name]
+    _ -> ret ' ' []
+  where
+    pgf = multigrammar cmdEnv
+    optLang opts = valIdOpts "lang" (head (languages pgf)) opts
+    optCat  opts = valIdOpts "cat"  (lookStartCat pgf)     opts
+    
+    ret c [x] = return [x++[c]]
+    ret _ xs  = return 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 (c:cs)
+      | isIdent c     = option x y cs
+      | otherwise     = 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 == '=') 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