ShowDependencies.hs

module Darcs.UI.Commands.ShowDependencies
    ( showDeps )
where

import Control.Arrow ( (***) )

import Data.Maybe( fromMaybe )
import Data.GraphViz
import Data.GraphViz.Algorithms ( transitiveReduction )
import Data.GraphViz.Attributes.Complete
import Data.Graph.Inductive.Graph ( Graph(..), mkGraph, LNode, UEdge )
import Data.Graph.Inductive.PatriciaTree ( Gr )

import qualified Data.Text.Lazy as T

import Darcs.Repository ( readRepo, withRepositoryLocation, RepoJob(..) )
import Darcs.UI.Flags ( DarcsFlag(..), getRepourl
                      , useCache )
import Darcs.UI.Options ( oid, odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts )
import Darcs.UI.Commands.Unrecord ( matchingHead )
import Darcs.UI.Completion ( noArgs )

import Darcs.Util.Text ( formatText )
import Darcs.Util.Path ( AbsolutePath )

import Darcs.Patch.Info ( piName )
import Darcs.Patch.PatchInfoAnd ( hopefully )
import Darcs.Patch.Named ( Named (..), patch2patchinfo )
import Darcs.Patch.Named.Wrapped ( removeInternalFL )
import Darcs.Patch.Match ( firstMatch, matchFirstPatchset )
import Darcs.Patch.Choices ( unLabel, LabelledPatch, label, getLabelInt )
import Darcs.Patch.Depends ( SPatchAndDeps, getDeps, findCommonWithThem )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), seal2, Sealed(..) )
import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:>)(..), foldlFL, mapFL_FL )

showDepsDescription :: String
showDepsDescription = "Generate the graph of dependencies."

showDepsHelp :: String
showDepsHelp = formatText 80
        [ unwords [ "The `darcs show dependencies` command is used to create"
                  , "a graph of the dependencies between patches of the"
                  , "repository (by default up to last tag)."
                  ]
        , unwords [ "The resulting graph is described in Dot Language, a"
                  , "general example of use could be:"
                  ]
        , "darcs show dependencies | dot -Tpdf -o FILE.pdf"
        ]

showDeps :: DarcsCommand [DarcsFlag]
showDeps = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "dependencies"
    , commandHelp = showDepsHelp
    , commandDescription = showDepsDescription
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = depsCmd
    , commandPrereq = findRepository
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = []
    , commandBasicOptions = odesc showDepsBasicOpts
    , commandDefaults = defaultFlags showDepsOpts
    , commandCheckOptions = ocheck showDepsOpts
    , commandParseOptions = onormalise showDepsOpts
    }
  where
    showDepsBasicOpts = O.matchSeveralOrLast
    showDepsOpts = showDepsBasicOpts `withStdOpts` oid

type DepsGraph = Gr String ()

depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd _ opts _ = do
    let repodir = fromMaybe "." (getRepourl opts)
    withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> do
        Sealed2 rFl <- readRepo repo >>= pruneRepo
        let deps   = getDeps
                        (removeInternalFL . mapFL_FL hopefully $ rFl)
                        rFl
            dGraph = transitiveReduction $
                                graphToDot nodeLabeledParams $ makeGraph deps
        putStrLn $ T.unpack $ printDotGraph dGraph
    where
        nodeLabeledParams :: GraphvizParams n String el () String
        nodeLabeledParams =
                defaultParams { globalAttributes =
                                    [GraphAttrs {attrs = [RankDir FromLeft]}]
                              , fmtNode = \(_,l) ->
                                    [ toLabel l
                                    , ImageScale UniformScale
                                    ]
                              }
        pruneRepo r = let matchFlags = O.matchSeveralOrLast ? opts in
                      if firstMatch matchFlags
                         then case getLastPatches matchFlags r of
                                Sealed2 ps -> return $ seal2 ps
                         else case matchingHead matchFlags r of
                                _ :> patches -> return $ seal2 patches
        getLastPatches matchFlags ps =
                case matchFirstPatchset matchFlags ps of
                    Sealed p1s -> case findCommonWithThem ps p1s of
                                    _ :> ps' -> seal2 ps'

makeGraph :: [SPatchAndDeps p] -> DepsGraph
makeGraph = uncurry mkGraph . (id *** concat) . unzip . map mkNodeWithEdges
    where
    mkNodeWithEdges :: SPatchAndDeps p -> (LNode String, [UEdge])
    mkNodeWithEdges (Sealed2 father, Sealed2 childs) = (mkLNode father,mkUEdges)
        where
            mkNode :: LabelledPatch (Named p) wX wY -> Int
            mkNode = getLabelInt . label
            mkUEdge :: [UEdge] -> LabelledPatch (Named p) wX wY -> [UEdge]
            mkUEdge les child = (mkNode father, mkNode child,()) : les
            mkLabel :: LabelledPatch (Named p) wX wY -> String
            mkLabel = formatText 20 . (:[]) . piName . patch2patchinfo . unLabel
            mkLNode :: LabelledPatch (Named p) wX wY -> LNode String
            mkLNode p = (mkNode p, mkLabel p)
            mkUEdges :: [UEdge]
            mkUEdges = foldlFL mkUEdge [] childs