Permalink
Fetching contributors…
Cannot retrieve contributors at this time
executable file 60 lines (53 sloc) 2.55 KB
#!/usr/bin/runhaskell
\begin{code}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where
import Data.List ( nub )
import Data.Version ( showVersion )
import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )
import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )
import Distribution.Simple.BuildPaths ( autogenModulesDir )
import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))
import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
import Distribution.Text ( display )
import Distribution.Verbosity ( Verbosity, normal )
import System.FilePath ( (</>) )
main :: IO ()
main = defaultMainWithHooks simpleUserHooks
{ buildHook = \pkg lbi hooks flags -> do
generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
buildHook simpleUserHooks pkg lbi hooks flags
, postHaddock = \args flags pkg lbi -> do
copyFiles normal (haddockOutputDir flags pkg) [("notes","SPOILER.html"), ("notes","grid.pdf")]
postHaddock simpleUserHooks args flags pkg lbi
}
haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath
haddockOutputDir flags pkg = destDir where
baseDir = case haddockDistPref flags of
NoFlag -> "."
Flag x -> x
destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)
generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule verbosity pkg lbi = do
let dir = autogenModulesDir lbi
createDirectoryIfMissingVerbose verbosity True dir
withLibLBI pkg lbi $ \_ libcfg -> do
withTestLBI pkg lbi $ \suite suitecfg -> do
rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
[ "module Build_" ++ testName suite ++ " where"
, ""
, "autogen_dir :: String"
, "autogen_dir = " ++ show dir
, ""
, "deps :: [String]"
, "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
]
where
formatdeps = map (formatone . snd)
formatone p = case packageName p of
PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
\end{code}