-- |
-- Module : cabalgraph: graph sets of modules from cabal packages
-- Copyright : (c) Don Stewart, 2009
-- License : BSD3
--
-- Maintainer: Don Stewart <dons@galois.com>
-- Stability : provisional
-- Portability:
--
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.PackageDescription.Configuration
import Distribution.Simple.Utils hiding (die, intercalate)
import Distribution.Verbosity
import Distribution.ModuleName hiding (main)
import Distribution.Version
import Distribution.Package
import Distribution.License
import Distribution.Text
import Distribution.Compiler
import Distribution.System
import Distribution.Simple.PackageIndex
import qualified Text.PrettyPrint as Disp
import Control.Monad
import Control.Concurrent
import Control.Exception
import qualified Control.OldException as C
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.Process hiding (cwd)
import Data.List
import Data.Maybe
import qualified Data.Map as M
import Data.Monoid
import Data.Char
import Debug.Trace
main :: IO ()
main =
bracket
-- We do all our work in a temp directory
(do cwd <- getCurrentDirectory
etmp <- myReadProcess "mktemp" ["-d"] []
case etmp of
Left _ -> die "Unable to create temp directory"
Right d -> do
let dir = makeValid (init d) -- drop newline
setCurrentDirectory dir
return (dir, cwd))
-- Always remember to clean up
(\(d,cwd) -> do
setCurrentDirectory cwd
removeDirectoryRecursive d)
-- Now, get to work:
$ \(tmp,cwd) -> do
res <- do x <- getArgs
case x of
["--help"] -> help
["-h"] -> help
(f:fs) -> return (f:fs)
modules' <- forM res $ \f -> do
cabalfile <- findCabalFile f cwd tmp
cabalsrc <- readPackageDescription normal cabalfile
let ms = case condLibrary cabalsrc of
Just x -> exposedModules (condTreeData x)
_ -> error "This is not a library package"
return ms
let modules = concat modules'
-- printing
putStrLn "strict graph graphname {"
mapM_ putStrLn (map ppr modules)
putStrLn "}"
ppr :: ModuleName -> String
ppr ms =
Disp.render $ Disp.hcat
$ intersperse (Disp.text " -- ")
[ Disp.doubleQuotes (Disp.text (intercalate "." x))
| x <- tail (inits (components ms)) ]
{-
D -- D.B -- D.B.C
strict graph graphname {
Data -- ByteString
Data -- ByteString -- Char8
Data -- ByteString -- Unsafe
Data -- ByteString -- Internal
Data -- ByteString -- Lazy
Data -- ByteString -- Lazy -- Char8
Data -- ByteString -- Lazy -- Internal
Data -- ByteString -- Fusion
}
-}
-- Return the path to a .cabal file.
-- If not arguments are specified, use ".",
-- if the argument looks like a url, download that
-- otherwise, assume its a directory
--
findCabalFile :: FilePath -> FilePath -> FilePath -> IO FilePath
findCabalFile file cwd tmp = do
let epath | null file
= Right cwd
| "http://" `isPrefixOf` file
= Left file
| ".cabal" `isSuffixOf` file
= Right (makeValid (joinPath [cwd,file]))
| otherwise -- a relative directory path
= Right (cwd </> file)
-- download url to .cabal
case epath of
Left url -> do
eres <- myReadProcess "wget" [url] []
case eres of
Left (_,s,_) -> do
hPutStrLn stderr s
die $ "Couldn't download .cabal file: " ++ show url
Right _ ->
findPackageDesc tmp -- tmp dir -- error: only allows one url on the command line
-- it might be a .cabal file
Right f | ".cabal" `isSuffixOf` f -> do
b <- doesFileExist f
if not b
then die $ ".cabal file doesn't exist: " ++ show f
else return f
-- or assume it is a dir to a file:
Right dir -> do
b <- doesDirectoryExist dir
if not b
then die $ "directory doesn't exist: " ++ show dir
else findPackageDesc dir
die :: String -> IO a
die s = do
hPutStrLn stderr $ "cabalgraph:\n" ++ s
exitWith (ExitFailure 1)
help :: IO a
help = do
hPutStrLn stderr $ unlines
[ "cabalgraph: [-h|--help] [directory|url]"
, ""
, " Generate graphs for .cabal files in <directory> or at <url>"
, ""
, "Usage:"
, " -h Display help message"
, ""
, "Arguments: <directory>"
, " Look for .cabal file in <directory>"
, " If directory is empty, use pwd"
, " <file.cabal>"
, " Use .cabal file as source"
, " <url>"
, " Download .cabal file from <url>"
]
exitWith ExitSuccess
------------------------------------------------------------------------
--
-- Strict process reading
--
myReadProcess :: FilePath -- ^ command to run
-> [String] -- ^ any arguments
-> String -- ^ standard input
-> IO (Either (ExitCode,String,String) String) -- ^ either the stdout, or an exitcode and any output
myReadProcess cmd args input = C.handle (return . handler) $ do
(inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing
output <- hGetContents outh
outMVar <- newEmptyMVar
forkIO $ (C.evaluate (length output) >> putMVar outMVar ())
errput <- hGetContents errh
errMVar <- newEmptyMVar
forkIO $ (C.evaluate (length errput) >> putMVar errMVar ())
when (not (null input)) $ hPutStr inh input
takeMVar outMVar
takeMVar errMVar
ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess)
hClose outh
hClose inh -- done with stdin
hClose errh -- ignore stderr
return $ case ex of
ExitSuccess -> Right output
ExitFailure _ -> Left (ex, errput, output)
where
handler (C.ExitException e) = Left (e,"","")
handler e = Left (ExitFailure 1, show e, "")