module Util.Interact(
Interact(..),
InteractCommand(..),
beginInteraction,
runInteraction,
runInteractions,
emptyInteract) where
import Data.Char
import Control.Monad.Identity
import Data.List
import qualified Data.Map as Map
#if defined(USE_HASKELINE)
import System.Console.Haskeline
import System.Console.Haskeline.IO
import Control.Exception
#elif defined(USE_EDITLINE)
import System.Console.Editline.Readline
#else
import System.Console.Readline
#endif
import System.Directory
import System.IO
import GenUtil
import Support.CompatMingw32
#ifndef USE_HASKELINE
readLine :: String -> (String -> IO [String]) -> IO String
readLine prompt tabExpand = do
setCompletionEntryFunction (Just (\s -> tabExpand s))
s <- readline prompt
case s of
Nothing -> putStrLn "Bye!" >> exitSuccess
Just cs | all isSpace cs -> return ""
Just s -> addHistory s >> return s
#endif
commands = [
(":quit","quit interactive session"),
(":version","print out version number"),
(":cd", "change directory to argument"),
(":pwd", "show current directory"),
(":set", "set options"),
(":unset", "unset options"),
(":execfile", "run sequence of commands from a file"),
(":echo", "echo argument to screen"),
#ifndef USE_HASKELINE
(":addhist", "add argument to command line history"),
#endif
(":command", "enter command mode"),
(":normal", "enter normal mode"),
(":help", "print help table")
]
extra_help = [
("!command", "run shell command")
]
basicParse :: Maybe String -> String -> Either (String,String) String
basicParse comm s = f (cleanupWhitespace s) where
f xs | Just c <- comm, c `isPrefixOf` xs = Right ""
f (':':rs) = Left (':':dropWhile (== ':') (map toLower as),dropWhile isSpace rest) where
(as,rest) = span isAlpha rs
f s = Right s
data InteractCommand = InteractCommand {
commandName :: String,
commandHelp :: String,
commandAction :: Interact -> String -> String -> IO Interact
}
data Interact = Interact {
interactPrompt :: String,
interactCommands :: [InteractCommand],
interactSettables :: [String],
interactVersion :: String,
interactSet :: Map.Map String String,
interactExpr :: Interact -> String -> IO Interact,
interactRC :: [String],
interactWords :: [String],
interactEcho :: Bool,
interactCommandMode :: Bool,
interactHistFile :: Maybe String,
interactComment :: Maybe String
}
emptyInteract = Interact {
interactPrompt = ">",
interactCommands = [],
interactSettables = [],
interactVersion = "(none)",
interactSet = Map.empty,
interactExpr = \i s -> putStrLn ("Unknown Command: " ++ s) >> return i,
interactRC = [],
interactWords = [],
interactEcho = False,
interactCommandMode = False,
interactHistFile = Nothing,
interactComment = Nothing
}
cleanupWhitespace s = reverse $ dropWhile isSpace (reverse $ dropWhile isSpace s)
runInteractions :: Interact -> [String] -> IO Interact
runInteractions act [] = return act
runInteractions act (x:xs) = do
act' <- runInteraction act x
runInteractions act' xs
thePrompt Interact { interactCommandMode = False, interactPrompt = p } = p
thePrompt Interact { interactCommandMode = True } = ":"
runInteraction :: Interact -> String -> IO Interact
runInteraction act s = do
act <- runInteractions act { interactRC = [] } (interactRC act)
let commands' = commands ++ [ (n,h) | InteractCommand { commandName = n, commandHelp = h } <- interactCommands act ]
help_text = unlines $ buildTableLL (commands' ++ extra_help)
let args s = [ bb | bb@(n,_) <- commands', s `isPrefixOf` n ]
let showSet
| null $ interactSettables act = putStrLn "Nothing may be set"
| otherwise = do
let set = [ " " ++ if null b then a else a ++ "=" ++ b | (a,b) <- Map.toList $ interactSet act]
setable = [ " " ++ a | a <- sort $ interactSettables act, not $ a `Map.member` interactSet act]
when (not $ null set) $ putStrLn "Set options:" >> putStr (unlines set)
when (not $ null setable) $ putStrLn "Setable options:" >> putStr (unlines setable)
case basicParse (interactComment act) (if interactCommandMode act then ':':s else s) of
Right "" -> return act
Right ('!':rest) -> systemCompat rest >> return act
Right s -> do
when (interactEcho act) $ putStrLn $ (interactPrompt act) ++ s
act' <- interactExpr act act s
return act'
Left (cmd,arg) -> case fsts $ args cmd of
[":quit"] -> putStrLn "Bye!" >> exitSuccess
[":help"] -> putStrLn help_text >> return act
[":version"] -> putStrLn (interactVersion act) >> return act
[":echo"] -> putStrLn arg >> return act
#ifndef USE_HASKELINE
[":addhist"] -> addHistory arg >> return act
#endif
[":cd"] -> iocatch (setCurrentDirectory arg) (\_ -> putStrLn $ "Could not change to directory: " ++ arg) >> return act
[":pwd"] -> (iocatch getCurrentDirectory (\_ -> putStrLn "Could not get current directory." >> return "") >>= putStrLn) >> return act
[":set"] -> case simpleUnquote arg of
[] -> showSet >> return act
rs -> do
let ts = [ let (a,b) = span (/= '=') x in (cleanupWhitespace a,drop 1 b) | x <- rs ]
sequence_ [ putStrLn $ "Unknown option: " ++ a | (a,_) <- ts, a `notElem` interactSettables act]
return act { interactSet = Map.fromList [ x | x@(a,_) <- ts, a `elem` interactSettables act ] `Map.union` interactSet act }
[":unset"] -> return act { interactSet = interactSet act Map.\\ Map.fromList [ (cleanupWhitespace rs,"") | rs <- simpleUnquote arg] }
[":execfile"] -> do
fc <- iocatch (readFile arg) (\_ -> putStrLn ("Could not read file: " ++ arg) >> return "")
act <- runInteractions act { interactEcho = True } (lines fc)
return act { interactEcho = False }
[":execfile!"] -> do
fc <- iocatch (readFile arg) (\_ -> return "")
runInteractions act { interactEcho = True } (lines fc)
[":command"] -> return act { interactCommandMode = True }
[":normal"] -> return act {interactCommandMode = False }
[m] -> let [a] = [ a | InteractCommand { commandName = n, commandAction = a } <- interactCommands act, n == m] in do
act' <- a act m arg
return act'
(_:_:_) -> putStrLn "Ambiguous command, possibilites are:" >> putStr (unlines $ buildTableLL $ args cmd) >> return act
[] -> (putStrLn $ "Unknown command (use :help for help): " ++ cmd) >> return act
beginInteraction :: Interact -> IO ()
beginInteraction act = do
hist <- case interactHistFile act of
Nothing -> return Nothing
Just fn -> do
ch <- iocatch (readFile fn >>= return . lines) (\_ -> return [])
let cl = (map head $ group ch)
#ifndef USE_HASKELINE
mapM_ addHistory cl
#endif
putStrLn $ show (length cl) ++ " lines of history added from " ++ fn
iocatch (openFile fn AppendMode >>= return . Just) (\_ -> return Nothing)
#if defined(USE_HASKELINE)
bracketOnError (initializeInput $ setComplete noCompletion defaultSettings)
cancelInput
(\hd -> loop act hd >> closeInput hd)
where
loop :: Interact -> InputState -> IO ()
loop act hd = do
minput <- queryInput hd (getInputLine (thePrompt act))
case minput of
Nothing -> putStrLn "Bye!" >> exitSuccess
Just cs | all isSpace cs -> loop act hd
Just s -> do act' <- runInteraction act s
loop act' hd
#else
go hist act
where
go hist act = do
let commands' = commands ++ [ (n,h) | InteractCommand { commandName = n, commandHelp = h } <- interactCommands act ]
args s = [ bb | bb@(n,_) <- commands', s `isPrefixOf` n ]
expand s = snub $ fsts (args s) ++ filter (isPrefixOf s) (interactSettables act ++ interactWords act)
s <- readLine (thePrompt act) (return . expand)
case (hist,s) of
(Just h,(_:_)) -> do
iocatch (hPutStrLn h s >> hFlush h) (const (return ()))
_ -> return ()
act' <- runInteraction act s
go hist act'
#endif