module Distribution.Cab.Commands (
    FunctionCommand
  , Option(..)
  , deps, revdeps, installed, outdated, uninstall, search
  , genpaths, check, initSandbox, add, ghci
  ) where

import Control.Applicative ((<$>))
import Control.Monad (forM_, unless, when, void)
import Data.Char (toLower)
import Data.List (intercalate, isPrefixOf)
import qualified Data.Map as M
import Distribution.Cab.GenPaths
import Distribution.Cab.PkgDB
import Distribution.Cab.Printer
import Distribution.Cab.Sandbox
import Distribution.Cab.VerDB
import Distribution.Cab.Version
import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
import System.Exit (exitFailure)
import System.FilePath (takeDirectory, takeFileName)
import System.IO (hPutStrLn, stderr)
import System.Process (readProcess, system)

----------------------------------------------------------------

type FunctionCommand = [String] -> [Option] -> [String] -> IO ()

data Option = OptNoharm
            | OptRecursive
            | OptAll
            | OptInfo
            | OptFlag String
            | OptTest
            | OptHelp
            | OptBench
            | OptDepsOnly
            | OptLibProfile
            | OptExecProfile
            | OptJobs String
            | OptImport String
            | OptStatic
            deriving (Eq,Show)

----------------------------------------------------------------

search :: FunctionCommand
search [x] _ _ = do
    nvls <- toList <$> getVerDB AllRegistered
    forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ verToString v
  where
    key = map toLower x
    sat (n,_) = key `isPrefixOf` map toLower n
    lok = filter sat
search _ _ _ = do
    hPutStrLn stderr "One search-key should be specified."
    exitFailure

----------------------------------------------------------------

installed :: FunctionCommand
installed _ opts _ = do
    db <- getDB opts
    let pkgs = toPkgInfos db
    forM_ pkgs $ \pkgi -> do
        putStr $ fullNameOfPkgInfo pkgi
        extraInfo info pkgi
        putStrLn ""
        when optrec $ printDeps True info db 1 pkgi
  where
    info = OptInfo `elem` opts
    optrec = OptRecursive `elem` opts

outdated :: FunctionCommand
outdated _ opts _ = do
    pkgs <- toPkgInfos <$> getDB opts
    verDB <- toMap <$> getVerDB InstalledOnly
    forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of
        Nothing  -> return ()
        Just ver -> when (verOfPkgInfo p /= ver) $
                      putStrLn $ fullNameOfPkgInfo p ++ " /= " ++ verToString ver

getDB :: [Option] -> IO PkgDB
getDB opts
  | optall    = getSandbox >>= getPkgDB
  | otherwise = getSandbox >>= getUserPkgDB
  where
    optall = OptAll `elem` opts

----------------------------------------------------------------

uninstall :: FunctionCommand
uninstall nmver opts _ = do
    userDB <- getSandbox >>= getUserPkgDB
    pkg <- lookupPkg nmver userDB
    let sortedPkgs = topSortedPkgs pkg userDB
    if onlyOne && length sortedPkgs /= 1 then do
        hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option."
        mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs)
      else do
        unless doit $ putStrLn "The following packages are deleted without the \"-n\" option."
        mapM_ (purge doit opts . pairNameOfPkgInfo) sortedPkgs
  where
    onlyOne = OptRecursive `notElem` opts
    doit = OptNoharm `notElem` opts

purge :: Bool -> [Option] -> (String,String) -> IO ()
purge doit opts nameVer = do
    sandboxOpts <- (makeOptList . getSandboxOpts2) <$> getSandbox
    dirs <- getDirs nameVer sandboxOpts
    unregister doit opts nameVer
    mapM_ (removeDir doit) dirs
  where
    makeOptList "" = []
    makeOptList x  = [x]

getDirs :: (String,String) -> [String] -> IO [FilePath]
getDirs (name,ver) sandboxOpts = do
    libdirs <- queryGhcPkg "library-dirs"
    haddock <- map docDir <$> queryGhcPkg "haddock-html"
    return $ topDir $ libdirs ++ haddock
  where
    nameVer = name ++ "-" ++ ver
    queryGhcPkg field = do
        let options = ["field"] ++ sandboxOpts ++ [nameVer, field]
        ws <- words <$> readProcess "ghc-pkg" options ""
        return $ case ws of
            []     -> []
            (_:xs) -> xs
    docDir dir
      | takeFileName dir == "html" = takeDirectory dir
      | otherwise                  = dir
    topDir []     = []
    topDir ds@(dir:_)
      | takeFileName top == nameVer = top : ds
      | otherwise                   = ds
      where
        top = takeDirectory dir

removeDir :: Bool -> FilePath -> IO ()
removeDir doit dir = do
    exist <- doesDirectoryExist dir
    when exist $ do
        putStrLn $ "Deleting " ++ dir
        when doit $ removeDirectoryRecursive dir

unregister :: Bool -> [Option] -> (String,String) -> IO ()
unregister doit _ (name,ver) =
    if doit then do
        putStrLn $ "Deleting " ++ name ++ " " ++ ver
        sandboxOpts <- getSandboxOpts2 <$> getSandbox
        when doit $ void . system $ script sandboxOpts
      else
        putStrLn $ name ++ " " ++ ver
  where
    script sandboxOpts = "ghc-pkg unregister " ++ sandboxOpts ++ " " ++ name ++ "-" ++ ver

----------------------------------------------------------------

genpaths :: FunctionCommand
genpaths _ _ _ = genPaths

----------------------------------------------------------------

check :: FunctionCommand
check _ _ _ = do
    sandboxOpts <- getSandboxOpts2 <$> getSandbox
    void . system $ script sandboxOpts
  where
    script sandboxOpts = "ghc-pkg check -v " ++ sandboxOpts

----------------------------------------------------------------

deps :: FunctionCommand
deps nmver opts _ = printDepends nmver opts printDeps

revdeps :: FunctionCommand
revdeps nmver opts _ = printDepends nmver opts printRevDeps

printDepends :: [String] -> [Option]
             -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()
printDepends nmver opts func = do
    db' <- getSandbox >>= getPkgDB
    pkg <- lookupPkg nmver db'
    db <- getDB opts
    func rec info db 0 pkg
  where
    rec = OptRecursive `elem` opts
    info = OptInfo `elem` opts

----------------------------------------------------------------

lookupPkg :: [String] -> PkgDB -> IO PkgInfo
lookupPkg [] _ = do
  hPutStrLn stderr "Package name must be specified."
  exitFailure
lookupPkg [name] db = checkOne $ lookupByName name db
lookupPkg [name,ver] db = checkOne $ lookupByVersion name ver db
lookupPkg _ _ = do
  hPutStrLn stderr "Only one package name must be specified."
  exitFailure

checkOne :: [PkgInfo] -> IO PkgInfo
checkOne [] = do
    hPutStrLn stderr "No such package found."
    exitFailure
checkOne [pkg] = return pkg
checkOne pkgs = do
    hPutStrLn stderr "Package version must be specified."
    mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs
    exitFailure

----------------------------------------------------------------

initSandbox :: FunctionCommand
initSandbox []     _ _ = void . system $ "cabal sandbox init"
initSandbox [path] _ _ = void . system $ "cabal sandbox init --sandbox " ++ path
initSandbox _      _ _ = do
    hPutStrLn stderr "Only one argument is allowed"
    exitFailure

----------------------------------------------------------------

add :: FunctionCommand
add [src] _ _ = void . system $ "cabal sandbox add-source " ++ src
add _     _ _ = do
    hPutStrLn stderr "A source path be specified."
    exitFailure

----------------------------------------------------------------

ghci :: FunctionCommand
ghci args _ options = do
    sbxOpts <- getSandboxOpts <$> getSandbox
    void $ system $ "ghci" ++ " " ++ sbxOpts ++ " " ++ intercalate " " (options ++ args)