{-
Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{- |
Module : Main
Description : Analyse source code as a graph.
Copyright : (c) Ivan Lazar Miljenovic 2009
License : GPL-3 or later.
Maintainer : Ivan.Miljenovic@gmail.com
The executable file for the /SourceGraph/ programme.
This was written as part of my mathematics honours thesis,
/Graph-Theoretic Analysis of the Relationships in Discrete Data/.
-}
module Main where
import CabalInfo
import Parsing
import Parsing.Types(nameOfModule)
import Analyse
import Data.Graph.Analysis
import Data.Graph.Analysis.Reporting.Pandoc
import Data.Char(toLower)
import Data.Maybe(catMaybes)
import qualified Data.Map as M
import System.IO(hPutStrLn, stderr)
import System.Directory( getCurrentDirectory
, doesDirectoryExist
, doesFileExist
, getDirectoryContents)
import System.FilePath( dropFileName
, takeExtension
, isPathSeparator
, (</>)
, (<.>))
import System.Random(newStdGen)
import System.Environment(getArgs)
import Control.Arrow(second)
import Control.Monad(liftM)
import Control.Exception.Extensible(SomeException(..), try)
import Data.Version(showVersion)
import qualified Paths_SourceGraph as Paths(version)
-- -----------------------------------------------------------------------------
main :: IO ()
main = do input <- getArgs
mInfo <- getPkgInfo input
case mInfo of
Nothing -> putErrLn "No parseable package information found."
Just (f,(nm,exps))
-> do let dir = dropFileName f
dir' <- if null dir
then getCurrentDirectory
else return dir
(failed,hms) <- parseFilesFrom dir'
mapM_ (putErrLn . ("Could not parse source file "++)) failed
analyseCode dir nm exps failed hms
programmeName :: String
programmeName = "SourceGraph"
programmeVersion :: String
programmeVersion = showVersion Paths.version
putErrLn :: String -> IO ()
putErrLn = hPutStrLn stderr
-- -----------------------------------------------------------------------------
getPkgInfo :: [String] -> IO (Maybe (FilePath, (String, [ModName])))
getPkgInfo [] = do putErrLn "Please provide either a Cabal file \
\or a Haskell source file as an argument."
return Nothing
getPkgInfo [f]
| isCabalFile f = withF parseCabal'
| isHaskellFile f = withF parseMain
where
withF func = do ex <- doesFileExist f
if ex
then addF $ func f
else do putErrLn "The provided file does not exist."
return Nothing
addF = fmap (fmap ((,) f))
getPkgInfo _ = do putErrLn "Please provide a single Cabal \
\or Haskell source file as an argument."
return Nothing
parseCabal' :: FilePath -> IO (Maybe (String, [ModName]))
parseCabal' = liftM (fmap (second (map fpToModule))) . parseCabal
isCabalFile :: FilePath -> Bool
isCabalFile = hasExt "cabal"
parseMain :: FilePath -> IO (Maybe (String, [ModName]))
parseMain fp = do (_,pms) <- parseHaskellFiles [fp]
let mn = fst $ M.findMin pms
return $ Just (nameOfModule mn, [mn])
-- | Determine if this is the path of a Haskell file.
isHaskellFile :: FilePath -> Bool
isHaskellFile fp = any (`hasExt` fp) haskellExtensions
hasExt :: String -> FilePath -> Bool
hasExt ext = (==) ext . drop 1 . takeExtension
fpToModule :: FilePath -> ModName
fpToModule = createModule . map pSep
where
pSep c
| isPathSeparator c = moduleSep
| otherwise = c
-- -----------------------------------------------------------------------------
-- | Recursively parse all files from this directory
parseFilesFrom :: FilePath -> IO ([FilePath],ParsedModules)
parseFilesFrom fp = parseHaskellFiles =<< getHaskellFilesFrom fp
parseHaskellFiles :: [FilePath] -> IO ([FilePath],ParsedModules)
parseHaskellFiles = liftM parseHaskell . readFiles
-- -----------------------------------------------------------------------------
-- Reading in the files.
-- | Recursively find all Haskell source files from the current directory.
getHaskellFilesFrom :: FilePath -> IO [FilePath]
getHaskellFilesFrom fp
= do isDir <- doesDirectoryExist fp -- Ensure it's a directory.
if isDir
then do r <- try getFilesIn -- Ensure we can read the directory.
case r of
(Right fs) -> return fs
(Left SomeException{}) -> return []
else return []
where
-- Filter out "." and ".." to stop infinite recursion.
nonTrivialContents :: IO [FilePath]
nonTrivialContents = do contents <- getDirectoryContents fp
let contents' = filter (not . isTrivial) contents
return $ map (fp </>) contents'
getFilesIn :: IO [FilePath]
getFilesIn = do contents <- nonTrivialContents
(dirs,files) <- partitionM doesDirectoryExist contents
let hFiles = filter isHaskellFile files
recursiveFiles <- concatMapM getHaskellFilesFrom dirs
return (hFiles ++ recursiveFiles)
haskellExtensions :: [FilePath]
haskellExtensions = ["hs","lhs"]
-- | Read in all the files that it can.
readFiles :: [FilePath] -> IO [FileContents]
readFiles = liftM catMaybes . mapM readFileContents
-- | Try to read the given file.
readFileContents :: FilePath -> IO (Maybe FileContents)
readFileContents f = do cnts <- try $ readFile f
case cnts of
(Right str) -> return $ Just (f,str)
(Left SomeException{}) -> return Nothing
-- | A version of 'concatMap' for use in monads.
concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM f = liftM concat . mapM f
-- | A version of 'partition' for use in monads.
partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM _ [] = return ([],[])
partitionM p (x:xs) = do ~(ts,fs) <- partitionM p xs
matches <- p x
if matches
then return (x:ts,fs)
else return (ts,x:fs)
-- | Trivial paths are the current directory, the parent directory and
-- such directories
isTrivial :: FilePath -> Bool
isTrivial "." = True
isTrivial ".." = True
isTrivial "_darcs" = True
isTrivial "dist" = True
isTrivial "HLInt.hs" = True
isTrivial f | isSetup f = True
isTrivial _ = False
lowerCase :: String -> String
lowerCase = map toLower
isSetup :: String -> Bool
isSetup f = lowerCase f `elem` map ("setup" <.>) haskellExtensions
-- -----------------------------------------------------------------------------
analyseCode :: FilePath -> String -> [ModName]
-> [FilePath] -> ParsedModules -> IO ()
analyseCode fp nm exps fld hms = do d <- today
g <- newStdGen
let dc = doc d g
docOut <- createDocument pandocHtml' dc
case docOut of
Just path -> success path
Nothing -> failure
where
pandocHtml' = alsoSaveDot pandocHtml
graphdir = "graphs"
doc d g = Doc { rootDirectory = rt
, fileFront = nm
, graphDirectory = graphdir
, title = t
, author = a
, date = d
, legend = sgLegend
, content = notes : c g
}
rt = fp </> programmeName
sv s v = s ++ " (version " ++ v ++ ")"
t = Grouping [Text "Analysis of", Text nm]
a = unwords [ "Analysed by", sv programmeName programmeVersion
, "using", sv "Graphalyze" version]
c g = analyse g exps hms
success fp' = putStrLn $ unwords ["Report generated at:",fp']
failure = putErrLn "Unable to generate report"
notes = Section (Text "Notes")
$ (if null fld then id else (++[failed]))
[msg, implicitMsg, linkMsg]
msg = Paragraph [ Text "Please note that the source-code analysis in this\
\ document is not necessarily perfect: "
, Emphasis $ Text programmeName
, Text " is "
, Bold $ Text "not"
, Text " a refactoring tool, and it's usage of Classes is\
\ still premature."
]
implicitMsg = Paragraph [ Text "Implicitly exported entities refer to\
\ class methods that are instantiated\
\ but defined elsewhere, or"
, BlankSpace
, DocLink (Text "entities whose names start with\
\ an underscore")
(Web "http://www.haskell.org/ghc/docs/latest/html/users_guide/options-sanity.html")
, BlankSpace
, Text ". Note that even for "
, Emphasis $ Text "Main"
, BlankSpace
, Text "modules, these implicit exports are included."
]
linkMsg = Paragraph [Text "All graph visualisations link to larger \
\SVG versions of the same graph."]
failed = Section (Text "Parsing Failures")
[ Paragraph [Text "The following source files were unable\
\ to be parsed; this may result in some\
\ analysis failures:"]
, Itemized $ map (Paragraph . return . Text) fld
]