Written by Ian Lynagh . 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", cabalToDebianPackageName "dev" cpkg), ("this:ghc6:prof", cabalToDebianPackageName "prof" cpkg), ("this:ghc6:doc", cabalToDebianPackageName "doc" cpkg), ("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}