|
1 | | -#!/usr/bin/runhaskell |
2 | 1 | \begin{code} |
3 | | -{-# OPTIONS_GHC -Wall #-} |
| 2 | +{-# LANGUAGE CPP #-} |
| 3 | +{-# LANGUAGE OverloadedStrings #-} |
4 | 4 | module Main (main) where |
5 | 5 |
|
6 | | -import Data.List ( nub ) |
7 | | -import Data.Version ( showVersion ) |
8 | | -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) |
9 | | -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) |
| 6 | +#ifndef MIN_VERSION_cabal_doctest |
| 7 | +#define MIN_VERSION_cabal_doctest(x,y,z) 0 |
| 8 | +#endif |
| 9 | +
|
10 | 10 | import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) |
| 11 | +
|
| 12 | +#if MIN_VERSION_cabal_doctest(1,0,0) |
| 13 | +import Distribution.Extra.Doctest ( generateBuildModule ) |
| 14 | +#else |
| 15 | +
|
| 16 | +-- Otherwise we provide a shim |
| 17 | +
|
| 18 | +#ifndef MIN_VERSION_Cabal |
| 19 | +#define MIN_VERSION_Cabal(x,y,z) 0 |
| 20 | +#endif |
| 21 | +#ifndef MIN_VERSION_directory |
| 22 | +#define MIN_VERSION_directory(x,y,z) 0 |
| 23 | +#endif |
| 24 | +#if MIN_VERSION_Cabal(1,24,0) |
| 25 | +#define InstalledPackageId UnitId |
| 26 | +#endif |
| 27 | +
|
| 28 | +import Control.Monad ( when ) |
| 29 | +import Data.List ( nub ) |
| 30 | +import Data.String ( fromString ) |
| 31 | +import Distribution.Package ( InstalledPackageId ) |
| 32 | +import Distribution.Package ( PackageId, Package (..), packageVersion ) |
| 33 | +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..)) |
11 | 34 | import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) |
12 | 35 | import Distribution.Simple.BuildPaths ( autogenModulesDir ) |
13 | | -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) |
14 | | -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) |
15 | | -import Distribution.Verbosity ( Verbosity ) |
| 36 | +import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag) |
| 37 | +import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler ) |
| 38 | +import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..)) |
| 39 | +import Distribution.Text ( display , simpleParse ) |
16 | 40 | import System.FilePath ( (</>) ) |
17 | 41 |
|
18 | | -main :: IO () |
19 | | -main = defaultMainWithHooks simpleUserHooks |
20 | | - { buildHook = \pkg lbi hooks flags -> do |
21 | | - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi |
22 | | - buildHook simpleUserHooks pkg lbi hooks flags |
23 | | - } |
| 42 | +#if MIN_VERSION_Cabal(1,25,0) |
| 43 | +import Distribution.Simple.BuildPaths ( autogenComponentModulesDir ) |
| 44 | +#endif |
| 45 | +
|
| 46 | +#if MIN_VERSION_directory(1,2,2) |
| 47 | +import System.Directory (makeAbsolute) |
| 48 | +#else |
| 49 | +import System.Directory (getCurrentDirectory) |
| 50 | +import System.FilePath (isAbsolute) |
| 51 | +
|
| 52 | +makeAbsolute :: FilePath -> IO FilePath |
| 53 | +makeAbsolute p | isAbsolute p = return p |
| 54 | + | otherwise = do |
| 55 | + cwd <- getCurrentDirectory |
| 56 | + return $ cwd </> p |
| 57 | +#endif |
| 58 | +
|
| 59 | +generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () |
| 60 | +generateBuildModule testsuiteName flags pkg lbi = do |
| 61 | + let verbosity = fromFlag (buildVerbosity flags) |
| 62 | + let distPref = fromFlag (buildDistPref flags) |
| 63 | +
|
| 64 | + -- Package DBs |
| 65 | + let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ] |
| 66 | + let dbFlags = "-hide-all-packages" : packageDbArgs dbStack |
| 67 | +
|
| 68 | + withLibLBI pkg lbi $ \lib libcfg -> do |
| 69 | + let libBI = libBuildInfo lib |
24 | 70 |
|
25 | | -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () |
26 | | -generateBuildModule verbosity pkg lbi = do |
27 | | - let dir = autogenModulesDir lbi |
28 | | - createDirectoryIfMissingVerbose verbosity True dir |
29 | | - withLibLBI pkg lbi $ \_ libcfg -> do |
30 | | - withTestLBI pkg lbi $ \suite suitecfg -> do |
31 | | - rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines |
32 | | - [ "module Build_" ++ testName suite ++ " where" |
| 71 | + -- modules |
| 72 | + let modules = exposedModules lib ++ otherModules libBI |
| 73 | + -- it seems that doctest is happy to take in module names, not actual files! |
| 74 | + let module_sources = modules |
| 75 | +
|
| 76 | + -- We need the directory with library's cabal_macros.h! |
| 77 | +#if MIN_VERSION_Cabal(1,25,0) |
| 78 | + let libAutogenDir = autogenComponentModulesDir lbi libcfg |
| 79 | +#else |
| 80 | + let libAutogenDir = autogenModulesDir lbi |
| 81 | +#endif |
| 82 | +
|
| 83 | + -- Lib sources and includes |
| 84 | + iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI |
| 85 | + includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI |
| 86 | +
|
| 87 | + -- CPP includes, i.e. include cabal_macros.h |
| 88 | + let cppFlags = map ("-optP"++) $ |
| 89 | + [ "-include", libAutogenDir ++ "/cabal_macros.h" ] |
| 90 | + ++ cppOptions libBI |
| 91 | +
|
| 92 | + withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do |
| 93 | +
|
| 94 | + -- get and create autogen dir |
| 95 | +#if MIN_VERSION_Cabal(1,25,0) |
| 96 | + let testAutogenDir = autogenComponentModulesDir lbi suitecfg |
| 97 | +#else |
| 98 | + let testAutogenDir = autogenModulesDir lbi |
| 99 | +#endif |
| 100 | + createDirectoryIfMissingVerbose verbosity True testAutogenDir |
| 101 | +
|
| 102 | + -- write autogen'd file |
| 103 | + rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines |
| 104 | + [ "module Build_doctests where" |
| 105 | + , "" |
| 106 | + -- -package-id etc. flags |
| 107 | + , "pkgs :: [String]" |
| 108 | + , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg) |
33 | 109 | , "" |
34 | | - , "autogen_dir :: String" |
35 | | - , "autogen_dir = " ++ show dir |
| 110 | + , "flags :: [String]" |
| 111 | + , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags) |
36 | 112 | , "" |
37 | | - , "deps :: [String]" |
38 | | - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) |
| 113 | + , "module_sources :: [String]" |
| 114 | + , "module_sources = " ++ show (map display module_sources) |
39 | 115 | ] |
40 | 116 | where |
41 | | - formatdeps = map (formatone . snd) |
42 | | - formatone p = case packageName p of |
43 | | - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) |
| 117 | + -- we do this check in Setup, as then doctests don't need to depend on Cabal |
| 118 | + isOldCompiler = maybe False id $ do |
| 119 | + a <- simpleParse $ showCompilerId $ compiler lbi |
| 120 | + b <- simpleParse "7.5" |
| 121 | + return $ packageVersion (a :: PackageId) < b |
| 122 | +
|
| 123 | + formatDeps = map formatOne |
| 124 | + formatOne (installedPkgId, pkgId) |
| 125 | + -- The problem is how different cabal executables handle package databases |
| 126 | + -- when doctests depend on the library |
| 127 | + | packageId pkg == pkgId = "-package=" ++ display pkgId |
| 128 | + | otherwise = "-package-id=" ++ display installedPkgId |
| 129 | +
|
| 130 | + -- From Distribution.Simple.Program.GHC |
| 131 | + packageDbArgs :: [PackageDB] -> [String] |
| 132 | + packageDbArgs | isOldCompiler = packageDbArgsConf |
| 133 | + | otherwise = packageDbArgsDb |
| 134 | +
|
| 135 | + -- GHC <7.6 uses '-package-conf' instead of '-package-db'. |
| 136 | + packageDbArgsConf :: [PackageDB] -> [String] |
| 137 | + packageDbArgsConf dbstack = case dbstack of |
| 138 | + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs |
| 139 | + (GlobalPackageDB:dbs) -> ("-no-user-package-conf") |
| 140 | + : concatMap specific dbs |
| 141 | + _ -> ierror |
| 142 | + where |
| 143 | + specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ] |
| 144 | + specific _ = ierror |
| 145 | + ierror = error $ "internal error: unexpected package db stack: " |
| 146 | + ++ show dbstack |
| 147 | +
|
| 148 | + -- GHC >= 7.6 uses the '-package-db' flag. See |
| 149 | + -- https://ghc.haskell.org/trac/ghc/ticket/5977. |
| 150 | + packageDbArgsDb :: [PackageDB] -> [String] |
| 151 | + -- special cases to make arguments prettier in common scenarios |
| 152 | + packageDbArgsDb dbstack = case dbstack of |
| 153 | + (GlobalPackageDB:UserPackageDB:dbs) |
| 154 | + | all isSpecific dbs -> concatMap single dbs |
| 155 | + (GlobalPackageDB:dbs) |
| 156 | + | all isSpecific dbs -> "-no-user-package-db" |
| 157 | + : concatMap single dbs |
| 158 | + dbs -> "-clear-package-db" |
| 159 | + : concatMap single dbs |
| 160 | + where |
| 161 | + single (SpecificPackageDB db) = [ "-package-db=" ++ db ] |
| 162 | + single GlobalPackageDB = [ "-global-package-db" ] |
| 163 | + single UserPackageDB = [ "-user-package-db" ] |
| 164 | + isSpecific (SpecificPackageDB _) = True |
| 165 | + isSpecific _ = False |
44 | 166 |
|
45 | 167 | testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] |
46 | 168 | testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys |
| 169 | +#endif |
| 170 | +
|
| 171 | +main :: IO () |
| 172 | +main = defaultMainWithHooks simpleUserHooks |
| 173 | + { buildHook = \pkg lbi hooks flags -> do |
| 174 | + generateBuildModule "doctests" flags pkg lbi |
| 175 | + buildHook simpleUserHooks pkg lbi hooks flags |
| 176 | + } |
47 | 177 |
|
48 | 178 | \end{code} |
0 commit comments