kerry-0.1: Setup.hs

{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE CPP #-}

import           Data.Char (isDigit)
import           Data.List (intercalate)
import           Data.Monoid ((<>))

import           Distribution.InstalledPackageInfo
import           Distribution.PackageDescription
import           Distribution.Simple (buildHook, defaultMainWithHooks, pkgName, pkgVersion, preConf, replHook, sDistHook, simpleUserHooks, testHook)
import           Distribution.Simple.Setup (BuildFlags(..), ReplFlags(..), TestFlags(..), fromFlag)
import           Distribution.Simple.LocalBuildInfo
import           Distribution.Simple.PackageIndex
import           Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile, rawSystemStdout)
import           Distribution.Verbosity

#ifndef MIN_VERSION_Cabal
#if __GLASGOW_HASKELL__ <= 710
-- GHC 7.10 and earlier do not support the MIN_VERSION_Cabal macro.
#define MIN_VERSION_Cabal(a,b,c) 0
#endif
#endif

#if MIN_VERSION_Cabal(2,0,0)
import           Distribution.Types.PackageName (unPackageName)
import           Distribution.Simple.BuildPaths (autogenPackageModulesDir)
import           Distribution.Version (Version, versionNumbers)

showVersion :: Version -> String
showVersion = intercalate "." . fmap show . versionNumbers

autogenModulesDirCompat :: LocalBuildInfo -> String
autogenModulesDirCompat = autogenPackageModulesDir

#else
import           Distribution.Simple (unPackageName)
import           Distribution.Simple.BuildPaths (autogenModulesDir)
import           Data.Version (showVersion)

autogenModulesDirCompat :: LocalBuildInfo -> String
autogenModulesDirCompat = autogenModulesDir
#endif


main :: IO ()
main =
  let hooks = simpleUserHooks
   in defaultMainWithHooks hooks {
     preConf = \args flags -> do
       createDirectoryIfMissingVerbose silent True "gen"
       preConf hooks args flags
   , sDistHook = \pd mlbi uh flags -> do
       genBuildInfo silent pd
       sDistHook hooks pd mlbi uh flags
   , buildHook = \pd lbi uh flags -> do
       genBuildInfo (fromFlag $ buildVerbosity flags) pd
       genDependencyInfo (fromFlag $ buildVerbosity flags) pd lbi
       buildHook hooks pd lbi uh flags
   , replHook = \pd lbi uh flags args -> do
       genBuildInfo (fromFlag $ replVerbosity flags) pd
       genDependencyInfo (fromFlag $ replVerbosity flags) pd lbi
       replHook hooks pd lbi uh flags args
   , testHook = \args pd lbi uh flags -> do
       genBuildInfo (fromFlag $ testVerbosity flags) pd
       genDependencyInfo (fromFlag $ testVerbosity flags) pd lbi
       testHook hooks args pd lbi uh flags
   }

genBuildInfo :: Verbosity -> PackageDescription -> IO ()
genBuildInfo verbosity pkg = do
  createDirectoryIfMissingVerbose verbosity True "gen"
  let pname = unPackageName . pkgName . package $ pkg
      version = pkgVersion . package $ pkg
      name = "BuildInfo_" ++ map (\c -> if c == '-' then '_' else c) pname
      targetHs = "gen/" ++ name ++ ".hs"
      targetText = "gen/version.txt"
  t <- timestamp verbosity
  gv <- gitVersion verbosity
  let v = showVersion version
  let buildVersion = intercalate "-" [v, t, gv]
  rewriteFile targetHs $ unlines [
      "module " ++ name ++ " where"
    , "import Prelude"
    , "data RuntimeBuildInfo = RuntimeBuildInfo { buildVersion :: String, timestamp :: String, gitVersion :: String }"
    , "buildInfo :: RuntimeBuildInfo"
    , "buildInfo = RuntimeBuildInfo \"" ++ v ++ "\" \"" ++ t ++ "\" \"" ++ gv ++ "\""
    , "buildInfoVersion :: String"
    , "buildInfoVersion = \"" ++ buildVersion ++ "\""
    ]
  rewriteFile targetText buildVersion

genDependencyInfo :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
genDependencyInfo verbosity pkg info = do
  let
    pname = unPackageName . pkgName . package $ pkg
    name = "DependencyInfo_" ++ map (\c -> if c == '-' then '_' else c) pname
    targetHs = autogenModulesDirCompat info ++ "/" ++ name ++ ".hs"
    render p =
      let
        n = unPackageName $ pkgName p
        v = showVersion $ pkgVersion p
      in
       n ++ "-" ++ v
    deps = fmap (render . sourcePackageId) . allPackages $ installedPkgs info
    strs = flip fmap deps $ \d -> "\"" ++ d ++ "\""

  createDirectoryIfMissingVerbose verbosity True (autogenModulesDirCompat info)

  rewriteFile targetHs $ unlines [
      "module " ++ name ++ " where"
    , "import Prelude"
    , "dependencyInfo :: [String]"
    , "dependencyInfo = [\n    " ++ intercalate "\n  , " strs ++ "\n  ]"
    ]

gitVersion :: Verbosity -> IO String
gitVersion verbosity = do
  ver <- rawSystemStdout verbosity "git" ["log", "--pretty=format:%h", "-n", "1"]
  notModified <- ((>) 1 . length) `fmap` rawSystemStdout verbosity "git" ["status", "--porcelain"]
  return $ ver ++ if notModified then "" else "-M"

timestamp :: Verbosity -> IO String
timestamp verbosity =
  rawSystemStdout verbosity "date" ["+%Y%m%d%H%M%S"] >>= \s ->
    case splitAt 14 s of
      (d, [_]) ->
        if length d == 14 && filter isDigit d == d
          then return d
          else fail $ "date has failed to produce the correct format [" <> s <> "]."
      _ ->
        fail $ "date has failed to produce a date long enough [" <> s <> "]."