{-# 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(..),
    toolProcess,
    newToolState,
    runTool,
    runTool',
    runInteractiveTool,
    newGhci,
    executeCommand,
    executeGhciCommand,
    quoteArg,
    escapeQuotes,

--    waitForChildren,
--    forkChild

) where

import Control.Concurrent
       (readMVar, takeMVar, putMVar, newEmptyMVar, forkIO, newChan, MVar,
        Chan, writeChan, getChanContents, dupChan)
import Control.Monad (unless, when)
import Data.List (stripPrefix)
import Data.Maybe (isJust, catMaybes)
#ifdef MIN_VERSION_process_leksah
import IDE.System.Process
       (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..))
import IDE.System.Process.Internals (StdStream(..))
#else
import System.Process
       (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..))
import System.Process.Internals (StdStream(..))
#endif
import Control.DeepSeq
import System.Log.Logger (debugM, criticalM)
import System.Exit (ExitCode(..))
import System.IO (hGetContents, hFlush, hPutStrLn, Handle)
import Control.Applicative ((<$>))
import Data.Char (isNumber)

data ToolOutput = ToolInput String
                | ToolError String
                | ToolOutput String
                | ToolPrompt
                | 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 (ToolPrompt) = rnf ()
    rnf (ToolExit code) = rnf code

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

toolProcess :: ToolState -> IO ProcessHandle
toolProcess = readMVar . toolProcessMVar

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

toolline :: ToolOutput -> String
toolline (ToolInput l)  = l
toolline (ToolOutput l) = l
toolline (ToolError l)  = l
toolline (ToolPrompt)  = ""
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
    (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments)
        { std_in  = CreatePipe,
          std_out = CreatePipe,
          std_err = CreatePipe,
          cwd = mbDir,
          new_group = True }
    output <- getOutputNoPrompt inp out err pid
    return (output, pid)

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

runInteractiveTool ::
    ToolState ->
    CommandLineReader ->
    FilePath ->
    [String] ->
    IO ()
runInteractiveTool tool clr executable arguments = do
    (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments)
        { std_in  = CreatePipe,
          std_out = CreatePipe,
          std_err = CreatePipe,
          new_group = True }
    putMVar (toolProcessMVar tool) pid
    output <- getOutput clr inp out err pid
    -- This is handy to show the processed output
    -- forkIO $ forM_ output (putStrLn.show)
    forkIO $ do
        commands <- getChanContents (toolCommandsRead tool)
        processCommand 0 commands inp output
    return ()
    where
        processCommand _ [] _ _ = do
            debugM "leksah-server" $ "No More Commands"
            return ()
        processCommand n ((command@(ToolCommand commandString handler)):remainingCommands)
                inp allOutput = do
            putMVar (currentToolCommand tool) command
            hPutStrLn inp commandString
            hFlush inp
            outputChan <- newChan
            outputChan' <- dupChan outputChan

            done <- newEmptyMVar
            forkIO $ do
                output <- fromRawOutput <$> getChanContents outputChan'
                debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString
                handler $ (map ToolInput (lines commandString)) ++ output
                debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString
                putMVar done True
                return ()

            remainingOutputWithPrompt <- writeCommandOutput outputChan inp allOutput False False (outputSyncCommand clr) n
            takeMVar done

            takeMVar (currentToolCommand tool)

            case remainingOutputWithPrompt of
                (RawToolOutput ToolPrompt:remainingOutput) -> do
                    debugM "leksah-server" $ "Ready For Next Command"
                    processCommand (n+1) 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"

        writeCommandOutput _ _ [] _ _ _ _ = do
            criticalM "leksah-server" $ "ToolExit not found"
            return []

        writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) False False (Just outSyncCmd) n = do
            debugM "leksah-server" $ "Pre Sync Prompt"
            hPutStrLn inp $ outSyncCmd n
            hFlush inp
            writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n

        writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) True False (Just outSyncCmd) n = do
            debugM "leksah-server" $ "Unsynced Prompt"
            writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n

        writeCommandOutput out inp (o@(RawToolOutput (ToolOutput line)):remainingOutput) True False (Just outSyncCmd) n = do
            let synced = (isExpectedOutput clr n line)
            unless synced $ writeChan out o
            when synced $ debugM "leksah-server" $ "Output Sync Found"
            writeCommandOutput out inp remainingOutput True synced (Just outSyncCmd) n

        writeCommandOutput out _ remainingOutput@(RawToolOutput ToolPrompt:_) _ _ _ _ = do
            debugM "leksah-server" $ "Synced Prompt"
            writeChan out $ RawToolOutput ToolPrompt
            return remainingOutput

        writeCommandOutput out _ (o@(RawToolOutput (ToolExit _)):_) _ _ _ _ = do
            debugM "leksah-server" $ "Tool Exit"
            writeChan out o
            return []

        writeCommandOutput out inp (o:remainingOutput) synching synched syncCmd n = do
            writeChan out o
            writeCommandOutput out inp remainingOutput synching synched syncCmd n

{-
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 (Int -> String),
    stripExpectedError :: String -> Maybe (Int, String),
    outputSyncCommand :: Maybe (Int -> String),
    isExpectedOutput :: Int -> String -> Bool
    }

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

{-
stripMarker $ marker 0 ++ "dfskfjdkl"
-}

marker :: Int -> String
marker n =
        take (29 - length num) "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" ++ num
    where num = show n

stripMarker :: String -> Maybe (Int, String)
stripMarker s =
        case strip "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" s of
            Just (nums, rest) -> Just (read nums, rest)
            Nothing -> Nothing
    where
        strip :: String -> String -> Maybe (String, String)
        strip letters@(a:as) input@(b:bs)
            | a == b = strip as bs
            | otherwise = numbers letters input
        strip _ _ = Nothing
        numbers :: String -> String -> Maybe (String, String)
        numbers (_:as) (n:ns)
            | isNumber n = case numbers as ns of
                                Just (nums, rest) -> Just (n:nums, rest)
                                _      -> Nothing
            | otherwise = Nothing
        numbers [] input = Just ([], input)
        numbers _ _ = Nothing



ghciStripExpectedError :: String -> Maybe (Int, String)
ghciStripExpectedError output =
    case stripPrefix "\n<interactive>:1:" output of
        Just rest ->
            case span (/= ':') rest of
                (cols, rest2) | cols == "0" || cols == "1" || cols == "0-28" || cols == "1-29" ->
                    case stripPrefix ": Not in scope: `" rest2 of
                        Just rest3 ->
                            case stripMarker rest3 of
                                Just (n, rest4) ->
                                    case stripPrefix "'\n" rest4 of
                                        Just rest5 -> Just (n, rest5)
                                        Nothing -> Nothing
                                Nothing -> Nothing
                        Nothing -> Nothing
                _ -> Nothing
        Nothing -> Nothing

ghciIsExpectedOutput :: Int -> String -> Bool
ghciIsExpectedOutput n =
    (==) (marker n)

ghciCommandLineReader :: CommandLineReader
ghciCommandLineReader    = CommandLineReader {
    stripInitialPrompt   = ghciStripInitialPrompt,
    stripFollowingPrompt = ghciStripFollowingPrompt,
    errorSyncCommand     = Just $ \n -> marker n,
    stripExpectedError   = ghciStripExpectedError,
    outputSyncCommand    = Just $ \n -> ":set prompt " ++ marker n ++ "\n:set prompt " ++ ghciPrompt,
    isExpectedOutput     = ghciIsExpectedOutput
    }

noInputCommandLineReader :: CommandLineReader
noInputCommandLineReader = CommandLineReader {
    stripInitialPrompt = const Nothing,
    stripFollowingPrompt = const Nothing,
    errorSyncCommand = Nothing,
    stripExpectedError = \_ -> Nothing,
    outputSyncCommand = Nothing,
    isExpectedOutput = \_ _ -> False
    }
--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) 0 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 (counter, unexpectedErrors) -> do
                    putMVar foundExpectedError counter
                    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 counter foundExpectedError errSynced = do
            let stripPrompt = (if counter==0 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 counter foundExpectedError errSynced
                _ -> do
                    when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line
                    case stripPrompt remaining of
                        Just afterPrompt -> do
                            case (counter, errSynced, errorSyncCommand clr) of
                                (0, _, _) -> do
                                    readOutput chan afterPrompt (counter+1) foundExpectedError errSynced

                                (_, False, Just syncCmd) -> do
                                    hPutStrLn inp $ syncCmd counter
                                    hFlush inp
                                    waitForError counter foundExpectedError
                                    readOutput chan afterPrompt (counter+1) foundExpectedError True

                                _ -> do
                                    writeChan chan $ RawToolOutput ToolPrompt
                                    readOutput chan afterPrompt (counter+1) foundExpectedError False

                        _ -> return () -- Should never happen
        getOutputLine _ [] = []
        getOutputLine _ ('\n':_) = []
        getOutputLine stripPrompt output@(x:xs)
            | isJust (stripPrompt output) = []
            | otherwise                   = x : (getOutputLine stripPrompt xs)
        waitForError counter foundExpectedError = do
            foundCount <- takeMVar foundExpectedError
            when (foundCount < counter) $ waitForError counter foundExpectedError


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

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 "cabal" (["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 ghciCommandLineReader "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 ())