Analyse.hs

{-
Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>

This file is part of SourceGraph.

SourceGraph is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- |
   Module      : Analyse
   Description : Analyse Haskell software
   Copyright   : (c) Ivan Lazar Miljenovic 2009
   License     : GPL-3 or later.
   Maintainer  : Ivan.Miljenovic@gmail.com

   Analyse Haskell software
 -}
module Analyse(analyse, sgLegend) where

import Analyse.Module
import Analyse.Imports
import Analyse.Everything
import Analyse.Colors
import Parsing.Types

import Data.Graph.Analysis hiding (Bold)
import qualified Data.Graph.Analysis.Reporting as R (DocInline(Bold))
import Data.GraphViz.Types.Canonical
import Data.GraphViz.Attributes
import Data.GraphViz.Attributes.Complete( Attribute(OutputOrder, FontSize)
                                        , OutputMode(EdgesFirst))

import System.Random(RandomGen)
import Control.Arrow(first)

-- | Analyse an entire Haskell project.  Takes in a random seed,
--   the list of exported modules and the parsed Haskell code in
--   'HaskellModules' form.
analyse            :: (RandomGen g) => g -> [ModName] -> ParsedModules
                   -> [DocElement]
analyse g exps hms = [ analyseEverything g exps hms
                     , analyseImports exps hms
                     , analyseModules hms
                     ]

sgLegend :: [(Either DocGraph DocInline, DocInline)]
sgLegend = map (first Left) [ esCall
                            , mods
                            , esLoc
                            , esData
                            , esClass
                            , esExp
                            , callCats
                            ]
           ++ [first Right edgeExplain]

esCall, mods, esLoc, esData, esClass, esExp, callCats :: (DocGraph, DocInline)

esCall = (dg', R.Bold txt)
    where
      dg' = DG "legend_call" (Text "Function Call") dg
      dg = mkLegendGraph ns es
      nAs = [shape BoxShape, fillColor defaultNodeColor]
      ns = [ (1, toLabel e1 : nAs)
           , (2, toLabel e2 : nAs)
           ]
      e1 = "f"
      e2 = "g"
      eAs = [color Black]
      es = [(1,2,eAs)]
      txt = Grouping [ Text "Two normal functions with"
                     , Emphasis $ Text e1
                     , Text "calling"
                     , Emphasis $ Text e2
                     , Text "."
                     ]

mods = (dg', R.Bold txt)
    where
      dg' = DG "legend_mods" (Text "Module Import") dg
      dg = mkLegendGraph ns es
      nAs = [shape Tab, fillColor defaultNodeColor]
      ns = [ (1, toLabel m1 : nAs)
           , (2, toLabel m2 : nAs)
           ]
      m1 = "Foo"
      m2 = "Bar"
      es = [(1,2,[])]
      txt = Grouping [ Text "Two modules with module"
                     , Emphasis $ Text m1
                     , Text "importing"
                     , Emphasis $ Text m2
                     , Text "."
                     ]

esLoc = (dg', R.Bold $ Text "Entities from different modules.")
    where
      dg' = DG "legend_loc" (Text "From module") dg
      dg = mkLegendGraph ns es
      nAs = [fillColor defaultNodeColor]
      ns = [ (1, toLabel "Current module"
                   : style bold : nAs)
           , (2, toLabel "Other project module"
                   : style solid : nAs)
           , (3, toLabel "Known external module"
                   : style dashed : nAs)
           , (4, toLabel "Unknown external module"
                   : style dotted : nAs)
           ]
      es = []

esData = (dg', R.Bold $ Text "Data type declaration.")
    where
      dg' = DG "legend_data" (Text "Data type declaration") dg
      dg = mkLegendGraph ns es
      nAs = [fillColor defaultNodeColor]
      ns = [ (1, toLabel "Constructor"
                   : shape Box3D : nAs)
           , (2, toLabel "Record function"
                   : shape Component : nAs)
           ]
      es = [(2,1,[ color Magenta, arrowFrom oDot, arrowTo vee])]

esClass = (dg', R.Bold $ Text "Class and instance declarations.")
    where
      dg' = DG "legend_class" (Text "Class declaration") dg
      dg = mkLegendGraph ns es
      nAs = [fillColor defaultNodeColor]
      ns = [ (1, toLabel "Default instance"
                   : shape Octagon : nAs)
           , (2, toLabel "Class function"
                   : shape DoubleOctagon : nAs)
           , (3, toLabel "Instance for data type"
                   : shape Octagon : nAs)
           ]
      eAs = [edgeEnds NoDir]
      es = [ (2,1, color Navy : eAs)
           , (2,3, color Turquoise : eAs)
           ]

esExp = (dg', R.Bold $ Text "Entity location/accessibility classification.")
    where
      dg' = DG "legend_loc2" (Text "Entity Location") dg
      dg = mkLegendGraph ns es
      ns = zip [1..]
           [ [ toLabel "Inaccessible entity"
             , fillColor inaccessibleColor]
           , [ toLabel "Exported root entity"
             , fillColor exportedRootColor]
           , [ toLabel "Exported non-root entity"
             , fillColor exportedInnerColor]
           , [ toLabel "Implicitly exported entity"
             , fillColor implicitExportColor]
           , [ toLabel "Leaf entity"
             , fillColor leafColor]
           , [ toLabel "Normal entity"
             , fillColor defaultNodeColor]
           ]
      es = []

callCats = (dg', R.Bold $ Text "Edge classification.")
  where
    dg' = DG "legend_edges" (Text "Edge Classification") dg
    dg = mkLegendGraph ns es
    ns = map (flip (,) [toLabel "", shape PointShape]) [1..5]
    eA = edgeEnds NoDir
    es = [ (1,2, [eA, toLabel "Clique", color cliqueColor])
         , (2,3, [eA, toLabel "Cycle", color cycleColor])
         , (3,4, [eA, toLabel "Chain", color chainColor])
         , (4,5, [eA, toLabel "Normal", color defaultEdgeColor])
         ]


mkLegendGraph       :: [(Int,Attributes)] -> [(Int,Int,Attributes)]
                       -> DotGraph Node
mkLegendGraph ns es = DotGraph { strictGraph   = False
                               , directedGraph = True
                               , graphID       = Nothing
                               , graphStatements
                                   = DotStmts { attrStmts = atts
                                              , subGraphs = [nSG]
                                              , nodeStmts = []
                                              , edgeStmts = map mkE es
                                              }
                               }
    where
      atts = [ GraphAttrs [OutputOrder EdgesFirst]
             , NodeAttrs [FontSize 10, style filled]
             ]
      sgAtts = [GraphAttrs [rank MinRank]]
      nSG = DotSG { isCluster     = False
                  , subGraphID    = Nothing
                  , subGraphStmts = DotStmts { attrStmts = sgAtts
                                             , subGraphs = []
                                             , nodeStmts = map mkN ns
                                             , edgeStmts = []
                                             }
                  }
      mkN (n,as)   = DotNode n as
      mkE (f,t,as) = DotEdge f t as

edgeExplain :: (DocInline, DocInline)
edgeExplain = (Grouping cntnt, R.Bold $ Text "Edge Widths")
  where
    cntnt = [ Text "The width of each edge is calculated by:"
            , BlankSpace
            , Emphasis $ Text
              "width = log (number of function calls) + 1"
            ]