1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE LambdaCase #-}
4-----------------------------------------------------------------------------
5-- |
6-- Module      :  Distribution.Simple
7-- Copyright   :  Isaac Jones 2003-2005
8-- License     :  BSD3
9--
10-- Maintainer  :  cabal-devel@haskell.org
11-- Portability :  portable
12--
13-- This is the command line front end to the Simple build system. When given
14-- the parsed command-line args and package information, is able to perform
15-- basic commands like configure, build, install, register, etc.
16--
17-- This module exports the main functions that Setup.hs scripts use. It
18-- re-exports the 'UserHooks' type, the standard entry points like
19-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of
20-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own
21-- behaviour.
22--
23-- This module isn't called \"Simple\" because it's simple.  Far from
24-- it.  It's called \"Simple\" because it does complicated things to
25-- simple software.
26--
27-- The original idea was that there could be different build systems that all
28-- presented the same compatible command line interfaces. There is still a
29-- "Distribution.Make" system but in practice no packages use it.
30
31{-
32Work around this warning:
33libraries/Cabal/Distribution/Simple.hs:78:0:
34    Warning: In the use of `runTests'
35             (imported from Distribution.Simple.UserHooks):
36             Deprecated: "Please use the new testing interface instead!"
37-}
38{-# OPTIONS_GHC -fno-warn-deprecations #-}
39
40module Distribution.Simple (
41        module Distribution.Package,
42        module Distribution.Version,
43        module Distribution.License,
44        module Distribution.Simple.Compiler,
45        module Language.Haskell.Extension,
46        -- * Simple interface
47        defaultMain, defaultMainNoRead, defaultMainArgs,
48        -- * Customization
49        UserHooks(..), Args,
50        defaultMainWithHooks, defaultMainWithHooksArgs,
51        defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs,
52        -- ** Standard sets of hooks
53        simpleUserHooks,
54        autoconfUserHooks,
55        emptyUserHooks,
56  ) where
57
58import Control.Exception (try)
59
60import Prelude ()
61import Distribution.Compat.Prelude
62
63-- local
64import Distribution.Simple.Compiler
65import Distribution.Simple.UserHooks
66import Distribution.Package
67import Distribution.PackageDescription
68import Distribution.PackageDescription.Configuration
69import Distribution.Simple.Program
70import Distribution.Simple.Program.Db
71import Distribution.Simple.PreProcess
72import Distribution.Simple.Setup
73import Distribution.Simple.Command
74
75import Distribution.Simple.Build
76import Distribution.Simple.SrcDist
77import Distribution.Simple.Register
78
79import Distribution.Simple.Configure
80
81import Distribution.Simple.LocalBuildInfo
82import Distribution.Simple.Bench
83import Distribution.Simple.BuildPaths
84import Distribution.Simple.Test
85import Distribution.Simple.Install
86import Distribution.Simple.Haddock
87import Distribution.Simple.Utils
88import Distribution.Utils.NubList
89import Distribution.Verbosity
90import Language.Haskell.Extension
91import Distribution.Version
92import Distribution.License
93import Distribution.Pretty
94import Distribution.System (buildPlatform)
95
96-- Base
97import System.Environment (getArgs, getProgName)
98import System.Directory   (removeFile, doesFileExist
99                          ,doesDirectoryExist, removeDirectoryRecursive)
100import System.FilePath                      (searchPathSeparator, takeDirectory, (</>), splitDirectories, dropDrive)
101import Distribution.Compat.ResponseFile (expandResponse)
102import Distribution.Compat.Directory        (makeAbsolute)
103import Distribution.Compat.Environment      (getEnvironment)
104import Distribution.Compat.GetShortPathName (getShortPathName)
105
106import Data.List       (unionBy, (\\))
107
108import Distribution.PackageDescription.Parsec
109
110-- | A simple implementation of @main@ for a Cabal setup script.
111-- It reads the package description file using IO, and performs the
112-- action specified on the command line.
113defaultMain :: IO ()
114defaultMain = getArgs >>= defaultMainHelper simpleUserHooks
115
116-- | A version of 'defaultMain' that is passed the command line
117-- arguments, rather than getting them from the environment.
118defaultMainArgs :: [String] -> IO ()
119defaultMainArgs = defaultMainHelper simpleUserHooks
120
121-- | A customizable version of 'defaultMain'.
122defaultMainWithHooks :: UserHooks -> IO ()
123defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks
124
125-- | A customizable version of 'defaultMain' that also takes the command
126-- line arguments.
127defaultMainWithHooksArgs :: UserHooks -> [String] -> IO ()
128defaultMainWithHooksArgs = defaultMainHelper
129
130-- | Like 'defaultMain', but accepts the package description as input
131-- rather than using IO to read it.
132defaultMainNoRead :: GenericPackageDescription -> IO ()
133defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks
134
135-- | A customizable version of 'defaultMainNoRead'.
136defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO ()
137defaultMainWithHooksNoRead hooks pkg_descr =
138  getArgs >>=
139  defaultMainHelper hooks { readDesc = return (Just pkg_descr) }
140
141-- | A customizable version of 'defaultMainNoRead' that also takes the
142-- command line arguments.
143--
144-- @since 2.2.0.0
145defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO ()
146defaultMainWithHooksNoReadArgs hooks pkg_descr =
147  defaultMainHelper hooks { readDesc = return (Just pkg_descr) }
148
149defaultMainHelper :: UserHooks -> Args -> IO ()
150defaultMainHelper hooks args = topHandler $ do
151  args' <- expandResponse args
152  case commandsRun (globalCommand commands) commands args' of
153    CommandHelp   help                 -> printHelp help
154    CommandList   opts                 -> printOptionsList opts
155    CommandErrors errs                 -> printErrors errs
156    CommandReadyToGo (flags, commandParse)  ->
157      case commandParse of
158        _ | fromFlag (globalVersion flags)        -> printVersion
159          | fromFlag (globalNumericVersion flags) -> printNumericVersion
160        CommandHelp     help           -> printHelp help
161        CommandList     opts           -> printOptionsList opts
162        CommandErrors   errs           -> printErrors errs
163        CommandReadyToGo action        -> action
164
165  where
166    printHelp help = getProgName >>= putStr . help
167    printOptionsList = putStr . unlines
168    printErrors errs = do
169      putStr (intercalate "\n" errs)
170      exitWith (ExitFailure 1)
171    printNumericVersion = putStrLn $ prettyShow cabalVersion
172    printVersion        = putStrLn $ "Cabal library version "
173                                  ++ prettyShow cabalVersion
174
175    progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb
176    commands =
177      [configureCommand progs `commandAddAction`
178        \fs as -> configureAction hooks fs as >> return ()
179      ,buildCommand     progs `commandAddAction` buildAction        hooks
180      ,showBuildInfoCommand progs `commandAddAction` showBuildInfoAction    hooks
181      ,replCommand      progs `commandAddAction` replAction         hooks
182      ,installCommand         `commandAddAction` installAction      hooks
183      ,copyCommand            `commandAddAction` copyAction         hooks
184      ,haddockCommand         `commandAddAction` haddockAction      hooks
185      ,cleanCommand           `commandAddAction` cleanAction        hooks
186      ,sdistCommand           `commandAddAction` sdistAction        hooks
187      ,hscolourCommand        `commandAddAction` hscolourAction     hooks
188      ,registerCommand        `commandAddAction` registerAction     hooks
189      ,unregisterCommand      `commandAddAction` unregisterAction   hooks
190      ,testCommand            `commandAddAction` testAction         hooks
191      ,benchmarkCommand       `commandAddAction` benchAction        hooks
192      ]
193
194-- | Combine the preprocessors in the given hooks with the
195-- preprocessors built into cabal.
196allSuffixHandlers :: UserHooks
197                  -> [PPSuffixHandler]
198allSuffixHandlers hooks
199    = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers
200    where
201      overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]
202      overridesPP = unionBy (\x y -> fst x == fst y)
203
204configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo
205configureAction hooks flags args = do
206    distPref <- findDistPrefOrDefault (configDistPref flags)
207    let flags' = flags { configDistPref = toFlag distPref
208                       , configArgs = args }
209
210    -- See docs for 'HookedBuildInfo'
211    pbi <- preConf hooks args flags'
212
213    (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity
214                                    (flagToMaybe (configCabalFilePath flags))
215
216    let epkg_descr = (pkg_descr0, pbi)
217
218    localbuildinfo0 <- confHook hooks epkg_descr flags'
219
220    -- remember the .cabal filename if we know it
221    -- and all the extra command line args
222    let localbuildinfo = localbuildinfo0 {
223                           pkgDescrFile = mb_pd_file,
224                           extraConfigArgs = args
225                         }
226    writePersistBuildConfig distPref localbuildinfo
227
228    let pkg_descr = localPkgDescr localbuildinfo
229    postConf hooks args flags' pkg_descr localbuildinfo
230    return localbuildinfo
231  where
232    verbosity = fromFlag (configVerbosity flags)
233
234confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath
235             -> IO (Maybe FilePath, GenericPackageDescription)
236confPkgDescr hooks verbosity mb_path = do
237  mdescr <- readDesc hooks
238  case mdescr of
239    Just descr -> return (Nothing, descr)
240    Nothing -> do
241        pdfile <- case mb_path of
242                    Nothing -> defaultPackageDesc verbosity
243                    Just path -> return path
244        info verbosity "Using Parsec parser"
245        descr  <- readGenericPackageDescription verbosity pdfile
246        return (Just pdfile, descr)
247
248buildAction :: UserHooks -> BuildFlags -> Args -> IO ()
249buildAction hooks flags args = do
250  distPref <- findDistPrefOrDefault (buildDistPref flags)
251  let verbosity = fromFlag $ buildVerbosity flags
252  lbi <- getBuildConfig hooks verbosity distPref
253  let flags' = flags { buildDistPref = toFlag distPref
254                     , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)}
255
256  progs <- reconfigurePrograms verbosity
257             (buildProgramPaths flags')
258             (buildProgramArgs flags')
259             (withPrograms lbi)
260
261  hookedAction verbosity preBuild buildHook postBuild
262               (return lbi { withPrograms = progs })
263               hooks flags' { buildArgs = args } args
264
265showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO ()
266showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do
267  distPref <- findDistPrefOrDefault (buildDistPref flags)
268  let verbosity = fromFlag $ buildVerbosity flags
269  lbi <- getBuildConfig hooks verbosity distPref
270  let flags' = flags { buildDistPref = toFlag distPref
271                     , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
272                     }
273
274  progs <- reconfigurePrograms verbosity
275             (buildProgramPaths flags')
276             (buildProgramArgs flags')
277             (withPrograms lbi)
278
279  pbi <- preBuild hooks args flags'
280  let lbi' = lbi { withPrograms = progs }
281      pkg_descr0 = localPkgDescr lbi'
282      pkg_descr = updatePackageDescription pbi pkg_descr0
283      -- TODO: Somehow don't ignore build hook?
284  buildInfoString <- showBuildInfo pkg_descr lbi' flags
285
286  case fileOutput of
287    Nothing -> putStr buildInfoString
288    Just fp -> writeFile fp buildInfoString
289
290  postBuild hooks args flags' pkg_descr lbi'
291
292replAction :: UserHooks -> ReplFlags -> Args -> IO ()
293replAction hooks flags args = do
294  distPref <- findDistPrefOrDefault (replDistPref flags)
295  let verbosity = fromFlag $ replVerbosity flags
296      flags' = flags { replDistPref = toFlag distPref }
297
298  lbi <- getBuildConfig hooks verbosity distPref
299  progs <- reconfigurePrograms verbosity
300             (replProgramPaths flags')
301             (replProgramArgs flags')
302             (withPrograms lbi)
303
304  -- As far as I can tell, the only reason this doesn't use
305  -- 'hookedActionWithArgs' is because the arguments of 'replHook'
306  -- takes the args explicitly.  UGH.   -- ezyang
307  pbi <- preRepl hooks args flags'
308  let pkg_descr0 = localPkgDescr lbi
309  sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
310  let pkg_descr = updatePackageDescription pbi pkg_descr0
311      lbi' = lbi { withPrograms = progs
312                 , localPkgDescr = pkg_descr }
313  replHook hooks pkg_descr lbi' hooks flags' args
314  postRepl hooks args flags' pkg_descr lbi'
315
316hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()
317hscolourAction hooks flags args = do
318    distPref <- findDistPrefOrDefault (hscolourDistPref flags)
319    let verbosity = fromFlag $ hscolourVerbosity flags
320    lbi <- getBuildConfig hooks verbosity distPref
321    let flags' = flags { hscolourDistPref = toFlag distPref
322                       , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)}
323
324    hookedAction verbosity preHscolour hscolourHook postHscolour
325                 (getBuildConfig hooks verbosity distPref)
326                 hooks flags' args
327
328haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()
329haddockAction hooks flags args = do
330  distPref <- findDistPrefOrDefault (haddockDistPref flags)
331  let verbosity = fromFlag $ haddockVerbosity flags
332  lbi <- getBuildConfig hooks verbosity distPref
333  let flags' = flags { haddockDistPref = toFlag distPref
334                     , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)}
335
336  progs <- reconfigurePrograms verbosity
337             (haddockProgramPaths flags')
338             (haddockProgramArgs flags')
339             (withPrograms lbi)
340
341  hookedAction verbosity preHaddock haddockHook postHaddock
342               (return lbi { withPrograms = progs })
343               hooks flags' { haddockArgs = args } args
344
345cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()
346cleanAction hooks flags args = do
347    distPref <- findDistPrefOrDefault (cleanDistPref flags)
348
349    elbi <- tryGetBuildConfig hooks verbosity distPref
350    let flags' = flags { cleanDistPref = toFlag distPref
351                       , cleanCabalFilePath = case elbi of
352                           Left _ -> mempty
353                           Right lbi -> maybeToFlag (cabalFilePath lbi)}
354
355    pbi <- preClean hooks args flags'
356
357    (_, ppd) <- confPkgDescr hooks verbosity Nothing
358    -- It might seem like we are doing something clever here
359    -- but we're really not: if you look at the implementation
360    -- of 'clean' in the end all the package description is
361    -- used for is to clear out @extra-tmp-files@.  IMO,
362    -- the configure script goo should go into @dist@ too!
363    --          -- ezyang
364    let pkg_descr0 = flattenPackageDescription ppd
365    -- We don't sanity check for clean as an error
366    -- here would prevent cleaning:
367    --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
368    let pkg_descr = updatePackageDescription pbi pkg_descr0
369
370    cleanHook hooks pkg_descr () hooks flags'
371    postClean hooks args flags' pkg_descr ()
372  where
373    verbosity = fromFlag (cleanVerbosity flags)
374
375copyAction :: UserHooks -> CopyFlags -> Args -> IO ()
376copyAction hooks flags args = do
377    distPref <- findDistPrefOrDefault (copyDistPref flags)
378    let verbosity = fromFlag $ copyVerbosity flags
379    lbi <- getBuildConfig hooks verbosity distPref
380    let flags' = flags { copyDistPref = toFlag distPref
381                       , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)}
382    hookedAction verbosity preCopy copyHook postCopy
383                 (getBuildConfig hooks verbosity distPref)
384                 hooks flags' { copyArgs = args } args
385
386installAction :: UserHooks -> InstallFlags -> Args -> IO ()
387installAction hooks flags args = do
388    distPref <- findDistPrefOrDefault (installDistPref flags)
389    let verbosity = fromFlag $ installVerbosity flags
390    lbi <- getBuildConfig hooks verbosity distPref
391    let flags' = flags { installDistPref = toFlag distPref
392                       , installCabalFilePath = maybeToFlag (cabalFilePath lbi)}
393    hookedAction verbosity preInst instHook postInst
394                 (getBuildConfig hooks verbosity distPref)
395                 hooks flags' args
396
397-- Since Cabal-3.4 UserHooks are completely ignored
398sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()
399sdistAction _hooks flags _args = do
400    (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing
401    let pkg_descr = flattenPackageDescription ppd
402    sdist pkg_descr flags srcPref knownSuffixHandlers
403  where
404    verbosity = fromFlag (sDistVerbosity flags)
405
406testAction :: UserHooks -> TestFlags -> Args -> IO ()
407testAction hooks flags args = do
408    distPref <- findDistPrefOrDefault (testDistPref flags)
409    let verbosity = fromFlag $ testVerbosity flags
410        flags' = flags { testDistPref = toFlag distPref }
411
412    hookedActionWithArgs verbosity preTest testHook postTest
413            (getBuildConfig hooks verbosity distPref)
414            hooks flags' args
415
416benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()
417benchAction hooks flags args = do
418    distPref <- findDistPrefOrDefault (benchmarkDistPref flags)
419    let verbosity = fromFlag $ benchmarkVerbosity flags
420        flags' = flags { benchmarkDistPref = toFlag distPref }
421    hookedActionWithArgs verbosity preBench benchHook postBench
422            (getBuildConfig hooks verbosity distPref)
423            hooks flags' args
424
425registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()
426registerAction hooks flags args = do
427    distPref <- findDistPrefOrDefault (regDistPref flags)
428    let verbosity = fromFlag $ regVerbosity flags
429    lbi <- getBuildConfig hooks verbosity distPref
430    let flags' = flags { regDistPref = toFlag distPref
431                       , regCabalFilePath = maybeToFlag (cabalFilePath lbi)}
432    hookedAction verbosity preReg regHook postReg
433                 (getBuildConfig hooks verbosity distPref)
434                 hooks flags' { regArgs = args } args
435
436unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()
437unregisterAction hooks flags args = do
438    distPref <- findDistPrefOrDefault (regDistPref flags)
439    let verbosity = fromFlag $ regVerbosity flags
440    lbi <- getBuildConfig hooks verbosity distPref
441    let flags' = flags { regDistPref = toFlag distPref
442                       , regCabalFilePath = maybeToFlag (cabalFilePath lbi)}
443    hookedAction verbosity preUnreg unregHook postUnreg
444                 (getBuildConfig hooks verbosity distPref)
445                 hooks flags' args
446
447hookedAction
448  :: Verbosity
449  -> (UserHooks -> Args -> flags -> IO HookedBuildInfo)
450  -> (UserHooks -> PackageDescription -> LocalBuildInfo
451                -> UserHooks -> flags -> IO ())
452  -> (UserHooks -> Args -> flags -> PackageDescription
453                -> LocalBuildInfo -> IO ())
454  -> IO LocalBuildInfo
455  -> UserHooks -> flags -> Args -> IO ()
456hookedAction verbosity pre_hook cmd_hook =
457    hookedActionWithArgs verbosity pre_hook
458    (\h _ pd lbi uh flags ->
459        cmd_hook h pd lbi uh flags)
460
461hookedActionWithArgs
462  :: Verbosity
463  -> (UserHooks -> Args -> flags -> IO HookedBuildInfo)
464  -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo
465                -> UserHooks -> flags -> IO ())
466  -> (UserHooks -> Args -> flags -> PackageDescription
467                -> LocalBuildInfo -> IO ())
468  -> IO LocalBuildInfo
469  -> UserHooks -> flags -> Args -> IO ()
470hookedActionWithArgs verbosity pre_hook cmd_hook post_hook
471  get_build_config hooks flags args = do
472   pbi <- pre_hook hooks args flags
473   lbi0 <- get_build_config
474   let pkg_descr0 = localPkgDescr lbi0
475   sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
476   let pkg_descr = updatePackageDescription pbi pkg_descr0
477       lbi = lbi0 { localPkgDescr = pkg_descr }
478   cmd_hook hooks args pkg_descr lbi hooks flags
479   post_hook hooks args flags pkg_descr lbi
480
481sanityCheckHookedBuildInfo
482  :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO ()
483sanityCheckHookedBuildInfo verbosity
484  (PackageDescription { library = Nothing }) (Just _,_)
485    = die' verbosity $ "The buildinfo contains info for a library, "
486      ++ "but the package does not have a library."
487
488sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes)
489    | exe1 : _ <- nonExistant
490    = die' verbosity $ "The buildinfo contains info for an executable called '"
491      ++ prettyShow exe1 ++ "' but the package does not have a "
492      ++ "executable with that name."
493  where
494    pkgExeNames  = nub (map exeName (executables pkg_descr))
495    hookExeNames = nub (map fst hookExes)
496    nonExistant  = hookExeNames \\ pkgExeNames
497
498sanityCheckHookedBuildInfo _ _ _ = return ()
499
500-- | Try to read the 'localBuildInfoFile'
501tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath
502                  -> IO (Either ConfigStateFileError LocalBuildInfo)
503tryGetBuildConfig u v = try . getBuildConfig u v
504
505
506-- | Read the 'localBuildInfoFile' or throw an exception.
507getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo
508getBuildConfig hooks verbosity distPref = do
509  lbi_wo_programs <- getPersistBuildConfig distPref
510  -- Restore info about unconfigured programs, since it is not serialized
511  let lbi = lbi_wo_programs {
512    withPrograms = restoreProgramDb
513                     (builtinPrograms ++ hookedPrograms hooks)
514                     (withPrograms lbi_wo_programs)
515  }
516
517  case pkgDescrFile lbi of
518    Nothing -> return lbi
519    Just pkg_descr_file -> do
520      outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file
521      if outdated
522        then reconfigure pkg_descr_file lbi
523        else return lbi
524
525  where
526    reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
527    reconfigure pkg_descr_file lbi = do
528      notice verbosity $ pkg_descr_file ++ " has been changed. "
529                      ++ "Re-configuring with most recently used options. "
530                      ++ "If this fails, please run configure manually.\n"
531      let cFlags = configFlags lbi
532      let cFlags' = cFlags {
533            -- Since the list of unconfigured programs is not serialized,
534            -- restore it to the same value as normally used at the beginning
535            -- of a configure run:
536            configPrograms_ = fmap (restoreProgramDb
537                                      (builtinPrograms ++ hookedPrograms hooks))
538                               `fmap` configPrograms_ cFlags,
539
540            -- Use the current, not saved verbosity level:
541            configVerbosity = Flag verbosity
542          }
543      configureAction hooks cFlags' (extraConfigArgs lbi)
544
545
546-- --------------------------------------------------------------------------
547-- Cleaning
548
549clean :: PackageDescription -> CleanFlags -> IO ()
550clean pkg_descr flags = do
551    let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags
552    notice verbosity "cleaning..."
553
554    maybeConfig <- if fromFlag (cleanSaveConf flags)
555                     then maybeGetPersistBuildConfig distPref
556                     else return Nothing
557
558    -- remove the whole dist/ directory rather than tracking exactly what files
559    -- we created in there.
560    chattyTry "removing dist/" $ do
561      exists <- doesDirectoryExist distPref
562      when exists (removeDirectoryRecursive distPref)
563
564    -- Any extra files the user wants to remove
565    traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr)
566
567    -- If the user wanted to save the config, write it back
568    traverse_ (writePersistBuildConfig distPref) maybeConfig
569
570  where
571        removeFileOrDirectory :: FilePath -> IO ()
572        removeFileOrDirectory fname = do
573            isDir <- doesDirectoryExist fname
574            isFile <- doesFileExist fname
575            if isDir then removeDirectoryRecursive fname
576              else when isFile $ removeFile fname
577        verbosity = fromFlag (cleanVerbosity flags)
578
579-- --------------------------------------------------------------------------
580-- Default hooks
581
582-- | Hooks that correspond to a plain instantiation of the
583-- \"simple\" build system
584simpleUserHooks :: UserHooks
585simpleUserHooks =
586    emptyUserHooks {
587       confHook  = configure,
588       postConf  = finalChecks,
589       buildHook = defaultBuildHook,
590       replHook  = defaultReplHook,
591       copyHook  = \desc lbi _ f -> install desc lbi f,
592                   -- 'install' has correct 'copy' behavior with params
593       testHook  = defaultTestHook,
594       benchHook = defaultBenchHook,
595       instHook  = defaultInstallHook,
596       cleanHook = \p _ _ f -> clean p f,
597       hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f,
598       haddockHook  = \p l h f -> haddock  p l (allSuffixHandlers h) f,
599       regHook   = defaultRegHook,
600       unregHook = \p l _ f -> unregister p l f
601      }
602  where
603    finalChecks _args flags pkg_descr lbi =
604      checkForeignDeps pkg_descr lbi (lessVerbose verbosity)
605      where
606        verbosity = fromFlag (configVerbosity flags)
607
608-- | Basic autoconf 'UserHooks':
609--
610-- * 'postConf' runs @.\/configure@, if present.
611--
612-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst',
613--   'preReg' and 'preUnreg' read additional build information from
614--   /package/@.buildinfo@, if present.
615--
616-- Thus @configure@ can use local system information to generate
617-- /package/@.buildinfo@ and possibly other files.
618
619autoconfUserHooks :: UserHooks
620autoconfUserHooks
621    = simpleUserHooks
622      {
623       postConf    = defaultPostConf,
624       preBuild    = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath,
625       preCopy     = readHookWithArgs copyVerbosity copyDistPref,
626       preClean    = readHook cleanVerbosity cleanDistPref,
627       preInst     = readHook installVerbosity installDistPref,
628       preHscolour = readHook hscolourVerbosity hscolourDistPref,
629       preHaddock  = readHookWithArgs haddockVerbosity haddockDistPref,
630       preReg      = readHook regVerbosity regDistPref,
631       preUnreg    = readHook regVerbosity regDistPref
632      }
633    where defaultPostConf :: Args -> ConfigFlags -> PackageDescription
634                          -> LocalBuildInfo -> IO ()
635          defaultPostConf args flags pkg_descr lbi
636              = do let verbosity = fromFlag (configVerbosity flags)
637                       baseDir lbi' = fromMaybe ""
638                                      (takeDirectory <$> cabalFilePath lbi')
639                   confExists <- doesFileExist $ (baseDir lbi) </> "configure"
640                   if confExists
641                     then runConfigureScript verbosity
642                            backwardsCompatHack flags lbi
643                     else die' verbosity "configure script not found."
644
645                   pbi <- getHookedBuildInfo verbosity (buildDir lbi)
646                   sanityCheckHookedBuildInfo verbosity pkg_descr pbi
647                   let pkg_descr' = updatePackageDescription pbi pkg_descr
648                       lbi' = lbi { localPkgDescr = pkg_descr' }
649                   postConf simpleUserHooks args flags pkg_descr' lbi'
650
651          backwardsCompatHack = False
652
653          readHookWithArgs :: (a -> Flag Verbosity)
654                           -> (a -> Flag FilePath)
655                           -> Args -> a
656                           -> IO HookedBuildInfo
657          readHookWithArgs get_verbosity get_dist_pref _ flags = do
658              dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
659              getHookedBuildInfo verbosity (dist_dir </> "build")
660            where
661              verbosity = fromFlag (get_verbosity flags)
662
663          readHook :: (a -> Flag Verbosity)
664                   -> (a -> Flag FilePath)
665                   -> Args -> a -> IO HookedBuildInfo
666          readHook get_verbosity get_dist_pref a flags = do
667              noExtraFlags a
668              dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
669              getHookedBuildInfo verbosity (dist_dir </> "build")
670            where
671              verbosity = fromFlag (get_verbosity flags)
672
673runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo
674                   -> IO ()
675runConfigureScript verbosity backwardsCompatHack flags lbi = do
676  env <- getEnvironment
677  let programDb = withPrograms lbi
678  (ccProg, ccFlags) <- configureCCompiler verbosity programDb
679  ccProgShort <- getShortPathName ccProg
680  -- The C compiler's compilation and linker flags (e.g.
681  -- "C compiler flags" and "Gcc Linker flags" from GHC) have already
682  -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS
683  -- to ccFlags
684  -- We don't try and tell configure which ld to use, as we don't have
685  -- a way to pass its flags too
686  configureFile <- makeAbsolute $
687    fromMaybe "." (takeDirectory <$> cabalFilePath lbi) </> "configure"
688  -- autoconf is fussy about filenames, and has a set of forbidden
689  -- characters that can't appear in the build directory, etc:
690  -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions
691  --
692  -- This has caused hard-to-debug failures in the past (#5368), so we
693  -- detect some cases early and warn with a clear message. Windows's
694  -- use of backslashes is problematic here, so we'll switch to
695  -- slashes, but we do still want to fail on backslashes in POSIX
696  -- paths.
697  --
698  -- TODO: We don't check for colons, tildes or leading dashes. We
699  -- also should check the builddir's path, destdir, and all other
700  -- paths as well.
701  let configureFile' = intercalate "/" $ splitDirectories configureFile
702  for_ badAutoconfCharacters $ \(c, cname) ->
703    when (c `elem` dropDrive configureFile') $
704      warn verbosity $ concat
705        [ "The path to the './configure' script, '", configureFile'
706        , "', contains the character '", [c], "' (", cname, ")."
707        , " This may cause the script to fail with an obscure error, or for"
708        , " building the package to fail later."
709        ]
710
711  let extraPath = fromNubList $ configProgramPathExtra flags
712  let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags))
713                  $ lookup "CFLAGS" env
714      spSep = [searchPathSeparator]
715      pathEnv = maybe (intercalate spSep extraPath)
716                ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env
717      overEnv = ("CFLAGS", Just cflagsEnv) :
718                [("PATH", Just pathEnv) | not (null extraPath)]
719      hp = hostPlatform lbi
720      maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)]
721      args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag
722      shProg = simpleProgram "sh"
723      progDb = modifyProgramSearchPath
724               (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
725  shConfiguredProg <- lookupProgram shProg
726                      `fmap` configureProgram  verbosity shProg progDb
727  case shConfiguredProg of
728      Just sh -> runProgramInvocation verbosity $
729                 (programInvocation (sh {programOverrideEnv = overEnv}) args')
730                 { progInvokeCwd = Just (buildDir lbi) }
731      Nothing -> die' verbosity notFoundMsg
732  where
733    args = configureArgs backwardsCompatHack flags
734
735    notFoundMsg = "The package has a './configure' script. "
736               ++ "If you are on Windows, This requires a "
737               ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "
738               ++ "If you are not on Windows, ensure that an 'sh' command "
739               ++ "is discoverable in your path."
740
741badAutoconfCharacters :: [(Char, String)]
742badAutoconfCharacters =
743  [ (' ', "space")
744  , ('\t', "tab")
745  , ('\n', "newline")
746  , ('\0', "null")
747  , ('"', "double quote")
748  , ('#', "hash")
749  , ('$', "dollar sign")
750  , ('&', "ampersand")
751  , ('\'', "single quote")
752  , ('(', "left bracket")
753  , (')', "right bracket")
754  , ('*', "star")
755  , (';', "semicolon")
756  , ('<', "less-than sign")
757  , ('=', "equals sign")
758  , ('>', "greater-than sign")
759  , ('?', "question mark")
760  , ('[', "left square bracket")
761  , ('\\', "backslash")
762  , ('`', "backtick")
763  , ('|', "pipe")
764  ]
765
766getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
767getHookedBuildInfo verbosity build_dir = do
768  maybe_infoFile <- findHookedPackageDesc verbosity build_dir
769  case maybe_infoFile of
770    Nothing       -> return emptyHookedBuildInfo
771    Just infoFile -> do
772      info verbosity $ "Reading parameters from " ++ infoFile
773      readHookedBuildInfo verbosity infoFile
774
775defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo
776                -> UserHooks -> TestFlags -> IO ()
777defaultTestHook args pkg_descr localbuildinfo _ flags =
778    test args pkg_descr localbuildinfo flags
779
780defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo
781                 -> UserHooks -> BenchmarkFlags -> IO ()
782defaultBenchHook args pkg_descr localbuildinfo _ flags =
783    bench args pkg_descr localbuildinfo flags
784
785defaultInstallHook :: PackageDescription -> LocalBuildInfo
786                   -> UserHooks -> InstallFlags -> IO ()
787defaultInstallHook pkg_descr localbuildinfo _ flags = do
788  let copyFlags = defaultCopyFlags {
789                      copyDistPref   = installDistPref flags,
790                      copyDest       = installDest     flags,
791                      copyVerbosity  = installVerbosity flags
792                  }
793  install pkg_descr localbuildinfo copyFlags
794  let registerFlags = defaultRegisterFlags {
795                          regDistPref  = installDistPref flags,
796                          regInPlace   = installInPlace flags,
797                          regPackageDB = installPackageDB flags,
798                          regVerbosity = installVerbosity flags
799                      }
800  when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags
801
802defaultBuildHook :: PackageDescription -> LocalBuildInfo
803        -> UserHooks -> BuildFlags -> IO ()
804defaultBuildHook pkg_descr localbuildinfo hooks flags =
805  build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)
806
807defaultReplHook :: PackageDescription -> LocalBuildInfo
808        -> UserHooks -> ReplFlags -> [String] -> IO ()
809defaultReplHook pkg_descr localbuildinfo hooks flags args =
810  repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args
811
812defaultRegHook :: PackageDescription -> LocalBuildInfo
813        -> UserHooks -> RegisterFlags -> IO ()
814defaultRegHook pkg_descr localbuildinfo _ flags =
815    if hasLibs pkg_descr
816    then register pkg_descr localbuildinfo flags
817    else setupMessage (fromFlag (regVerbosity flags))
818           "Package contains no library to register:" (packageId pkg_descr)
819