lambdaFeed-0.3.1: VersionTool.hs
#!/bin/env runhaskell
-- |Tool to insert version information into darcs-controlled program source.
--
-- Copyright (c) 2006 Manuel M T Chakravarty
--
-- License: BSD3 <http://opensource.org/licenses/bsd-license.php>
--
-- 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 <http://www.cse.unsw.edu.au/~chak/haskell/VersionTool/>.
--
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