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

import PGF
import PGF.Data
import PGF.Macros
import PGF.Expr (readTree)

import Data.Char
import Data.List(isPrefixOf)
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP
import System.Cmd
import System.CPUTime
import Control.Exception

import Data.Version
import Paths_gf

mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do
  putStrLn welcome
  gfenv <- importInEnv emptyGFEnv opts files
  loop opts gfenv
  return ()

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
        putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
        loop opts $ gfenv' {cputime = cpu'}
  let 
    pwords = case words s of
      w:ws -> getCommandOp w :ws
      ws -> ws
  case pwords of
  -- special commands, requiring source grammar in env
    "!":ws -> do
       system $ unwords ws
       loopNewCPU gfenv
    "cc":ws -> do
       let 
         (style,term) = case ws of 
           ('-':w):ws2 -> (pTermPrintStyle w, ws2)
           _ -> (TermPrintDefault, ws)
       case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of   ---- pipe!
         Ok  x -> putStrLn (showTerm style x)
         Bad s -> putStrLn s
       loopNewCPU gfenv
    "i":args -> do
        gfenv' <- case parseOptions args of
                    Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
                    Bad err -> do putStrLn $ "Command parse error: " ++ err
                                  return gfenv
        loopNewCPU gfenv'

  -- other special commands, working on GFEnv
    "e":_ -> loopNewCPU $ gfenv {
       commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
       }

    "dc":f:ws -> do
       case readCommandLine (unwords ws) of
         Just comm -> loopNewCPU $ gfenv {
           commandenv = env {
             commandmacros = Map.insert f comm (commandmacros env)
             }
           }
         _ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv

    "dt":f:ws -> do
       case readTree (unwords ws) of
         Just exp -> loopNewCPU $ gfenv {
           commandenv = env {
             expmacros = Map.insert f exp (expmacros env)
             }
           }
         _ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv

    "ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
    "q":_  -> putStrLn "See you." >> return gfenv

  -- ordinary commands, working on CommandEnv
    _ -> do
      interpretCommandLine env s
      loopNewCPU gfenv

importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
importInEnv gfenv opts files
    | flag optRetainResource opts =
        do src <- importSource (sourcegrammar gfenv) opts files
           return $ gfenv {sourcegrammar = src}
    | otherwise =
        do let opts' = addOptions (setOptimization OptCSE False) opts
               pgf0 = multigrammar (commandenv gfenv)
           pgf1 <- importGrammar pgf0 opts' files
           putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
           return $ gfenv { commandenv = mkCommandEnv pgf1 }

welcome = unlines [
  "                              ",
  "         *  *  *              ",
  "      *           *           ",
  "    *               *         ",
  "   *                          ",
  "   *                          ",
  "   *        * * * * * *       ",
  "   *        *         *       ",
  "    *       * * * *  *        ",
  "      *     *      *          ",
  "         *  *  *              ",
  "                              ",
  "This is GF version "++showVersion version++". ",
  "Some things may work.         "
  ]

prompt env = absname ++ "> " where
  absname = case abstractName (multigrammar env) of
    "_" -> ""  --- created by new Ident handling 22/5/2008
    n   -> n

data GFEnv = GFEnv {
  sourcegrammar :: Grammar, -- gfo grammar -retain
  commandenv :: CommandEnv,
  history    :: [String],
  cputime    :: Integer
  }

emptyGFEnv :: GFEnv
emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0


wordCompletion cmdEnv line prefix p =
  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 (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
      -> filenameCompletionFunction prefix
    CmplIdent _ pref
      -> do mb_abs <- try (evaluate (abstract pgf))
            case mb_abs of
              Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
              Left  _   -> ret ' ' []
    _ -> 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