#!/bin/env runhaskell -- |Tool to insert version information into darcs-controlled program source. -- -- Copyright (c) 2006 Manuel M T Chakravarty -- -- License: BSD3 -- -- Version: 1.0 -- --- Description --------------------------------------------------------------- -- -- Extract version information from a .cabal file and from darcs, and then, -- insert it into a source file. The name of the source file that is to be -- rewritten with the version information must be passed as the only argument -- to VersionTool. If that file's name is `Version.hs', there must be a -- template file `Version.hs.in' containing version information markers -- indicating where VersionTool should to enter the version information. The -- markers are the following: -- -- @VERSION@ -- version number, typically in XX.YY.ZZ format -- (from `Version' entry in Cabal file) -- @VERSNICK@ -- version nickname, a string that may contain white space -- (from non-standard `--Versnick' entry in Cabal file) -- @VERSDATE@ -- date of version, typically in DD MMM YYYY format -- (from non-standard `--Versdate' entry in Cabal file) -- @PATCHLEVEL@ -- number of darcs patches after a tag including the value -- of @VERSION@, in `plN' format -- @CONTEXT@ -- first entry of `darcs changes --context' -- @CONFDATE@ -- date when VersionTool ran, in DD MMM YYYY format -- -- VersionTool replaces these markers by H98 string literals. -- -- VersionTool allows the Cabal file to have two extra entries not recognised -- by Cabal itself. Hence, these entries start with the Cabal comment -- characters `--'. -- -- VersionTool uses darcs to find a tag containing the version number -- @VERSION@. If it finds such a tag, the number of patches added, since that -- tag, determine the patchlevel. If it does not find such a tag, it tags -- the repository with "Version @VERSION@" and the patchlevel is "pl0". -- -- More info at . -- module Main (main) where import Data.Char ( toLower, isSpace) import Control.Monad ( when, unless, liftM) import System.Process ( runInteractiveCommand, waitForProcess) import System.Directory ( getDirectoryContents, doesFileExist) import System.Environment ( getArgs) import System.Exit ( ExitCode(..)) import System.IO ( hGetContents) import System.Time ( ClockTime, Month, CalendarTime(..), getClockTime, toUTCTime) -- Constants -- --------- -- Suffix of input file -- inSuffix :: String inSuffix = ".in" -- Darcs commands -- darcsChangesFromTag, darcsContext :: String darcsChangesFromTag = "darcs changes --from-tag=" darcsTag = "darcs tag " darcsContext = "darcs changes --context --last=1" -- Data -- ---- -- Versioning information -- data Version = Version { version :: String, nickname :: String, versdate :: String, patchlevel :: String, context :: String, confdate :: String } -- Actual program -- -------------- main :: IO () main = do -- Get name of source file into which we enter the version information args <- getArgs when (length args /= 1) $ error "Usage: VersionTool.hs VERSION-FILE" let versionFName = head args exists <- doesFileExist (versionFName ++ ".in") unless exists $ error $ "VersionTool: `" ++ versionFName ++ ".in' does not exist" -- Get the package's Cabal file and extract version information from it fnames <- getDirectoryContents "." let cabalFNames = [fname | fname <- fnames, suffix fname == "cabal"] when (null cabalFNames) $ error "VersionTool: no .cabal file in current directory" (version, versnick, versdate) <- getCabalInfo (head cabalFNames) -- Query darcs for tag, patchlevel, and context; maybe add tag (patchlevel, context) <- darcsPatchLevelAndContext version -- Get current date confdate <- getCurrentDate -- Enter the gathered information into the version file rewriteFile versionFName (Version version versnick versdate patchlevel context confdate) -- Cabal file processing -- --------------------- -- Extract version information (version number and version nick) from Cabal -- file. -- getCabalInfo :: FilePath -> IO (String, String, String) getCabalInfo fname = do cabalSpec <- liftM lines $ readFile fname let versionLs = [line | line <- cabalSpec, "Version" `isPrefix` line] versnickLs = [line | line <- cabalSpec, "--Versnick" `isPrefix` line] versdateLs = [line | line <- cabalSpec, "--Versdate" `isPrefix` line] when (null versionLs) $ error $ "VersionTool: no line with `version' tag in `" ++ fname ++ "'" when (null versnickLs) $ putStrLn $ "Warning: VersionTool: no line with `--versnick' tag in `" ++ fname ++ "'" when (null versdateLs) $ putStrLn $ "Warning: VersionTool: no line with `--versdate' tag in `" ++ fname ++ "'" return (extract versionLs, extract versnickLs, extract versdateLs) where extract ls | null ls = "" | otherwise = clean . tail . dropWhile (/= ':') . head $ ls -- Darcs interaction -- ----------------- -- Compute the current patchlevel in darcs, obtain the context, and maybe set -- a new version tag. -- -- * The computation of the patchlevel relies on the fact that `darcs changes' -- produces output where only the first line of every patch has a non-space -- character. -- darcsPatchLevelAndContext :: String -> IO (String, String) darcsPatchLevelAndContext version = do changes <- runDarcs (darcsChangesFromTag ++ version) ("darcs: Couldn't find" `isPrefix`) patchlevel <- case changes of Nothing -> do runDarcs_ (darcsTag ++ "\"version " ++ version ++ "\"") return 0 Just changes -> return $ length [ line | line <- lines changes , not (null line || isSpace (head line))] - 1 -- don't count tag itself Just context <- runDarcs darcsContext (const False) return ("pl" ++ show patchlevel, dropWhile (/= '[') context) where runDarcs cmd errorTest = do (stdin, stdout, stderr, hdl) <- runInteractiveCommand cmd exitcode <- waitForProcess hdl case exitcode of ExitSuccess -> liftM Just $ hGetContents stdout ExitFailure code -> do errMsg <- hGetContents stderr if errorTest errMsg then return Nothing else error $ "VersionTool: darcs error " ++ show code ++ (if null errMsg then "" else ": " ++ errMsg) runDarcs_ cmd = runDarcs cmd (const False) >> return () -- Date information -- ---------------- -- Get the current date in `DD MMM YYYY' format. -- getCurrentDate :: IO String getCurrentDate = do time <- liftM toUTCTime $ getClockTime let preday = show $ ctDay time day = if length preday == 1 then '0':preday else preday month = take 3 (show $ ctMonth time) year = show $ ctYear time return $ day ++ " " ++ month ++ " " ++ year -- Target rewriting -- ---------------- -- Enter version information into the version source. -- rewriteFile :: FilePath -> Version -> IO () rewriteFile fname vers = do contents <- readFile (fname ++ inSuffix) writeFile fname (rewrite contents) where rewrite "" = "" rewrite ('@':rest) = case match rest of Nothing -> '@' : rewrite rest Just (new, rest') -> show new ++ rewrite rest' rewrite (c :rest) = c : rewrite rest -- match str | "VERSION@" `isPrefix` str = Just (version vers, drop (length "VERSION@" ) str) | "VERSNICK@" `isPrefix` str = Just (nickname vers, drop (length "VERSNICK@") str) | "VERSDATE@" `isPrefix` str = Just (versdate vers, drop (length "VERSDATE@") str) | "PATCHLEVEL@" `isPrefix` str = Just (patchlevel vers, drop (length "PATCHLEVEL@") str) | "CONTEXT@" `isPrefix` str = Just (context vers, drop (length "CONTEXT@") str) | "CONFDATE@" `isPrefix` str = Just (confdate vers, drop (length "CONFDATE@") str) match _ = Nothing -- Utility functions -- ----------------- -- Lose leading and trailing whitespace. -- clean :: String -> String clean = reverse . dropWhile isSpace . reverse . dropWhile isSpace -- Check for string prefix disregarding case. -- isPrefix :: String -> String -> Bool str1 `isPrefix` str2 = map toLower str1 == map toLower (take (length str1) str2) -- Project the suffix from a filename. -- suffix :: FilePath -> String suffix = reverse . takeWhile (/= '.') . reverse