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

5 files changed, 120 insertions, 22 deletions

diff --git a/src-3.0/GF/Command/Abstract.hs b/src-3.0/GF/Command/Abstract.hs
index 127cbf6e0..1f72688a0 100644
--- a/src-3.0/GF/Command/Abstract.hs
+++ b/src-3.0/GF/Command/Abstract.hs
@@ -26,3 +26,23 @@ data Argument
   = AExp Exp
   | ANoArg
   deriving (Eq,Ord,Show)
+
+valIdOpts :: String -> String -> [Option] -> String
+valIdOpts flag def opts = case valOpts flag (VId def) opts of
+  VId v -> v
+  _     -> def
+
+valIntOpts :: String -> Integer -> [Option] -> Int
+valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
+  VInt v -> v
+  _      -> def
+
+valOpts :: String -> Value -> [Option] -> Value
+valOpts flag def opts = case lookup flag flags of
+  Just v -> v
+  _ -> def
+ where
+   flags = [(f,v) | OFlag f v <- opts]
+
+isOpt :: String -> [Option] -> Bool
+isOpt o opts = elem o [x | OOpt x <- opts]
diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs
index ceabbde7b..e97c54861 100644
--- a/src-3.0/GF/Command/Commands.hs
+++ b/src-3.0/GF/Command/Commands.hs
@@ -64,26 +64,6 @@ commandHelp full (co,info) = unlines $ [
   "flags: " ++ unwords (flags info)
   ] else []
 
-valIdOpts :: String -> String -> [Option] -> String
-valIdOpts flag def opts = case valOpts flag (VId def) opts of
-  VId v -> v
-  _     -> def
-
-valIntOpts :: String -> Integer -> [Option] -> Int
-valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
-  VInt v -> v
-  _      -> def
-
-valOpts :: String -> Value -> [Option] -> Value
-valOpts flag def opts = case lookup flag flags of
-  Just v -> v
-  _ -> def
- where
-   flags = [(f,v) | OFlag f v <- opts]
-
-isOpt :: String -> [Option] -> Bool
-isOpt o opts = elem o [x | OOpt x <- opts]
-
 -- this list must be kept sorted by the command name!
 allCommands :: PGF -> Map.Map String CommandInfo
 allCommands pgf = Map.fromAscList [
diff --git a/src-3.0/GF/Command/Parse.hs b/src-3.0/GF/Command/Parse.hs
index e3cc21cca..dfab70128 100644
--- a/src-3.0/GF/Command/Parse.hs
+++ b/src-3.0/GF/Command/Parse.hs
@@ -1,4 +1,4 @@
-module GF.Command.Parse(readCommandLine) where
+module GF.Command.Parse(readCommandLine, pCommand) where
 
 import PGF.ExprSyntax
 import GF.Command.Abstract
diff --git a/src-3.0/GF/System/UseReadline.hs b/src-3.0/GF/System/UseReadline.hs
index c4a8f9239..7a4999850 100644
--- a/src-3.0/GF/System/UseReadline.hs
+++ b/src-3.0/GF/System/UseReadline.hs
@@ -18,6 +18,8 @@ import System.Console.Readline
 
 fetchCommand :: String -> IO (String)
 fetchCommand s = do
+  setCompletionAppendCharacter Nothing
+  setBasicQuoteCharacters ""
   res <- readline s
   case res of
    Nothing -> return "q"
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