content: {-# OPTIONS_GHC -cpp #-}
  {-# LANGUAGE CPP #-}
  
  -- This module contains routines to provide an interactive shell prompt and is
  -- built on top of the readline library.
  
  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
  
  
  --simpleCommand :: String -> IO (Maybe String)
  
  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"),
  --    (":execfile!", "run sequence of commands from a file if it exists"),
      (":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,               -- ^ the prompt to use
      interactCommands :: [InteractCommand],  -- ^ a list of commands
      interactSettables :: [String],          -- ^ possible things that may be set
      interactVersion :: String,              -- ^ version string to print
      interactSet :: Map.Map String String,   -- ^ vars that are actually set
      interactExpr :: Interact -> String -> IO Interact, -- ^ what to run on a bare expression
      interactRC   :: [String],               -- ^ commands to run at startup
      interactWords :: [String],              -- ^ list of words to autocomplete
      interactEcho :: Bool,                   -- ^ whether to echo commands
      interactCommandMode :: Bool,                -- ^ whether we are in command mode
      interactHistFile :: Maybe String,       -- ^ filename to store history of commands in
      interactComment :: Maybe String         -- ^ comment initializer
      }
  
  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 } = ":"
  
  -- | run a command as if typed at prompt
  
  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 ]
  --        expand s = fsts (args s) ++ filter (isPrefixOf s) (interactSettables act)
  
      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
  
  
  -- | begin interactive interaction
  
  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 -- This will only be called if an exception such
                              -- as a SigINT is received.
              (\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
  
  
  