Written by Ian Lynagh <igloo@debian.org>.
Copyright (C) 2003, 2004, 2007 Ian Lynagh.
Released under the GNU GPL version 2.

\begin{code}
module Main (main) where

import Control.Exception
import Control.Monad
import Data.Char
import Data.List
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.Utils hiding (die)
import Distribution.Verbosity
import Prelude hiding (catch)
import System.Directory
import System.Environment
import System.Exit
import System.IO

type Error = String
data Flags = Flags { fl_verbosity :: Verbosity,
                     fl_script_path :: FilePath }
           | HelpFlag
           | VersionFlag
           | ErrorFlag Error

die :: [Error] -> IO a
die errors = do mapM_ (hPutStrLn stderr) errors
                exitWith (ExitFailure 1)

verbosePutStrLn :: Verbosity -> String -> IO ()
verbosePutStrLn v s = when (v >= verbose) $ putStrLn s

defaultFlags :: Flags
defaultFlags = Flags {
                   fl_verbosity = normal,
                   fl_script_path = "@libdir@/haskell-utils/scripts/current"
               }

parseArgs :: Flags -> [String] -> Flags
parseArgs fs [] = fs
parseArgs _ ("--help":_) = HelpFlag
parseArgs _ ("-h":_) = HelpFlag
parseArgs _ ("--version":_) = VersionFlag
parseArgs _ ("-V":_) = VersionFlag
parseArgs fs ("-v":as) = let v = flagToVerbosity Nothing
                         in parseArgs (fs { fl_verbosity = v }) as
parseArgs fs ("-q":as) = let v = flagToVerbosity (Just "0")
                         in parseArgs (fs { fl_verbosity = v }) as
parseArgs fs ("-s":d:as)
    = parseArgs (fs { fl_script_path = d }) as
parseArgs _ ["-s"] = ErrorFlag "Missing argument to -s"
parseArgs _ (a:_) = ErrorFlag ("Unknown argument: " ++ a)

main :: IO ()
main = main' `catch` \e -> die [show e]

main' :: IO ()
main' = do args <- getArgs
           case parseArgs defaultFlags args of
               ErrorFlag s -> die [s]
               HelpFlag -> usage
               VersionFlag -> show_version
               Flags v scriptPath -> doit v scriptPath

doit :: Verbosity -> FilePath -> IO ()
doit v scriptPath
 = do cabalFile <- defaultPackageDesc v
      gpd <- readPackageDescription v cabalFile
      let -- XXX Just flattening it means we might get too many deps
          pd = flattenPackageDescription gpd
          cpkg = map toLower $ pkgName $ package pd
          copyAFile f = do let src = scriptPath ++ "/" ++ f
                               dest = "debian/" ++ replace "PACKAGE" cpkg f
                               msg = "Installing " ++ src ++ " as " ++ dest
                           exists <- doesFileExist src
                           when exists $ do verbosePutStrLn v msg
                                            copyFile src dest
      fs <- getDirectoryContents scriptPath
      mapM_ copyAFile fs

replace :: String -> String -> String -> String
replace _ _ "" = ""
replace what with xs@(x:xs')
 | what `isPrefixOf` xs = with ++ replace what with (drop (length what) xs)
 | otherwise = x : replace what with xs'

usage :: IO ()
usage =
    do putStrLn "Usage: update-haskell-control [ --help | -h | --version | -V ]"
       putStrLn "       update-haskell-control [ OPTION ]..."
       putStrLn ""
       putStrLn "   -s path        Set the path from which to get the scripts"
       putStrLn "   -v             Verbose"
       putStrLn "   -q             Input filename"
       putStrLn ""

show_version :: IO ()
show_version = do putStrLn "update-debian-haskell-files @version@"
                  putStrLn "Written by Ian Lynagh."
                  putStrLn "Copyright (C) 2003, 2004, 2007 Ian Lynagh."
\end{code}