diff --git a/Analyse.hs b/Analyse.hs --- a/Analyse.hs +++ b/Analyse.hs @@ -41,6 +41,7 @@ import Data.GraphViz.Attributes import System.Random(RandomGen) +import Control.Arrow(first) -- | Analyse an entire Haskell project. Takes in a random seed, -- the list of exported modules and the parsed Haskell code in @@ -52,15 +53,16 @@ , analyseModules hms ] -sgLegend :: [(DocGraph, DocInline)] -sgLegend = [ esCall - , mods - , esLoc - , esData - , esClass - , esExp - , callCats - ] +sgLegend :: [(Either DocGraph DocInline, DocInline)] +sgLegend = map (first Left) [ esCall + , mods + , esLoc + , esData + , esClass + , esExp + , callCats + ] + ++ [first Right edgeExplain] esCall, mods, esLoc, esData, esClass, esExp, callCats :: (DocGraph, DocInline) @@ -206,3 +208,12 @@ } mkN (n,as) = DotNode n as mkE (f,t,as) = DotEdge f t True as + +edgeExplain :: (DocInline, DocInline) +edgeExplain = (Grouping cntnt, R.Bold $ Text "Edge Widths") + where + cntnt = [ Text "The width of each edge is calculated by:" + , BlankSpace + , Emphasis $ Text + "width = log (number of function calls) + 1" + ] diff --git a/Analyse/Visualise.hs b/Analyse/Visualise.hs --- a/Analyse/Visualise.hs +++ b/Analyse/Visualise.hs @@ -51,7 +51,7 @@ where params = Params True gAttrs toClust ctypeID clustAttributes' nAttr eAttr dg' = origHData dg - gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]] -- Possible clustering problem toClust = clusterEntity -- bool clusterEntity clusterEntityM' $ isJust mm nAttr = entityAttributes dg' (isNothing mm) mm @@ -64,7 +64,7 @@ where params = Params True gAttrs N (const Nothing) modClustAttrs nAttr eAttr dg' = collapsedHData dg - gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]] nAttr = entityAttributes dg' False Nothing eAttr = callAttributes' dg' @@ -75,7 +75,7 @@ entityAttributes :: GData n e -> Bool -> Maybe ModName -> LNode Entity -> Attributes entityAttributes hd a mm (n,Ent m nm t) - = [ Label $ StrLabel lbl + = [ toLabel lbl , Shape $ shapeFor t -- , Color [ColorName cl] , FillColor $ entCol hd n @@ -121,7 +121,7 @@ callAttributes' :: GData n e -> LEdge (Int, CallType) -> Attributes -callAttributes' hd (f,t,(n,ct)) = PenWidth (fromIntegral n) +callAttributes' hd (f,t,(n,ct)) = PenWidth (log (fromIntegral n) + 1) : callAttributes hd (f,t) ct clustAttributes :: EntClustType -> Attributes @@ -141,7 +141,7 @@ , Style [SItem Filled [], SItem Rounded []] , FillColor $ X11Color SlateGray1 ] -clustAttributes (ModPath p) = [ Label $ StrLabel p ] +clustAttributes (ModPath p) = [ toLabel p ] clustAttributes' :: EntClustType -> [GlobalAttributes] clustAttributes' = return . GraphAttrs . clustAttributes @@ -168,7 +168,7 @@ , fmtEdge = eAttr } dg' = mapData' cf $ collapsedHData dg - gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]] cAttr = [GraphAttrs [ Style [SItem Filled []] , FillColor clusterBackground ] @@ -190,7 +190,7 @@ dg = compactData hd' wrs = wantedRootNodes dg ++ S.toList (implicitExports vs dg) dg' = updateGraph (levelGraphFrom wrs) dg - gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]] nAttr = entityAttributes hd' (isNothing mm) mm eAttr = callAttributes' hd' @@ -215,9 +215,9 @@ where params = Params True gAttrs clusteredModule cID cAttr nAttr eAttr cID (_,s) = bool Nothing (Just $ Str s) $ (not . null) s - gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]] cAttr dp = [GraphAttrs $ directoryAttributes dp] - nAttr (n,m) = [ Label $ StrLabel m + nAttr (n,m) = [ toLabel m , FillColor $ entCol md n , Shape Tab ] @@ -241,7 +241,7 @@ hasNode = S.member n . fst nodeAttrs :: GlobalAttributes -nodeAttrs = NodeAttrs [ Margin . PVal $ Point 0.4 0.1 +nodeAttrs = NodeAttrs [ Margin . PVal $ createPoint 0.4 0.1 , Style [SItem Filled []] ] diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -72,8 +72,9 @@ dir' <- if null dir then getCurrentDirectory else return dir - hms <- parseFilesFrom dir' - analyseCode dir nm exps hms + (failed,hms) <- parseFilesFrom dir' + mapM_ (putErrLn . ("Could not parse source file "++)) failed + analyseCode dir nm exps failed hms programmeName :: String programmeName = "SourceGraph" @@ -111,13 +112,13 @@ isCabalFile = hasExt "cabal" parseMain :: FilePath -> IO (Maybe (String, [ModName])) -parseMain fp = do pms <- parseHaskellFiles [fp] +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 (flip hasExt fp) haskellExtensions +isHaskellFile fp = any (`hasExt` fp) haskellExtensions hasExt :: String -> FilePath -> Bool hasExt ext = (==) ext . drop 1 . takeExtension @@ -132,10 +133,10 @@ -- ----------------------------------------------------------------------------- -- | Recursively parse all files from this directory -parseFilesFrom :: FilePath -> IO ParsedModules +parseFilesFrom :: FilePath -> IO ([FilePath],ParsedModules) parseFilesFrom fp = parseHaskellFiles =<< getHaskellFilesFrom fp -parseHaskellFiles :: [FilePath] -> IO ParsedModules +parseHaskellFiles :: [FilePath] -> IO ([FilePath],ParsedModules) parseHaskellFiles = liftM parseHaskell . readFiles -- ----------------------------------------------------------------------------- @@ -211,15 +212,15 @@ -- ----------------------------------------------------------------------------- -analyseCode :: FilePath -> String -> [ModName] - -> ParsedModules -> IO () -analyseCode fp nm exps hms = do d <- today - g <- newStdGen - let dc = doc d g - docOut <- createDocument pandocHtml' dc - case docOut of - Just path -> success path - Nothing -> failure +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" @@ -240,7 +241,9 @@ c g = analyse g exps hms success fp' = putStrLn $ unwords ["Report generated at:",fp'] failure = putErrLn "Unable to generate report" - notes = Section (Text "Notes") [msg, implicitMsg, linkMsg] + 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 @@ -264,3 +267,9 @@ ] 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 + ] diff --git a/Parsing.hs b/Parsing.hs --- a/Parsing.hs +++ b/Parsing.hs @@ -46,28 +46,28 @@ , defaultParseMode) import Language.Haskell.Exts.Syntax(Module) -import Data.Maybe(mapMaybe) +import Data.Either(partitionEithers) type FileContents = (FilePath,String) -- | Parse all the files and return the map. -- This uses laziness to evaluate the 'HaskellModules' result -- whilst also using it to parse all the modules to create it. -parseHaskell :: [FileContents] -> ParsedModules -parseHaskell fc = hms +parseHaskell :: [FileContents] -> ([FilePath],ParsedModules) +parseHaskell fc = (failed,hms) where - ms = parseFiles fc + (failed,ms) = parseFiles fc hms = createModuleMap hss hss = map (parseModule hms) ms -- | Attempt to parse an individual file. -parseFile :: FileContents -> Maybe Module +parseFile :: FileContents -> Either FilePath Module parseFile (p,f) = case (parseFileContentsWithMode mode f) of - (ParseOk hs) -> Just hs - _ -> Nothing + (ParseOk hs) -> Right hs + _ -> Left p where mode = defaultParseMode { parseFilename = p } -- | Parse all the files that you can. -parseFiles :: [FileContents] -> [Module] -parseFiles = mapMaybe parseFile +parseFiles :: [FileContents] -> ([FilePath],[Module]) +parseFiles = partitionEithers . map parseFile diff --git a/SourceGraph.cabal b/SourceGraph.cabal --- a/SourceGraph.cabal +++ b/SourceGraph.cabal @@ -1,5 +1,5 @@ Name: SourceGraph -Version: 0.6.1.1 +Version: 0.7.0.0 Synopsis: Static code analysis using graph-theoretic techniques. Description: { Statically analyse Haskell source code using graph-theoretic @@ -76,8 +76,8 @@ directory, mtl, fgl >= 5.4.2.3 && < 5.5, - Graphalyze >= 0.10.0.0 && < 0.11.0.0, - graphviz >= 2999.10.0.0 && < 2999.11.0.0, - Cabal >= 1.8 && < 1.9, + Graphalyze >= 0.11.0.0 && < 0.12.0.0, + graphviz >= 2999.11.0.0 && < 2999.12.0.0, + Cabal >= 1.8 && < 1.11, haskell-src-exts >= 1.5.0 && < 1.10.0 }