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 qualified Data.ByteString.Char8 as BC ( unpack )

import Darcs.Util.Tree ( Tree )

import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) )
import Darcs.UI.Flags ( DarcsFlag(..), getRepourl
                      , useCache, toMatchFlags )
import Darcs.UI.Options ( PrimDarcsOption, 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.Util.Text ( formatText )
import Darcs.Util.Path ( AbsolutePath )

import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Set ( PatchSet(..), newset2FL )
import Darcs.Patch.Info ( _piName )
import Darcs.Patch.PatchInfoAnd ( hopefully )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Named ( Named (..), patch2patchinfo )
import Darcs.Patch.Named.Wrapped ( removeInternalFL )
import Darcs.Patch.Match ( firstMatch, matchFirstPatchset )
import Darcs.Patch.Choices ( lpPatch, LabelledPatch, label, getLabelInt )
import Darcs.Patch.Depends ( SPatchAndDeps, getDeps, findCommonWithThem )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), seal2, Sealed(..) )
import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:>)(..), RL(..)
                                     , reverseFL, foldlFL, mapFL_FL )
import Darcs.Repository.Flags ( Verbosity(..), UseCache(..) ) 

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"
        ]

showDepsBasicOpts ::  PrimDarcsOption [O.MatchFlag]
showDepsBasicOpts = O.matchSeveralOrLast

showDepsOpts :: O.DarcsOption
                  a
                  ([O.MatchFlag]
                   -> Maybe O.StdCmdAction
                   -> Bool
                   -> Bool
                   -> Verbosity
                   -> Bool
                   -> UseCache
                   -> Maybe String
                   -> Bool
                   -> Maybe String
                   -> Bool
                   -> a)
showDepsOpts = showDepsBasicOpts `withStdOpts` oid

showDeps :: DarcsCommand [DarcsFlag]
showDeps = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "dependencies"
    , commandHelp = showDepsHelp
    , commandDescription = showDepsDescription
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = depsCmd
    , commandPrereq = findRepository
    , commandGetArgPossibilities = return []
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = []
    , commandBasicOptions = odesc showDepsBasicOpts
    , commandDefaults = defaultFlags showDepsOpts
    , commandCheckOptions = ocheck showDepsOpts
    , commandParseOptions = onormalise showDepsOpts
    }

type DepsGraph = Gr String ()

depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd _ opts _ = do
    let repodir = fromMaybe "." (getRepourl opts)
    withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> do
        Sealed2 r <- readRepo repo >>= pruneRepo
        let rFl    = newset2FL r
            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 = toMatchFlags opts in
                      if firstMatch matchFlags
                         then case getLastPatches matchFlags r of
                                Sealed2 ps -> return $ seal2 $ PatchSet NilRL ps
                         else case matchingHead matchFlags r of
                                _ :> patches -> return $ seal2 $ PatchSet NilRL $ reverseFL patches
        getLastPatches matchFlags ps =
                case matchFirstPatchset matchFlags ps of
                    Sealed p1s -> case findCommonWithThem ps p1s of
                                    _ :> ps' -> seal2 $ reverseFL ps'

makeGraph :: (RepoPatch p,ApplyState p ~ Tree) => [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 = fromInteger . 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 . (:[]) . BC.unpack . _piName . patch2patchinfo . lpPatch
            mkLNode :: LabelledPatch (Named p) wX wY -> LNode String
            mkLNode p = (mkNode p, mkLabel p)
            mkUEdges :: [UEdge]
            mkUEdges = foldlFL mkUEdge [] childs