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