diff --git a/Analyse.hs b/Analyse.hs --- a/Analyse.hs +++ b/Analyse.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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 diff --git a/Analyse/Everything.hs b/Analyse/Everything.hs --- a/Analyse/Everything.hs +++ b/Analyse/Everything.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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) diff --git a/Analyse/Imports.hs b/Analyse/Imports.hs --- a/Analyse/Imports.hs +++ b/Analyse/Imports.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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") diff --git a/Analyse/Module.hs b/Analyse/Module.hs --- a/Analyse/Module.hs +++ b/Analyse/Module.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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") diff --git a/Analyse/Utils.hs b/Analyse/Utils.hs --- a/Analyse/Utils.hs +++ b/Analyse/Utils.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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 diff --git a/KnownProblems.txt b/KnownProblems.txt new file mode 100644 --- /dev/null +++ b/KnownProblems.txt @@ -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. diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -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 diff --git a/Parsing.hs b/Parsing.hs --- a/Parsing.hs +++ b/Parsing.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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 diff --git a/Parsing/ParseModule.hs b/Parsing/ParseModule.hs --- a/Parsing/ParseModule.hs +++ b/Parsing/ParseModule.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} + {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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 + +-- ----------------------------------------------------------------------------- diff --git a/Parsing/State.hs b/Parsing/State.hs new file mode 100644 --- /dev/null +++ b/Parsing/State.hs @@ -0,0 +1,109 @@ +{- +Copyright (C) 2009 Ivan Lazar Miljenovic + +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) diff --git a/Parsing/Types.hs b/Parsing/Types.hs --- a/Parsing/Types.hs +++ b/Parsing/Types.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE MultiParamTypeClasses - , TypeSynonymInstances - #-} +{-# LANGUAGE TypeFamilies #-} {- -Copyright (C) 2008 Ivan Lazar Miljenovic +Copyright (C) 2009 Ivan Lazar Miljenovic 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 + diff --git a/ParsingProblems.txt b/ParsingProblems.txt new file mode 100644 --- /dev/null +++ b/ParsingProblems.txt @@ -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. diff --git a/SourceGraph.cabal b/SourceGraph.cabal --- a/SourceGraph.cabal +++ b/SourceGraph.cabal @@ -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 }