{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.ShowDependencies ( showDeps ) where

import Darcs.Prelude

import qualified Data.Map.Strict as M
import Data.Maybe( fromJust, fromMaybe )
import qualified Data.Set as S

import Darcs.Repository ( RepoJob(..), readRepo, withRepositoryLocation )

import Darcs.UI.Flags ( DarcsFlag, getRepourl, useCache )
import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts )
import Darcs.UI.Commands.Util ( matchRange )
import Darcs.UI.Completion ( noArgs )

import Darcs.Util.Hash ( sha1short, showAsHex )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer
    ( Doc
    , (<+>)
    , formatText
    , hsep
    , prefixLines
    , putDocLn
    , quoted
    , renderString
    , text
    , vcat
    )

import Darcs.Patch.Commute ( Commute, commuteFL )
import Darcs.Patch.Ident ( PatchId, Ident(..) )
import Darcs.Patch.Info ( PatchInfo, piName, makePatchname )
import Darcs.Patch.Witnesses.Ordered
    ( (:>)(..)
    , FL(..)
    , RL(..)
    , reverseFL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )

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

showDepsHelp :: Doc
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
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
    }
  where
    showDepsBasicOpts = O.matchRange
    showDepsOpts = showDepsBasicOpts `withStdOpts` oid

depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd _ opts _ = do
    let repodir = fromMaybe "." (getRepourl opts)
    withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> do
        Sealed2 rFl <- matchRange (O.matchRange ? opts) <$> readRepo repo
        putDocLn $ renderDepsGraphAsDot $ depsGraph $ reverseFL rFl

-- A 'M.Map' from 'PatchId's to 'Deps'.
type DepsGraph p = M.Map (PatchId p) (Deps p)

-- A pair of (direct, indirect) dependencies.
type Deps p = (S.Set (PatchId p), S.Set (PatchId p))

-- Determine the 'DepsGraph' of an 'RL' of patches.
depsGraph :: forall p wX wY. (Commute p, Ident p) => RL p wX wY -> DepsGraph p
depsGraph NilRL = M.empty
depsGraph (ps :<: p) =
  M.insert i (foldDeps ps (p :>: NilFL) NilFL (S.empty, S.empty)) m
  where
    m = depsGraph ps
    i = ident p
    allDeps j = uncurry S.union . fromJust . M.lookup j
    addDeps j = S.insert j . S.union (allDeps j m)
    foldDeps :: RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p
    foldDeps NilRL _ _ acc = acc
    foldDeps (qs :<: q) p_and_deps non_deps acc@(direct, indirect)
      -- no need to commute or adjust acc if we already know we depend
      -- (indirectly) on q; note that (ident q `S.member` direct) is
      -- impossible
      | j `S.member` indirect = foldDeps qs (q :>: p_and_deps) non_deps acc
      -- if q commutes past p_and_deps then we don't depend on it
      | Just (p_and_deps' :> q') <- commuteFL (q :> p_and_deps) =
        foldDeps qs p_and_deps' (q' :>: non_deps) acc
      -- we have a new dependency which must be a direct one
      | otherwise =
        foldDeps qs (q :>: p_and_deps) non_deps (addDeps j direct, indirect)
      where
        j = ident q

renderDepsGraphAsDot :: M.Map PatchInfo (S.Set PatchInfo, S.Set PatchInfo) -> Doc
renderDepsGraphAsDot g = vcat ["digraph {", indent body, "}"]
  where
    indent = prefixLines ("  ")
    body = vcat
      [ "graph [rankdir=LR];"
      , "node [imagescale=true];"
      , vcat (map showNode (map fst pairs))
      , vcat (map showEdges pairs)
      ]
    pairs = M.toList $ M.map fst g
    showEdges (i, ds)
      | S.null ds = mempty
      | otherwise =
          hsep [showID i, "->", "{" <> hsep (map showID (S.toList ds)) <> "}"]
    showNode i = showID i <+> "[label=" <> showLabel i <> "]"
    showID = quoted . showAsHex . sha1short . makePatchname
    showLabel i = text $ show $ renderString $ formatText 20 [piName i]