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 :: String
showDepsDescription = "Generate the graph of dependencies."

showDepsHelp :: String
showDepsHelp :: String
showDepsHelp = Int -> [String] -> String
formatText 80
        [ [String] -> String
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)."
                  ]
        , [String] -> String
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 [DarcsFlag]
showDeps = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "dependencies"
    , commandHelp :: String
commandHelp = String
showDepsHelp
    , commandDescription :: String
commandDescription = String
showDepsDescription
    , commandExtraArgs :: Int
commandExtraArgs = 0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
findRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
showDepsOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
showDepsOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
showDepsOpts
    }
  where
    showDepsBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchSeveralOrLast
    showDepsOpts :: DarcsOption
  a
  ([MatchFlag]
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
showDepsOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
  [MatchFlag]
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
showDepsBasicOpts PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
  [MatchFlag]
-> DarcsOption
     (UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     ([MatchFlag]
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid

type DepsGraph = Gr String ()

depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
depsCmd _ opts :: [DarcsFlag]
opts _ = do
    let repodir :: String
repodir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "." ([DarcsFlag] -> Maybe String
getRepourl [DarcsFlag]
opts)
    UseCache -> String -> RepoJob () -> IO ()
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
repodir (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repo :: Repository rt p wR wU wR
repo -> do
        Sealed2 rFl :: FL (PatchInfoAnd rt p) wX wY
rFl <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repo IO (PatchSet rt p Origin wR)
-> (PatchSet rt p Origin wR
    -> IO (Sealed2 (FL (PatchInfoAnd rt p))))
-> IO (Sealed2 (FL (PatchInfoAnd rt p)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PatchSet rt p Origin wR -> IO (Sealed2 (FL (PatchInfoAnd rt p)))
forall (rt :: RepoType) (p :: * -> * -> *) (m :: * -> *) wR.
(IsRepoType rt, RepoPatch p, Monad m) =>
PatchSet rt p Origin wR -> m (Sealed2 (FL (PatchInfoAnd rt p)))
pruneRepo
        let deps :: [SPatchAndDeps p]
deps   = FL (Named p) wX wY
-> FL (PatchInfoAnd rt p) wX wY -> [SPatchAndDeps p]
forall (p :: * -> * -> *) wA wR (rt :: RepoType) wX wY.
RepoPatch p =>
FL (Named p) wA wR
-> FL (PatchInfoAnd rt p) wX wY -> [SPatchAndDeps p]
getDeps
                        (FL (WrappedNamed rt p) wX wY -> FL (Named p) wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
IsRepoType rt =>
FL (WrappedNamed rt p) wX wY -> FL (Named p) wX wY
removeInternalFL (FL (WrappedNamed rt p) wX wY -> FL (Named p) wX wY)
-> (FL (PatchInfoAnd rt p) wX wY -> FL (WrappedNamed rt p) wX wY)
-> FL (PatchInfoAnd rt p) wX wY
-> FL (Named p) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wY. PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY)
-> FL (PatchInfoAnd rt p) wX wY -> FL (WrappedNamed rt p) wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY. PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully (FL (PatchInfoAnd rt p) wX wY -> FL (Named p) wX wY)
-> FL (PatchInfoAnd rt p) wX wY -> FL (Named p) wX wY
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wX wY
rFl)
                        FL (PatchInfoAnd rt p) wX wY
rFl
            dGraph :: DotGraph Int
dGraph = DotGraph Int -> DotGraph Int
forall (dg :: * -> *) n. DotRepr dg n => dg n -> DotGraph n
transitiveReduction (DotGraph Int -> DotGraph Int) -> DotGraph Int -> DotGraph Int
forall a b. (a -> b) -> a -> b
$
                                GraphvizParams Int String () () String
-> Gr String () -> DotGraph Int
forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Int nl el cl l -> gr nl el -> DotGraph Int
graphToDot GraphvizParams Int String () () String
forall n el. GraphvizParams n String el () String
nodeLabeledParams (Gr String () -> DotGraph Int) -> Gr String () -> DotGraph Int
forall a b. (a -> b) -> a -> b
$ [SPatchAndDeps p] -> Gr String ()
forall (p :: * -> * -> *). [SPatchAndDeps p] -> Gr String ()
makeGraph [SPatchAndDeps p]
deps
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ DotGraph Int -> Text
forall (dg :: * -> *) n. PrintDotRepr dg n => dg n -> Text
printDotGraph DotGraph Int
dGraph
    where
        nodeLabeledParams :: GraphvizParams n String el () String
        nodeLabeledParams :: GraphvizParams n String el () String
nodeLabeledParams =
                GraphvizParams n String el () String
forall n nl el cl. GraphvizParams n nl el cl nl
defaultParams { globalAttributes :: [GlobalAttributes]
globalAttributes =
                                    [GraphAttrs :: Attributes -> GlobalAttributes
GraphAttrs {attrs :: Attributes
attrs = [RankDir -> Attribute
RankDir RankDir
FromLeft]}]
                              , fmtNode :: (n, String) -> Attributes
fmtNode = \(_,l :: String
l) ->
                                    [ String -> Attribute
forall a. Labellable a => a -> Attribute
toLabel String
l
                                    , ScaleType -> Attribute
ImageScale ScaleType
UniformScale
                                    ]
                              }
        pruneRepo :: PatchSet rt p Origin wR -> m (Sealed2 (FL (PatchInfoAnd rt p)))
pruneRepo r :: PatchSet rt p Origin wR
r = let matchFlags :: [MatchFlag]
matchFlags = forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
O.matchSeveralOrLast (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag])
-> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts in
                      if [MatchFlag] -> Bool
firstMatch [MatchFlag]
matchFlags
                         then case [MatchFlag]
-> PatchSet rt p Origin wR -> Sealed2 (FL (PatchInfoAnd rt p))
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
(IsRepoType rt, Matchable p) =>
[MatchFlag]
-> PatchSet rt p wStart wX -> Sealed2 (FL (PatchInfoAnd rt p))
getLastPatches [MatchFlag]
matchFlags PatchSet rt p Origin wR
r of
                                Sealed2 ps :: FL (PatchInfoAnd rt p) wX wY
ps -> Sealed2 (FL (PatchInfoAnd rt p))
-> m (Sealed2 (FL (PatchInfoAnd rt p)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed2 (FL (PatchInfoAnd rt p))
 -> m (Sealed2 (FL (PatchInfoAnd rt p))))
-> Sealed2 (FL (PatchInfoAnd rt p))
-> m (Sealed2 (FL (PatchInfoAnd rt p)))
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wX wY -> Sealed2 (FL (PatchInfoAnd rt p))
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
seal2 FL (PatchInfoAnd rt p) wX wY
ps
                         else case [MatchFlag]
-> PatchSet rt p Origin wR
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wR.
(IsRepoType rt, RepoPatch p) =>
[MatchFlag]
-> PatchSet rt p Origin wR
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR
matchingHead [MatchFlag]
matchFlags PatchSet rt p Origin wR
r of
                                _ :> patches :: FL (PatchInfoAnd rt p) wZ wR
patches -> Sealed2 (FL (PatchInfoAnd rt p))
-> m (Sealed2 (FL (PatchInfoAnd rt p)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed2 (FL (PatchInfoAnd rt p))
 -> m (Sealed2 (FL (PatchInfoAnd rt p))))
-> Sealed2 (FL (PatchInfoAnd rt p))
-> m (Sealed2 (FL (PatchInfoAnd rt p)))
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wZ wR -> Sealed2 (FL (PatchInfoAnd rt p))
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
seal2 FL (PatchInfoAnd rt p) wZ wR
patches
        getLastPatches :: [MatchFlag]
-> PatchSet rt p wStart wX -> Sealed2 (FL (PatchInfoAnd rt p))
getLastPatches matchFlags :: [MatchFlag]
matchFlags ps :: PatchSet rt p wStart wX
ps =
                case [MatchFlag]
-> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
(IsRepoType rt, Matchable p) =>
[MatchFlag]
-> PatchSet rt p wStart wX -> SealedPatchSet rt p wStart
matchFirstPatchset [MatchFlag]
matchFlags PatchSet rt p wStart wX
ps of
                    Sealed p1s :: PatchSet rt p wStart wX
p1s -> case PatchSet rt p wStart wX
-> PatchSet rt p wStart wX
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart wX
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
Commute p =>
PatchSet rt p wStart wX
-> PatchSet rt p wStart wY
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart wX
findCommonWithThem PatchSet rt p wStart wX
ps PatchSet rt p wStart wX
p1s of
                                    _ :> ps' :: FL (PatchInfoAnd rt p) wZ wX
ps' -> FL (PatchInfoAnd rt p) wZ wX -> Sealed2 (FL (PatchInfoAnd rt p))
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
seal2 FL (PatchInfoAnd rt p) wZ wX
ps'

makeGraph :: [SPatchAndDeps p] -> DepsGraph
makeGraph :: [SPatchAndDeps p] -> Gr String ()
makeGraph = ([LNode String] -> [LEdge ()] -> Gr String ())
-> ([LNode String], [LEdge ()]) -> Gr String ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [LNode String] -> [LEdge ()] -> Gr String ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph (([LNode String], [LEdge ()]) -> Gr String ())
-> ([SPatchAndDeps p] -> ([LNode String], [LEdge ()]))
-> [SPatchAndDeps p]
-> Gr String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([LNode String] -> [LNode String]
forall a. a -> a
id ([LNode String] -> [LNode String])
-> ([[LEdge ()]] -> [LEdge ()])
-> ([LNode String], [[LEdge ()]])
-> ([LNode String], [LEdge ()])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [[LEdge ()]] -> [LEdge ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (([LNode String], [[LEdge ()]]) -> ([LNode String], [LEdge ()]))
-> ([SPatchAndDeps p] -> ([LNode String], [[LEdge ()]]))
-> [SPatchAndDeps p]
-> ([LNode String], [LEdge ()])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(LNode String, [LEdge ()])] -> ([LNode String], [[LEdge ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(LNode String, [LEdge ()])] -> ([LNode String], [[LEdge ()]]))
-> ([SPatchAndDeps p] -> [(LNode String, [LEdge ()])])
-> [SPatchAndDeps p]
-> ([LNode String], [[LEdge ()]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SPatchAndDeps p -> (LNode String, [LEdge ()]))
-> [SPatchAndDeps p] -> [(LNode String, [LEdge ()])]
forall a b. (a -> b) -> [a] -> [b]
map SPatchAndDeps p -> (LNode String, [LEdge ()])
forall (p :: * -> * -> *).
SPatchAndDeps p -> (LNode String, [LEdge ()])
mkNodeWithEdges
    where
    mkNodeWithEdges :: SPatchAndDeps p -> (LNode String, [UEdge])
    mkNodeWithEdges :: SPatchAndDeps p -> (LNode String, [LEdge ()])
mkNodeWithEdges (Sealed2 father :: LabelledPatch (Named p) wX wY
father, Sealed2 childs :: FL (LabelledPatch (Named p)) wX wY
childs) = (LabelledPatch (Named p) wX wY -> LNode String
forall (p :: * -> * -> *) wX wY.
LabelledPatch (Named p) wX wY -> LNode String
mkLNode LabelledPatch (Named p) wX wY
father,[LEdge ()]
mkUEdges)
        where
            mkNode :: LabelledPatch (Named p) wX wY -> Int
            mkNode :: LabelledPatch (Named p) wX wY -> Int
mkNode = Label -> Int
getLabelInt (Label -> Int)
-> (LabelledPatch (Named p) wX wY -> Label)
-> LabelledPatch (Named p) wX wY
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelledPatch (Named p) wX wY -> Label
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> Label
label
            mkUEdge :: [UEdge] -> LabelledPatch (Named p) wX wY -> [UEdge]
            mkUEdge :: [LEdge ()] -> LabelledPatch (Named p) wX wY -> [LEdge ()]
mkUEdge les :: [LEdge ()]
les child :: LabelledPatch (Named p) wX wY
child = (LabelledPatch (Named p) wX wY -> Int
forall (p :: * -> * -> *) wX wY.
LabelledPatch (Named p) wX wY -> Int
mkNode LabelledPatch (Named p) wX wY
father, LabelledPatch (Named p) wX wY -> Int
forall (p :: * -> * -> *) wX wY.
LabelledPatch (Named p) wX wY -> Int
mkNode LabelledPatch (Named p) wX wY
child,()) LEdge () -> [LEdge ()] -> [LEdge ()]
forall a. a -> [a] -> [a]
: [LEdge ()]
les
            mkLabel :: LabelledPatch (Named p) wX wY -> String
            mkLabel :: LabelledPatch (Named p) wX wY -> String
mkLabel = Int -> [String] -> String
formatText 20 ([String] -> String)
-> (LabelledPatch (Named p) wX wY -> [String])
-> LabelledPatch (Named p) wX wY
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String])
-> (LabelledPatch (Named p) wX wY -> String)
-> LabelledPatch (Named p) wX wY
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> String
piName (PatchInfo -> String)
-> (LabelledPatch (Named p) wX wY -> PatchInfo)
-> LabelledPatch (Named p) wX wY
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named p wX wY -> PatchInfo
forall (p :: * -> * -> *) wX wY. Named p wX wY -> PatchInfo
patch2patchinfo (Named p wX wY -> PatchInfo)
-> (LabelledPatch (Named p) wX wY -> Named p wX wY)
-> LabelledPatch (Named p) wX wY
-> PatchInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelledPatch (Named p) wX wY -> Named p wX wY
forall (p :: * -> * -> *) wX wY. LabelledPatch p wX wY -> p wX wY
unLabel
            mkLNode :: LabelledPatch (Named p) wX wY -> LNode String
            mkLNode :: LabelledPatch (Named p) wX wY -> LNode String
mkLNode p :: LabelledPatch (Named p) wX wY
p = (LabelledPatch (Named p) wX wY -> Int
forall (p :: * -> * -> *) wX wY.
LabelledPatch (Named p) wX wY -> Int
mkNode LabelledPatch (Named p) wX wY
p, LabelledPatch (Named p) wX wY -> String
forall (p :: * -> * -> *) wX wY.
LabelledPatch (Named p) wX wY -> String
mkLabel LabelledPatch (Named p) wX wY
p)
            mkUEdges :: [UEdge]
            mkUEdges :: [LEdge ()]
mkUEdges = (forall wW wY.
 [LEdge ()] -> LabelledPatch (Named p) wW wY -> [LEdge ()])
-> [LEdge ()] -> FL (LabelledPatch (Named p)) wX wY -> [LEdge ()]
forall a (b :: * -> * -> *) wX wZ.
(forall wW wY. a -> b wW wY -> a) -> a -> FL b wX wZ -> a
foldlFL forall wW wY.
[LEdge ()] -> LabelledPatch (Named p) wW wY -> [LEdge ()]
forall (p :: * -> * -> *) wX wY.
[LEdge ()] -> LabelledPatch (Named p) wX wY -> [LEdge ()]
mkUEdge [] FL (LabelledPatch (Named p)) wX wY
childs