Written by Ian Lynagh <igloo@debian.org>.
Copyright (C) 2003, 2004, 2007, 2008 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 Data.Maybe
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.Utils hiding (die)
import Distribution.Verbosity
import Distribution.Version
import Prelude hiding (catch)
import System.Cmd
import System.Directory
import System.Environment
import System.Exit
import System.IO

type Variable = String
type Mapping = [(Variable, String)]
type VarFunction = Pos -> Variable -> String
type FunFunction = Function -> String -> String
type EscapingFunction = Char -> String
data Pos = Pos {
               line :: !Int, -- [1..]
               col :: !Int   -- [1..]
           }
    deriving Show

type Error = String
data Action = Update | Check
data Flags = Flags { action :: Action,
                     verbosity :: Verbosity,
                     input_file :: Maybe FilePath,
                     output_file :: Maybe FilePath,
                     include_paths :: [FilePath] }
           | HelpFlag
           | VersionFlag
           | ErrorFlag Error

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

showPos :: Pos -> String
showPos p = "line " ++ show (line p) ++ ", character " ++ show (col p)

defaultFlags :: Flags
defaultFlags = Flags {
                   action = Update,
                   verbosity = normal,
                   input_file = Nothing,
                   output_file = Nothing,
                   include_paths = ["debian/varfiles/",
                                    "@libdir@/haskell-utils/", -- deprecated
                                    "@libdir@/haskell-utils/varfiles/"]
               }

parseArgs :: Flags -> [String] -> Flags
parseArgs fs []
    = let fs1 = case input_file fs of
                    Nothing ->
                        fs { input_file = Just "debian/control.in" }
                    _ -> fs
          fs2 = case (input_file fs1, output_file fs1) of
                (Just i, Nothing) ->
                  case break ('.' ==) (reverse i) of
                  ("ni", '.':rfn) ->
                      fs1 { output_file = Just (reverse rfn) }
                  _ -> ErrorFlag "Output filename not given or deducable"
                _ -> fs1
      in fs2
parseArgs _ ("--help":_) = HelpFlag
parseArgs _ ("-h":_) = HelpFlag
parseArgs _ ("--version":_) = VersionFlag
parseArgs _ ("-V":_) = VersionFlag
parseArgs fs ("--update":as) = parseArgs (fs { action = Update }) as
parseArgs fs ("--check":as) = parseArgs (fs { action = Check }) as
parseArgs fs ("-v":as) = let v = flagToVerbosity Nothing
                         in parseArgs (fs { verbosity = v }) as
parseArgs fs ("-q":as) = let v = flagToVerbosity (Just "0")
                         in parseArgs (fs { verbosity = v }) as
parseArgs fs ("-I":d:as)
    = parseArgs (fs { include_paths = d:include_paths fs }) as
parseArgs _ ["-I"] = ErrorFlag "Missing argument to -I"
parseArgs fs ("-i":f:as)
    = case input_file fs of
          Nothing -> parseArgs (fs { input_file = Just f }) as
          Just _ -> ErrorFlag "Two input files given"
parseArgs _ ["-i"] = ErrorFlag "Missing argument to -i"
parseArgs fs ("-o":f:as)
    = case output_file fs of
          Nothing -> parseArgs (fs { output_file = Just f }) as
          Just _ -> ErrorFlag "Two output files given"
parseArgs _ ["-o"] = ErrorFlag "Missing argument to -o"
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 Update v (Just i) (Just o) ps -> update v i o ps
               Flags Check  v (Just i) (Just o) _  -> check  v i o
               _ -> error "update-haskell-control: Can't happen"

check :: Verbosity -> FilePath -> FilePath -> IO ()
check v i o
 = do ifVerbose v $ do putStrLn $ "Input filename: " ++ i
                       putStrLn $ "Check filename: " ++ o
      inp <- readFile i
      out <- readFile o
      let pat = tokensToPattern $ tokenise $ number inp
      ifVerbose v $ do putStrLn "Pattern:"
                       print pat
      unless (out `matches` pat) $ die ["File mismatch!"]

update :: Verbosity -> FilePath -> FilePath -> [FilePath] -> IO ()
update v i o ps
 = do ifVerbose v $ do putStrLn $ "Input filename: " ++ i
                       putStrLn $ "Output filename: " ++ o
                       putStrLn $ "Search path:"
                       mapM_ (putStrLn . ("  " ++)) ps
      inp <- readFile i
      cms <- getCabalVarMappings v
      gms <- getGhc6VarMappings
      mss <- mapM (getDirectoryVarMappings v) ps
      let ms = concat (cms:gms:mss)
          mf p n = case lookup n ms of
                       Nothing -> error ("Unbound variable " ++ n ++
                                         " at " ++ showPos p)
                       Just xs -> myApply xs
          vf = doFunction
          myApply = apply (\c -> [c]) mf vf
      writeFile o $ myApply inp

dropDebianRevision :: String -> String
dropDebianRevision = reverse . f . reverse
    where f xs = case break ('-' ==) xs of
                 (_, "") -> xs
                 (_, _ : xs') -> xs'

getGhc6VarMappings :: IO Mapping
getGhc6VarMappings
 = do mv <- getPackageVersion "ghc6"
      case mv of
          Just debian_version ->
              do let v = dropDebianRevision debian_version
                     mkMinDep pkg = pkg ++ " (>= " ++ v ++ ")"
                     mkMaxDep pkg = pkg ++ " (<< " ++ v ++ "+)"
                     mkDeps pkg = [mkMinDep pkg, mkMaxDep pkg]
                     allDeps = concatMap mkDeps
                                         ["ghc6", "ghc6-prof", "ghc6-doc"]
                     flattenDeps = concat . intersperse ", "
                     -- For library deps we want something like:
                     --     ghc6 (>= 6.8.2), ghc6 (<< 6.8.2+)
                     -- which does not contain, e.g., 6.8.2.0.0.0.1, but
                     -- does contain all Debian revisions of 6.8.2
                     dev_deps = flattenDeps $ mkDeps "ghc6"
                     prof_deps = flattenDeps $ mkDeps "ghc6-prof"
                     doc_deps = flattenDeps $ mkDeps "ghc6-doc"
                     -- For library build-deps, i the past we have
                     -- restricted the arches listed to just those that
                     -- have GHC:
                     --     ghc6 (>= 6.8.2) [alpha amd64 ...], ...
                     -- but (a) that is currently all arches and (b) we
                     -- only generate ghc6 packages anyawy at the moment
                     build_deps = flattenDeps allDeps
                 return [("impl:ghc6:lib:build_deps", build_deps),
                         ("impl:ghc6:lib:dev_deps",   dev_deps),
                         ("impl:ghc6:lib:prof_deps",  prof_deps),
                         ("impl:ghc6:lib:doc_deps",   doc_deps)]
          Nothing ->
              die ["Can't find version number for ghc6"]

getCabalVarMappings :: Verbosity -> IO Mapping
getCabalVarMappings v
 = 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
          deps = buildDepends pd
          -- The nub is really a bit of a hack, due to us ignoring version
          -- ranges in fromCabalDep.
          mkDeps depType = do xs <- mapM (fromCabalDep depType) deps
                              return $ concat $ intersperse ", "
                                     $ nub $ catMaybes xs
      devDeps  <- mkDeps "dev"
      profDeps <- mkDeps "prof"
      docDeps  <- mkDeps "doc"
      return [("this:source", "haskell-" ++ cpkg),
              ("this:ghc6:dev", "libghc6-" ++ cpkg ++ "-dev"),
              ("this:ghc6:prof", "libghc6-" ++ cpkg ++ "-prof"),
              ("this:ghc6:doc", "libghc6-" ++ cpkg ++ "-doc"),
              ("cabal:deps:ghc6:dev",  devDeps),
              ("cabal:deps:ghc6:prof", profDeps),
              ("cabal:deps:ghc6:doc",  docDeps)]

cabalToDebianPackageName :: String -- type of Debian package: dev/prof/doc
                         -> String -- Cabal package name
                         -> String -- Debian package name
cabalToDebianPackageName packageType cabalName
    = "libghc6-" ++ map toLower cabalName ++ "-" ++ packageType

-- We work on the assumption that no-one can be malicious in .,
-- otherwise they could do all sorts of nasty things anyway.
-- So for simplicity we use a temporary file in here. We only need
-- one temporary file at a time, so we can always use the same name.
tempFile :: FilePath
tempFile = "debian/haskell-utils-tmp"

-- Returns nothing on any sort of failure.
-- Assumes that it is given a command line that it is safe to append
-- " > foo" to and run. Yes, it would be nicer to do it properly, but
-- then we potentially have to worry about buffer and deadlocks etc,
-- and whether the RTS does the right thing on all platforms. Just keep
-- it simple for now.
runCommandGetOutput :: String -> IO (Maybe String)
runCommandGetOutput cmd
    = do ec <- system (cmd ++ " > " ++ tempFile)
         case ec of
             ExitSuccess ->
                 do xs <- readFile tempFile
                    evaluate (length xs)
                    removeFile tempFile
                    return (Just xs)
             _ ->
                 do -- In case the program is going to keep going, we
                    -- remove the temp file
                    removeFile tempFile
                    return Nothing

goodPackageName :: String -> Bool
goodPackageName "" = False
goodPackageName [_] = False
goodPackageName xs@(x:xs') = all isAscii xs && isAlphaNum x && all isOK xs'
    where isOK c
           | isAlphaNum c = True
           | otherwise = c `elem` "+-."

getPackageVersion :: String -> IO (Maybe String)
getPackageVersion pkg
 | goodPackageName pkg =
    do let cmd = "grep-status -rP '^" ++ pkg ++ "$' -s Version -n"
       ms <- runCommandGetOutput cmd
       -- A bit of a heavy duty way to remove the trailing \n:
       return $ fmap (filter ('\n' /=)) ms
 | otherwise = die ["getPackageVersion: Bad package name: " ++ show pkg]

getPackageProvides :: String -> IO [String]
getPackageProvides pkg
 | goodPackageName pkg =
    do let cmd = "grep-status -rP '^" ++ pkg ++ "$' -s Provides -n"
       ms <- runCommandGetOutput cmd
       case ms of
           Nothing -> die ["Failed to find provides of " ++ pkg]
           Just s ->
               return $ splitCommaSpaceList s
 | otherwise = die ["getPackageProvides: Bad package name: " ++ show pkg]

splitCommaSpaceList :: String -> [String]
splitCommaSpaceList xs
    = case span isCommaSpace xs of
      (_, xs') -> case break isCommaSpace xs' of
                  ("",  _)    -> []
                  (elt, xs'') -> elt : splitCommaSpaceList xs''
  where isCommaSpace c = c `elem` ", \n" -- Note that we also ignore \n

-- XXX We could cache this
ghc6StarProvides :: IO [String]
ghc6StarProvides
 = do ghc6Provides     <- getPackageProvides "ghc6"
      ghc6ProfProvides <- getPackageProvides "ghc6-prof"
      ghc6DocProvides  <- getPackageProvides "ghc6-doc"
      return (ghc6Provides ++ ghc6ProfProvides ++ ghc6DocProvides)

fromCabalDep :: String -> Dependency -> IO (Maybe String)
-- XXX Filtering out Win32 is a hack, due to us not using flags and thus
-- getting all the possible deps. If we used flags then we wouldn't get
-- the deps from the Win32 route. We could then drop the Maybe from the
-- type.
fromCabalDep _       (Dependency "Win32" _) = return Nothing
fromCabalDep depType (Dependency cabalPackageName _)
 = do let debianPackageName = cabalToDebianPackageName depType cabalPackageName
      mpv <- getPackageVersion debianPackageName
      provided <- ghc6StarProvides
      case (mpv, debianPackageName `elem` provided) of
          -- The package doesn't exist, but ghc6* provides it. We are
          -- happy. No need to make another dep on the ghc6* package.
          (Nothing, True) -> return Nothing
          -- The package exists, and it isn't also provided by ghc6*.
          -- We are happy. Add a dep, with a tight version number so
          -- we don't trip over cross-module inlining problems.
          (Just pv, False) ->
              return $ Just (debianPackageName ++ " (= " ++ pv ++ ")")
          (Just _, True) ->
              die [debianPackageName ++
                   " exists, but is also provided by ghc6*"]
          (Nothing, False) ->
              die ["Couldn't find a package to depend on for " ++
                   debianPackageName]

ifVerbose :: Verbosity -> IO () -> IO ()
ifVerbose v io = when (v >= verbose) io

verboseDoesFileExist :: Verbosity -> FilePath -> IO Bool
verboseDoesFileExist v fp
 = do exists <- doesFileExist fp
      if exists
        then return True
        else do ifVerbose v $ putStrLn ("No such file " ++ fp)
                return False

getDirectoryVarMappings :: Verbosity -> FilePath -> IO Mapping
getDirectoryVarMappings v dir
 = do fs <- getDirectoryContents dir `catch` \_ -> return []
      let fs' = map ((dir ++ "/") ++) $ filter (not . dotFile) fs
      fs'' <- filterM (verboseDoesFileExist v) fs'
      mss <- mapM (getFileVarMappings v) fs''
      return $ concat mss

dotFile :: FilePath -> Bool
dotFile ('.' : _) = True
dotFile _ = False

getFileVarMappings :: Verbosity -> FilePath -> IO Mapping
getFileVarMappings v f
 = do ifVerbose v $ putStrLn ("Loading " ++ f)
      xs <- readFile f
      let mes = map mk_maplet $ zip [1..] $ filter ("" /=) $ lines xs
          es = [ e | Right e <- mes ]
          ms = [ m | Left m <- mes ]
      unless (null es) $ die es
      return ms

mk_maplet :: (Int, String) -> Either (Variable, String) Error
mk_maplet (n, xs) = case break ('=' ==) xs of
                        ("", _) -> Right $ "No variable name on line " ++ s
                        (ys, '=':'"':zs) -> case read_val "" zs of
                                                Left zs' -> Left (ys, zs')
                                                Right err -> Right err
                        _ -> Right bvb
    where s = show n
          read_val acc "\"" = Left (reverse acc)
          read_val _   [] = Right bvb
          read_val _   [_] = Right bvb
          read_val acc ('\\':ys) = case ys of
                                       '"':ys' -> read_val ('"':acc) ys'
                                       'n':ys' -> read_val ('\n':acc) ys'
                                       '\\':ys' -> read_val ('\\':acc) ys'
                                       _ -> Right bvb
          read_val acc (y:ys) = read_val (y:acc) ys
          bvb = "Bad variable binding on line " ++ s

number :: String -> [(Char, Pos)]
number = f (Pos { line = 1, col = 1 })
    where f _ "" = []
          f p ('\n':xs) = let p' = Pos { line = line p + 1, col = 1 }
                          in ('\n', p):f p' xs
          f p (x:xs) = seq p $ (x, p):f (p { col = col p +1 }) xs

data Function = CanonicaliseCommaList
    deriving Show
data Token = TChar Char
           | TVar Pos Variable
           | TFun Pos Function [Token]
    deriving Show

apply :: EscapingFunction -> VarFunction -> FunFunction -> String -> String
apply ef mf vf = apply' ef mf vf . tokenise . number

tokenise :: [(Char, Pos)] -> [Token]
tokenise [] = []
tokenise (('\\', p):cs) = case cs of
                              ('\\', _):cs' -> TChar '\\' : tokenise cs'
                              ('n', _):cs'  -> TChar '\n' : tokenise cs'
                              ('$', _):cs'  -> TChar '$'  : tokenise cs'
                              _ -> error ("Bad escape at " ++ showPos p)
tokenise (('$', p):xs) = case getVarName xs of
                             (n, xs') ->
                                 TVar p n : tokenise xs'
tokenise (('&', p):xs) = case getFun xs of
                             (f, contents, xs') ->
                                 TFun p f contents : tokenise xs'
tokenise ((x, _):xs) = TChar x : tokenise xs

apply' :: EscapingFunction -> VarFunction -> FunFunction -> [Token]
       -> String
apply' ef mf vf = concatMap f
    where f (TChar c) = ef c
          f (TVar p n) = mf p n
          f (TFun _ fun xs) = vf fun $ apply' ef mf vf xs

doFunction :: FunFunction
doFunction CanonicaliseCommaList xs
 = concat $ intersperse ", " $ filter (not . null) $ splitCommas xs

splitCommas :: String -> [String]
splitCommas "" = []
splitCommas xs = case break (',' ==) xs of
                     (ys, _:zs) ->
                         ys : splitCommas (dropWhile (' ' ==) zs)
                     (_, "") -> [xs]

getVarName :: [(Char, Pos)] -> (Variable, [(Char, Pos)])
getVarName (('{', p):xs)
 = case break (('}' ==) . fst) xs of
       (ys, _:zs) -> (map fst ys, zs)
       _ -> error ("Unterminated { found at " ++ showPos p)
getVarName xs@((c, p):_)
 | isAlpha c = case span (\(x, _) -> isAlphaNum x || x == '_') xs of
                   (ys, zs) -> (map fst ys, zs)
 | otherwise = error ("Bad variable name found at " ++ showPos p)
getVarName [] = error "End of file where variable name expected"

getFun :: [(Char, Pos)] -> (Function, [Token], [(Char, Pos)])
getFun (('{', p):xs)
 = case getBracedBlock 0 xs of
       Just (funDecl, xs') ->
           case break ((':' ==) . fst) funDecl of
               (funName, _:contents) ->
                   (funNameToFun (map fst funName), tokenise contents, xs')
               _ -> error ("No : found in function starting at " ++ showPos p)
       Nothing -> error ("Unterminated { found at " ++ showPos p)
    where funNameToFun "canonicalise-comma-list" = CanonicaliseCommaList
          funNameToFun n = error ("Unknown function name " ++ show n)
getFun ((_, p):_) = error ("Expected { not found at " ++ showPos p)
getFun [] = error "Expected { not found at end of file"

getBracedBlock :: Int -> [(Char, Pos)] -> Maybe ([(Char, Pos)], [(Char, Pos)])
getBracedBlock 0 (('}', _):xs) = Just ([], xs)
getBracedBlock n (x@(c, _):xs)
 = case getBracedBlock n' xs of
       Just (ys, zs) -> Just (x:ys, zs)
       Nothing -> Nothing
    where n' = case c of
                   '{' -> n + 1
                   '}' -> n - 1
                   _   -> n
getBracedBlock _ [] = Nothing

data Pat = PChar Char | PAny
    deriving (Eq, Show)
type Pattern = [Pat]

tokensToPattern :: [Token] -> Pattern
tokensToPattern = flatten . map tToP
    where tToP (TChar c) = PChar c
          tToP _ = PAny
          flatten (PAny : PAny : ps) = flatten (PAny : ps)
          flatten (p : ps) = p : flatten ps
          flatten [] = []

matches :: String -> Pattern -> Bool
str `matches` pats = f [pats] str
    where f patterns "" = any patDone patterns
          f []       _  = False
          f patterns (c:cs) = f (concatMap (step c) patterns) cs
          step c (PChar p:pattern) = if c == p then [pattern] else []
          step c pattern@(PAny:pattern') = pattern : step c pattern'
          step _ [] = []
          patDone ps = all (PAny ==) ps

usage :: IO ()
usage =
    do putStrLn "Usage: update-haskell-control [ --help | -h | --version | -V ]"
       putStrLn "       update-haskell-control [ OPTION ]..."
       putStrLn ""
       putStrLn "   --update       Update output filename (default)"
       putStrLn "   --check        Check output filename"
       putStrLn "   -i filename    Input filename"
       putStrLn "   -o filename    Output filename"
       putStrLn "   -I path        Add search path"
       putStrLn "   -v             Verbose"
       putStrLn "   -q             Input filename"
       putStrLn ""

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