make --with-haddock actually work

** did this ever work before? ** cleaned up some comments ** made rawSystemVerbose more robust. Check for file existing, check for permissions. Before it was just failing silently.
haskell · Oct 9, 2005 · 8eeb72e · 8eeb72e
1 parent dd91190
commit 8eeb72e
Show file tree

Hide file tree

Showing 3 changed files with 66 additions and 24 deletions.
diff --git a/Distribution/Program.hs b/Distribution/Program.hs
@@ -9,6 +9,8 @@ module Distribution.Program( Program(..)
                            , userSpecifyPath
                            , userSpecifyArgs
                            , lookupProgram
+                           , rawSystemProgram
+                             -- Programs
                            , ghcProgram
                            , ghcPkgProgram
                            , nhcProgram
@@ -25,7 +27,10 @@ module Distribution.Program( Program(..)
                            ) where
 
 import Data.FiniteMap
+import Control.Monad(when)
+import System.Exit (ExitCode)
 import Distribution.Compat.Directory(findExecutable)
+import Distribution.Simple.Utils (die, rawSystemVerbose)
 
 -- |Represents a program which cabal may call.
 data Program
@@ -48,15 +53,23 @@ data ProgramLocation = EmptyLocation
 
 data ProgramConfiguration = ProgramConfiguration (FiniteMap String Program)
 
+-- Read & Show instances are based on listToFM
+
 instance Show ProgramConfiguration where
   show (ProgramConfiguration s) = show $ fmToList s
 
 instance Read ProgramConfiguration where
-  readsPrec p s = [(ProgramConfiguration $ listToFM $ s', r) | (s', r) <- readsPrec p s ]
+  readsPrec p s = [(ProgramConfiguration $ listToFM $ s', r)
+                       | (s', r) <- readsPrec p s ]
+
+-- |The default list of programs and their arguments.  These programs
+-- are typically used internally to Cabal.
 
 defaultProgramConfiguration :: ProgramConfiguration
 defaultProgramConfiguration = progListToFM 
-                              [ ghcProgram
+                              [ haddockProgram ]
+-- haddock is currently the only one that really works.
+{-                              [ ghcProgram
                               , ghcPkgProgram
                               , nhcProgram
                               , hugsProgram
@@ -69,7 +82,7 @@ defaultProgramConfiguration = progListToFM
                               , ldProgram
                               , cppProgram
                               , pfesetupProgram
-                              ]
+                              ]-}
 
 -- |The flag for giving a path to this program.  eg --with-alex=\/usr\/bin\/alex
 withProgramFlag :: Program -> String
@@ -132,13 +145,12 @@ pfesetupProgram = simpleProgram "pfesetup"
 -- * helpers
 -- ------------------------------------------------------------
 
--- |Looks up a program in the given configuration.  If the user
--- provides a location, then we use that location in the returned
--- program.  If no location is given then we check in the
--- configuration for a location.  If there's none in the
--- configuration, then we use IO to look on the system.  Do we want a
--- way to specify NOT to find it on the system (populate
--- programLocation).
+-- |Looks up a program in the given configuration.  If there's no
+-- location information in the configuration, then we use IO to look
+-- on the system in PATH for the program.  If the program is not in
+-- the configuration at all, we return Nothing.  FIX: should we build
+-- a simpleProgram in that case? Do we want a way to specify NOT to
+-- find it on the system (populate programLocation).
 
 lookupProgram :: String -- simple name of program
               -> ProgramConfiguration
@@ -155,8 +167,10 @@ lookupProgram name conf =
                          a   -> return a
               return $ Just p{programLocation=newLoc}
 
--- |User-specify this path.  If it's not a known program, add it.
-userSpecifyPath :: String -- ^Program name
+-- |User-specify this path.  Basically override any path information
+-- for this program in the configuration. If it's not a known
+-- program, add it.
+userSpecifyPath :: String   -- ^Program name
                 -> FilePath -- ^user-specified path to filename
                 -> ProgramConfiguration
                 -> ProgramConfiguration
@@ -166,7 +180,9 @@ userSpecifyPath name path conf'@(ProgramConfiguration conf)
        Nothing -> updateProgram (Just $ Program name name [] (UserSpecified path))
                                 conf'
 
--- |User-specify this path.  If it's not a known program, add it.
+-- |User-specify the arguments for this program.  Basically override
+-- any args information for this program in the configuration. If it's
+-- not a known program, add it.
 userSpecifyArgs :: String -- ^Program name
                 -> String -- ^user-specified args
                 -> ProgramConfiguration
@@ -176,11 +192,32 @@ userSpecifyArgs name args conf'@(ProgramConfiguration conf)
        Just p  -> updateProgram (Just p{programArgs=(words args)}) conf'
        Nothing -> updateProgram (Just $ Program name name (words args) EmptyLocation) conf'
 
+-- |Update this program's entry in the configuration.  No changes if
+-- you pass in Nothing.
 updateProgram :: Maybe Program -> ProgramConfiguration -> ProgramConfiguration
 updateProgram (Just p@Program{programName=n}) (ProgramConfiguration conf)
     = ProgramConfiguration $ addToFM conf n p
 updateProgram Nothing conf = conf
 
+-- |Runs the given program.
+rawSystemProgram :: Int      -- ^Verbosity
+                 -> Program  -- ^The program to run
+                 -> [String] -- ^Any /extra/ arguments to add
+                 -> IO ExitCode
+rawSystemProgram verbose (Program { programLocation=(UserSpecified p)
+                                  , programArgs=args
+                                  })
+
+                 extraArgs = rawSystemVerbose verbose p (extraArgs ++ args)
+rawSystemProgram verbose (Program { programLocation=(FoundOnSystem p)
+                                  , programArgs=args
+                                  })
+
+                 extraArgs = rawSystemVerbose verbose p (extraArgs ++ args)
+rawSystemProgram _ (Program { programLocation=EmptyLocation
+                            , programName=n})_ 
+    = die ("Error: Could not find location for program: " ++ n)
+
 -- ------------------------------------------------------------
 -- * Internal helpers
 -- ------------------------------------------------------------

diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs
@@ -67,7 +67,8 @@ module Distribution.Simple (
 import Distribution.Compiler
 import Distribution.Package --must not specify imports, since we're exporting moule.
 import Distribution.PackageDescription
-import Distribution.Program(lookupProgram, Program(..), haddockProgram)
+import Distribution.Program(lookupProgram, Program(..),
+                            haddockProgram, rawSystemProgram)
 import Distribution.PreProcess (knownSuffixHandlers, ppSuffixes, ppCpp',
                                 ppUnlit, removePreprocessedPackage,
                                 preprocessSources, PPSuffixHandler)
@@ -80,8 +81,9 @@ import Distribution.Simple.Register	( register, unregister,
                                           regScriptLocation, unregScriptLocation
                                         )
 
-import Distribution.Simple.Configure(LocalBuildInfo(..), getPersistBuildConfig, findProgram,
-				     configure, writePersistBuildConfig, localBuildInfoFile)
+import Distribution.Simple.Configure(LocalBuildInfo(..), getPersistBuildConfig,
+                                     findProgram, configure, writePersistBuildConfig,
+                                     localBuildInfoFile)
 import Distribution.Simple.Install(install)
 import Distribution.Simple.Utils (die, currentDir, rawSystemVerbose,
                                   defaultPackageDesc, defaultHookedPackageDesc,
@@ -434,7 +436,7 @@ haddock pkg_descr lbi verbose pps =
         setupMessage "Running Haddock for" pkg_descr
         let outFiles = map (joinFileName tmpDir)
                        (map ((flip changeFileExt) "hs") inFiles)
-        code <- rawSystemVerbose verbose (programBinName confHaddock)
+        code <- rawSystemProgram verbose confHaddock
                 (["-h",
                   "-o", targetDir,
                   "-t", showPkg,

diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs
@@ -95,7 +95,7 @@ import Distribution.Compat.FilePath
 	(splitFileName, splitFileExt, joinFileName, joinFileExt,
 	pathSeparator)
 import System.Directory (getDirectoryContents, getCurrentDirectory,
-                        doesFileExist, removeFile)
+                         doesFileExist, removeFile, getPermissions, executable)
 
 import Distribution.Compat.Directory (copyFile,findExecutable,createDirectoryIfMissing)
 
@@ -129,16 +129,19 @@ rawSystemPath verbose prog args = do
   r <- findExecutable prog
   case r of
     Nothing -> die ("Cannot find: " ++ prog)
-    Just path -> do
-      when (verbose > 0) $
-        putStrLn (path ++ concatMap (' ':) args)
-      rawSystem path args
+    Just path -> rawSystemVerbose verbose path args
 
-rawSystemVerbose :: Int -> String -> [String] -> IO ExitCode
+rawSystemVerbose :: Int -> FilePath -> [String] -> IO ExitCode
 rawSystemVerbose verbose prog args = do
       when (verbose > 0) $
         putStrLn (prog ++ concatMap (' ':) args)
-      rawSystem prog args
+      e <- doesFileExist prog
+      if e
+         then do perms <- getPermissions prog
+                 if (executable perms)
+                    then rawSystem prog args
+                    else die ("Error: file is not executable: " ++ show prog)
+         else die ("Error: file does not exist: " ++ show prog)
 
 maybeExit :: IO ExitCode -> IO ()
 maybeExit cmd = do