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