|
| 1 | +-- Copyright © 2012, 2013 Iain Nicol |
| 2 | + |
| 3 | +-- This program is free software: you can redistribute it and/or modify |
| 4 | +-- it under the terms of the GNU Affero General Public License as published by |
| 5 | +-- the Free Software Foundation, either version 3 of the License, or |
| 6 | +-- (at your option) any later version. |
| 7 | +-- |
| 8 | +-- This program is distributed in the hope that it will be useful, |
| 9 | +-- but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 11 | +-- GNU Affero General Public License for more details. |
| 12 | +-- |
| 13 | +-- You should have received a copy of the GNU Affero General Public License |
| 14 | +-- along with this program. If not, see <http://www.gnu.org/licenses/>. |
| 15 | + |
| 16 | +-- This file is compiled into a standalone executable by the ``cabal |
| 17 | +-- configure'' command, and so must be called module Main and not Setup! |
| 18 | + |
| 19 | +-- | Provides the implementation of Setup.hs for bscc. This is required |
| 20 | +-- because Cabal does not let you specify build dependencies for |
| 21 | +-- Setup.hs itself; see <https://github.com/haskell/cabal/issues/948>. |
| 22 | +module Bscc.SetupHs (setupMain) where |
| 23 | + |
| 24 | +import Distribution.Package (packageId) |
| 25 | +import Distribution.PackageDescription (PackageDescription (package)) |
| 26 | +import Distribution.Simple (defaultMainWithHooks, hookedPrograms, |
| 27 | + UserHooks (buildHook, instHook, postSDist)) |
| 28 | +import Distribution.Simple.Compiler (Compiler (compilerId)) |
| 29 | +import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest)) |
| 30 | +import Distribution.Simple.LocalBuildInfo (absoluteInstallDirs, |
| 31 | + LocalBuildInfo (buildDir, compiler, |
| 32 | + installDirTemplates, |
| 33 | + withPrograms)) |
| 34 | +import Distribution.Simple.Program (defaultProgramConfiguration, |
| 35 | + getProgramOutput, locationPath, Program, |
| 36 | + programLocation, runProgram, simpleProgram) |
| 37 | +import Distribution.Simple.Program.Db (requireProgram) |
| 38 | +import Distribution.Simple.Setup (BuildFlags (buildVerbosity), fromFlag, |
| 39 | + flagToMaybe, |
| 40 | + InstallFlags (installVerbosity), |
| 41 | + SDistFlags (sDistDirectory, sDistDistPref, |
| 42 | + sDistVerbosity)) |
| 43 | +import Distribution.Simple.Utils (die) |
| 44 | +import Distribution.Simple.UUAGC (uuagcLibUserHook) |
| 45 | +import Distribution.Simple.UserHooks (Args) |
| 46 | +import Distribution.Simple.Utils (info, installOrdinaryFile) |
| 47 | +import Distribution.Verbosity (Verbosity) |
| 48 | +import Prelude hiding (FilePath, writeFile) |
| 49 | +import System.Path (AbsDir, asRelDir, asRelFile, mkAbsPathFromCwd, getPathString, (</>)) |
| 50 | +import System.Path.Directory (createDirectoryIfMissing) |
| 51 | +import System.Path.IO (writeFile) |
| 52 | +import UU.UUAGC (uuagc) |
| 53 | + |
| 54 | +-- | Effectively the entry point. Largely this utility's functionality |
| 55 | +-- is stock-Cabal -- functionality. However, we override the basic |
| 56 | +-- behaviour by adding -- hooks (see `myHooks'). |
| 57 | +setupMain = defaultMainWithHooks myHooks |
| 58 | + |
| 59 | +-- | Hooks to properly handle .ag files. .ag files are compiled to .hs |
| 60 | +-- files by /UUAGC/. |
| 61 | +uuagcHooks :: UserHooks |
| 62 | +uuagcHooks = uuagcLibUserHook uuagc |
| 63 | + |
| 64 | +-- | Hooks to augment the stock-Cabal behaviour. We support .ag files |
| 65 | +-- with /UUAGC/. Additionally, we build a man page using /help2man/. |
| 66 | +-- Moreover, we generate the ChangeLog automatically when the source |
| 67 | +-- distribution tarball is created. |
| 68 | +myHooks :: UserHooks |
| 69 | +myHooks = (uuagcHooks |
| 70 | + --Man page generation and installation. |
| 71 | + `appendHookedPrograms` [help2man, runhaskell] |
| 72 | + `appendBuildHook` manBuildHook |
| 73 | + `appendInstallHook` manInstallHook |
| 74 | + -- Replace placeholder ChangeLog contents with git log during |
| 75 | + -- sdist. |
| 76 | + `appendHookedPrograms` [git] |
| 77 | + `appendPostSDist` changeLogPostSDist) |
| 78 | + |
| 79 | +-- For every program we define here (to be run at some point), we should |
| 80 | +-- probably use with `appendHookedPrograms'; see that function's |
| 81 | +-- documentation. |
| 82 | +git, help2man, runhaskell :: Program |
| 83 | +git = simpleProgram "git" |
| 84 | +help2man = simpleProgram "help2man" |
| 85 | +runhaskell = simpleProgram "runhaskell" |
| 86 | + |
| 87 | +-- | Type of `buildHook' `UserHooks'. |
| 88 | +type BuildHook = PackageDescription -> LocalBuildInfo -> UserHooks -> |
| 89 | + BuildFlags -> IO () |
| 90 | +-- | Type of `instHook' `UserHooks'. |
| 91 | +type InstallHook = PackageDescription -> LocalBuildInfo -> UserHooks -> |
| 92 | + InstallFlags -> IO () |
| 93 | +-- | Type of `postSDist' `UserHooks'. |
| 94 | +type PostSDist = Args -> SDistFlags -> PackageDescription -> |
| 95 | + Maybe LocalBuildInfo -> IO () |
| 96 | + |
| 97 | +-- | Append a `BuildHook' to the `buildHook' of the `UserHooks'. |
| 98 | +buildHook_a :: BuildHook -> UserHooks -> UserHooks |
| 99 | +buildHook_a v r = r { buildHook = combinedBuildHook } |
| 100 | + where combinedBuildHook descr buildInfo hooks flags = do |
| 101 | + (buildHook r) descr buildInfo hooks flags |
| 102 | + v descr buildInfo hooks flags |
| 103 | + |
| 104 | +-- | Append an `InstallHook' to the `instHook' of the `UserHooks'. |
| 105 | +installHook_a :: InstallHook -> UserHooks -> UserHooks |
| 106 | +installHook_a v r = r { instHook = combinedInstallHook } |
| 107 | + where combinedInstallHook descr buildInfo hooks flags = do |
| 108 | + (instHook r) descr buildInfo hooks flags |
| 109 | + v descr buildInfo hooks flags |
| 110 | + |
| 111 | +-- | Append a `PostSDist' hook to the `postSDist' of the `UserHooks'. |
| 112 | +-- `PostSDist' hook. |
| 113 | +postSDist_a :: PostSDist -> UserHooks -> UserHooks |
| 114 | +postSDist_a v r = r { postSDist = combinedSDistHook } |
| 115 | + where combinedSDistHook args flags packageDescr buildInfo = do |
| 116 | + (postSDist r) args flags packageDescr buildInfo |
| 117 | + v args flags packageDescr buildInfo |
| 118 | + |
| 119 | +-- | Update the `hookedPrograms' field of the `UserHooks' by applying |
| 120 | +-- the function to it. |
| 121 | +hookedPrograms_u :: ([Program] -> [Program]) -> UserHooks -> UserHooks |
| 122 | +hookedPrograms_u f r = r { hookedPrograms = f (hookedPrograms r) } |
| 123 | + |
| 124 | +-- | `buildHook_a' with parameters flipped. |
| 125 | +appendBuildHook = flip buildHook_a |
| 126 | +-- | `installHook_a' with parameters flipped. |
| 127 | +appendInstallHook = flip installHook_a |
| 128 | +-- | `postSDist_a' with parameters flipped. |
| 129 | +appendPostSDist = flip postSDist_a |
| 130 | +-- | Append the programs to the `hookedPrograms' of the `UserHooks'. |
| 131 | +-- This will cause the existence of these programs to be asserted at |
| 132 | +-- ``cabal configure time. Such programs should probably also be added |
| 133 | +-- to to the build-tools section of our .cabal file. |
| 134 | +appendHookedPrograms :: UserHooks -> [Program] -> UserHooks |
| 135 | +appendHookedPrograms hooks progs = hookedPrograms_u (++ progs) hooks |
| 136 | + |
| 137 | +-- | Converts the input, assumed to be a directory, into an absolute |
| 138 | +-- directory. If the input is relative, the current working directory |
| 139 | +-- is used in the process. |
| 140 | +mkAbsDirFromCwd :: String -> IO AbsDir |
| 141 | +mkAbsDirFromCwd = mkAbsPathFromCwd |
| 142 | + |
| 143 | +-- | Create a man page using help2man. |
| 144 | +manBuildHook :: BuildHook |
| 145 | +manBuildHook descr buildInfo hooks flags = do |
| 146 | + let progsDb = withPrograms buildInfo |
| 147 | + verbosity = fromFlag $ buildVerbosity flags |
| 148 | + absBuildDir <- mkAbsPathFromCwd $ buildDir buildInfo |
| 149 | + let outFile = absBuildDir </> asRelFile "bscc.1" |
| 150 | + (help2man', _) <- requireProgram verbosity help2man progsDb |
| 151 | + -- For reasons documented in the shim program, a shim Haskell program |
| 152 | + -- is interpreted, and help2man uses this to generate the real |
| 153 | + -- bscc's man page. |
| 154 | + (runhaskell', _) <- requireProgram verbosity runhaskell progsDb |
| 155 | + let runhaskellPath = locationPath $ programLocation runhaskell' |
| 156 | + runProgram verbosity help2man' ["-o", getPathString outFile, |
| 157 | + "--no-info", |
| 158 | + runhaskellPath ++ " " ++ |
| 159 | + "./bscc-help2man-shim.hs"] |
| 160 | + |
| 161 | +-- | Install the man page. |
| 162 | +manInstallHook :: InstallHook |
| 163 | +manInstallHook descr buildInfo hooks flags = do |
| 164 | + let verbosity = fromFlag $ installVerbosity flags |
| 165 | + absBuildDir <- mkAbsDirFromCwd $ buildDir buildInfo |
| 166 | + let builtMan = absBuildDir </> asRelFile "bscc.1" |
| 167 | + relManDir = mandir $ absoluteInstallDirs descr buildInfo NoCopyDest |
| 168 | + absManDir <- mkAbsDirFromCwd relManDir |
| 169 | + let destMan1Dir = absManDir </> asRelDir "man1" |
| 170 | + destMan = destMan1Dir </> asRelFile "bscc.1" |
| 171 | + createDirectoryIfMissing True destMan1Dir |
| 172 | + installOrdinaryFile verbosity (getPathString builtMan) (getPathString destMan) |
| 173 | + |
| 174 | +-- | Ensures a real change log from the version control system ends up |
| 175 | +-- in the distribution tarball. Updates the to-be-tarballed directory |
| 176 | +-- tree. |
| 177 | +changeLogPostSDist :: PostSDist |
| 178 | +changeLogPostSDist args flags packageDescr buildInfo = do |
| 179 | + let progsDb = (maybe defaultProgramConfiguration withPrograms buildInfo) |
| 180 | + verbosity = fromFlag $ sDistVerbosity flags |
| 181 | + info verbosity "Replacing dummy ChangeLog with the version control log" |
| 182 | + (git', _) <- requireProgram verbosity git progsDb |
| 183 | + sDistDir <- case flagToMaybe $ sDistDirectory flags of |
| 184 | + Just dir -> mkAbsPathFromCwd dir |
| 185 | + Nothing -> die "changeLogPostSDist: unknown sdist working directory" |
| 186 | + -- Make git format the log a bit like a GNU-style ChangeLog |
| 187 | + let gitLogParams = ["--date=short", |
| 188 | + "--format=%ad %an <%ae>%n%n%w(80,8,8)%B"] |
| 189 | + changeLogContents <- getProgramOutput verbosity git' $ |
| 190 | + ["log"] ++ gitLogParams |
| 191 | + writeFile (sDistDir </> asRelFile "ChangeLog") changeLogContents |
0 commit comments