{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Package
-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License     :  GNU-GPL
--
-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>
-- Stability   :  experimental
-- Portability :  portable
--
--
-- | The packages methods of ide.
--
---------------------------------------------------------------------------------


module IDE.Package (
    packageOpen
,   packageConfig
,   packageBuild
,   packageDoc
,   packageClean
,   packageCopy
,   packageRun
,   nextError
,   previousError
,   activatePackage
,   deactivatePackage
,   packageFlags

,   packageInstall
,   packageRegister
,   packageUnregister
,   packageTest
,   packageSdist
,   packageOpenDoc
) where

import Graphics.UI.Gtk
import Control.Monad.Reader
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Verbosity
import System.FilePath
import Control.Concurrent
import System.Directory
import System.IO
--import System.Process
import Prelude hiding (catch)
import Text.ParserCombinators.Parsec.Language
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec hiding(Parser)
import Data.Maybe(isJust,fromJust)
import Control.Exception hiding (try)
import System.Process

import IDE.Log
import IDE.Core.State
import IDE.PackageEditor
import IDE.SourceEditor
import IDE.PackageFlags
import IDE.Framework.ViewFrame
import IDE.Metainfo.Info

packageOpen :: IDEAction
packageOpen = do
    active <- readIDE activePack
    case active of
        Just p -> deactivatePackage
        Nothing -> return ()
    selectActivePackage
    return ()

getActivePackage :: IDEM (Maybe IDEPackage)
getActivePackage = do
    active <- readIDE activePack
    case active of
        Just p -> return (Just p)
        Nothing -> selectActivePackage

activatePackage :: FilePath -> IDEM (Maybe IDEPackage)
activatePackage filePath = do
    session <- readIDE session
    let ppath = dropFileName filePath
    lift $setCurrentDirectory ppath
    ideR    <- ask
    mbPackageD <- lift $ catch (do
        pd <- readPackageDescription normal filePath
        return (Just (flattenPackageDescription pd)))
        (\e -> do
            runReaderT (ideMessage Normal ("Can't activate package " ++(show e))) ideR
            return Nothing)
    case mbPackageD of
        Nothing -> return (Nothing)
        Just packageD -> do
            let packp = IDEPackage (package packageD) filePath (buildDepends packageD) [] [] [] [] [] [] [] []
            pack <- (do
                flagFileExists <- lift $doesFileExist (ppath </> "IDE.flags")
                if flagFileExists
                    then lift $readFlags (ppath </> "IDE.flags") packp
                    else return packp)
            modifyIDE_ (\ide -> return (ide{activePack = (Just pack)}))
            ide <- getIDE
            triggerEvent ideR ActivePack
            sb <- getSBActivePackage
            lift $statusbarPop sb 1
            lift $statusbarPush sb 1 (showPackageId $packageId pack)
            return (Just pack)

deactivatePackage :: IDEAction
deactivatePackage = do
    modifyIDE_ (\ide -> return (ide{activePack = Nothing}))
    ideR <- ask
    triggerEvent ideR ActivePack
    sb <- getSBActivePackage
    lift $statusbarPop sb 1
    lift $statusbarPush sb 1 ""
    return ()

packageFlags :: IDEAction
packageFlags = do
    active <- getActivePackage
    case active of
        Nothing ->   return ()
        Just p  ->   do
            editFlags
            active2 <- getActivePackage
            case active2 of
                Nothing -> do
                    ideMessage Normal "no more active package"
                    return ()
                Just p  ->
                    lift $writeFlags ((dropFileName (cabalFile p)) </> "IDE.flags") p

selectActivePackage :: IDEM (Maybe IDEPackage)
selectActivePackage = do
    window  <- readIDE window
    mbFilePath <- lift $choosePackageFile window
    case mbFilePath of
        Nothing -> return Nothing
        Just filePath -> activatePackage filePath


packageConfig :: IDEAction
packageConfig = do
    mbPackage   <- getActivePackage
    log         <- getLog
    ideR        <- ask
    case mbPackage of
        Nothing         -> return ()
        Just package    -> do
            mbPackageD  <- lift $ catch (do
                (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","configure"]
                                                ++ (configFlags package))
                oid <- forkIO(readOut log out)
                eid <- forkIO (readErr log err)
                pd  <- readPackageDescription normal (cabalFile package)
                return (Just (flattenPackageDescription pd)))
                (\e -> do
                        runReaderT (ideMessage Normal (show e)) ideR
                        return Nothing)
            case mbPackageD of
                Just packageD -> do
                    modifyIDE_ (\ide -> return (ide{activePack =
                        Just package{depends=buildDepends packageD}}))
                    triggerEvent ideR ActivePack
                    return ()
                Nothing -> return ()

packageBuild :: IDEAction
packageBuild = do
    mbPackage   <- getActivePackage
    log         <- getLog
    ideR        <- ask
    case mbPackage of
        Nothing         -> return ()
        Just package    -> do
            sb <- getSBErrors
            lift $statusbarPop sb 1
            lift $statusbarPush sb 1 "Building"
            unmarkCurrentError
            pid' <- lift $do
                (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","build"]
                                                ++ buildFlags package)
                oid     <-  forkIO (readOut log out)
                eid     <-  forkIO (runReaderT (readErrForBuild log err) ideR)
                return pid
            mayRebuildInBackground (Just pid')

packageDoc :: IDEAction
packageDoc = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","haddock"]
                                            ++ (haddockFlags package))
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

packageClean :: IDEAction
packageClean = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","clean"]
                                            ++ (haddockFlags package))
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

packageCopy :: IDEAction
packageCopy = do
    mbPackage   <- getActivePackage
    log         <- getLog
    mbDir       <- chooseDir "Select the target directory"
    case mbDir of
        Nothing -> return ()
        Just fp ->
            case mbPackage of
                Nothing         -> return ()
                Just package    -> lift $do
                    (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","copy"]
                                            ++ ["--destdir=" ++ fp])
                    oid <- forkIO (readOut log out)
                    eid <- forkIO (readErr log err)
                    return ()

packageRun :: IDEAction
packageRun = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            pd <- readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription
            case executables pd of
                [(Executable name _ _)] -> do
                    let path = "dist/build" </> pkgName (packageId package) </> name
                    (inp,out,err,pid) <- runExternal path (exeFlags package)
                    oid <- forkIO (readOut log out)
                    eid <- forkIO (readErr log err)
                    return ()
                otherwise -> do
                    sysMessage Normal "no single executable in selected package"
                    return ()

packageInstall :: IDEAction
packageInstall = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","install"]
                                            ++ (installFlags package))
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

packageRegister :: IDEAction
packageRegister = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","register"]
                                            ++ (registerFlags package))
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

packageUnregister :: IDEAction
packageUnregister = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","unregister"]
                                            ++ (unregisterFlags package))
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

packageTest :: IDEAction
packageTest = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","test"])
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

packageSdist :: IDEAction
packageSdist = do
    mbPackage   <- getActivePackage
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","sdist"]
                                            ++ (sdistFlags package))
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

packageOpenDoc :: IDEAction
packageOpenDoc = do
    mbPackage   <- getActivePackage
    prefs       <- readIDE prefs
    log         <- getLog
    case mbPackage of
        Nothing         -> return ()
        Just package    -> lift $do
            let path = "dist/doc/html" </> pkgName (packageId package) </> "index.html"
            (inp,out,err,pid) <- runExternal (browser prefs) [path]
            oid <- forkIO (readOut log out)
            eid <- forkIO (readErr log err)
            return ()

chooseDir :: String -> IDEM (Maybe FilePath)
chooseDir str = do
    win <- readIDE window
    lift $do
        dialog <- fileChooserDialogNew
                        (Just $ str)
                        (Just win)
                    FileChooserActionSelectFolder
                    [("gtk-cancel"
                    ,ResponseCancel)
                    ,("gtk-open"
                    ,ResponseAccept)]
        widgetShow dialog
        response <- dialogRun dialog
        case response of
            ResponseAccept -> do
                fn <- fileChooserGetFilename dialog
                widgetDestroy dialog
                return fn
            ResponseCancel -> do
                widgetDestroy dialog
                return Nothing
            ResponseDeleteEvent -> do
                widgetDestroy dialog
                return Nothing
            _ -> return Nothing

-- ---------------------------------------------------------------------
-- | Handling of Compiler errors
--

readErrForBuild :: IDELog -> Handle -> IDEAction
readErrForBuild log hndl = do
    errs <- lift $readAndShow False []
    modifyIDE_ (\ide -> return (ide{errors = reverse errs, currentErr = Nothing}))
    sb <- getSBErrors
    let errorNum    =   length (filter isError errs)
    let warnNum     =   length errs - errorNum
    lift $statusbarPop sb 1
    lift $statusbarPush sb 1 $show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"
    when (not (null errs)) nextError
    where
    readAndShow inError errs = do
        isEnd <- hIsEOF hndl
        if isEnd
            then return errs
            else do
                line    <-  hGetLine hndl
                let parsed  = parse buildLineParser "" line
                lineNr  <-  appendLog log (line ++ "\n") ErrorTag
                case (parsed, errs) of
                    (Left e,_) -> do
                        sysMessage Normal (show e)
                        readAndShow False errs
                    (Right ne@(ErrorLine fp l c str),_) ->
                        readAndShow True ((ErrorSpec fp l c str (lineNr,lineNr) True):errs)
                    (Right (OtherLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->
                        if inError
                            then readAndShow True ((ErrorSpec fp i1 i2
                                                    (if null str
                                                        then line
                                                        else str ++ "\n" ++ line)
                                                    (l1,lineNr) isError) : tl)
                            else readAndShow False errs
                    (Right (WarningLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->
                        if inError
                            then readAndShow True ((ErrorSpec fp i1 i2
                                                    (if null str
                                                        then line
                                                        else str ++ "\n" ++ line)
                                                    (l1,lineNr) False) : tl)
                            else readAndShow False errs
                    otherwise -> readAndShow False errs

selectErr :: Int -> IDEAction
selectErr index = do
    errors <- readIDE errors
    if length errors < index + 1
        then return ()
        else do
            let thisErr = errors !! index
            succ <- selectSourceBuf (filePath thisErr)
            if succ
                then markErrorInSourceBuf (line thisErr) (column thisErr)
                        (errDescription thisErr)
                else return ()
            log :: IDELog <- getLog
            lift $ markErrorInLog log (logLines thisErr)

unmarkCurrentError :: IDEAction
unmarkCurrentError = do
    currentErr'     <-  readIDE currentErr
    errors'         <-  readIDE errors
    when (isJust currentErr') $ do
        let theError =  errors' !! fromJust currentErr'
        allBufs     <-  allBuffers
        fpc         <-  lift $ canonicalizePath $ filePath theError
        let theBufs =   filter (\ buf -> isJust (fileName buf) &&
                                            equalFilePath fpc (fromJust (fileName buf)))
                            allBufs
        mapM_ removeMark theBufs
        where
        removeMark buf = lift $ do
            gtkbuf  <-  textViewGetBuffer (sourceView buf)
            i1      <-  textBufferGetStartIter gtkbuf
            i2      <-  textBufferGetEndIter gtkbuf
            textBufferRemoveTagByName gtkbuf "activeErr" i1 i2

nextError :: IDEAction
nextError = do
    errs <- readIDE errors
    currentErr <- readIDE currentErr
    if null errs
        then return ()
        else do
            case currentErr of
                Nothing -> do
                    modifyIDE_ (\ide -> return (ide{currentErr = Just 0}))
                    selectErr 0
                Just n | (n + 1) < length errs -> do
                    modifyIDE_ (\ide -> return (ide{currentErr = Just (n + 1)}))
                    selectErr (n + 1)
                Just n  -> selectErr n

previousError :: IDEAction
previousError = do
    errs <- readIDE errors
    currentErr <- readIDE currentErr
    if null errs
        then return ()
        else do
            case currentErr of
                Nothing -> do
                    modifyIDE_ (\ide -> return (ide{currentErr = Just (length errs - 1)}))
                    selectErr (length errs - 1)
                Just n | n > 0 -> do
                    modifyIDE_ (\ide -> return (ide{currentErr = Just (n - 1)}))
                    selectErr (n - 1)
                otherwise -> selectErr 0

data BuildError =   BuildLine
                |   EmptyLine
                |   ErrorLine FilePath Int Int String
                |   WarningLine String
                |   OtherLine String

buildLineParser :: CharParser () BuildError
buildLineParser = try (do
        char '['
        integer
        symbol "of"
        integer
        char '['
        many (anyChar)
        return BuildLine)
    <|> try (do
        filePath <- many (noneOf ":")
        char ':'
        line <- integer
        char ':'
        column <- integer
        char ':'
        whiteSpace
        text <- many anyChar
        return (ErrorLine filePath (fromIntegral line) (fromIntegral column) text))
    <|> try (do
        whiteSpace
        eof
        return EmptyLine)
    <|> try (do
        whiteSpace
        symbol "Warning:"
        text <- many anyChar
        return (WarningLine ("Warning:" ++ text)))
    <|> try (do
        text <- many anyChar
        eof
        return (OtherLine text))
    <?> "buildLineParser"


lexer = P.makeTokenParser emptyDef
lexeme = P.lexeme lexer
whiteSpace = P.whiteSpace lexer
hexadecimal = P.hexadecimal lexer
symbol = P.symbol lexer
identifier = P.identifier lexer
colon = P.colon lexer
integer = P.integer lexer

-- Spawning external processes

readOut :: IDELog -> Handle -> IO ()
readOut log hndl =
     catch (readAndShow)
       (\e -> do
        --appendLog log ("----------------------------------------\n") FrameTag
        hClose hndl
        return ())
    where
    readAndShow = do
        line <- hGetLine hndl
        appendLog log (line ++ "\n") LogTag
        readAndShow

readErr :: IDELog -> Handle -> IO ()
readErr log hndl =
     catch (readAndShow)
       (\e -> do
        hClose hndl
        return ())
    where
    readAndShow = do
        line <- hGetLine hndl
        appendLog log (line ++ "\n") ErrorTag
        readAndShow

runExternal :: FilePath -> [String] -> IO (Handle, Handle, Handle, ProcessHandle)
runExternal path args = do
    putStrLn $ "Run external called with args " ++ show args
    hndls@(inp, out, err, _) <- runInteractiveProcess path args Nothing Nothing
    sysMessage Normal $ "Starting external tool: " ++ path ++ " with args " ++ (show args)
    hSetBuffering out NoBuffering
    hSetBuffering err NoBuffering
    hSetBuffering inp NoBuffering
    hSetBinaryMode out True
    hSetBinaryMode err True
    return hndls