{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Utils.Tool
-- Copyright   :  (c) Hamish Mackenzie, Juergen Nicklisch-Franken
-- License     :  GPL
--
-- Maintainer  :  <maintainer@leksah.org>
-- Stability   :  provisional
-- Portability :
--
-- | Support for running external tools.  Written mainly for GHCi but with
-- | support for others in mind.
--
-----------------------------------------------------------------------------

module IDE.Utils.Tool (
    ToolOutput(..),
    toolline,
    ToolCommand(..),
    ToolState(..),
    newToolState,
    runTool,
    runTool',
    runInteractiveTool,
    newGhci,
    executeCommand,
    executeGhciCommand,
    quoteArg,
    escapeQuotes,

--    waitForChildren,
--    forkChild

) where

import Control.Concurrent
    (takeMVar,
     putMVar,
     newEmptyMVar,
     forkIO,
     newChan,
     MVar,
     Chan,
     writeChan,
     getChanContents,
     dupChan)
import Control.Monad (when)
import Data.List (stripPrefix)
import Data.Maybe (isJust, catMaybes)
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
import System.Posix (sigQUIT, sigINT, installHandler)
import System.Posix.Signals (Handler(..))
#endif
import System.Process
    (waitForProcess, ProcessHandle, runInteractiveProcess)
import Control.DeepSeq
import System.Log.Logger (debugM, criticalM)
import System.Exit (ExitCode(..))
import System.IO (hGetContents, hFlush, hPutStrLn, Handle)

data ToolOutput = ToolInput String | ToolError String | ToolOutput String | ToolExit ExitCode deriving(Eq, Show)

instance NFData ExitCode where
    rnf ExitSuccess = rnf ()
    rnf (ExitFailure failureCode) = rnf failureCode

instance  NFData ToolOutput where
    rnf (ToolInput s) = rnf s
    rnf (ToolError s) = rnf s
    rnf (ToolOutput s) = rnf s
    rnf (ToolExit code) = rnf code


data ToolCommand = ToolCommand String ([ToolOutput] -> IO ())
data ToolState = ToolState {
    toolProcess :: MVar ProcessHandle,
    outputClosed :: MVar Bool,
    toolCommands :: Chan ToolCommand,
    toolCommandsRead :: Chan ToolCommand,
    currentToolCommand :: MVar ToolCommand}

data RawToolOutput = RawToolOutput ToolOutput
                   | ToolPrompt
                   | ToolOutClosed
                   | ToolErrClosed
                   | ToolClosed deriving(Eq, Show)

toolline :: ToolOutput -> String
toolline (ToolInput l)  = l
toolline (ToolOutput l) = l
toolline (ToolError l)  = l
toolline (ToolExit _code) = []

quoteArg :: String -> String
quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\""
quoteArg s                = s

escapeQuotes :: String -> String
escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) ""

runTool' :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)
runTool' fp args mbDir = do
    debugM "leksah-server" $ "Start: " ++ show (fp, args)
    (out,pid) <- runTool fp args mbDir
    deepseq out $ waitForProcess pid
    debugM "leksah-server" $ "End: " ++ show (fp, args)
    return (out,pid)

runTool :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)
runTool executable arguments mbDir = do
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
    installHandler sigINT Ignore Nothing
    installHandler sigQUIT Ignore Nothing
#endif
    (inp,out,err,pid) <- runInteractiveProcess executable arguments mbDir Nothing
    output <- getOutputNoPrompt inp out err pid
    return (output, pid)

newToolState :: IO ToolState
newToolState = do
    toolProcess <- newEmptyMVar
    outputClosed <- newEmptyMVar
    toolCommands <- newChan
    toolCommandsRead <- dupChan toolCommands
    currentToolCommand <- newEmptyMVar
    return ToolState{..}

runInteractiveTool :: ToolState -> (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ()
runInteractiveTool tool getOutput' executable arguments = do
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
    installHandler sigINT Ignore Nothing
    installHandler sigQUIT Ignore Nothing
#endif

    (inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing
    putMVar (toolProcess tool) pid
    output <- getOutput' inp out err pid
    -- This is handy to show the processed output
    -- forkIO $ forM_ output (putStrLn.show)
    forkIO $ do
        commands <- getChanContents (toolCommandsRead tool)
        processCommand commands inp output
    return ()
    where
        processCommand [] _ _ = return ()
        processCommand ((command@(ToolCommand commandString handler)):remainingCommands) inp allOutput = do
            putMVar (currentToolCommand tool) command
            hPutStrLn inp commandString
            hFlush inp
            let (output, remainingOutputWithPrompt) = span (/= ToolPrompt) allOutput
            debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString
            handler $ (map ToolInput (lines commandString)) ++ fromRawOutput output
            debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString
            takeMVar (currentToolCommand tool)
            case remainingOutputWithPrompt of
                (ToolPrompt:remainingOutput) -> do
                    debugM "leksah-server" $ "Prompt"
                    processCommand remainingCommands inp remainingOutput
                [] -> do
                    debugM "leksah-server" $ "Tool Output Closed"
                    putMVar (outputClosed tool) True
                _ -> do
                    criticalM "leksah-server" $ "This should never happen in Tool.hs"

{-
newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState
newInteractiveTool getOutput' executable arguments = do
    tool <- newToolState
    runInteractiveTool tool getOutput' executable arguments
    return tool
-}

ghciPrompt :: String
ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX"

data CommandLineReader = CommandLineReader {
    stripInitialPrompt :: String -> Maybe String,
    stripFollowingPrompt :: String -> Maybe String,
    errorSyncCommand :: Maybe String,
    stripExpectedError :: String -> Maybe String
    }

ghciStripInitialPrompt :: String -> Maybe String
ghciStripInitialPrompt output =
    case catMaybes [stripPrefix "Prelude" output, stripPrefix "*" output] of
        remaining:_ ->
            case dropWhile (/= '>') remaining of
                '>':' ':next -> Just next
                _ -> Nothing
        _ -> Nothing

ghciStripFollowingPrompt :: String -> Maybe String
ghciStripFollowingPrompt = stripPrefix ghciPrompt

ghciStripExpectedError :: String -> Maybe String
ghciStripExpectedError output = case stripPrefix "\n<interactive>:1:0" output of
                                    Just rest ->
                                        stripPrefix ": Not in scope: `kM2KWR7LZZbHdXfHUOA5YBBsJVYoC'\n"
                                            (maybe rest id (stripPrefix "-28" rest))
                                    Nothing -> Nothing

ghciCommandLineReader :: CommandLineReader
ghciCommandLineReader    = CommandLineReader {
    stripInitialPrompt   = ghciStripInitialPrompt,
    stripFollowingPrompt = ghciStripFollowingPrompt,
    errorSyncCommand     = Just "kM2KWR7LZZbHdXfHUOA5YBBsJVYoC",
    stripExpectedError   = ghciStripExpectedError
    }

noInputCommandLineReader :: CommandLineReader
noInputCommandLineReader = CommandLineReader {
    stripInitialPrompt = const Nothing,
    stripFollowingPrompt = const Nothing,
    errorSyncCommand = Nothing,
    stripExpectedError = const Nothing
    }
--waitTillEmpty :: Handle -> IO ()
--waitTillEmpty handle = do
--    ready <- hReady handle
--    when ready $ do
--        yield
--        threadDelay 100
--        yield
--        waitTillEmpty handle

getOutput :: CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]
getOutput clr inp out err pid = do
    chan <- newChan
    testClosed <- dupChan chan
    -- hSetBuffering out NoBuffering
    -- hSetBuffering err NoBuffering
    foundExpectedError <- newEmptyMVar
    -- Use this and the too putStr threads bellow if you want to see the raw output
    -- hSetBuffering stdout NoBuffering
    forkIO $ do
        errors <- hGetContents err
        -- forkIO $ putStr errors
        readError chan (filter (/= '\r') errors) foundExpectedError
        writeChan chan ToolErrClosed
    forkIO $ do
        output <- hGetContents out
        -- forkIO $ putStr output
        readOutput chan (filter (/= '\r') output) True foundExpectedError False
        writeChan chan ToolOutClosed
    forkIO $ do
        output <- getChanContents testClosed
        when ((ToolOutClosed `elem` output) && (ToolErrClosed `elem` output)) $ do
            exitCode <- waitForProcess pid
            writeChan chan (RawToolOutput (ToolExit exitCode))
            writeChan chan ToolClosed
            debugM "leksah-server" $ "Tool Exited " ++ show exitCode
    fmap (takeWhile ((/=) ToolClosed)) $ getChanContents chan
    where
        readError chan errors foundExpectedError = do
            case stripExpectedError clr errors of
                Just unexpectedErrors -> do
                    putMVar foundExpectedError True
                    readError chan unexpectedErrors foundExpectedError
                Nothing -> do
                    let (line, remaining) = break (== '\n') errors
                    case remaining of
                        [] -> return ()
                        _:remainingLines -> do
                            writeChan chan $ RawToolOutput $ ToolError line
                            readError chan remainingLines foundExpectedError

        readOutput chan output initial foundExpectedError synced = do
            let stripPrompt = (if initial then (stripInitialPrompt clr) else (stripFollowingPrompt clr))
            let line = getOutputLine stripPrompt output
            let remaining = drop (length line) output
            case remaining of
                [] -> do
                        when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line
                '\n':remainingLines -> do
                        writeChan chan $ RawToolOutput $ ToolOutput line
                        readOutput chan remainingLines initial foundExpectedError synced
                _ -> do
                    when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line
                    case stripPrompt remaining of
                        Just afterPrompt -> do
                            case (initial, synced, errorSyncCommand clr) of
                                (True, _, _) -> do
                                    readOutput chan afterPrompt False foundExpectedError synced
                                (False, _, Nothing) -> do
                                    writeChan chan ToolPrompt
                                    readOutput chan afterPrompt False foundExpectedError synced
                                (False, False, Just syncCmd) -> do
                                    hPutStrLn inp syncCmd
                                    hFlush inp
                                    takeMVar foundExpectedError
                                    readOutput chan afterPrompt False foundExpectedError True
                                (False, True, Just _) -> do
                                    writeChan chan ToolPrompt
                                    readOutput chan afterPrompt False foundExpectedError False
                        _ -> return () -- Should never happen
        getOutputLine _ [] = []
        getOutputLine _ ('\n':_) = []
        getOutputLine stripPrompt output@(x:xs)
            | isJust (stripPrompt output) = []
            | otherwise                   = x : (getOutputLine stripPrompt xs)

fromRawOutput :: [RawToolOutput] -> [ToolOutput]
fromRawOutput [] = []
fromRawOutput (RawToolOutput (ToolExit code):_) = [ToolExit code]
fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs)
fromRawOutput (_:xs) = fromRawOutput xs

getGhciOutput :: Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]
getGhciOutput = getOutput ghciCommandLineReader

getOutputNoPrompt :: Handle -> Handle -> Handle -> ProcessHandle -> IO [ToolOutput]
getOutputNoPrompt inp out err pid = fmap fromRawOutput $ getOutput noInputCommandLineReader inp out err pid

newGhci :: [String] -> [String] -> ([ToolOutput] -> IO ()) -> IO ToolState
newGhci buildFlags interactiveFlags startupOutputHandler = do
        tool <- newToolState
        writeChan (toolCommands tool) $
            ToolCommand (":set prompt " ++ ghciPrompt) startupOutputHandler
        debugM "leksah-server" $ "Working out GHCi options"
        forkIO $ do
            (output, _) <- runTool "runhaskell" (["Setup","build","--with-ghc=leksahecho"] ++ buildFlags) Nothing
            case catMaybes $ map (findMake . toolline) output of
                options:_ -> do
                        let newOptions = filterUnwanted options
                        debugM "leksah-server" $ newOptions
                        debugM "leksah-server" $ "Starting GHCi"
                        debugM "leksah-server" $ unwords (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)
                        runInteractiveTool tool getGhciOutput "ghci"
                            (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)
                _ -> do
                    startupOutputHandler output
                    putMVar (outputClosed tool) True
        return tool
    where
        findMake [] = Nothing
        findMake line@(_:xs) =
                case stripPrefix "--make " line of
                    Nothing -> findMake xs
                    s -> s
        filterUnwanted [] = []
        filterUnwanted line@(x:xs) =
                case stripPrefix "-O " line of
                    Nothing -> x: filterUnwanted xs
                    Just s  -> filterUnwanted s


executeCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()
executeCommand tool command handler = do
    writeChan (toolCommands tool) $ ToolCommand command handler

executeGhciCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()
executeGhciCommand tool command handler = do
    if '\n' `elem` command
        then executeCommand tool safeCommand $ \output -> do
            handler $ fixInput $ fixOutput output
        else executeCommand tool command handler
    where
        filteredLines = (filter safeLine (lines command))
        promptCount = (length filteredLines)+1
        safeCommand = (unlines ([":{"] ++ filteredLines)) ++ ":}"
        safeLine ":{" = False
        safeLine ":}" = False
        safeLine _ = True
        fixOutput ((ToolOutput line):xs) = (ToolOutput (removePrompts line line promptCount)):xs
        fixOutput (x:xs) = x:(fixOutput xs)
        fixOutput [] = []
        fixInput = filter (\x -> (x /= ToolInput ":{") && (x /= ToolInput ":}"))
        removePrompts _fullLine line 0 = line
        removePrompts fullLine line n = case dropWhile ((/=) '|') line of
            '|':' ':xs -> removePrompts fullLine xs (n-1)
            _ -> fullLine

--children :: MVar [MVar ()]
--children = unsafePerformIO (newMVar [])
--
--waitForChildren :: IO ()
--waitForChildren = do
--  cs <- takeMVar children
--  case cs of
--    []   -> return ()
--    m:ms -> do
--       putMVar children ms
--       takeMVar m
--       waitForChildren
--
--forkChild :: IO () -> IO ThreadId
--forkChild io = do
--    mvar <- newEmptyMVar
--    childs <- takeMVar children
--    putMVar children (mvar:childs)
--    forkIO (io `finally` putMVar mvar ())