content: {-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
  -- | 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.Commands2(PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands)
  import GF.Command.CommonCommands
  import GF.Command.CommandInfo
  import GF.Command.Help(helpCommand)
  import GF.Command.Abstract
  import GF.Command.Parse(readCommandLine,pCommand)
  import GF.Data.Operations (Err(..),done)
  import GF.Data.Utilities(whenM,repeatM)
  
  import GF.Infra.UseIO(ioErrorText,putStrLnE)
  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 Data.Char
  import Data.List(isPrefixOf)
  import qualified Data.Map as Map
  
  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,try)
  --import Control.Monad
  import Control.Monad.State hiding (void)
  
  import qualified GF.System.Signal as IO(runInterruptibly)
  {-
  #ifdef SERVER_MODE
  import GF.Server(server)
  #endif
  -}
  
  import GF.Command.Messages(welcome)
  
  -- | 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
    P.putStrLn "This shell uses the C run-time system. See help for available commands."
    shell opts files
  
  shell opts files = flip evalStateT (emptyGFEnv opts) $
                     do mapStateT runSIO $ importInEnv opts files
                        loop
  
  {-
  #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) opts files)
    where
      root = flag optDocumentRoot opts
      opts = beQuiet opts0
      jobs = join (flag optJobs opts)
  #else
  mainServerGFI opts port files =
    error "GF has not been compiled with server mode support"
  #endif
  -}
  -- | Read end execute commands until it is time to quit
  loop :: StateT GFEnv IO ()
  loop = repeatM readAndExecute1
  
  -- | Read and execute one command, returning 'True' to continue execution,
  -- | 'False' when it is time to quit
  readAndExecute1 :: StateT GFEnv IO Bool
  readAndExecute1 = mapStateT runSIO . execute1 =<< readCommand
  
  -- | Read a command
  readCommand :: StateT GFEnv IO String
  readCommand =
    do opts <- gets startOpts
       case flag optMode opts of
         ModeRun -> lift tryGetLine
         _       -> lift . fetchCommand =<< get
  
  timeIt act =
    do t1 <- liftSIO $ getCPUTime
       a <-  act
       t2 <- liftSIO $ getCPUTime
       return (t2-t1,a)
  
  -- | Optionally show how much CPU time was used to run an IO action
  optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
  optionallyShowCPUTime opts act 
    | not (verbAtLeast opts Normal) = act
    | otherwise = do (dt,r) <- timeIt act
                     liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
                     return r
  
  type ShellM = StateT GFEnv SIO
  
  -- | Execute a given command line, returning 'True' to continue execution,
  -- | 'False' when it is time to quit
  execute1 :: String -> ShellM Bool
  execute1 s0 =
    do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0}
       execute1' s0
  
  -- | Execute a given command line, without adding it to the history
  execute1' s0 =
    do opts <- gets startOpts
       interruptible $ optionallyShowCPUTime opts $
         case pwords s0 of
        -- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands
        -- special commands
           "q" :_   -> quit
           "!" :ws  -> system_command ws
           "eh":ws  -> execute_history ws
           "i" :ws  -> do import_ ws; continue
        -- other special commands, working on GFEnv
           "dc":ws  -> define_command ws
           "dt":ws  -> define_tree ws
        -- ordinary commands
           _        -> do env <- gets commandenv
                          interpretCommandLine env s0
                          continue
    where
      continue,stop :: ShellM Bool
      continue = return True
      stop = return False
  
      interruptible :: ShellM Bool -> ShellM Bool
      interruptible act =
        do gfenv <- get
           mapStateT (
             either (\e -> printException e >> return (True,gfenv)) return
               <=< runInterruptibly) act
  
    -- Special commands:
  
      quit = do opts <- gets startOpts
                when (verbAtLeast opts Normal) $ putStrLnE "See you."
                stop
  
      system_command ws = do lift $ restrictedSystem $ unwords ws ; continue
  
  
         {-"eh":w:_ -> do
                    cs <- readFile w >>= return . map words . lines
                    gfenv' <- foldM (flip (process False benv)) gfenv cs
                    loopNewCPU gfenv' -}
      execute_history [w] =
        do execute . lines =<< lift (restricted (readFile w))
           continue
        where
          execute :: [String] -> ShellM ()
          execute [] = done
          execute (line:lines) = whenM (execute1' line) (execute lines)
  
      execute_history _   =
         do putStrLnE "eh command not parsed"
            continue
  
      define_command (f:ws) =
          case readCommandLine (unwords ws) of
             Just comm ->
               do modify $
                    \ gfenv ->
                      let env = commandenv gfenv
                      in gfenv {
                           commandenv = env {
                             commandmacros = Map.insert f comm (commandmacros env)
                           }
                         }
                  continue
             _ -> dc_not_parsed
      define_command _ = dc_not_parsed
  
      dc_not_parsed = putStrLnE "command definition not parsed" >> continue
  
      define_tree (f:ws) =
          case H.readExpr (unwords ws) of
            Just exp ->
             do modify $
                  \ gfenv ->
                    let env = commandenv gfenv
                    in gfenv { commandenv = env {
                                 expmacros = Map.insert f exp (expmacros env) } }
                continue
            _ -> dt_not_parsed
      define_tree _ = dt_not_parsed
  
      dt_not_parsed = putStrLnE "value definition not parsed" >> continue
  
  pwords s = case words s of
               w:ws -> getCommandOp w :ws
               ws -> ws
  import_ args =
    do case parseOptions args of
         Ok (opts',files) -> do
           opts <- gets startOpts
           curr_dir <- lift getCurrentDirectory
           lib_dir  <- lift $ getLibraryDirectory (addOptions opts opts')
           importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
         Bad err ->
           do putStrLnE $ "Command parse error: " ++ err
  
  -- | Commands that work on 'GFEnv'
  moreCommands = [
    ("e",  emptyCommandInfo {
       longname = "empty",
       synopsis = "empty the environment (except the command history)",
       exec = \ _ _ ->
              do modify $ \ gfenv -> (emptyGFEnv (startOpts gfenv))
                                       { history=history gfenv }
                 return void
       }),
    ("ph", emptyCommandInfo {
       longname = "print_history",
       synopsis = "print command history",
       explanation = unlines [
         "Prints the commands issued during the GF session.",
         "The result is readable by the eh command.",
         "The result can be used as a script when starting GF."
         ],
       examples = [
        mkEx "ph | wf -file=foo.gfs  -- save the history into a file"
        ],
       exec = \ _ _ ->
              fmap (fromString . unlines . reverse . drop 1 . history) get
       }),
    ("r",  emptyCommandInfo {
       longname = "reload",
       synopsis = "repeat the latest import command",
       exec = \ _ _ ->
         do gfenv0 <- get
            let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
            case imports of
              (s,ws):_ -> do
                putStrLnE $ "repeating latest import: " ++ s
                import_ ws
              _ -> do
                putStrLnE $ "no import in history"
            return void
       })
    ]
  
  
  printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
  
  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 :: Options -> [FilePath] -> ShellM ()
  importInEnv opts files =
    case files of
      _ | flag optRetainResource opts ->
            putStrLnE "Flag -retain is not supported in this shell"
      [file] | takeExtensions file == ".pgf" -> importPGF file
      [] -> done
      _ -> do putStrLnE "Can only import one .pgf file"
    where
      importPGF file =
        do gfenv <- get
           case multigrammar gfenv of
             Just _ -> putStrLnE "Discarding previous grammar"
             _ -> done
           pgf1 <- lift $ readPGF2 file
           let gfenv' = gfenv { pgfenv = pgfEnv pgf1 }
           when (verbAtLeast opts Normal) $
             let langs = Map.keys . concretes $ gfenv'
             in putStrLnE . unwords $ "\nLanguages:":langs
           put gfenv'
  
  tryGetLine = do
    res <- try getLine
    case res of
     Left (e :: SomeException) -> return "q"
     Right l -> return l
  
  prompt env = abs ++ "> "
    where
      abs = maybe "" C.abstractName (multigrammar env)
  
  data GFEnv = GFEnv {
      startOpts :: Options,
    --grammar :: (), -- gfo grammar -retain
    --retain :: (),  -- grammar was imported with -retain flag
      pgfenv :: PGFEnv,
      commandenv :: CommandEnv ShellM,
      history    :: [String]
    }
  
  emptyGFEnv opts = GFEnv opts {-() ()-} emptyPGFEnv emptyCommandEnv []
  
  emptyCommandEnv = mkCommandEnv allCommands
  multigrammar = pgf . pgfenv
  concretes = concs . pgfenv
  
  allCommands =
    extend pgfCommands (helpCommand allCommands:moreCommands)
    `Map.union` commonCommands
  
  instance HasPGFEnv ShellM where getPGFEnv = gets pgfenv
  
  -- ** Completion
  
  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 gfenv
      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
  