{- Copyright (C) 2009 Ivan Lazar Miljenovic 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 ]