SourceGraph 0.3 → 0.5.0.0
raw patch · 13 files changed
+1774/−705 lines, 13 filesdep +extensible-exceptionsdep +multisetdep ~Cabaldep ~Graphalyzedep ~base
Dependencies added: extensible-exceptions, multiset
Dependency ranges changed: Cabal, Graphalyze, base, graphviz, haskell-src-exts
Files
- Analyse.hs +4/−4
- Analyse/Everything.hs +83/−76
- Analyse/Imports.hs +43/−37
- Analyse/Module.hs +105/−100
- Analyse/Utils.hs +253/−20
- KnownProblems.txt +14/−0
- Main.hs +49/−35
- Parsing.hs +16/−13
- Parsing/ParseModule.hs +649/−290
- Parsing/State.hs +109/−0
- Parsing/Types.hs +374/−112
- ParsingProblems.txt +43/−0
- SourceGraph.cabal +32/−18
Analyse.hs view
@@ -1,5 +1,5 @@ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -21,7 +21,7 @@ {- | Module : Analyse Description : Analyse Haskell software- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com @@ -36,12 +36,12 @@ import Data.Graph.Analysis -import System.Random+import System.Random(RandomGen) -- | Analyse an entire Haskell project. Takes in a random seed, -- the list of exported modules and the parsed Haskell code in -- 'HaskellModules' form.-analyse :: (RandomGen g) => g -> [ModuleName] -> HaskellModules+analyse :: (RandomGen g) => g -> [ModName] -> ParsedModules -> [DocElement] analyse g exps hms = [ analyseModules hms , analyseImports exps hms
Analyse/Everything.hs view
@@ -1,5 +1,5 @@ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -21,131 +21,134 @@ {- | Module : Analyse.Software Description : Analyse Haskell software- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com Analysis of the entire overall piece of software. -}-module Analyse.Everything (analyseEverything) where+module Analyse.Everything(analyseEverything) where import Parsing.Types import Analyse.Utils import Data.Graph.Analysis -import Data.List-import Data.Maybe-import Text.Printf-import System.Random--type CodeData = GraphData Function+import Data.List(nub)+import Data.Maybe(mapMaybe)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.MultiSet as MS+import Text.Printf(printf)+import System.Random(RandomGen) -- | Performs analysis of the entire codebase.-analyseEverything :: (RandomGen g) => g -> [ModuleName] -> HaskellModules+analyseEverything :: (RandomGen g) => g -> [ModName] -> ParsedModules -> DocElement analyseEverything g exps hm = Section sec elems where cd = codeToGraph exps hm sec = Text "Analysis of the entire codebase"- elems = catMaybes- $ map ($cd) [ graphOf- , clustersOf g- , collapseAnal- , coreAnal- , cycleCompAnal- , rootAnal- , componentAnal- , cliqueAnal- , cycleAnal- , chainAnal- ]+ elems = mapMaybe ($cd) [ graphOf+ , clustersOf g+ -- , collapseAnal+ , coreAnal+ , cycleCompAnal+ , rootAnal+ , componentAnal+ , cliqueAnal+ , cycleAnal+ , chainAnal+ ] -codeToGraph :: [ModuleName] -> HaskellModules -> CodeData-codeToGraph exps hms = importData params+codeToGraph :: [ModName] -> ParsedModules -> HSData+codeToGraph exps pms = importData params where- exps' = concat . catMaybes $ map (fmap exports . getModule hms) exps- fl = combineCalls .map functions $ hModulesIn hms- params = Params { dataPoints = functionsIn fl- , relationships = functionEdges fl+ pms' = M.elems pms+ exps' = S.toList . S.unions+ . map exports $ mapMaybe (flip M.lookup pms) exps+ ents = S.toList . S.unions+ $ map internalEnts pms'+ calls = MS.toList . MS.map callToRel . MS.unions+ $ map funcCalls pms'+ params = Params { dataPoints = ents+ , relationships = calls , roots = exps' , directed = True } -graphOf :: CodeData -> Maybe DocElement+graphOf :: HSData -> Maybe DocElement graphOf cd = Just $ Section sec [gc] where sec = Text "Visualisation of the entire software"- gc = GraphImage $ applyAlg dg cd- dg g = toGraph "code" lbl g- lbl = "Software visualisation"+ gc = GraphImage ("code", Text lbl, drawGraph lbl Nothing cd)+ lbl = "Entire Codebase" -clustersOf :: (RandomGen g) => g -> CodeData -> Maybe DocElement+clustersOf :: (RandomGen g) => g -> HSData -> Maybe DocElement clustersOf g cd = Just $ Section sec [ text, gc, textAfter , blank, cwMsg, cw, blank, rngMsg, rng] where blank = Paragraph [BlankSpace] sec = Text "Visualisation of overall function calls"- gc = GraphImage $ applyAlg dg cd+ gc = GraphImage ("codeCluster", Text lbl, drawGraph' lbl cd) text = Paragraph [Text "Here is the current module grouping of functions:"]- dg gr = toClusters "codeCluster" lbl gr- lbl = "Module groupings"+ lbl = "Current module groupings" textAfter = Paragraph [Text "Here are two proposed module groupings:"] cwMsg = Paragraph [Emphasis $ Text "Using the Chinese Whispers algorithm:"]- cw = GraphImage- . toClusters "codeCW" "Chinese Whispers module suggestions"- $ applyAlg (chineseWhispers g) cd+ cw = GraphImage ("codeCW", Text cwLbl, drawClusters cwLbl (chineseWhispers g) cd)+ cwLbl = "Chinese Whispers module suggestions" rngMsg = Paragraph [Emphasis $ Text "Using the Relative Neighbourhood algorithm:"]- rng = GraphImage- . toClusters "codeRNG" "Relative Neighbourhood module suggestions"- $ applyAlg relativeNeighbourhood cd+ rng = GraphImage ("codeRNG", Text rngLbl, drawClusters lbl relNbrhd cd)+ -- Being naughty to avoid having to define drawClusters'+ relNbrhd = relativeNeighbourhood $ directedData cd+ rngLbl = "Relative Neighbourhood module suggestions" -componentAnal :: CodeData -> Maybe DocElement+componentAnal :: HSData -> Maybe DocElement componentAnal cd | single comp = Nothing | otherwise = Just $ Section sec [Paragraph [Text text]] where- comp = applyAlg componentsOf cd+ comp = applyAlg componentsOf $ collapseStructures cd len = length comp sec = Text "Function component analysis" text = printf "The functions are split up into %d components. \ \You may wish to consider splitting the code up \ \into multiple libraries." len -cliqueAnal :: CodeData -> Maybe DocElement+cliqueAnal :: HSData -> Maybe DocElement cliqueAnal cd | null clqs = Nothing | otherwise = Just el where- clqs = onlyCrossModule $ applyAlg cliquesIn cd+ clqs = onlyCrossModule . applyAlg cliquesIn $ collapseStructures cd clqs' = return . Itemized- $ map (Paragraph . return . Text . showNodes) clqs+ $ map (Paragraph . return . Text . showNodes' (fullName . snd)) clqs text = Text "The code has the following cross-module cliques:"- el = Section sec $ (Paragraph [text]) : clqs'+ el = Section sec $ Paragraph [text] : clqs' sec = Text "Overall clique analysis" -cycleAnal :: CodeData -> Maybe DocElement+cycleAnal :: HSData -> Maybe DocElement cycleAnal cd | null cycs = Nothing | otherwise = Just el where- cycs = onlyCrossModule $ applyAlg uniqueCycles cd+ cycs = onlyCrossModule . applyAlg uniqueCycles $ collapseStructures cd cycs' = return . Itemized- $ map (Paragraph . return . Text . showCycle) cycs+ $ map (Paragraph . return . Text . showCycle' (fullName . snd)) cycs text = Text "The code has the following cross-module non-clique cycles:"- el = Section sec $ (Paragraph [text]) : cycs'+ el = Section sec $ Paragraph [text] : cycs' sec = Text "Overall cycle analysis" -chainAnal :: CodeData -> Maybe DocElement+chainAnal :: HSData -> Maybe DocElement chainAnal cd | null chns = Nothing | otherwise = Just el where- chns = onlyCrossModule $ interiorChains cd+ chns = onlyCrossModule . interiorChains $ collapseStructures cd chns' = return . Itemized- $ map (Paragraph . return . Text . showPath) chns+ $ map (Paragraph . return . Text . showPath' (fullName . snd)) chns text = Text "The code has the following cross-module chains:" textAfter = Text "These chains can all be compressed down to \ \a single function."@@ -153,31 +156,31 @@ [Paragraph [text]] ++ chns' ++ [Paragraph [textAfter]] sec = Text "Overall chain analysis" -rootAnal :: CodeData -> Maybe DocElement+rootAnal :: HSData -> Maybe DocElement rootAnal cd | asExpected = Nothing | otherwise = Just $ Section sec ps where (wntd, ntRs, ntWd) = classifyRoots cd- asExpected = (null ntRs) && (null ntWd)- rpt (s,ns) = if (null ns)+ asExpected = null ntRs && null ntWd+ rpt (s,ns) = if null ns then Nothing else Just [ Paragraph [Text $ concat ["These functions are those that are " , s, ":"]]- , Paragraph [Emphasis . Text $ showNodes ns]]- ps = concat . catMaybes- $ map rpt [ ("available for use and roots",wntd)- , ("available for use but not roots",ntRs)- , ("not available for use but roots",ntWd)]+ , Paragraph [Emphasis . Text . showNodes' fullName $ map snd ns]]+ ps = concat+ $ mapMaybe rpt [ ("available for use and roots",wntd)+ , ("available for use but not roots",ntRs)+ , ("not available for use but roots",ntWd)] sec = Text "Import root analysis" -cycleCompAnal :: CodeData -> Maybe DocElement+cycleCompAnal :: HSData -> Maybe DocElement cycleCompAnal cd = Just $ Section sec pars where- cc = cyclomaticComplexity cd+ cc = cyclomaticComplexity $ collapseStructures cd sec = Text "Overall Cyclomatic Complexity" pars = [Paragraph [text], Paragraph [textAfter, link]] text = Text@@ -185,39 +188,43 @@ textAfter = Text "For more information on cyclomatic complexity, \ \please see: " link = DocLink (Text "Wikipedia: Cyclomatic Complexity")- (URL "http://en.wikipedia.org/wiki/Cyclomatic_complexity")+ (Web "http://en.wikipedia.org/wiki/Cyclomatic_complexity") -coreAnal :: CodeData -> Maybe DocElement-coreAnal cd = if (isEmpty core)+coreAnal :: HSData -> Maybe DocElement+coreAnal cd = if isEmpty core then Nothing else Just $ Section sec [hdr, anal] where- core = applyAlg coreOf cd- p = "codeCore"+ cd' = updateGraph coreOf $ collapseStructures cd+ core = graph cd' lbl = "Overall core" hdr = Paragraph [Text "The core of software can be thought of as \ \the part where all the work is actually done."]- anal = GraphImage (toGraph p lbl core)+ anal = GraphImage ("codeCore", Text lbl, drawGraph lbl Nothing cd') sec = Text "Overall Core analysis" -collapseAnal :: CodeData -> Maybe DocElement+-- Comment out until can work out a way of dealing with [Entity] for+-- the node-label type.+{-+collapseAnal :: HSData -> Maybe DocElement collapseAnal cd = if (trivialCollapse gc) then Nothing else Just $ Section sec [hdr, gr] where- gc = applyAlg collapseGraph cd- p = "codeCollapsed"+ cd' = updateGraph collapseGraph cd+ gc = graph cd' lbl = "Collapsed view of the entire codebase" hdr = Paragraph [Text "The collapsed view of code collapses \ \down all cliques, cycles, chains, etc. to \ \make the graph tree-like." ]- gr = GraphImage (toGraph p lbl gc)+ gr = GraphImage ("codeCollapsed", Text lbl, drawGraph lbl Nothing cd') sec = Text "Collapsed view of the entire codebase"+-} -- | Only use those values that are in more than one module.-onlyCrossModule :: [LNGroup Function] -> [LNGroup Function]+onlyCrossModule :: [LNGroup Entity] -> [LNGroup Entity] onlyCrossModule = filter crossModule where crossModule = not . single . nub . map (inModule . label)
Analyse/Imports.hs view
@@ -1,5 +1,5 @@ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -21,7 +21,7 @@ {- | Module : Analyse.Imports Description : Analyse module imports.- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com @@ -34,45 +34,51 @@ import Data.Graph.Analysis -import Data.Maybe-import Text.Printf+import Data.Maybe(mapMaybe)+import qualified Data.Map as M+import Text.Printf(printf) -type ImportData = GraphData ModuleName+-- ----------------------------------------------------------------------------- -- | Analyse the imports present in the software. Takes in a random seed -- as well as a list of all modules exported.-analyseImports :: [ModuleName] -> HaskellModules -> DocElement+analyseImports :: [ModName] -> ParsedModules -> DocElement analyseImports exps hm = Section sec elems where imd = importsToGraph exps hm sec = Text "Analysis of module imports"- elems = catMaybes- $ map ($imd) [ graphOf- , cycleCompAnal- , rootAnal- , componentAnal- , cycleAnal- , chainAnal- ]+ elems = mapMaybe ($imd) [ graphOf+ , cycleCompAnal+ , rootAnal+ , componentAnal+ , cycleAnal+ , chainAnal+ ] -importsToGraph :: [ModuleName] -> HaskellModules -> ImportData-importsToGraph exps hms = importData params+importsToGraph :: [ModName] -> ParsedModules -> ModData+importsToGraph exps pms = importData params where- params = Params { dataPoints = modulesIn hms- , relationships = moduleImports hms+ params = Params { dataPoints = M.keys pms+ , relationships = moduleImports pms , roots = exps , directed = True } -graphOf :: ImportData -> Maybe DocElement+moduleImports :: ParsedModules -> [Rel ModName ()]+moduleImports = concatMap imps . M.elems+ where+ imps pm = map (toRel (moduleName pm))+ . M.keys $ imports pm+ toRel m m' = (m,m',())++graphOf :: ModData -> Maybe DocElement graphOf imd = Just $ Section sec [gi] where sec = Text "Visualisation of imports"- gi = GraphImage $ applyAlg dg imd- dg g = toGraph "imports" lbl g+ gi = GraphImage ("imports", Text lbl, drawModules lbl imd) lbl = "Import visualisation" -componentAnal :: ImportData -> Maybe DocElement+componentAnal :: ModData -> Maybe DocElement componentAnal imd | single comp = Nothing | otherwise = Just el@@ -84,29 +90,29 @@ text = printf "The imports have %d components. \ \You may wish to consider splitting the code up." len -cycleAnal :: ImportData -> Maybe DocElement+cycleAnal :: ModData -> Maybe DocElement cycleAnal imd | null cycs = Nothing | otherwise = Just el where cycs = applyAlg cyclesIn imd cycs' = return . Itemized- $ map (Paragraph . return . Text . showCycle) cycs+ $ map (Paragraph . return . Text . showCycle' (nameOfModule' . snd)) cycs text = Text "The imports have the following cycles:" textAfter = Text "Whilst this is valid, it may make it difficult \ \to use in ghci, etc." el = Section sec- $ (Paragraph [text]) : cycs' ++ [Paragraph [textAfter]]+ $ Paragraph [text] : cycs' ++ [Paragraph [textAfter]] sec = Text "Cycle analysis of imports" -chainAnal :: ImportData -> Maybe DocElement+chainAnal :: ModData -> Maybe DocElement chainAnal imd | null chns = Nothing | otherwise = Just el where chns = interiorChains imd chns' = return . Itemized- $ map (Paragraph . return . Text . showPath) chns+ $ map (Paragraph . return . Text . showPath' (nameOfModule . snd)) chns text = Text "The imports have the following chains:" textAfter = Text "These chains can all be compressed down to \ \a single module."@@ -114,27 +120,27 @@ [Paragraph [text]] ++ chns' ++ [Paragraph [textAfter]] sec = Text "Import chain analysis" -rootAnal :: ImportData -> Maybe DocElement+rootAnal :: ModData -> Maybe DocElement rootAnal imd | asExpected = Nothing | otherwise = Just $ Section sec ps where (wntd, ntRs, ntWd) = classifyRoots imd- asExpected = (null ntRs) && (null ntWd)- rpt (s,ns) = if (null ns)+ asExpected = null ntRs && null ntWd+ rpt (s,ns) = if null ns then Nothing else Just [ Paragraph [Text $ concat ["These modules are those that are " , s, ":"]]- , Paragraph [Emphasis . Text $ showNodes ns]]- ps = concat . catMaybes- $ map rpt [ ("in the export list and roots",wntd)- , ("in the export list but not roots",ntRs)- , ("not in the export list but roots",ntWd)]+ , Paragraph [Emphasis . Text . showNodes' nameOfModule $ map snd ns]]+ ps = concat+ $ mapMaybe rpt [ ("in the export list and roots",wntd)+ , ("in the export list but not roots",ntRs)+ , ("not in the export list but roots",ntWd)] sec = Text "Import root analysis" -cycleCompAnal :: ImportData -> Maybe DocElement+cycleCompAnal :: ModData -> Maybe DocElement cycleCompAnal imd = Just $ Section sec pars where cc = cyclomaticComplexity imd@@ -145,4 +151,4 @@ textAfter = Text "For more information on cyclomatic complexity, \ \please see: " link = DocLink (Text "Wikipedia: Cyclomatic Complexity")- (URL "http://en.wikipedia.org/wiki/Cyclomatic_complexity")+ (Web "http://en.wikipedia.org/wiki/Cyclomatic_complexity")
Analyse/Module.hs view
@@ -1,5 +1,5 @@ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -21,7 +21,7 @@ {- | Module : Analyse.Module Description : Analyse modules.- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com @@ -34,190 +34,195 @@ import Data.Graph.Analysis -import Data.Maybe-import Text.Printf+import Data.Maybe(mapMaybe)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.MultiSet as MS+import Text.Printf(printf) -- ----------------------------------------------------------------------------- -- Helper types -- | Shorthand type-type FunctionData = (String, GraphData AString)+type ModuleData = (String, ModName, HSData) -- ----------------------------------------------------------------------------- -- Analysing. --- | Performs analysis of all modules present in the 'HaskellModules' provided.-analyseModules :: HaskellModules -> DocElement+-- | Performs analysis of all modules present in the 'ParsedModules' provided.+analyseModules :: ParsedModules -> DocElement analyseModules = Section (Text "Analysis of each module")- . catMaybes . map analyseModule . hModulesIn+ . mapMaybe analyseModule . M.elems --- | Performs analysis of the given 'HaskellModule'.-analyseModule :: HaskellModule -> Maybe DocElement-analyseModule hm = if (n > 1)- then Just $ Section sec elems+-- | Performs analysis of the given 'ParsedModule'.+analyseModule :: ParsedModule -> Maybe DocElement+analyseModule hm = if n > 1+ then Just $ Section sec elems else Nothing where- m = show $ moduleName hm- (n,fd) = moduleToGraph hm- elems = catMaybes- $ map ($fd) [ graphOf- , collapseAnal- , coreAnal- , cycleCompAnal- , rootAnal- , componentAnal- , cliqueAnal- , cycleAnal- , chainAnal- ]+ (n,fd@(m,_,_)) = moduleToGraph hm+ elems = mapMaybe ($fd) [ graphOf+ -- , collapseAnal+ , coreAnal+ , cycleCompAnal+ , rootAnal+ , componentAnal+ , cliqueAnal+ , cycleAnal+ , chainAnal+ ] sec = Grouping [ Text "Analysis of" , Emphasis (Text m)] -- | Convert the module to the /Graphalyze/ format.-moduleToGraph :: HaskellModule -> (Int,FunctionData)-moduleToGraph hm = (n,(show $ moduleName hm, fd'))+moduleToGraph :: ParsedModule -> (Int,ModuleData)+moduleToGraph hm = (n,(nameOfModule mn, mn, fd)) where- n = applyAlg noNodes fd'- fd' = manipulateNodes (AS . name) fd+ mn = moduleName hm+ n = applyAlg noNodes fd fd = importData params- funcs = functions hm- params = Params { dataPoints = functionsIn funcs- , relationships = functionEdges funcs- , roots = exports hm+ params = Params { dataPoints = S.toList $ internalEnts hm+ , relationships = MS.toList . MS.map callToRel+ $ funcCalls hm+ , roots = S.toList $ exports hm , directed = True } -graphOf :: FunctionData -> Maybe DocElement-graphOf (m,fd) = Just $ Section sec [gi]+graphOf :: ModuleData -> Maybe DocElement+graphOf (n,m,fd) = Just $ Section sec [gi] where sec = Grouping [ Text "Visualisation of"- , Emphasis (Text m)]- gi = GraphImage $ applyAlg dg fd- dg g = toGraph m lbl g- lbl = unwords ["Diagram of:", m]+ , Emphasis $ Text n]+ gi = GraphImage (n, Text lbl, drawGraph lbl (Just m) fd)+ lbl = unwords ["Diagram of:", n] -componentAnal :: FunctionData -> Maybe DocElement-componentAnal (m,fd)+componentAnal :: ModuleData -> Maybe DocElement+componentAnal (n,_,fd) | single comp = Nothing | otherwise = Just el where- comp = applyAlg componentsOf fd+ comp = applyAlg componentsOf $ collapseStructures fd len = length comp el = Section sec [Paragraph [Text text]] sec = Grouping [ Text "Component analysis of"- , Emphasis (Text m)]+ , Emphasis (Text n)] text = printf "The module %s has %d components. \- \You may wish to consider splitting it up." m len+ \You may wish to consider splitting it up." n len -cliqueAnal :: FunctionData -> Maybe DocElement-cliqueAnal (m,fd)+cliqueAnal :: ModuleData -> Maybe DocElement+cliqueAnal (n,_,fd) | null clqs = Nothing | otherwise = Just el where- clqs = applyAlg cliquesIn fd+ clqs = applyAlg cliquesIn $ collapseStructures fd clqs' = return . Itemized- $ map (Paragraph . return . Text . showNodes) clqs- text = Text $ printf "The module %s has the following cliques:" m- el = Section sec $ (Paragraph [text]) : clqs'+ $ map (Paragraph . return . Text . showNodes' (name . snd)) clqs+ text = Text $ printf "The module %s has the following cliques:" n+ el = Section sec $ Paragraph [text] : clqs' sec = Grouping [ Text "Clique analysis of"- , Emphasis (Text m)]+ , Emphasis (Text n)] -cycleAnal :: FunctionData -> Maybe DocElement-cycleAnal (m,fd)+cycleAnal :: ModuleData -> Maybe DocElement+cycleAnal (n,_,fd) | null cycs = Nothing | otherwise = Just el where- cycs = applyAlg uniqueCycles fd+ cycs = applyAlg uniqueCycles $ collapseStructures fd cycs' = return . Itemized- $ map (Paragraph . return . Text . showCycle) cycs+ $ map (Paragraph . return . Text . showCycle' (name . snd)) cycs text = Text $ printf "The module %s has the following non-clique \- \cycles:" m- el = Section sec $ (Paragraph [text]) : cycs'+ \cycles:" n+ el = Section sec $ Paragraph [text] : cycs' sec = Grouping [ Text "Cycle analysis of"- , Emphasis (Text m)]+ , Emphasis (Text n)] -chainAnal :: FunctionData -> Maybe DocElement-chainAnal (m,fd)+chainAnal :: ModuleData -> Maybe DocElement+chainAnal (n,_,fd) | null chns = Nothing | otherwise = Just el where- chns = interiorChains fd+ chns = interiorChains $ collapseStructures fd chns' = return . Itemized- $ map (Paragraph . return . Text . showPath) chns- text = Text $ printf "The module %s has the following chains:" m+ $ map (Paragraph . return . Text . showPath' (name . snd)) chns+ text = Text $ printf "The module %s has the following chains:" n textAfter = Text "These chains can all be compressed down to \ \a single function." el = Section sec $ [Paragraph [text]] ++ chns' ++ [Paragraph [textAfter]] sec = Grouping [ Text "Chain analysis of"- , Emphasis (Text m)]+ , Emphasis (Text n)] -rootAnal :: FunctionData -> Maybe DocElement-rootAnal (m,fd)+rootAnal :: ModuleData -> Maybe DocElement+rootAnal (n,_,fd) | asExpected = Nothing | otherwise = Just el where- (wntd, ntRs, ntWd) = classifyRoots fd- asExpected = (null ntRs) && (null ntWd)- rpt (s,ns) = if (null ns)+ (wntd, ntRs, ntWd) = classifyRoots $ collapseStructures fd+ asExpected = null ntRs && null ntWd+ rpt (s,ns) = if null ns then Nothing else Just [ Paragraph [Text $ concat ["These nodes are those that are " , s, ":"]]- , Paragraph [Emphasis . Text $ showNodes ns]]- ps = concat . catMaybes- $ map rpt [ ("in the export list and roots",wntd)- , ("in the export list but not roots",ntRs)- , ("not in the export list but roots",ntWd)]+ , Paragraph [Emphasis . Text . showNodes' name $ map snd ns]]+ ps = concat+ $ mapMaybe rpt [ ("in the export list and roots",wntd)+ , ("in the export list but not roots",ntRs)+ , ("not in the export list but roots",ntWd)] el = Section sec ps sec = Grouping [ Text "Root analysis of"- , Emphasis (Text m)]+ , Emphasis (Text n)] -coreAnal :: FunctionData -> Maybe DocElement-coreAnal (m,fd) = if (isEmpty core)- then Nothing- else Just el+coreAnal :: ModuleData -> Maybe DocElement+coreAnal (n,m,fd) = if isEmpty core+ then Nothing+ else Just el where- core = applyAlg coreOf fd- p = m ++ "_core"- lbl = unwords ["Core of", m]+ fd' = updateGraph coreOf $ collapseStructures fd+ core = graph fd'+ p = n ++ "_core"+ lbl = unwords ["Core of", n] hdr = Paragraph [Text "The core of a module can be thought of as \ \the part where all the work is actually done."]- anal = GraphImage (toGraph p lbl core)+ anal = GraphImage (p,Text lbl,drawGraph lbl (Just m) fd') el = Section sec [hdr, anal] sec = Grouping [ Text "Core analysis of"- , Emphasis (Text m)]+ , Emphasis (Text n)] -collapseAnal :: FunctionData -> Maybe DocElement-collapseAnal (m,fd) = if (trivialCollapse gc)- then Nothing- else Just el+-- Comment out until can work out a way of dealing with [Entity] for+-- the node-label type.+{-+collapseAnal :: ModuleData -> Maybe DocElement+collapseAnal (n,m,fd) = if (trivialCollapse gc)+ then Nothing+ else Just el where- gc = applyAlg collapseGraph fd- p = m ++ "_collapsed"- lbl = unwords ["Collapsed view of", m]+ fd' = updateGraph collapseGraph fd+ gc = graph fd'+ p = n ++ "_collapsed"+ lbl = unwords ["Collapsed view of", n] hdr = Paragraph [Text "The collapsed view of a module collapses \ \down all cliques, cycles, chains, etc. to \ \make the graph tree-like." ]- gr = GraphImage (toGraph p lbl gc)+ gr = GraphImage (p,Text lbl,drawGraph lbl (Just m) fd') el = Section sec [hdr, gr] sec = Grouping [ Text "Collapsed view of"- , Emphasis (Text m)]-+ , Emphasis (Text n)]+-} -cycleCompAnal :: FunctionData -> Maybe DocElement-cycleCompAnal (m,fd) = Just $ Section sec pars+cycleCompAnal :: ModuleData -> Maybe DocElement+cycleCompAnal (n,_,fd) = Just $ Section sec pars where- cc = cyclomaticComplexity fd+ cc = cyclomaticComplexity $ collapseStructures fd sec = Grouping [ Text "Cyclomatic Complexity of"- , Emphasis (Text m)]+ , Emphasis (Text n)] pars = [Paragraph [text], Paragraph [textAfter, link]] text = Text- $ printf "The cyclomatic complexity of %s is: %d." m cc+ $ printf "The cyclomatic complexity of %s is: %d." n cc textAfter = Text "For more information on cyclomatic complexity, \ \please see: " link = DocLink (Text "Wikipedia: Cyclomatic Complexity")- (URL "http://en.wikipedia.org/wiki/Cyclomatic_complexity")+ (Web "http://en.wikipedia.org/wiki/Cyclomatic_complexity")
Analyse/Utils.hs view
@@ -1,5 +1,5 @@ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -21,7 +21,7 @@ {- | Module : Analyse.Utils Description : Utility functions and types for analysis.- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com @@ -29,34 +29,267 @@ -} module Analyse.Utils where -import Data.Graph.Analysis+import Parsing.Types++import Data.Graph.Analysis hiding (Bold) import Data.Graph.Inductive hiding (graphviz) +import Data.GraphViz --- | Defining a wrapper around String to define a sensible 'show' definition.-newtype AString = AS String- deriving (Eq, Ord)+import Data.List(groupBy, sortBy)+import Data.Maybe(isJust)+import Data.Function(on)+import qualified Data.Set as S+import Data.Set(Set)+import qualified Data.IntSet as I+import Data.IntSet(IntSet) -instance Show AString where- show (AS f) = f+-- ----------------------------------------------------------------------------- --- | Create a graph in the 'DocGraph' format.--- Takes in the filepath, title and the graph to be drawn.-toGraph :: (Show a) => FilePath -> String -> AGr a -> DocGraph-toGraph p t g = (p,Text t,dg)- where- dg = graphviz t g+type HSData = GraphData Entity CallType+type HSClustData = GraphData (GenCluster Entity) CallType+type HSGraph = AGr Entity CallType+type HSClustGraph = AGr (GenCluster Entity) CallType -toClusters :: (Show c, ClusterLabel a c) => FilePath -> String- -> AGr a -> DocGraph-toClusters p t g = (p, Text t, dg)- where- dg = graphvizClusters t g+type ModData = GraphData ModName ()+type ModGraph = AGr ModName () +-- -----------------------------------------------------------------------------+ -- | Cyclomatic complexity-cyclomaticComplexity :: GraphData a -> Int+cyclomaticComplexity :: GraphData a b -> Int cyclomaticComplexity gd = e - n + 2*p where p = length $ applyAlg componentsOf gd n = applyAlg noNodes gd e = length $ applyAlg labEdges gd++-- | Collapse items that must be kept together before clustering, etc.+collapseStructures :: HSData -> HSData+collapseStructures = updateGraph collapseStructures'++collapseStructures' :: HSGraph -> HSGraph+collapseStructures' = collapseGraphBy' [ collapseDatas+ , collapseClasses+ , collapseInsts+ ]+ where+ collapseDatas = mkCollapseTp isData getDataType mkData+ mkData m d = Ent m ("Data: " ++ d) (CollapsedData d)+ collapseClasses = mkCollapseTp isClass getClassName mkClass+ mkClass m c = Ent m ("Class: " ++ c) (CollapsedClass c)+ collapseInsts = mkCollapseTp isInstance getInstance mkInst+ mkInst m (c,d) = Ent m ("Class: " ++ c ++ "\\nData: " ++ d)+ (CollapsedInstance c d)+++mkCollapseTp :: (Ord a) => (EntityType -> Bool) -> (EntityType -> a)+ -> (ModName -> a -> Entity) -> HSGraph+ -> [(NGroup, Entity)]+mkCollapseTp p v mkE g = map lng2ne lngs+ where+ lns = filter (p . eType . snd) $ labNodes g+ lnas = map addA lns+ lngs = groupSortBy snd lnas+ lng2ne lng = ( map (fst . fst) lng+ , mkEnt $ head lng+ )+ mkEnt ((_,e),a) = mkE (inModule e) a+ addA ln@(_,l) = (ln, v $ eType l)++groupSortBy :: (Ord b) => (a -> b) -> [a] -> [[a]]+groupSortBy f = groupBy ((==) `on` f) . sortBy (compare `on` f)++toSet :: (Ord a) => LNGroup a -> Set a+toSet = S.fromList . map snd++getRoots :: (Ord a) => GraphData a b -> Set a+getRoots = toSet . applyAlg rootsOf++getLeaves :: (Ord a) => GraphData a b -> Set a+getLeaves = toSet . applyAlg leavesOf++getWRoots :: (Ord a) => GraphData a b -> Set a+getWRoots = toSet . wantedRoots++bool :: a -> a -> Bool -> a+bool t f b = if b then t else f++-- -----------------------------------------------------------------------------++-- | Create the nested 'DotGraph'.+drawGraph :: String -> Maybe ModName -> HSData -> DotGraph Node+drawGraph gid mm dg = setID (Str gid)+ $ graphvizClusters' dg'+ gAttrs+ toClust+ ctypeID+ clustAttributes'+ nAttr+ callAttributes'+ where+ gAttrs = [NodeAttrs [Margin . PVal $ PointD 0.2 0.2]] -- [GraphAttrs [Label $ StrLabel t]]+ dg' = updateGraph compactSame dg+ -- Possible clustering problem+ toClust = clusterEntity -- bool clusterEntity clusterEntityM' $ isJust mm+ rs = getRoots dg+ ls = getLeaves dg+ es = getWRoots dg+ nAttr = entityAttributes rs ls es False mm++-- | One-module-per-cluster 'DotGraph'+drawGraph' :: String -> HSData -> DotGraph Node+drawGraph' gid dg = setID (Str gid)+ $ graphvizClusters dg'+ gAttrs+ modClustAttrs+ nAttr+ callAttributes'+ where+ gAttrs = [] -- [GraphAttrs [Label $ StrLabel t]]+ dg' = updateGraph (compactSame . collapseStructures') dg+ rs = getRoots dg+ ls = getLeaves dg+ es = getWRoots dg+ nAttr = entityAttributes rs ls es False Nothing++-- | GetRoots, GetLeaves, Exported, @'Just' m@ if only one module, @'Nothing'@ if all.+-- 'True' if add explicit module name to all entities.+entityAttributes :: Set Entity -> Set Entity -> Set Entity -> Bool+ -> Maybe ModName -> LNode Entity -> Attributes+entityAttributes rs ls ex a mm (_,e@(Ent m n t))+ = [ Label $ StrLabel lbl+ , Shape $ shapeFor t+ -- , Color [ColorName cl]+ , FillColor $ ColorName sh+ , Style [SItem Filled [], styleFor mm m]+ ]+ where+ lbl = bool (nameOfModule m ++ "\\n" ++ n) n+ $ not sameMod || a+ -- Using the default X11 color names.+ {-+ isR = e `S.member` rs+ isL = e `S.member` ls+ -}+ isE = e `S.member` ex+ {-+ cl | isR && not isE = "red"+ | isR = "mediumblue"+ | isL = "forestgreen"+ | otherwise = "black"+ -}+ sh | isE = "gold"+ | otherwise = "beige"+ sameMod = maybe True ((==) m) mm++shapeFor :: EntityType -> Shape+shapeFor Constructor{} = Box3D+shapeFor RecordFunction{} = Component+shapeFor ClassFunction{} = DoubleOctagon+shapeFor DefaultInstance{} = Octagon+shapeFor ClassInstance{} = Octagon+shapeFor CollapsedData{} = Box3D+shapeFor CollapsedClass{} = DoubleOctagon+shapeFor CollapsedInstance{} = Octagon+shapeFor NormalEntity = BoxShape++styleFor :: Maybe ModName -> ModName -> StyleItem+styleFor mm m@LocalMod{} = flip SItem [] . bool Bold Solid+ $ maybe True ((==) m) mm+styleFor _ ExtMod{} = SItem Dashed []+styleFor _ UnknownMod = SItem Dotted []++callAttributes :: CallType -> Attributes+callAttributes NormalCall = [ Color [ColorName "black"]]+callAttributes InstanceDeclaration = [ Color [ColorName "navy"]+ , Dir NoDir+ ]+callAttributes DefaultInstDeclaration = [ Color [ColorName "turquoise"]+ , Dir NoDir+ ]+callAttributes RecordConstructor = [ Color [ColorName "magenta"]+ , ArrowTail oDot+ , ArrowHead vee+ ]++callAttributes' :: LEdge (Int, CallType) -> Attributes+callAttributes' (_,_,(n,ct)) = PenWidth (fromIntegral n)+ : callAttributes ct++clustAttributes :: EntClustType -> Attributes+clustAttributes (ClassDefn c) = [ Label . StrLabel $ "Class: " ++ c+ , Style [SItem Filled [], SItem Rounded []]+ , FillColor $ ColorName "rosybrown1"+ ]+clustAttributes (DataDefn d) = [ Label . StrLabel $ "Data: " ++ d+ , Style [SItem Filled [], SItem Rounded []]+ , FillColor $ ColorName "papayawhip"+ ]+clustAttributes (ClassInst d) = [ Label . StrLabel $ "Instance for: " ++ d+ , Style [SItem Filled [], SItem Rounded []]+ , FillColor $ ColorName "slategray1"+ ]+clustAttributes DefInst = [ Label . StrLabel $ "Default Instance"+ , Style [SItem Filled [], SItem Rounded []]+ , FillColor $ ColorName "slategray1"+ ]+clustAttributes (ModPath p) = [ Label $ StrLabel p ]++clustAttributes' :: EntClustType -> [GlobalAttributes]+clustAttributes' = return . GraphAttrs . clustAttributes++modClustAttrs :: ModName -> [GlobalAttributes]+modClustAttrs m = [GraphAttrs [Label . StrLabel $ nameOfModule m]]++-- -----------------------------------------------------------------------------++-- | Create a 'DotGraph' using a clustering function.+drawClusters :: String -> (HSGraph -> HSClustGraph) -> HSData -> DotGraph Node+drawClusters gid cf dg = setID (Str gid)+ $ graphvizClusters dg'+ gAttrs+ (const [])+ nAttr+ callAttributes'+ where+ gAttrs = [] -- [GraphAttrs [Label $ StrLabel t]]+ dg' = updateGraph (compactSame . cf . collapseStructures') dg+ rs = getRoots dg+ ls = getLeaves dg+ es = getWRoots dg+ nAttr = entityAttributes rs ls es True Nothing++-- -----------------------------------------------------------------------------++drawModules :: String -> ModData -> DotGraph Node+drawModules gid dg = setID (Str gid)+ $ graphvizClusters' dg+ gAttrs+ clusteredModule+ cID+ cAttr+ nAttr+ (const [])+ where+ cID s = bool (Just $ Str s) Nothing $ null s+ gAttrs = [] --[GraphAttrs [Label $ StrLabel t]]+ cAttr p = [GraphAttrs [Label $ StrLabel p]]+ rs = I.fromList $ applyAlg rootsOf' dg+ ls = I.fromList $ applyAlg leavesOf' dg+ es = I.fromList $ wantedRootNodes dg+ nAttr (n,m) = [ Label $ StrLabel m+ , Color [ColorName $ mCol rs ls es n]+ , Shape Tab+ ]++mCol :: IntSet -> IntSet -> IntSet -> Node -> String+mCol rs ls es n+ | isR && not isE = "red"+ | isR = "mediumblue"+ | isL = "forestgreen"+ | otherwise = "black"+ where+ isR = n `I.member` rs+ isL = n `I.member` ls+ isE = n `I.member` es
+ KnownProblems.txt view
@@ -0,0 +1,14 @@+This is a list of known problems with SourceGraph except for those+related to parsing.++* Node-based reporting (cycles, etc.) get confused with Class+ functions.++* Printing of labels doesn't always turn out so well (overlaps, etc.).++* For some reason, a lot of class instance functions won't get drawn+ in their clusters like they're meant to. Not sure why, as the+ generated Dot code looks right (this might be from a limitation of+ dot...).++* No options on what to do, etc.
Main.hs view
@@ -1,5 +1,5 @@ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+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@@ -19,7 +19,7 @@ {- | Module : Main Description : Analyse source code as a graph.- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com @@ -39,20 +39,33 @@ import Distribution.Package import Distribution.PackageDescription hiding (author) import Distribution.PackageDescription.Parse-import Distribution.ModuleName (toFilePath)+import Distribution.ModuleName(toFilePath) import Distribution.Verbosity -import Data.Char-import Data.List-import Data.Maybe-import System.IO-import System.Directory-import System.FilePath-import System.Random-import System.Environment-import Control.Monad-import Control.Exception+import Data.Char(toLower)+import Data.List(nub)+import Data.Maybe(isJust, fromJust, listToMaybe, catMaybes)+import System.IO(hPutStrLn, stderr)+import System.Directory( getCurrentDirectory+ , doesDirectoryExist+ , getDirectoryContents)+import System.FilePath( dropFileName+ , dropExtension+ , takeExtension+ , extSeparator+ , isPathSeparator+ , (</>)+ , (<.>))+import System.Random(newStdGen)+import System.Environment(getArgs)+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 let mcbl = getCabalFile input@@ -76,18 +89,18 @@ programmeName = "SourceGraph" programmeVersion :: String-programmeVersion = "0.3"+programmeVersion = showVersion Paths.version putErrLn :: String -> IO () putErrLn = hPutStrLn stderr -- ----------------------------------------------------------------------------- -parseCabal :: FilePath -> IO (Maybe (String, [ModuleName]))+parseCabal :: FilePath -> IO (Maybe (String, [ModName])) parseCabal fp = do gpd <- try $ readPackageDescription silent fp case gpd of- (Right gpd') -> return (Just $ parse gpd')- (Left _) -> return Nothing+ (Right gpd') -> return (Just $ parse gpd')+ (Left SomeException{}) -> return Nothing where parse pd = (nm, exps') where@@ -111,9 +124,9 @@ getCabalFile :: [FilePath] -> Maybe FilePath getCabalFile = listToMaybe . filter isCabalFile where- isCabalFile f = (takeExtension f) == (extSeparator : "cabal")+ isCabalFile f = takeExtension f == extSeparator : "cabal" -fpToModule :: FilePath -> ModuleName+fpToModule :: FilePath -> ModName fpToModule = createModule . map pSep where pSep c@@ -123,7 +136,7 @@ -- ----------------------------------------------------------------------------- -- | Recursively parse all files from this directory-parseFilesFrom :: FilePath -> IO HaskellModules+parseFilesFrom :: FilePath -> IO ParsedModules parseFilesFrom fp = do files <- getHaskellFilesFrom fp cnts <- readFiles files return $ parseHaskell cnts@@ -139,8 +152,8 @@ if isDir then do r <- try getFilesIn -- Ensure we can read the directory. case r of- (Right fs) -> return fs- (Left _) -> return []+ (Right fs) -> return fs+ (Left SomeException{}) -> return [] else return [] where -- Filter out "." and ".." to stop infinite recursion.@@ -157,7 +170,7 @@ -- | Determine if this is the path of a Haskell file. isHaskellFile :: FilePath -> Bool-isHaskellFile f = (takeExtension f) `elem` haskellExtensions+isHaskellFile f = takeExtension f `elem` haskellExtensions haskellExtensions :: [FilePath] haskellExtensions = map (extSeparator :) ["hs","lhs"]@@ -170,8 +183,8 @@ readFileContents :: FilePath -> IO (Maybe FileContents) readFileContents f = do cnts <- try $ readFile f case cnts of- (Right str) -> return $ Just (f,str)- (Left _) -> return Nothing+ (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]@@ -188,24 +201,25 @@ -- | 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 :: FilePath -> Bool+isTrivial "." = True+isTrivial ".." = True+isTrivial "_darcs" = True+isTrivial "dist" = True+isTrivial "HLInt.hs" = True isTrivial f | isSetup f = True-isTrivial _ = False+isTrivial _ = False lowerCase :: String -> String lowerCase = map toLower isSetup :: String -> Bool-isSetup f = lowerCase f `elem` (map ("setup" <.>) haskellExtensions)+isSetup f = lowerCase f `elem` map ("setup" <.>) haskellExtensions -- ----------------------------------------------------------------------------- -analyseCode :: FilePath -> String -> [ModuleName]- -> HaskellModules -> IO ()+analyseCode :: FilePath -> String -> [ModName]+ -> ParsedModules -> IO () analyseCode fp nm exps hms = do d <- today g <- newStdGen let dc = doc d g@@ -225,7 +239,7 @@ } rt = fp </> programmeName sv s v = s ++ " (version " ++ v ++ ")"- t = Grouping [Text "Analysis of", Emphasis $ Text nm]+ t = Grouping [Text "Analysis of", Text nm] a = unwords [ "Analysed by", sv programmeName programmeVersion , "using", sv "Graphalyze" version] c g = analyse g exps hms
Parsing.hs view
@@ -1,5 +1,5 @@ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -21,7 +21,7 @@ {- | Module : Parsing Description : Parse the given Haskell modules.- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com @@ -29,8 +29,8 @@ -} module Parsing ( FileContents- , HaskellModules- , ModuleName+ , ParsedModules+ , ModName , createModule , parseHaskell -- from Parsing.Types@@ -40,17 +40,20 @@ import Parsing.Types import Parsing.ParseModule -import Language.Haskell.Exts.Parser hiding (parseModule)-import Language.Haskell.Exts.Syntax(HsModule)+import Language.Haskell.Exts(parseFileContentsWithMode)+import Language.Haskell.Exts.Parser( ParseMode(..)+ , ParseResult(..)+ , defaultParseMode)+import Language.Haskell.Exts.Syntax(Module) -import Data.Maybe+import Data.Maybe(mapMaybe) 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] -> HaskellModules+parseHaskell :: [FileContents] -> ParsedModules parseHaskell fc = hms where ms = parseFiles fc@@ -58,13 +61,13 @@ hss = map (parseModule hms) ms -- | Attempt to parse an individual file.-parseFile :: FileContents -> Maybe HsModule-parseFile (p,f) = case (parseModuleWithMode mode f) of+parseFile :: FileContents -> Maybe Module+parseFile (p,f) = case (parseFileContentsWithMode mode f) of (ParseOk hs) -> Just hs _ -> Nothing where- mode = ParseMode p+ mode = defaultParseMode { parseFilename = p } -- | Parse all the files that you can.-parseFiles :: [FileContents] -> [HsModule]-parseFiles = catMaybes . map parseFile+parseFiles :: [FileContents] -> [Module]+parseFiles = mapMaybe parseFile
Parsing/ParseModule.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE FlexibleInstances #-}+ {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -21,368 +23,725 @@ {- | Module : Parsing.ParseModule Description : Parse a Haskell module.- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com Parse a Haskell module. -}-module Parsing.ParseModule (parseModule) where+module Parsing.ParseModule(parseModule) where import Parsing.Types+import Parsing.State import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Pretty -import Data.List-import Data.Maybe+import Data.Char(isUpper)+import Data.Foldable(foldrM)+import Data.Maybe(fromMaybe, catMaybes, fromJust) import qualified Data.Map as M+import qualified Data.Set as S+import Data.Set(Set)+import qualified Data.MultiSet as MS+import Data.MultiSet(MultiSet)+import Control.Arrow((***), second)+import Control.Monad(liftM, liftM2) -- ----------------------------------------------------------------------------- -{- |- Parses a Haskell Module in 'HsModule' format into the internal- 'HaskellModule' format. The 'HaskellModules' parameter is used- to look up the export lists of all imported functions.+parseModule :: ParsedModules -> Module -> ParsedModule+parseModule hms m = pm+ where+ mns = moduleNames hms+ pm = runPState hms mns blankPM $ parseInfo m - The resulting 'HaskellModule'\'s 'functions' field is a 'Map' that- maps all functions defined in this module to those functions- accessible to them from modules in the first parameter.+-- ----------------------------------------------------------------------------- - At the moment, parsing works only on stand-alone functions, i.e. no- data structures, class declarations or instance declarations.- -}-parseModule :: HaskellModules -> HsModule -> HaskellModule-parseModule hm (HsModule _ md exps imp decls) = Hs { moduleName = m- , imports = imps'- , exports = exps'- , functions = funcs- }- where- m = createModule' md- (imps,fl) = parseImports hm imp- imps' = map fromModule imps- -- If there isn't an export list, export everything.- -- The exception is if there isn't an export list but there is a- -- /main/ function, in which case only export that.- exps' | isJust exps = parseExports m $ fromJust exps- | hasMain = [mainFunc]- | otherwise = defFuncs- mainFunc = F m (nameOf main_name) Nothing- hasMain = elem mainFunc defFuncs- -- We utilise "Tying-the-knot" here to simultaneously update the- -- lookup map as well as utilise that lookup map.- funcs = functionCalls m fl' decls- defFuncs = map fst funcs- flInternal = createLookup defFuncs- fl' = M.union fl flInternal+class ModuleItem a where+ parseInfo :: a -> PState () --- | Create the 'ModuleName'.-createModule' :: Module -> ModuleName-createModule' = createModule . modName+instance (ModuleItem a) => ModuleItem [a] where+ parseInfo = mapM_ parseInfo --- | Parse all import declarations, and create the 'FunctionLookup' map--- on the imports.-parseImports :: HaskellModules -> [HsImportDecl]- -> ([HsImport],FunctionLookup)-parseImports hm is = (is', flookup)+-- -----------------------------------------------------------------------------+-- Overall Module++instance ModuleItem Module where+ parseInfo (Module _ nm _ _ es is ds)+ = do let mn = createModule' nm+ pm <- getParsedModule+ putParsedModule $ pm { moduleName = mn }+ parseInfo es+ parseInfo is+ parseInfo ds++-- -----------------------------------------------------------------------------+-- Imports++instance ModuleItem ImportDecl where+ parseInfo iDcl+ = do mns <- getModuleNames+ ms <- getModules+ pm <- getParsedModule+ let nm = getModName mns . nameOf $ importModule iDcl+ md = M.lookup nm ms+ es = imported nm md+ im = mi nm es+ pm' = pm { imports = M.insert nm im (imports pm) }+ putParsedModule pm'+ where+ mi nm es = I { fromModule = nm+ , importQuald = importQualified iDcl+ , importedAs = fmap nameOf $ importAs iDcl+ , importedEnts = es+ }++ imported nm Nothing+ = case importSpecs iDcl of+ Just (False,is) -> mkSet+ $ map (createEnt nm) is+ _ -> S.empty+ imported _ (Just ml)+ = case importSpecs iDcl of+ Nothing -> exprtd+ Just (False,is) -> lstd is+ Just (True, is) -> exprtd `S.difference` lstd is+ where+ exprtd = exports ml+ exLk = exportLookup ml+ lstd = mkSet . map (listedEnt ml exLk)++-- | Guesstimate the correct 'Entity' designation for those from+-- external modules.+createEnt :: ModName -> ImportSpec -> [Entity]+createEnt mn (IVar n) = [Ent mn (nameOf n) NormalEntity]+createEnt mn (IThingWith n cs) = map (\c -> Ent mn c (eT c)) cs' where- is' = catMaybes $ map (parseImport hm) is- flookup = createLookup $ concatMap importList is'+ n' = nameOf n+ cs' = map nameOf cs+ isD = isUpper . head+ isDta = any (isUpper . head) cs'+ mkData c | isD c = Constructor n'+ | otherwise = RecordFunction n' -- Nothing+ mkClass _ = ClassFunction n'+ eT = if isDta then mkData else mkClass+createEnt _ _ = [] --- | Convert the import declaration. Assumes that all functions imported--- are indeed valid.-parseImport :: HaskellModules -> HsImportDecl -> Maybe HsImport-parseImport hm im- | not (M.member m hm) = Nothing -- This module isn't available.- | otherwise = Just $ I m qual imps+-- | Determine the correct 'Entity' designation for the listed import item.+listedEnt :: ParsedModule -> EntityLookup+ -> ImportSpec -> [Entity]+listedEnt _ el (IVar n) = [lookupEntity' el $ nameOf n]+listedEnt _ _ IAbs{} = []+listedEnt pm _ (IThingAll n) = esFrom dataDecls ++ esFrom classDecls+ -- one will be empty where- mn = importModule im- m = createModule' mn- -- Determine if this module has been imported with an /as/ prefix.- -- If not, it has the entire name as its prefix.- qual = fmap modName (importAs im)- qual' = fromMaybe (modName mn) qual- -- Try and get the functions that this module exports.- mExport = exports $ hm M.! m- mImport = case (importSpecs im) of- -- Everything was imported- Nothing -> mExport- -- Only specific items were imported.- Just (True, ims) -> getFunctions m ims- -- These items were hidden.- Just (False, hd) -> mExport \\ (getFunctions m hd)- qImport = map (addQual qual') mImport- imps = if (importQualified im)- then qImport- else mImport ++ qImport- getFunctions m' = map (setModule m') . getItems- setModule m' f = F m' f Nothing- getItems = catMaybes . map getImport- -- We only care about functions, variables, etc.- getImport (HsIVar nm) = Just (nameOf nm)- getImport _ = Nothing+ esFrom f = maybe [] M.elems $ M.lookup (nameOf n) (f pm)+listedEnt pm _ (IThingWith n cs) = esFrom dataDecls ++ esFrom classDecls+ where+ el f = M.lookup (nameOf n) $ f pm+ esFrom = maybe [] (\lk -> map (lookupEntity' lk . nameOf) cs) . el +-- -----------------------------------------------------------------------------+-- Exports +-- If the export list is unspecified but there is a function called+-- "main" defined, then it is defined as the export list (otherwise+-- all top-level items are exported).+instance ModuleItem (Maybe [ExportSpec]) where+ parseInfo Nothing = do pm <- getParsedModule+ fpm <- getFutureParsedModule+ el <- getLookup+ let mainFunc = M.lookup (Nothing,"main") el+ es = maybe (exportableEnts fpm) S.singleton mainFunc+ putParsedModule $ pm { exports = es }+ parseInfo (Just eps) = do pm <- getParsedModule+ fpm <- getFutureParsedModule+ let el = exportableLookup fpm+ es = mkSet $ map (listedExp fpm el) eps+ putParsedModule $ pm { exports = es } --- | Parsing the export list.-parseExports :: ModuleName -> [HsExportSpec] -> [Function]-parseExports m = catMaybes . map parseExport+-- Doesn't work on re-exported Class/Data specs.+listedExp :: ParsedModule -> EntityLookup+ -> ExportSpec -> [Entity]+listedExp _ el (EVar qn) = maybe [] (return . lookupEntity el)+ $ qName qn+listedExp _ _ EAbs{} = []+listedExp pm _ (EThingAll qn) = esFrom dataDecls ++ esFrom classDecls+ -- one will be empty where- -- We only care about exported functions.- parseExport (HsEVar qn) = fmap (setFuncModule m) $ hsName qn- parseExport _ = Nothing+ esFrom f = fromMaybe []+ $ do n <- liftM snd $ qName qn+ el <- M.lookup n $ f pm+ return $ M.elems el+listedExp pm _ (EThingWith qn cs) = esFrom dataDecls ++ esFrom classDecls+ where+ esFrom f = fromMaybe [] $ do mn <- fmap snd $ qName qn+ el <- M.lookup mn $ f pm+ return $ map (lookupEntity' el . nameOf) cs+listedExp pm _ (EModuleContents m) = fromMaybe []+ . fmap (S.toList . importedEnts)+ . M.lookup (createModule' m)+ $ imports pm --- | Parse the contents of the module. For each stand-alone function,--- return it along with all other known functions that it calls.-functionCalls :: ModuleName -> FunctionLookup -> [HsDecl]- -> [(Function, [Function])]-functionCalls m fl ds = catMaybes $ map (functionCall m fl) ds+-- -----------------------------------------------------------------------------+-- Main part of the module --- | Parse an individual 'HsDecl'. We only parse 'HsFunBind' and 'HsPatBind'--- declarations, as they're the only ones that define stand-alone functions.-functionCall :: ModuleName -> FunctionLookup -> HsDecl- -> Maybe (Function, [Function])-functionCall m fl d@(HsFunBind {}) = fmap (flip (,) calls) nm+instance ModuleItem Decl where+ -- Type alias+ parseInfo TypeDecl{} = return ()+ -- Type Families: don't seem to have any entities.+ parseInfo TypeFamDecl{} = return ()+ -- Data or Newtype+ parseInfo (DataDecl _ _ _ nm _ cs _)+ = do let d = nameOf nm+ els <- mapM (addConstructor d . unQConDecl) cs+ pm <- getParsedModule+ let el = M.unions els+ dds' = M.insert d el $ dataDecls pm+ putParsedModule $ pm { dataDecls = dds' }+ -- GADT-style Data or Newtype+ parseInfo (GDataDecl _ _ _ n _ _ gds _)+ = do m <- getModuleName+ pm <- getParsedModule+ let d = nameOf n+ el = addGConstructors m d gds+ dds' = M.insert d el $ dataDecls pm+ putParsedModule $ pm { dataDecls = dds' }+ -- Data Families: don't seem to have any entities+ parseInfo DataFamDecl{} = return ()+ -- Type families are basically aliases...+ parseInfo TypeInsDecl{} = return ()+ -- Data family instances are pretty much data declarations+ -- Don't add them yet, as can't necessarily go from Type -> Name+ -- todo+ parseInfo DataInsDecl{} = return ()+ -- Same thing as above+ -- todo+ parseInfo GDataInsDecl{} = return ()+ -- Defining a new class+ parseInfo (ClassDecl _ _ n _ _ cds)+ = do let c = nameOf n+ mels <- mapM (addClassDecl c) cds+ pm <- getParsedModule+ let el = M.unions $ catMaybes mels+ cl' = M.insert c el $ classDecls pm+ putParsedModule $ pm { classDecls = cl' }+ -- Instance of a class+ parseInfo (InstDecl _ _ n ts ids)+ = do let c = snd . fromJust $ qName n+ d = unwords $ map prettyPrint ts+ mapM_ (addInstDecl c d) ids+ -- Stand-alone deriving+ parseInfo DerivDecl{} = return ()+ -- Fixity of infix operators+ parseInfo InfixDecl{} = return ()+ -- Default types (Integer, etc.)+ parseInfo DefaultDecl{} = return ()+ -- TH Splicing+ parseInfo SpliceDecl{} = return ()+ -- Type sigs... use the actual function+ parseInfo TypeSig{} = return ()+ -- Actual Function+ parseInfo (FunBind ms) = mapM_ addMatch ms+ -- Defining a variable, etc.+ parseInfo pb@PatBind{}+ = do mn <- getModuleName+ el <- getLookup+ pm <- getParsedModule+ (d,c) <- getDecl pb -- Might as well use this+ -- We can have more than one definition from here, unlike+ -- for Matches.+ let vs = S.map snd d+ mkE v = Ent mn v NormalEntity+ es = S.map mkE vs+ es' = MS.fromList $ S.toList es+ mkFC e o = FC e (lookupEntity el o) NormalCall+ mkFCs o = MS.map (flip mkFC o) es'+ cs = MS.unions . map mkFCs $ MS.toList c+ pm' = pm { topEnts = topEnts pm `S.union` es+ , funcCalls = funcCalls pm `MS.union` cs+ }+ putParsedModule pm'+ -- The rest are foreign import/export and pragmas+ parseInfo _ = return ()++-- -----------------------------------------------------------------------------+-- Constructors++unQConDecl :: QualConDecl -> ConDecl+unQConDecl (QualConDecl _ _ _ cd) = cd++addConstructor :: DataType -> ConDecl -> PState EntityLookup+addConstructor d (ConDecl n _) = do m <- getModuleName+ let n' = nameOf n+ e = Ent m n' (Constructor d)+ return $ M.singleton (Nothing,n') e+addConstructor d (InfixConDecl _ n _) = do m <- getModuleName+ let n' = nameOf n+ e = Ent m n' (Constructor d)+ return $ M.singleton (Nothing,n') e+addConstructor d (RecDecl n rbs) = do m <- getModuleName+ pm <- getParsedModule+ let n' = nameOf n+ ce = Ent m n' (Constructor d)+ rs = map nameOf $ concatMap fst rbs+ res = map (mkRe m) rs+ es = ce : res+ fcs = MS.fromList $ map (mkFc ce) res+ putParsedModule $ addFcs pm fcs+ return $ mkEl es where- nm = listToMaybe . setFuncModules m $ functionNames d- calls = lookupFunctions fl $ hsNames d-functionCall m fl d@(HsPatBind {}) = fmap (flip (,) calls) nm+ mkRe m r = Ent m r (RecordFunction d)+ mkFc c r = FC r c RecordConstructor+ addFcs pm fcs = pm { funcCalls = fcs `MS.union` funcCalls pm }++-- -----------------------------------------------------------------------------+-- GADT constructors++addGConstructors :: ModName -> DataType -> [GadtDecl] -> EntityLookup+addGConstructors m d = mkEl . map addGConst where- nm = listToMaybe . setFuncModules m $ functionNames d- calls = lookupFunctions fl $ hsNames d-functionCall _ _ _ = Nothing+ addGConst (GadtDecl _ n _) = Ent m (nameOf n) (Constructor d) -- -----------------------------------------------------------------------------+-- Class declaration --- Utility functions.+addClassDecl :: ClassName -> ClassDecl+ -> PState (Maybe EntityLookup)+addClassDecl c (ClsDecl d) = addCDecl c d+addClassDecl _ _ = return Nothing --- | Extract the actual name of the 'Module'.-modName :: Module -> String-modName (Module m) = m+addCDecl :: ClassName -> Decl -> PState (Maybe EntityLookup)+addCDecl c (TypeSig _ ns _) = do m <- getModuleName+ let ns' = map nameOf ns+ eTp = ClassFunction c+ es = map (\n -> Ent m n eTp) ns'+ return $ Just (mkEl es)+addCDecl c (FunBind ms) = mapM_ (addCMatch c) ms >> return Nothing --- | A true list-difference function. The default '\\\\' function only deletes--- the first instance of each value, this deletes /all/ of them.-diff :: (Eq a) => [a] -> [a] -> [a]-diff xs ys = filter (not . flip elem ys) xs+addCDecl c pb@PatBind{} = do mn <- getModuleName+ el <- getLookup+ pm <- getParsedModule+ (d,cs) <- getDecl pb+ let vs = S.map snd d+ -- Class-based entities+ mkI n = Ent mn n (DefaultInstance c)+ mkC n = Ent mn n (ClassFunction c)+ cis = S.map (\n -> (mkC n, mkI n)) vs+ -- Instance Decls+ iDcls = S.map snd cis `S.union` instDecls pm+ cis' = MS.fromList $ S.toList cis+ -- DefInst calls+ mkiCl(t,f) = FC f t DefaultInstDeclaration+ ciCls = MS.map mkiCl cis'+ -- Calls for that instance+ is = MS.map snd cis'+ mkFC i o = FC i (lookupEntity el o) NormalCall+ mkFCs o = MS.map (flip mkFC o) is+ cs' = MS.unions . map mkFCs $ MS.toList cs+ pm' = pm { instDecls = iDcls+ , funcCalls = funcCalls pm+ `MS.union` ciCls+ `MS.union` cs'+ }+ putParsedModule pm'+ return Nothing+-- Can't have anything else in classes+addCDecl _ _ = return Nothing --- | Specify the qualification that this function was imported with.-addQual :: String -> Function -> Function-addQual q f = f { qualdBy = Just q }+addCMatch :: ClassName -> Match -> PState ()+addCMatch c m = do el <- getLookup+ di <- addFuncCalls (DefaultInstance c) m+ pm <- getParsedModule+ let cfn = name di+ cf = lookupEntity' el cfn+ dic = FC cf di DefaultInstDeclaration+ pm' = pm { instDecls = S.insert di $ instDecls pm+ , funcCalls = MS.insert dic $ funcCalls pm+ }+ putParsedModule pm' -- -----------------------------------------------------------------------------+-- Instance Declaration --- | Parsing of names, identifiers, etc.+addInstDecl :: ClassName -> DataType -> InstDecl -> PState ()+addInstDecl c d (InsDecl decl) = do cs <- addIDecl c d decl+ mn <- getModuleName+ pm <- getParsedModule+ let fromThisMod = (==) mn . inModule+ cs' = S.filter (not . fromThisMod) cs+ pm' = pm { virtualEnts = virtualEnts pm+ `S.union`+ cs'+ }+ putParsedModule pm'+addInstDecl _ _ _ = return () -nameOf :: HsName -> String-nameOf (HsIdent i) = i-nameOf (HsSymbol s) = s+addIDecl :: ClassName -> DataType -> Decl -> PState (Set Entity)+addIDecl c d (FunBind ms) = liftM S.fromList $ mapM (addIMatch c d) ms+addIDecl c d pb@PatBind{} = do mn <- getModuleName+ el <- getLookup+ pm <- getParsedModule+ (df,cs) <- getDecl pb+ let vs = S.map snd df+ -- Class-based entities+ mkI n = Ent mn n (ClassInstance c d)+ mkC = classFuncLookup c el+ cis = S.map (\n -> (mkC n, mkI n)) vs+ -- Instance Decls+ iDcls = S.map snd cis `S.union` instDecls pm+ cis' = MS.fromList $ S.toList cis+ -- DefInst calls+ mkiCl(t,f) = FC f t InstanceDeclaration+ ciCls = MS.map mkiCl cis'+ -- Calls for that instance+ is = MS.map snd cis'+ mkFC i o = FC i (lookupEntity el o) NormalCall+ mkFCs o = MS.map (flip mkFC o) is+ cs' = MS.unions . map mkFCs $ MS.toList cs+ pm' = pm { instDecls = iDcls+ , funcCalls = funcCalls pm+ `MS.union` ciCls+ `MS.union` cs'+ }+ putParsedModule pm'+ return $ S.map fst cis+addIDecl _ _ _ = return S.empty --- The class of parsed items which represent a single element.-class HsItem f where- hsName :: f -> Maybe Function+addIMatch :: ClassName -> DataType -> Match -> PState Entity+addIMatch c d m = do el <- getLookup+ fi <- addFuncCalls (ClassInstance c d) m+ pm <- getParsedModule+ let cfn = name fi+ cf = classFuncLookup c el cfn+ ic = FC cf fi InstanceDeclaration+ pm' = pm { instDecls = S.insert fi $ instDecls pm+ , funcCalls = MS.insert ic $ funcCalls pm+ }+ putParsedModule pm'+ return cf -instance HsItem HsName where- hsName nm = Just $ defFunc (nameOf nm)+classFuncLookup :: ClassName -> EntityLookup -> EntityName -> Entity+classFuncLookup c el n = case inModule e of+ UnknownMod -> e { eType = ClassFunction c }+ _ -> e+ where+ e = lookupEntity' el n --- Implicit parameters-instance HsItem HsIPName where- hsName (HsIPDup v) = Just $ defFunc v- hsName (HsIPLin v) = Just $ defFunc v+-- -----------------------------------------------------------------------------+-- For top-level functions --- Qualified variables and constructors-instance HsItem HsQName where- hsName (Qual m nm) = fmap (addQual (modName m)) (hsName nm)- hsName (UnQual nm) = hsName nm- -- inbuilt special syntax, e.g. [], (,), etc.- hsName (Special _) = Nothing+addMatch :: Match -> PState ()+addMatch m = do e <- addFuncCalls NormalEntity m+ pm <- getParsedModule+ putParsedModule $ pm { topEnts = S.insert e $ topEnts pm } --- Infix operators.-instance HsItem HsQOp where- hsName (HsQVarOp qn) = hsName qn- hsName (HsQConOp qn) = hsName qn+-- ----------------------------------------------------------------------------- --- Operators in infix declarations-instance HsItem HsOp where- hsName (HsVarOp nm) = hsName nm- hsName (HsConOp nm) = hsName nm+-- Add the appropriate 'FunctionCall' values and return the created+-- 'Entity'. The 'FunctionCall's have @callType = NormalCall@.+addFuncCalls :: EntityType -> Match -> PState Entity+addFuncCalls et m = do mn <- getModuleName+ el <- getLookup+ pm <- getParsedModule+ (d,c) <- getMatch m+ let nm = snd $ S.findMin d+ f = Ent { inModule = mn+ , name = nm -- Assume non-qualified...+ , eType = et+ }+ cs = MS.map (mkFC el f) c+ pm' = pm { funcCalls = cs `MS.union` funcCalls pm }+ putParsedModule pm'+ return f+ where+ mkFC el l qn = FC l (lookupEntity el qn) NormalCall --- Items in import statements-instance HsItem HsCName where- hsName (HsVarName nm) = hsName nm- hsName (HsConName nm) = hsName nm+-- ----------------------------------------------------------------------------- --- We don't care about literals-instance HsItem HsLiteral where- hsName _ = Nothing+-- Pulling apart sub-components --------------------------------------------------------------------------------+-- None of these really need PState... I thought they did mid-write,+-- refactored them all to use it and then after I'd finished realised+-- they didn't. Too late to change, so they can stay this way. --- | Functions, blocks, etc.+type Defined = Set QEntityName+type Called = MultiSet QEntityName+type DefCalled = (Defined, Called) -class HsItemList vs where- hsNames :: vs -> [Function]+getMatch :: Match -> PState DefCalled+getMatch (Match _ n ps _ rhs bs) = do (avs, afs) <- getPats ps+ rcs <- getRHS rhs+ (bds, bcs) <- getBindings bs+ let vs = avs `S.union` bds+ fs = MS.unions [afs, rcs, bcs]+ cs = defElsewhere fs vs+ return (S.singleton $ nameOf' n, cs) --- | A \"compatibility\" function to pseudo-convert an instance of 'HsItem'--- into one that acts like one from 'HsItemList'-hsName' :: (HsItem i) => i -> [Function]-hsName' i = maybeToList (hsName i)+-- In a pattern, all variables are ones that have just been defined to+-- use in that function, etc.+getPat :: Pat -> PState DefCalled+-- Variable+getPat (PVar n) = return $ onlyVar n+-- Literal value+getPat PLit{} = return noEnts+-- Negation of a Pat value+getPat (PNeg p) = getPat p+-- n + k pattern+getPat (PNPlusK n _) = return $ onlyVar n+-- e.g. a : as+getPat (PInfixApp p1 c p2) = do (v1, c1) <- getPat p1+ (v2, c2) <- getPat p2+ return ( v1 `S.union` v2+ , insQName c $ c1 `MS.union` c2)+-- Data constructor + args+getPat (PApp qn ps) = liftM (second $ insQName qn) $ getPats ps+-- Tuple+getPat (PTuple ps) = getPats ps+-- Explicit list+getPat (PList ps) = getPats ps+-- Parens around a Pat+getPat (PParen p) = getPat p+-- Record pattern+getPat (PRec q ps) = liftM (second (insQName q) . sMsUnions)+ $ mapM getPField ps+-- @-pattern+getPat (PAsPat n p) = liftM (sMsMerge (onlyVar n)) $ getPat p+-- _+getPat PWildCard = return noEnts+-- ~pat+getPat (PIrrPat p) = getPat p+-- pattern with explicit type-sig+getPat (PatTypeSig _ p _) = getPat p+-- View pattern (function -> constructor) [this avoids an explicit+-- case statement]+getPat (PViewPat e p) = do ec <- getExp e+ (pd,pc) <- getPat p+ return (pd, ec `MS.union` pc)+-- HaRP... no idea now to deal with this+getPat PRPat{} = return noEnts+-- !foo+getPat (PBangPat p) = getPat p+-- The rest are XML and TH patterns+getPat _ = return noEnts --- A list of 'HsItemList' instances can be treated as a single instance.-instance (HsItemList vs) => HsItemList [vs] where- hsNames vss = concatMap hsNames vss+getPats :: [Pat] -> PState DefCalled+getPats = liftM sMsUnions . mapM getPat -instance HsItemList HsPat where- hsNames (HsPVar var) = hsName' var- hsNames (HsPLit _) = []- hsNames (HsPNeg pat) = hsNames pat- hsNames (HsPInfixApp pat1 _ pat2) = (hsNames pat1)- ++ (hsNames pat2)- hsNames (HsPApp _ pats) = hsNames pats- hsNames (HsPTuple pats) = hsNames pats- hsNames (HsPList pats) = hsNames pats- hsNames (HsPParen pat) = hsNames pat- hsNames (HsPRec _ pfields) = hsNames pfields- hsNames (HsPAsPat nm pat) = hsName' nm- ++ hsNames pat- hsNames HsPWildCard = []- hsNames (HsPIrrPat pat) = hsNames pat- -- Ignore HaRP and Hsx extensions for now- hsNames _ = []+insQName :: QName -> Called -> Called+insQName qn sq = maybe sq (flip MS.insert sq) $ qName qn -instance HsItemList HsPatField where- hsNames (HsPFieldPat _ pat) = hsNames pat+onlyVar :: (Named n) => n -> DefCalled+onlyVar n = (S.singleton $ nameOf' n, MS.empty) -instance HsItemList HsBinds where- hsNames (HsBDecls dcls) = hsNames dcls- hsNames (HsIPBinds ibs) = hsNames ibs+-- Punned fields: not registered as variables+-- Record wildcards: nothing returned+getPField :: PatField -> PState DefCalled+getPField (PFieldPat qn p) = liftM (second $ insQName qn) $ getPat p+getPField (PFieldPun n) = return (S.empty, MS.singleton $ nameOf' n)+getPField PFieldWildcard = return noEnts -instance HsItemList HsExp where- hsNames (HsVar qn) = hsName' qn- hsNames (HsIPVar ip) = hsName' ip- hsNames (HsCon _) = []- hsNames (HsLit _) = []- hsNames (HsInfixApp e1 q e2) = hsName' q- ++ hsNames e1 ++ hsNames e2- hsNames (HsApp e1 e2) = hsNames e1 ++ hsNames e2- hsNames (HsNegApp e) = hsNames e- hsNames (HsLambda _ ps e) = (hsNames e) `diff` (hsNames ps)- hsNames (HsLet bs e) = (hsNames bs ++ hsNames e)- `diff` (functionNames bs)- hsNames (HsDLet ips e) = (hsNames ips ++ hsNames e)- `diff` (functionNames ips)- hsNames (HsWith e ips) = (hsNames ips ++ hsNames e)- `diff` (functionNames ips)- hsNames (HsIf i t e) = hsNames [i,t,e]- hsNames (HsCase e as) = hsNames e ++ hsNames as- hsNames (HsDo stmts) = hsNames stmts- hsNames (HsMDo stmts) = hsNames stmts- hsNames (HsTuple es) = hsNames es- hsNames (HsList es) = hsNames es- hsNames (HsParen e) = hsNames e- hsNames (HsLeftSection e qop) = hsNames e ++ hsName' qop- hsNames (HsRightSection qop e) = hsNames e ++ hsName' qop- hsNames (HsRecConstr _ flds) = hsNames flds- hsNames (HsRecUpdate e flds) = hsNames e ++ hsNames flds- hsNames (HsEnumFrom f) = hsNames f- hsNames (HsEnumFromTo f t) = hsNames [f,t]- hsNames (HsEnumFromThen f th) = hsNames [f,th]- hsNames (HsEnumFromThenTo f th t) = hsNames [f,th,t]- hsNames (HsListComp e stmts) = let svars = functionNames stmts- e' = hsNames e ++ hsNames stmts- in e' `diff` svars- hsNames (HsExpTypeSig _ e _) = hsNames e- hsNames (HsAsPat _ _) = [] -- something for FunctionNames?- hsNames (HsIrrPat _) = []- -- For now, ignore HaRP, TH and Hsx stuff- hsNames _ = []+-- Still have to take care of function calls here somewhere...+-- Nope: trying to get the overall list of functions called here...+-- and _then_ create function calls to them! -instance HsItemList HsFieldUpdate where- hsNames (HsFieldUpdate _ e) = hsNames e+getBindings :: Binds -> PState DefCalled+getBindings (BDecls ds) = liftM sMsUnions $ mapM getDecl ds+getBindings (IPBinds is) = liftM sMsUnions $ mapM getIPBinds is -instance HsItemList HsAlt where- hsNames (HsAlt _ pats rhs bnds) = (rhs' ++ bnds')- `diff` (lhs ++ bndNames)- where- lhs = hsNames pats- bndNames = functionNames bnds- bnds' = hsNames bnds- rhs' = hsNames rhs+getIPBinds :: IPBind -> PState DefCalled+getIPBinds (IPBind _ _ e) = liftM noDefs $ getExp e -instance HsItemList HsGuardedAlts where- hsNames (HsUnGuardedAlt e) = hsNames e- hsNames (HsGuardedAlts gas) = hsNames gas+getDecl :: Decl -> PState DefCalled+getDecl (FunBind ms) = liftM sMsUnions $ mapM getMatch ms+getDecl (PatBind _ p _ r bs) = do (pd,pc) <- getPat p+ rc <- getRHS r+ (bd,bc) <- getBindings bs+ let fs = MS.unions [pc, rc, bc]+ cs = defElsewhere fs bd+ return (pd, cs)+getDecl _ = return noEnts -instance HsItemList HsGuardedAlt where- hsNames (HsGuardedAlt _ stmts e) = e' `diff` svars- where- svars = functionNames stmts- e' = hsNames e ++ hsNames stmts -instance HsItemList HsDecl where- hsNames (HsFunBind ms) = hsNames ms- hsNames (HsPatBind _ _ rhs bds) = (bds' ++ rhs') `diff` rNames- where- rNames = functionNames bds- bds' = hsNames bds- rhs' = hsNames rhs- hsNames _ = []+getRHS :: Rhs -> PState Called+getRHS (UnGuardedRhs e) = getExp e+getRHS (GuardedRhss grs) = liftM MS.unions $ mapM getGRhs grs +getGRhs :: GuardedRhs -> PState Called+getGRhs (GuardedRhs _ ss e) = do (sf,sc) <- getStmts ss+ ec <- getExp e+ return $ defElsewhere' sf (sc `MS.union` ec) -instance HsItemList HsMatch where- hsNames (HsMatch _ _ pats rhs bnds) = (rhs' ++ bnds')- `diff` (lhs ++ bndNames)- where- lhs = hsNames pats- bndNames = functionNames bnds- bnds' = hsNames bnds- rhs' = hsNames rhs+-- Gah, this might be wrong... -instance HsItemList HsRhs where- hsNames (HsUnGuardedRhs e) = hsNames e- hsNames (HsGuardedRhss rs) = hsNames rs+getExp :: Exp -> PState Called+getExp (Var qn) = return $ maybeEnt qn+getExp IPVar{} = return MS.empty+getExp (Con qn) = return $ maybeEnt qn+getExp Lit{} = return MS.empty+getExp (InfixApp e1 o e2) = do e1' <- getExp e1+ e2' <- getExp e2+ let o' = maybeEnt o+ return $ e1' `MS.union` e2' `MS.union` o'+getExp (App ef vf) = liftM2 MS.union (getExp ef) (getExp vf)+getExp (NegApp e) = getExp e+getExp (Lambda _ ps e) = do (pd,pc) <- getPats ps+ e' <- getExp e+ return $ defElsewhere' pd+ $ MS.union pc e'+getExp (Let bs e) = do (bd,bc) <- getBindings bs+ e' <- getExp e+ return $ defElsewhere' bd (MS.union bc e')+getExp (If i t e) = getExps [i,t,e]+getExp (Case e as) = do e' <- getExp e+ as' <- mapM getAlt as+ return $ MS.unions (e':as')+getExp (Do ss) = chainedCalled $ map getStmt ss+getExp (MDo ss) = liftM (uncurry defElsewhere') $ getStmts ss+getExp (Tuple es) = getExps es+getExp (TupleSection mes) = getExps $ catMaybes mes+getExp (List es) = getExps es+getExp (Paren e) = getExp e+getExp (LeftSection e o) = liftM (MS.union (maybeEnt o)) $ getExp e+getExp (RightSection o e) = liftM (MS.union (maybeEnt o)) $ getExp e+getExp (RecConstr qn fus) = liftM (MS.union (maybeEnt qn)) $ getFUpdates fus+getExp (RecUpdate e fus) = liftM2 MS.union (getExp e) (getFUpdates fus)+getExp (EnumFrom e) = getExp e+getExp (EnumFromTo e1 e2) = liftM2 MS.union (getExp e1) (getExp e2)+getExp (EnumFromThen e1 e2) = liftM2 MS.union (getExp e1) (getExp e2)+getExp (EnumFromThenTo e1 e2 e3) = liftM2 MS.union (getExp e1)+ $ liftM2 MS.union (getExp e2) (getExp e3)+getExp (ListComp e qss) = liftM2 MS.union (getExp e) $ getQStmts qss+getExp (ParComp e qsss) = liftM2 MS.union (getExp e) . liftM MS.unions+ $ mapM getQStmts qsss+getExp (ExpTypeSig _ e _) = getExp e+getExp (VarQuote qn) = return $ maybeEnt qn+getExp (Proc p e) = do (pd,pc) <- getPat p+ c <- getExp e+ return $ pc `MS.union` defElsewhere c pd+getExp (RightArrApp e1 e2) = liftM2 MS.union (getExp e1) (getExp e2)+getExp (LeftArrApp e1 e2) = liftM2 MS.union (getExp e1) (getExp e2)+getExp (RightArrHighApp e1 e2) = liftM2 MS.union (getExp e1) (getExp e2)+getExp (LeftArrHighApp e1 e2) = liftM2 MS.union (getExp e1) (getExp e2)+-- Everything else is TH, XML or Pragmas+getExp _ = return MS.empty -instance HsItemList HsGuardedRhs where- hsNames (HsGuardedRhs _ stmts e) = e' `diff` svars- where- svars = functionNames stmts- e' = hsNames e ++ hsNames stmts+getExps :: [Exp] -> PState Called+getExps = liftM MS.unions . mapM getExp -instance HsItemList HsStmt where- hsNames (HsGenerator _ _ e) = hsNames e- hsNames (HsQualifier e) = hsNames e- hsNames (HsLetStmt bnds) = hsNames bnds+chainedCalled :: [PState DefCalled] -> PState Called+chainedCalled = foldrM go MS.empty+ where+ go s cs = liftM (rmVars cs) s+ rmVars cs (d,c) = defElsewhere cs d `MS.union` c -instance HsItemList HsIPBind where- hsNames (HsIPBind _ ip e) = e' `diff` ip'- where- ip' = hsName' ip- e' = hsNames e+getQStmt :: QualStmt -> PState DefCalled+getQStmt (QualStmt s) = getStmt s+getQStmt (ThenTrans e) = liftM noDefs $ getExp e+getQStmt (ThenBy e1 e2) = liftM noDefs $ liftM2 MS.union (getExp e1) (getExp e2)+getQStmt (GroupBy e) = liftM noDefs $ getExp e+getQStmt (GroupUsing e) = liftM noDefs $ getExp e+getQStmt (GroupByUsing e1 e2) = liftM noDefs+ $ liftM2 MS.union (getExp e1) (getExp e2) +getQStmts :: [QualStmt] -> PState Called+getQStmts = chainedCalled . map getQStmt++getFUpdates :: [FieldUpdate] -> PState Called+getFUpdates = liftM MS.unions . mapM getFUpdate++getFUpdate :: FieldUpdate -> PState Called+getFUpdate (FieldUpdate qn e) = liftM (MS.union (maybeEnt qn)) $ getExp e+getFUpdate (FieldPun n) = return . MS.singleton $ nameOf' n+getFUpdate _ = return MS.empty++getAlt :: Alt -> PState Called+getAlt (Alt _ p gas bs) = do (pd,pc) <- getPat p+ gc <- getGAlts gas+ (bd,bc) <- getBindings bs+ let d = pd `S.union` bd+ c = pc `MS.union` gc `MS.union` bc+ return $ defElsewhere c d++getGAlts :: GuardedAlts -> PState Called+getGAlts (UnGuardedAlt e) = getExp e+getGAlts (GuardedAlts gas) = liftM MS.unions $ mapM getGAlt gas++getGAlt :: GuardedAlt -> PState Called+getGAlt (GuardedAlt _ ss e) = do (sf, sc) <- getStmts ss+ ec <- getExp e+ return $ defElsewhere' sf (MS.union sc ec)++getStmt :: Stmt -> PState DefCalled+getStmt (Generator _ p e) = do (pf,pc) <- getPat p+ ec <- getExp e+ return (pf, defElsewhere' pf (MS.union pc ec))+getStmt (Qualifier e) = liftM noDefs $ getExp e+getStmt (LetStmt bs) = getBindings bs+getStmt (RecStmt ss) = getStmts ss++getStmts :: [Stmt] -> PState DefCalled+getStmts = liftM sMsUnions . mapM getStmt++noDefs :: Called -> DefCalled+noDefs = (,) S.empty++maybeEnt :: (QNamed a) => a -> Called+maybeEnt = maybe MS.empty MS.singleton . qName++noEnts :: DefCalled+noEnts = (S.empty, MS.empty)+ -- ----------------------------------------------------------------------------- --- | Those parsed elements that represent a function.-class FunctionNames fn where- functionNames :: fn -> [Function]+class Named a where+ nameOf :: a -> String -instance (FunctionNames fn) => FunctionNames [fn] where- functionNames = concatMap functionNames+instance Named Name where+ nameOf (Ident n) = n+ nameOf (Symbol n) = n -instance FunctionNames HsStmt where- functionNames (HsGenerator _ p _) = hsNames p- functionNames (HsQualifier _) = []- functionNames (HsLetStmt bnds) = functionNames bnds+nameOf' :: (Named n) => n -> QEntityName+nameOf' = (,) Nothing . nameOf -instance FunctionNames HsMatch where- functionNames (HsMatch _ nm _ _ _) = hsName' nm+instance Named CName where+ nameOf (VarName n) = nameOf n+ nameOf (ConName n) = nameOf n -instance FunctionNames HsDecl where- functionNames (HsFunBind ms) = functionNames ms- functionNames (HsPatBind _ p _ _) = hsNames p- functionNames _ = []+instance Named ModuleName where+ nameOf (ModuleName m) = m -instance FunctionNames HsBinds where- functionNames (HsBDecls decls) = functionNames decls- functionNames (HsIPBinds bnds) = functionNames bnds+-- | Create the 'ModName'.+createModule' :: ModuleName -> ModName+createModule' = createModule . nameOf -instance FunctionNames HsIPBind where- functionNames (HsIPBind _ ipn _) = hsName' ipn+class QNamed a where+ qName :: a -> Maybe QEntityName++instance QNamed QName where+ qName (Qual m n) = Just (Just $ nameOf m, nameOf n)+ qName (UnQual n) = Just (Nothing, nameOf n)+ qName Special{} = Nothing++instance QNamed QOp where+ qName (QVarOp qn) = qName qn+ qName (QConOp qn) = qName qn++sMsUnions :: (Ord a, Ord b) => [(Set a, MultiSet b)] -> (Set a, MultiSet b)+sMsUnions = (S.unions *** MS.unions) . unzip++sMsMerge :: (Ord a, Ord b) => (Set a, MultiSet b)+ -> (Set a, MultiSet b) -> (Set a, MultiSet b)+sMsMerge (s1, ms1) = S.union s1 *** MS.union ms1++defElsewhere :: Called -> Defined -> Called+defElsewhere ms s = MS.fromMap $ fs `M.difference` ifs+ where+ fs = MS.toMap ms+ ifs = M.fromList . map (flip (,) () ) $ S.toList s++defElsewhere' :: Defined -> Called -> Called+defElsewhere' = flip defElsewhere++-- -----------------------------------------------------------------------------
+ Parsing/State.hs view
@@ -0,0 +1,109 @@+{-+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>++This file is part of SourceGraph.++SourceGraph 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 : Parsing.State+ Description : State Monad for parsing.+ Copyright : (c) Ivan Lazar Miljenovic 2009+ License : GPL-3 or later.+ Maintainer : Ivan.Miljenovic@gmail.com++ Customised State Monad for parsing Haskell code.+ -}+module Parsing.State+ ( PState+ , runPState+ , getModules+ , getModuleNames+ , getLookup+ , getParsedModule+ , getFutureParsedModule+ , getModuleName+ , putParsedModule+ ) where++import Parsing.Types++-- -----------------------------------------------------------------------------++runPState :: ParsedModules -> ModuleNames+ -> ParsedModule -> PState a -> ParsedModule+runPState hms mns pm st = pm'+ where+ -- Tying the knot+ el = internalLookup pm'+ mp = MP hms mns el pm pm'+ pm' = parsedModule $ execState st mp++data ModuleParsing = MP { moduleLookup :: ParsedModules+ , modNmsLookup :: ModuleNames+ , entityLookup :: EntityLookup+ , parsedModule :: ParsedModule+ , futureParsedModule :: ParsedModule+ }++newtype PState value+ = PS { runState :: ModuleParsing -> (value, ModuleParsing) }++instance Monad PState where+ return v = PS (\ps -> (v,ps))++ x >>= f = PS $ \ps -> let (r, ps') = runState x ps+ in runState (f r) ps'+++getModules :: PState ParsedModules+getModules = gets moduleLookup++getModuleNames :: PState ModuleNames+getModuleNames = gets modNmsLookup++getLookup :: PState EntityLookup+getLookup = gets entityLookup++getParsedModule :: PState ParsedModule+getParsedModule = gets parsedModule++getFutureParsedModule :: PState ParsedModule+getFutureParsedModule = gets futureParsedModule++getModuleName :: PState ModName+getModuleName = gets (moduleName . parsedModule)++putParsedModule :: ParsedModule -> PState ()+putParsedModule pm = modify (\ s -> s { parsedModule = pm } )+++get :: PState ModuleParsing+get = PS (\s -> (s,s))++put :: ModuleParsing -> PState ()+put s = PS (const ((), s))++execState :: PState value -> ModuleParsing -> ModuleParsing+execState s = snd . runState s++modify :: (ModuleParsing -> ModuleParsing) -> PState ()+modify f = do s <- get+ put (f s)++gets :: (ModuleParsing -> value) -> PState value+gets f = do s <- get+ return (f s)
Parsing/Types.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE MultiParamTypeClasses- , TypeSynonymInstances- #-}+{-# LANGUAGE TypeFamilies #-} {--Copyright (C) 2008 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>+Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> This file is part of SourceGraph. @@ -25,7 +23,7 @@ {- | Module : Parsing.Types Description : Types for parsing Haskell code.- Copyright : (c) Ivan Lazar Miljenovic 2008+ Copyright : (c) Ivan Lazar Miljenovic 2009 License : GPL-3 or later. Maintainer : Ivan.Miljenovic@gmail.com @@ -33,159 +31,423 @@ -} module Parsing.Types where -import Data.Graph.Analysis.Types+import Data.Graph.Analysis.Types( ClusterLabel(..)+ , ClusterType(..)+ , Rel)+import Data.Graph.Analysis.Reporting(unDotPath)+import Data.GraphViz(GraphID(..), NodeCluster(..))+import Data.Graph.Inductive.Graph(LNode) -import Data.Maybe+import Data.Char(isLetter, isDigit)+import Data.List(intercalate)+import Data.Maybe(fromMaybe, isJust) import qualified Data.Map as M import Data.Map(Map)-import Control.Arrow(first)+import qualified Data.Set as S+import Data.Set(Set)+import qualified Data.MultiSet as MS+import Data.MultiSet(MultiSet)+import qualified Data.Foldable as F -- ----------------------------------------------------------------------------- --- | A high-level viewpoint of a Haskell module.-data HaskellModule = Hs { moduleName :: ModuleName- , imports :: [ModuleName]- , exports :: [Function]- , functions :: FunctionCalls- }+data ParsedModule = PM { moduleName :: ModName+ , imports :: ImpLookup+ , exports :: Set Entity+ , dataDecls :: DataDecs+ , classDecls :: ClassDecs+ -- These aren't real defined functions+ , instDecls :: Set Entity+ , topEnts :: Set Entity+ , virtualEnts :: Set Entity -- used for+ -- drawing+ -- this module+ , funcCalls :: MultiSet FunctionCall -- We want each+ -- function+ -- call made,+ -- including duplicates.+ }+ deriving (Eq, Ord, Show, Read) +blankPM :: ParsedModule+blankPM = PM { moduleName = UnknownMod+ , imports = M.empty+ , exports = S.empty+ , dataDecls = M.empty+ , classDecls = M.empty+ , instDecls = S.empty+ , topEnts = S.empty+ , virtualEnts = S.empty+ , funcCalls = MS.empty+ }++-- | Creates an 'EntityLookup' for the purposes of determining which+-- 'Entity's are exported from this module.+exportLookup :: ParsedModule -> EntityLookup+exportLookup = mkLookup' . exports++-- -----------------------------------------------------------------------------++type EntityLookup = Map QEntityName Entity++mkEl :: [Entity] -> EntityLookup+mkEl = M.fromList . map (\e -> ((Nothing, name e), e))++-- | The 'EntityLookup' for use within a module; combines imports with+-- what is defined in the module.+internalLookup :: ParsedModule -> EntityLookup+internalLookup pm = M.union imported internal+ where+ imported = importsLookup . M.elems $ imports pm+ internal = exportableLookup pm++-- | The defined stand-alone 'Entity's from this module.+exportableLookup :: ParsedModule -> EntityLookup+exportableLookup pm = M.unions [ decLookup+ , clLookup+ , defLookup+ ]+ where+ decLookup = getLookups dataDecls pm+ clLookup = getLookups classDecls pm+ defLookup = mkLookup' $ topEnts pm++-- | Create an 'EntityLookup' from a particular part of a 'ParsedModule'.+getLookups :: (ParsedModule -> Map String EntityLookup)+ -> ParsedModule -> EntityLookup+getLookups f = M.unions . M.elems . f++-- | Create an 'EntityLookup' using the given qualification for the+-- 'Set' of 'Entity's.+mkLookup :: EntQual -> Set Entity -> EntityLookup+mkLookup al = mergeMaps . S.map (\e -> M.singleton (al, name e) e)++mkLookup' :: Set Entity -> EntityLookup+mkLookup' = mkLookup Nothing++-- | Find the corresponding 'Entity' for the given name and qualification.+lookupEntity :: EntityLookup -> QEntityName -> Entity+lookupEntity el qn = fromMaybe unkn $ M.lookup qn el+ where+ unkn = Ent UnknownMod (snd qn) NormalEntity++-- | Find the corresponding 'Entity' for the given name with no qualification.+lookupEntity' :: EntityLookup -> EntityName -> Entity+lookupEntity' el = lookupEntity el . (,) Nothing++-- -----------------------------------------------------------------------------++ -- | A lookup-map of 'HaskellModule's.-type HaskellModules = Map ModuleName HaskellModule+type ParsedModules = Map ModName ParsedModule --- | Create the 'HaskellModules' lookup map from a list of 'HaskellModule's.-createModuleMap :: [HaskellModule] -> HaskellModules-createModuleMap = M.fromList . map (\m -> (moduleName m, m))+type ModuleNames = Map String ModName -modulesIn :: HaskellModules -> [ModuleName]-modulesIn = M.keys+createModuleMap :: [ParsedModule] -> ParsedModules+createModuleMap = M.fromList+ . map (\m -> (moduleName m, m)) -moduleImports :: HaskellModules -> [(ModuleName,ModuleName)]-moduleImports = concatMap mkEdges . M.assocs+{-+removeMod :: ParsedModules -> ModName -> ParsedModules+removeMod = flip M.delete+-}+modulesIn :: ParsedModules -> Set ModName+modulesIn = S.fromList . M.keys++moduleNames :: ParsedModules -> ModuleNames+moduleNames = M.fromList . map (\m -> (nameOfModule m, m))+ . M.keys++getModName :: ModuleNames -> String -> ModName+getModName mns nm = fromMaybe ext $ M.lookup nm mns where- mkEdges (m,hm) = map ((,) m) $ imports hm+ ext = ExtMod nm -hModulesIn :: HaskellModules -> [HaskellModule]-hModulesIn = M.elems+moduleRelationships :: Set ParsedModule -> Set (ModName, ModName)+moduleRelationships = setUnion . S.map mkEdges+ where+ mkEdges pm = S.fromList+ . map ((,) (moduleName pm) . fromModule)+ . M.elems+ $ imports pm+{-+hModulesIn :: ParsedModules -> Set ParsedModule+hModulesIn = S.fromList . M.elems+-} -getModule :: HaskellModules -> ModuleName -> Maybe HaskellModule+{-+getModule :: ParsedModules -> ModName -> Maybe ParsedModule getModule hm m = M.lookup m hm+-} -- ----------------------------------------------------------------------------- --- | The name of a module. The 'Maybe' component refers to the possible path--- of this module.-data ModuleName = M (Maybe String) String- deriving (Eq, Ord)+-- | The name of a module.+data ModName = LocalMod { modName :: String }+ | ExtMod { modName :: String }+ | UnknownMod+ deriving (Eq, Ord, Show, Read) -instance ClusterLabel ModuleName String where- cluster (M p _) = fromMaybe "Root directory" p- nodelabel (M _ m) = m+clusteredModule :: LNode ModName -> NodeCluster String String+clusteredModule (n,m) = go $ modulePathOf m+ where+ go [m'] = N (n,m')+ go (p:ps) = C p $ go ps+ go [] = error "Shouldn't be able to have an empty module name." --- | The seperator between components of a module.-moduleSep :: Char-moduleSep = '.'+instance ClusterType ModName where+ clusterID = Just . Str . unDotPath . nameOfModule --- | Split the module string into a path string and a name string.-splitMod :: String -> (String,String)-splitMod m = case (break (moduleSep ==) m) of- (m',"") -> ("",m')- (p,_:m') -> first (addPath p) $ splitMod m'+instance ClusterLabel ModName where+ type Cluster ModName = String+ type NodeLabel ModName = String --- | Add two path components together.-addPath :: String -> String -> String-addPath "" m = m-addPath p "" = p-addPath p m = p ++ (moduleSep : m)+ cluster = containingDir'+ nodeLabel = nameOfModule' -instance Show ModuleName where- show (M Nothing m) = m- show (M (Just dir) m) = addPath dir m+nameOfModule :: ModName -> String+nameOfModule UnknownMod = "Unknown Module"+nameOfModule mn = modName mn --- | Create the 'ModuleName' from its 'String' representation.-createModule :: String -> ModuleName-createModule m = case (splitMod m) of- (m',"") -> M Nothing m'- (d,m') -> M (Just d) m'+nameOfModule' :: ModName -> String+nameOfModule' = last . modulePathOf --- | A default module, used for when you haven't specified which module--- something belongs to yet.-unknownModule :: ModuleName-unknownModule = M Nothing "Module Not Found"+containingDir :: ModName -> String+containingDir = intercalate [moduleSep] . dirPath +containingDir' :: ModName -> String+containingDir' m = case containingDir m of+ "" -> "Project Root"+ dir -> dir++dirPath :: ModName -> [String]+dirPath = init . modulePathOf++modulePathOf :: ModName -> [String]+modulePathOf = splitSects . nameOfModule+ where+ splitSects mp = case break ((==) moduleSep) mp of+ (p,"") -> [p]+ (p,dmp) -> p : splitSects (tail dmp)+++-- | The seperator between components of a module.+moduleSep :: Char+moduleSep = '.'++-- | Create the 'ModName' from its 'String' representation.+createModule :: String -> ModName+createModule = LocalMod+ -- ----------------------------------------------------------------------------- +type ImpLookup = Map ModName ModImport+ -- | The import list of a module.-data HsImport = I { fromModule :: ModuleName- -- | How the module was imported, if it actually was.- , qualAs :: Maybe String- -- | The functions from this module that were imported.- , importList :: [Function]- }+data ModImport = I { fromModule :: ModName+ , importQuald :: Bool+ -- | Any alias used to import it. Should be Just+ -- foo if importQuald is True.+ , importedAs :: Maybe String+ -- | The functions from this module that were imported.+ , importedEnts :: Set Entity+ }+ deriving (Eq, Ord, Show, Read) +importsLookup :: [ModImport] -> EntityLookup+importsLookup = M.unions . map importLookup++importLookup :: ModImport -> EntityLookup+importLookup hi+ | importQuald hi = with+ | isJust alias = M.union with without -- alias, no qual+ | otherwise = without+ where+ es = importedEnts hi+ alias = importedAs hi+ with = mkLookup alias es+ without = mkLookup Nothing es+ -- ----------------------------------------------------------------------------- --- | Defines a function.-data Function = F { inModule :: ModuleName- , name :: String- , qualdBy :: Maybe String+data Entity = Ent { inModule :: ModName+ , name :: EntityName+ , eType :: EntityType }- deriving (Eq, Ord)+ deriving (Eq, Ord, Show, Read) -instance Show Function where- show f = addPath (show $ inModule f) (name f)+instance ClusterLabel Entity where+ type Cluster Entity = ModName+ type NodeLabel Entity = Entity -instance ClusterLabel Function ModuleName where cluster = inModule- nodelabel = name---- | Create a default function with using 'unknownModule'.-defFunc :: String -> Function-defFunc f = F unknownModule f Nothing+ nodeLabel = id --- | Set the module of this function.-setFuncModule :: ModuleName -> Function -> Function-setFuncModule m f = f { inModule = m }+clusterEntityM :: LNode Entity -> NodeCluster String Entity+clusterEntityM ln = modPathClust id ln (N ln) --- | Set the module of these functions.-setFuncModules :: ModuleName -> [Function] -> [Function]-setFuncModules m = map (setFuncModule m)+modPathClust :: (String -> a) -> LNode Entity+ -> NodeCluster a Entity -> NodeCluster a Entity+modPathClust f ln b = foldr ($) b $ map (C . f) p+ where+ p = modulePathOf . inModule $ snd ln --- | Defines a lookup map between the used qualifier and function name,--- and the actual /unqualified/ function.-type FunctionLookup = Map (Maybe String,String) Function+clusterEntityM' :: LNode Entity -> NodeCluster EntClustType Entity+clusterEntityM' ln = modPathClust ModPath ln (clusterEntity ln) --- | Create a 'FunctionLookup' map using the given functions.-createLookup :: [Function] -> FunctionLookup-createLookup = M.fromList . map addKey+clusterEntity :: LNode Entity -> NodeCluster EntClustType Entity+clusterEntity ln@(_,e) = setClust (N ln) where- addKey f = ((qualdBy f, name f), f)+ setClust = case eType e of+ (Constructor d) -> C $ DataDefn d+ (RecordFunction d) -> C $ DataDefn d+ (ClassFunction c) -> C $ ClassDefn c+ (DefaultInstance c) -> C (ClassDefn c) . C DefInst+ (ClassInstance c d) -> C (ClassDefn c) . C (ClassInst d)+ _ -> id --- | Try to lookup the given function.-functionLookup :: FunctionLookup -> Function -> Maybe Function-functionLookup fl f = M.lookup k fl- where- k = (qualdBy f, name f)+data EntClustType = ClassDefn ClassName+ | DataDefn DataType+ | ClassInst DataType+ | DefInst+ | ModPath String+ deriving (Eq, Ord, Show, Read) --- | Lookup the given functions, returning only those that are in the--- 'FunctionLookup' map.-lookupFunctions :: FunctionLookup -> [Function] -> [Function]-lookupFunctions fl = catMaybes . map (functionLookup fl)+ctypeID :: EntClustType -> Maybe GraphID+ctypeID (ClassDefn c) = Just . Str $ "Class_" ++ escID c+ctypeID (DataDefn d) = Just . Str $ "Data_" ++ escID d+ctypeID (ClassInst d) = Just . Str $ "Inst_For_" ++ escID d+ctypeID DefInst = Just . Str $ "DefaultInstance"+ctypeID (ModPath p) = Just . Str $ "Directory_" ++ escID p -type FunctionCalls = [(Function,[Function])]+escID :: String -> String+escID = filter (\c -> isLetter c || isDigit c || c == '_') --- | Get every function call as a pair.-functionEdges :: FunctionCalls -> [(Function,Function)]-functionEdges = concatMap mkEdges+type EntityName = String++type EntQual = Maybe String++type QEntityName = (EntQual, EntityName)++-- | All 'Entity's defined in this 'ParsedModule'.+definedEnts :: ParsedModule -> Set Entity+definedEnts pm = exportableEnts pm `S.union` instDecls pm++exportableEnts :: ParsedModule -> Set Entity+exportableEnts pm = S.unions [ decEnts+ , clEnts+ , defEnts+ ] where- mkEdges (f,fs) = map ((,) f) fs+ decEnts = getEnts dataDecls pm+ clEnts = getEnts classDecls pm+ defEnts = topEnts pm --- The next two functions are defined to avoid having to import--- Data.Map in modules that use this one.+-- | All 'Entity's used internally within this 'ParsedModule'.+internalEnts :: ParsedModule -> Set Entity+internalEnts pm = S.union (definedEnts pm) (virtualEnts pm) --- | Gets the functions-functionsIn :: FunctionCalls -> [Function]-functionsIn = map fst+getEnts :: (ParsedModule -> Map String EntityLookup)+ -> ParsedModule -> Set Entity+getEnts f = mkSet+ . map M.elems+ . M.elems+ . f --- | Combine multiple function calls-combineCalls :: [FunctionCalls] -> FunctionCalls-combineCalls = concat++fullName :: Entity -> EntityName+fullName e = nameOfModule (inModule e) ++ moduleSep : name e++defEntity :: EntityName -> Entity+defEntity nm = Ent { inModule = UnknownMod+ , name = nm+ , eType = NormalEntity+ }++setEntModule :: ModName -> Entity -> Entity+setEntModule m e = e { inModule = m }++setEntModules :: ModName -> Set Entity -> Set Entity+setEntModules = S.map . setEntModule++-- -----------------------------------------------------------------------------++-- Extra type defns.++type DataType = String++type ClassName = String++type DataDecs = Map DataType EntityLookup++type ClassDecs = Map ClassName EntityLookup++data FunctionCall = FC { fromEntity :: Entity+ , toEntity :: Entity+ , callType :: CallType+ }+ deriving (Eq, Ord, Show, Read)++callToRel :: FunctionCall -> Rel Entity CallType+callToRel (FC from to tp) = (from, to, tp)++data CallType = NormalCall+ | InstanceDeclaration -- ClassName DataType EntityName+ | DefaultInstDeclaration -- ClassName EntityName+ | RecordConstructor+ deriving (Eq, Ord, Show, Read)++data EntityType = Constructor DataType+ | RecordFunction DataType -- (Maybe EntityName)+ -- same record function in+ -- multiple constructors+ | ClassFunction ClassName+ | DefaultInstance ClassName+ | ClassInstance ClassName DataType+ -- The following three are only for when collapsing.+ | CollapsedData DataType+ | CollapsedClass ClassName+ | CollapsedInstance ClassName DataType+ | NormalEntity -- A function or variable+ deriving (Eq, Ord, Show, Read)++isData :: EntityType -> Bool+isData Constructor{} = True+isData RecordFunction{} = True+isData _ = False++getDataType :: EntityType -> DataType+getDataType (Constructor d) = d+getDataType (RecordFunction d) = d+getDataType _ = error "Should not see this"++isClass :: EntityType -> Bool+isClass ClassFunction{} = True+isClass DefaultInstance{} = True+isClass _ = False++getClassName :: EntityType -> ClassName+getClassName (ClassFunction c) = c+getClassName (DefaultInstance c) = c+getClassName _ = error "Should not see this"++isInstance :: EntityType -> Bool+isInstance ClassInstance{} = True+isInstance _ = False++getInstance :: EntityType -> (ClassName, DataType)+getInstance (ClassInstance c d) = (c,d)+getInstance _ = error "Should not see this"++-- -----------------------------------------------------------------------------++setUnion :: (Ord a) => Set (Set a) -> Set a+setUnion = F.foldl' S.union S.empty++mkSet :: (Ord a) => [[a]] -> Set a+mkSet = S.fromList . concat -- or should this be S.unions . map+ -- S.fromList ?++mergeMaps :: (Ord k) => Set (Map k a) -> Map k a+mergeMaps = F.foldl' M.union M.empty+
+ ParsingProblems.txt view
@@ -0,0 +1,43 @@+Can't parse/understand the following types items:++* Code that doesn't compile/type-check/etc.; haskell-src-exts won't understand+ them.++* Modules using CPP.++* HaRP usage.++* Template Haskell++* Haskell Source with XML/Haskell Server Pages-style embedded XML++* Data Family instances (both normal and GADT) don't have their+ constructors/records added as it isn't obvious how to go from the+ type to a name of the type.++* FFI imports/exports are ignored.++* Pragmas are ignored.++Possible parsing problems with the following items:++* Modules not within the given project; if an explicit import is used,+ then the entitys are guessed at (can't always categorise function+ types, etc.).++* When using record puns, it is not always possible to distinguish+ between the records and punned values.++* When using record wildcards, not all records are completely+ listed/used as both record functions and variables (see the problem+ with record puns above).++* When considering instances of a class, it doesn't deal well with+ multi-param type classes, etc. in that it assumes the first type+ mentioned is the type that the instance is for. This is mainly for+ creating virtual functions for the instances.++* Language options specified in the Cabal file.++* If a datatype or class is re-exported from another module, then this+ won't be picked up.
SourceGraph.cabal view
@@ -1,5 +1,5 @@ Name: SourceGraph-Version: 0.3+Version: 0.5.0.0 Synopsis: Use graph-theory to analyse your code Description: SourceGraph uses the Graphalyze library to analyse Cabalized Haskell code.@@ -9,29 +9,43 @@ Copyright: (c) Ivan Lazar Miljenovic Author: Ivan Lazar Miljenovic Maintainer: Ivan.Miljenovic@gmail.com-Extra-Source-Files: TODO-Cabal-Version: >= 1.2+Cabal-Version: >= 1.6 Build-Type: Simple-Tested-With: GHC==6.8.3-build-Depends: base+Extra-Source-Files: TODO+ KnownProblems.txt+ ParsingProblems.txt -Flag small_base- description: Choose the new smaller, split-up base package.+Source-Repository head+ Type: darcs+ Location: http://code.haskell.org/SourceGraph + Executable SourceGraph { Main-Is: Main.hs- Other-Modules: Parsing, Parsing.Types, Parsing.ParseModule,- Analyse, Analyse.Utils, Analyse.Module,- Analyse.Imports, Analyse.Everything+ Other-Modules: Parsing,+ Parsing.ParseModule,+ Parsing.State,+ Parsing.Types,+ Analyse,+ Analyse.Utils,+ Analyse.Module,+ Analyse.Imports,+ Analyse.Everything,+ Paths_SourceGraph Ghc-Options: -Wall- Ghc-Prof-Options: -auto-all-- if flag(small_base)- Build-Depends: base >= 3, containers, filepath, random, directory- else- Build-Depends: base < 3+ Ghc-Prof-Options: -prof -auto-all - Build-Depends: fgl, Graphalyze >= 0.5, graphviz >= 2008.9.20,- Cabal >= 1.6, Cabal < 1.7, haskell-src-exts >= 0.3+ Build-Depends: base >= 3 && < 5,+ extensible-exceptions,+ containers,+ multiset,+ filepath,+ random,+ directory,+ fgl,+ Graphalyze >= 0.7.0.0 && < 0.8.0.0,+ graphviz >= 2999.6.0.0 && < 2999.7.0.0,+ Cabal >= 1.6 && < 1.7,+ haskell-src-exts >= 1.1.0 && < 1.2.0 }