From 25c5ad2bf044a90d7a34c3c9a0bd74386708fd7f Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Wed, 30 May 2012 15:45:45 +0000
Subject: [PATCH] More detailed version info in the startup message

The Setup.hs script now queries darcs to create more detailed version info
to include in the startup message.

Note thought that with distributed version control systems like darcs,
the only way to uniquely identify a version is by the set of patches included.
Since the patches are not totally ordered, just looking at the last patch is
not enough.

For official releases, we tag the current set of patches so we can refer to
it by name (e.g. RELEASE-3.3.3).
---
 Setup.hs                           | 47 +++++++++++++++++++++++++++---
 src/compiler/GF/Infra/BuildInfo.hs | 18 +++++++++++-
 2 files changed, 60 insertions(+), 5 deletions(-)

diff --git a/Setup.hs b/Setup.hs
index 0454b36e7..3b6462e9d 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -7,7 +7,9 @@ import Distribution.Simple.Setup
 import Distribution.PackageDescription hiding (Flag)
 import Control.Monad
 import Data.List(isPrefixOf)
+import Data.Maybe(listToMaybe)
 import System.IO
+import qualified System.IO.Error as E
 import System.Cmd
 import System.FilePath
 import System.Directory
@@ -17,16 +19,24 @@ import System.Exit
 import WebSetup
 
 main :: IO ()
-main = defaultMainWithHooks simpleUserHooks{ preBuild =checkRGLArgs
+main = defaultMainWithHooks simpleUserHooks{ preBuild =gfPreBuild
                                            , postBuild=buildRGL
-                                           , preInst  =checkRGLArgs
+                                           , preInst  =gfPreInst
                                            , postInst =gfPostInst
-                                           , preCopy  =checkRGLArgs
+                                           , preCopy  =const . checkRGLArgs
                                            , postCopy =gfPostCopy
                                            , sDistHook=sdistRGL
                                            , runTests =testRGL
                                            }
   where
+    gfPreBuild args  = gfPre args . buildDistPref
+    gfPreInst args = gfPre args . installDistPref
+
+    gfPre args distFlag =
+      do h <- checkRGLArgs args
+         extractDarcsVersion distFlag
+         return h
+
     gfPostInst args flags pkg lbi =
       do installRGL args flags pkg lbi
          let gf = default_gf pkg lbi
@@ -92,7 +102,7 @@ rglCommands =
 
 --------------------------------------------------------
 
-checkRGLArgs args flags = do
+checkRGLArgs args = do
   let args' = filter (\arg -> not (arg `elem` all_modes ||
                                    rgl_prefix `isPrefixOf` arg ||
                                    langs_prefix `isPrefixOf` arg)) args
@@ -360,3 +370,32 @@ default_gf pkg lbi = buildDir lbi </> exeName' </> exeNameReal
   where
     exeName' = (exeName . head . executables) pkg
     exeNameReal = exeName' <.> (if null $ takeExtension exeName' then exeExtension else "")
+
+-- | Create autogen module with detailed version info by querying darcs
+extractDarcsVersion distFlag =
+  do info <- E.try askDarcs
+     updateFile versionModulePath $ unlines $
+       ["module "++modname++" where",
+        "darcs_info = "++show info]
+  where
+    dist = fromFlagOrDefault "dist" distFlag
+    versionModulePath = dist</>"build"</>"autogen"</>"DarcsVersion_gf.hs"
+    modname = "DarcsVersion_gf"
+
+    askDarcs =
+      do tags <- lines `fmap` readProcess "darcs" ["show","tags"] ""
+         let from = case tags of
+                      [] -> []
+                      tag:_ -> ["--from-tag="++tag]
+         changes <- lines `fmap` readProcess "darcs" ("changes":from) ""
+         let dates = filter ((`notElem` [""," "]).take 1) changes
+         whatsnew <- lines `fmap` readProcess "darcs" ["whatsnew","-s"] ""
+         return (listToMaybe tags,listToMaybe dates,
+                 length dates,length whatsnew)
+
+-- | Only update the file if contents has changed
+updateFile path new =
+  do old <- E.try $ readFile path
+     when (Right new/=old) $ seq (either (const 0) length old) $
+                                 writeFile path new
+
diff --git a/src/compiler/GF/Infra/BuildInfo.hs b/src/compiler/GF/Infra/BuildInfo.hs
index 2ff770393..a9c974e74 100644
--- a/src/compiler/GF/Infra/BuildInfo.hs
+++ b/src/compiler/GF/Infra/BuildInfo.hs
@@ -2,9 +2,11 @@
 module GF.Infra.BuildInfo where
 import System.Info
 import Data.Version(showVersion)
+import DarcsVersion_gf
 
 buildInfo =
-    "Built on "++os++"/"++arch
+    details
+    ++"\nBuilt on "++os++"/"++arch
     ++" with "++compilerName++"-"++showVersion compilerVersion
     ++", flags:"
 #ifdef USE_INTERRUPT
@@ -13,3 +15,17 @@ buildInfo =
 #ifdef SERVER_MODE
     ++" server"
 #endif
+  where
+    details = either (const no_info) info darcs_info
+    no_info = "No detailed version info available"
+    info (otag,olast,changes,whatsnew) =
+      (case changes of
+         0 -> "No recorded changes"
+         1 -> "One recorded change"
+         _ -> show changes++" recorded changes")++
+      (case whatsnew of
+         0 -> ""
+         1 -> " + one file with unrecorded changes"
+         _ -> " + "++show whatsnew++" files with unrecorded changes")++
+      (maybe "" (" since "++) otag)++
+      (maybe "" ("\nLast recorded change: "++) olast)