File: Setup.lhs

package info (click to toggle)
darcs 2.4.4-3
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 4,292 kB
  • ctags: 259
  • sloc: haskell: 26,818; sh: 7,051; ansic: 1,572; perl: 124; makefile: 24
file content (392 lines) | stat: -rw-r--r-- 15,638 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
\begin{code}
{-# OPTIONS_GHC -cpp #-}
-- copyright (c) 2008 Duncan Coutts
-- portions copyright (c) 2008 David Roundy

import Distribution.Simple
         ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
import Distribution.ModuleName( toFilePath )
import Distribution.PackageDescription
         ( PackageDescription(executables), Executable(buildInfo, exeName)
         , BuildInfo(customFieldsBI), emptyBuildInfo
         , updatePackageDescription, cppOptions, ccOptions
         , library, libBuildInfo, otherModules )
import Distribution.Package
         ( packageVersion )
import Distribution.Version
         ( Version(versionBranch) )
import Distribution.Simple.LocalBuildInfo
         ( LocalBuildInfo(..), absoluteInstallDirs )
import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))
import Distribution.Simple.Setup
    (buildVerbosity, copyDest, copyVerbosity, fromFlag,
     haddockVerbosity, installVerbosity, sDistVerbosity)
import Distribution.Simple.BuildPaths
         ( autogenModulesDir )
import Distribution.System
         ( OS(Windows), buildOS )
import Distribution.Simple.Utils
    (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,
     rewriteFile)
import Distribution.Verbosity
         ( Verbosity )
import Distribution.Text
         ( display )
import Distribution.Package (Package)

import Control.Monad ( zipWithM_, when, unless, filterM )
import Control.Exception ( bracket )
import System.Directory
    (copyFile, createDirectory, createDirectoryIfMissing,
     doesDirectoryExist, doesFileExist,
     getCurrentDirectory, getDirectoryContents,
     removeDirectoryRecursive, removeFile, setCurrentDirectory)
import System.IO (openFile, IOMode (..))
import System.Process (runProcess)
import System.IO.Error ( isDoesNotExistError )
import Data.List( isPrefixOf, isSuffixOf, sort, partition )

import System.FilePath       ( (</>), splitDirectories, isAbsolute )
import Foreign.Marshal.Utils ( with )
import Foreign.Storable      ( peek )
import Foreign.Ptr           ( castPtr )
import Data.Word             ( Word8, Word32 )

import qualified Distribution.ShellHarness as Harness ( runTests )

#if __GLASGOW_HASKELL__ >= 610
import qualified Control.OldException as Exception
#else
import qualified Control.Exception as Exception
#endif

main :: IO ()
main = defaultMainWithHooks simpleUserHooks {

  buildHook = \ pkg lbi hooks flags ->
              let verb = fromFlag $ buildVerbosity flags
               in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),

  haddockHook = \ pkg lbi hooks flags ->
                let verb = fromFlag $ haddockVerbosity flags
                 in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,

  postBuild = \ _ _ _ lbi -> buildManpage lbi,
  postCopy = \ _ flags pkg lbi ->
             installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags),
  postInst = \ _ flags pkg lbi ->
             installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest,

  runTests = \ args _ _ lbi -> do
             cwd <- getCurrentDirectory
             let isabs = isAbsolute $ buildDir lbi
                 path = (if isabs then id else (cwd </>))
                        (buildDir lbi </> "darcs")
                 what = if null args then ["tests"] else args
                 (series, tests) = partition
                                     (`elem` ["bugs", "network", "tests"]) what
             sequence_ [ case w of
                           "bugs" -> allTests path Bug []
                           "network" -> execTests path Network "" []
                           "tests" -> allTests path Test []
                           _ -> return () {- impossible, silence -Wall -}
                         | w <- series ]
             when (not $ null tests) $ individualTests path tests,

  -- Remove the temporary directories created by "cabal test".
  postClean = \ _ _ _ _ -> mapM_ rmRf
              ["tests-darcs-2.dir",
               "tests-hashed.dir",
               "tests-old-fashioned-inventory.dir",
               "bugs-darcs-2.dir",
               "bugs-hashed.dir",
               "bugs-old-fashioned-inventory.dir",
               "tests-network.dir"],

  sDistHook = \ pkg lbi hooks flags -> do
    let pkgVer = packageVersion pkg
        verb = fromFlag $ sDistVerbosity flags
    x <- versionPatches verb pkgVer
    y <- context verb pkgVer
    rewriteFile "release/distributed-version" $ show x
    rewriteFile "release/distributed-context" $ show y
    putStrLn "about to hand over"
    let pkg' = pkg { library = sanity (library pkg) }
        sanity (Just lib) = Just $ lib { libBuildInfo = sanity' $ libBuildInfo lib }
        sanity _ = error "eh"
        sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] }

    sDistHook simpleUserHooks pkg' lbi hooks flags
}

-- | For @./Setup build@ and @./Setup haddock@, do some unusual
-- things, then invoke the base behaviour ("simple hook").
commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)
                -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a
commonBuildHook runHook pkg lbi hooks verbosity = do
  (version, state) <- determineVersion verbosity pkg

  -- Create our own context file.
  generateVersionModule verbosity pkg lbi version state

  -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c)
  -- invocations, doing a dance to make the base hook aware of them.
  littleEndian <- testEndianness
  let args = ("-DPACKAGE_VERSION=" ++ show' version) :
             ("-DPACKAGE_VERSION_STATE=" ++ show' state) :
             [arg | (arg, True) <-         -- include fst iff snd.
              [("-DHAVE_HTTP", "x-have-http" `elem` customFields),
               ("-DUSE_COLOR", "x-use-color" `elem` customFields),
               -- We have MAPI iff building on/for Windows.
               ("-DHAVE_MAPI", buildOS == Windows),
               ("-DBIGENDIAN", not littleEndian)]]
      bi = emptyBuildInfo { cppOptions = args, ccOptions = args }
      hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg])
      pkg' = updatePackageDescription hbi pkg
      lbi' = lbi { localPkgDescr = pkg' }
  return $ runHook simpleUserHooks pkg' lbi' hooks

  where
    customFields = map fst . customFieldsBI . buildInfo $ darcsExe
    darcsExe = head [e | e <- executables pkg, exeName e == "darcs"]
    show' :: String -> String   -- Petr was worried that we might
    show' = show                -- allow non-String arguments.
    testEndianness :: IO Bool
    testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p
                                                   return $ o == (1 :: Word8)

buildManpage :: LocalBuildInfo -> IO ()
buildManpage lbi = do
  let darcs = buildDir lbi </> "darcs/darcs"
      manpage = buildDir lbi </> "darcs/darcs.1"
  manpageHandle <- openFile manpage WriteMode
  runProcess darcs ["help","manpage"]
             Nothing Nothing Nothing (Just manpageHandle) Nothing
  return ()

installManpage :: PackageDescription -> LocalBuildInfo
                  -> Verbosity -> CopyDest -> IO ()
installManpage pkg lbi verbosity copy =
    copyFiles verbosity
              (mandir (absoluteInstallDirs pkg lbi copy) </> "man1")
              [(buildDir lbi </> "darcs", "darcs.1")]

determineVersion :: Verbosity -> PackageDescription -> IO (String, String)
determineVersion verbosity pkg = do
  let darcsVersion  =  packageVersion pkg
  numPatches <- versionPatches verbosity darcsVersion
  return (display darcsVersion, versionStateString numPatches darcsVersion)

  where
    versionStateString :: Maybe Int -> Version -> String
    versionStateString Nothing  _ = "unknown"
    versionStateString (Just 0) v = case versionBranch v of
                         x | 97 `elem` x -> "alpha " ++ show (after 97 x)
                           | 98 `elem` x -> "beta " ++ show (after 98 x)
                           | 99 `elem` x  ->
                               "release candidate " ++ show (after 99 x)
                         _ -> "release"
    versionStateString (Just 1) _ = "+ 1 patch"
    versionStateString (Just n) _ = "+ " ++ show n ++ " patches"
    after w (x:r) | w == x = head r
                  | otherwise = after w r
    after _ [] = undefined

versionPatches :: Verbosity -> Version -> IO (Maybe Int)
versionPatches verbosity darcsVersion = do
  numPatchesDarcs <- do
      out <- rawSystemStdout verbosity "darcs"
               ["changes", "--from-tag", display darcsVersion, "--count"]
      case reads (out) of
        ((n,_):_) -> return $ Just ((n :: Int) - 1)
        _         -> return Nothing
    `Exception.catch` \_ -> return Nothing

  numPatchesDist <- parseFile versionFile
  return $ case (numPatchesDarcs, numPatchesDist) of
             (Just x, _) -> Just x
             (Nothing, Just x) -> Just x
             (Nothing, Nothing) -> Nothing

 where
  versionFile = "release/distributed-version"

generateVersionModule :: Verbosity -> PackageDescription -> LocalBuildInfo
                      -> String -> String -> IO ()
generateVersionModule verbosity pkg lbi version state = do
  let dir = autogenModulesDir lbi
  createDirectoryIfMissingVerbose verbosity True dir
  ctx <- context verbosity (packageVersion pkg)
  rewriteFile (dir </> "Version.hs") $ unlines
    ["module Version where"
    ,"version, context :: String"
    ,"version = \"" ++ version ++ " (" ++ state ++ ")\""
    ,"context = " ++ case ctx of
                       Just x -> show x
                       Nothing -> show "context not available"
    ]

context :: Verbosity -> Version -> IO (Maybe String)
context verbosity version = do
  contextDarcs <- do
      -- FIXME currently we run changes --from-tag to at least assert that the
      -- requested version is tagged in this repository... it is a weak check,
      -- but otherwise, my ~/_darcs context tends to gets used when running
      -- from an unpacked distribution
      rawSystemStdout verbosity "darcs"
                          ["changes", "--from-tag", display version ]
      out <- rawSystemStdout verbosity "darcs" ["changes", "--context"]
      return $ Just out
   `Exception.catch` \_ -> return Nothing

  contextDist <- parseFile contextFile
  return $ case (contextDarcs, contextDist) of
             (Just x, _) -> Just x
             (Nothing, Just x) -> Just x
             (Nothing, Nothing) -> Nothing
 where contextFile = "release/distributed-context"

parseFile :: (Read a) => String -> IO (Maybe a)
parseFile f = do
  exist <- doesFileExist f
  if exist then do
             content <- readFile f -- ^ ratify readFile: we don't care here.
             case reads content of
               ((s,_):_) -> return s
               _         -> return Nothing
             else return Nothing

-------------------------------------
-- Running the testsuite
--

data TestKind = Bug | Test | Network deriving Eq

testDir :: TestKind -> String
testDir Bug = "tests"
testDir Test = "tests"
testDir Network = "tests/network"

deslash :: Char -> Char
deslash '/' = '-'
deslash x  = x

isSh :: FilePath -> Bool
isSh = (".sh" `isSuffixOf`)

-- | By convention, a test script starts with "failing-" iff it is
-- expected to fail, i.e. it is a bug that hasn't been fixed yet.
isTest :: TestKind -> FilePath -> Bool
isTest Bug = ("failing-" `isPrefixOf`)
isTest _   = not . isTest Bug

execTests :: FilePath -> TestKind -> String -> [String] -> IO ()
execTests darcs_path k fmt tests = do
  let dir = map deslash (testDir k) ++ (if null fmt then fmt else  "-" ++ fmt) ++ ".dir"
  rmRf dir
  cloneTree (testDir k) dir
  withCurrentDirectory dir $ do
    createDirectory ".darcs"
    when (not $ null fmt) $ appendFile ".darcs/defaults" $ "ALL " ++ fmt ++ "\n"
    putStrLn $ "Running tests for format: " ++ fmt
    fs <- case tests of
            [] -> sort `fmap` getDirectoryContents "."
            x -> return x
    let run = filter (\f -> isSh f && isTest k f) fs
    cwd <- getCurrentDirectory
    res <- Harness.runTests (Just darcs_path) cwd run
    when ((not res) && (k /= Bug)) $ fail "Tests failed"
    return ()

individualTests :: FilePath -> [String] -> IO ()
individualTests darcs_path tests = do
  run <- concat `fmap` mapM find tests
  sequence_ [ do exec kind [test | (kind', test) <- run, kind' == kind]
                     | kind <- [Test, Bug, Network] ]
      where tryin w t' = [w </> t', w </> (t' ++ ".sh")]
            exec _ [] = return ()
            exec kind to_run = allTests darcs_path kind to_run
            find t = do
              let c = [t, t ++ ".sh"] ++ tryin "tests" t
                        ++ tryin "network" t
              run <- map kindify `fmap` filterM doesFileExist c
              return $ take 1 run
            kindify test = case splitDirectories test of
                             [p, y] -> (parse_kind p y, y)
                             _ -> error $ "Bad format in " ++ test ++
                                          ": expected type/test"
            parse_kind "tests" y   = if isTest Bug y then Bug else Test
            parse_kind "network" _ = Network
            parse_kind x _ = error $ "Test prefix must be one of " ++
                              "[tests, network] in " ++ x


allTests :: FilePath -> TestKind -> [String] -> IO ()
allTests darcs_path k s =
    do test `mapM` repotypes
       return ()
    where repotypes = ["darcs-2", "hashed", "old-fashioned-inventory"]
          test x = execTests darcs_path k x s

-------------------------------------------------------
-- Utility functions (FIXME)
-- copy & paste & edit: darcs wants to share these
--

withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory name m =
    bracket
        (do cwd <- getCurrentDirectory
            when (name /= "") (setCurrentDirectory name)
            return cwd)
        (\oldwd -> setCurrentDirectory oldwd `catch` (\_ -> return ()))
        (const m)

cloneTree :: FilePath -> FilePath -> IO ()
cloneTree = cloneTreeExcept []

cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
cloneTreeExcept except source dest =
 do isdir <- doesDirectoryExist source
    if isdir then do
        createDirectoryIfMissing True dest
        fps <- getDirectoryContents source
        let fps' = filter (`notElem` (".":"..":except)) fps
            mk_source fp = source ++ "/" ++ fp
            mk_dest   fp = dest   ++ "/" ++ fp
        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
     else fail ("cloneTreeExcept: Bad source " ++ source)
   `catch` fail ("cloneTreeExcept: Bad source " ++ source)

cloneSubTree :: FilePath -> FilePath -> IO ()
cloneSubTree source dest =
 do isdir <- doesDirectoryExist source
    isfile <- doesFileExist source
    if isdir then do
        createDirectory dest
        fps <- getDirectoryContents source
        let fps' = filter (`notElem` [".", ".."]) fps
            mk_source fp = source ++ "/" ++ fp
            mk_dest   fp = dest   ++ "/" ++ fp
        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')
     else if isfile then do
        cloneFile source dest
     else fail ("cloneSubTree: Bad source "++ source)
    `catch` (\e -> if isDoesNotExistError e
                   then return ()
                   else ioError e)

cloneFile :: FilePath -> FilePath -> IO ()
cloneFile = copyFile

rmRf :: FilePath -> IO ()
rmRf path = do
  isdir <- doesDirectoryExist path
  isf <- doesFileExist path
  when isdir $ removeDirectoryRecursive path
  when isf $ removeFile path
  return ()

-- (END FIXME)

\end{code}