diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +fr33domlover diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,17 @@ +The changes are recorded by the version control system, Darcs. To see a log +quickly from the terminal, run: + + $ darcs changes --repo http://hub.darcs.net/fr33domlover/hit-graph + +There is also a web interface at which, among other +things, can display the history log. + +To see the log in a local clone, first get a copy of the repository if you +haven't yet: + + $ darcs get http://hub.darcs.net/fr33domlover/hit-graph + +Then move into the newly created directory and run darcs: + + $ cd hit-graph + $ darcs changes diff --git a/INSTALL.md b/INSTALL.md new file mode 100644 --- /dev/null +++ b/INSTALL.md @@ -0,0 +1,12 @@ +Install from Hackage/Stackage: + + $ stack install hit-graph + +Install from unpacked release tarball or source repo: + + $ cd hit-graph + $ stack install + +Just play with it without installing: + + $ stack repl diff --git a/NEWS.md b/NEWS.md new file mode 100644 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,23 @@ +This file lists the user-visible interesting changes between releases. For a +full list of changes to the source, see the ChangeLog. + + + +hit-graph 0.1 2016-04-09 +=============================== + +General, build and documentation changes: + +* (This is the first release, so everything is new) + +New APIs, features and enhancements: + +* (This is the first release, so everything is a new feature) + +Bug fixes: + +* (This is just the first release, many bugs haven't been discovered yet) + +Dependency changes: + +* (This is the first release) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +See the .cabal file for more info and link to project website the version +control. + +The official download location is Hackage: + + + +This library is free software, and is committed to software freedom. It is +released to the public domain using the CC0 Public Domain Dedication. For the +boring "legal" details see the file 'COPYING'. + +See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains +how to see the history log of the changes done in the code. 'NEWS' provides a +friendly overview of the changes for each release. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hit-graph.cabal b/hit-graph.cabal new file mode 100644 --- /dev/null +++ b/hit-graph.cabal @@ -0,0 +1,40 @@ +name: hit-graph +version: 0.1 +synopsis: Use graph algorithms to access and manipulate Git repos +description: + This library contains utilities for loading Git repo data into a graph, and + using graph algorithms to extract useful information, and perhaps even modify + the repo in interesting ways. +homepage: http://hub.darcs.net/fr33domlover/hit-graph +bug-reports: mailto:fr33domlover@riseup.net +license: PublicDomain +license-file: COPYING +author: fr33domlover +maintainer: fr33domlover@riseup.net +copyright: ♡ Copying is an act of love. Please copy, reuse and share. +category: Graphs, Git, Development +build-type: Simple +extra-source-files: AUTHORS ChangeLog COPYING INSTALL.md NEWS.md README.md +cabal-version: >=1.10 + +source-repository head + type: darcs + location: http://hub.darcs.net/fr33domlover/hit-graph + +library + exposed-modules: Data.Git.Graph + Data.Git.Graph.Util + Data.Graph.Inductive.Query.Topsort + -- other-modules: + -- other-extensions: + build-depends: base >= 4.8 && < 5 + , containers + --, dlist + , fgl + , hashable + , hit + , transformers + , unordered-containers + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Data/Git/Graph.hs b/src/Data/Git/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Data/Git/Graph.hs @@ -0,0 +1,260 @@ +{- This file is part of hit-graph. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Data.Git.Graph + ( NodeLabel + , EdgeLabel + , CommitGraph + , loadCommitGraph + , loadCommitGraphPT + , Depth + , commitDepths + , filterDepth + , partitionDepth + , isHealthy + , isShallow + , isExcluded + --, loadCommitGraphByNameMaybe + --, loadCommitGraphByName + --, loadCommitsTopsort + --, loadCommitsTopsortList + ) +where + +import Control.Monad.IO.Class +import Data.Foldable (foldl', foldlM) +import Data.Git.Named (RefName (..)) +import Data.Git.Ref (Ref, toBinary) +import Data.Git.Repository (getCommit, resolveRevision, branchList, tagList) +import Data.Git.Revision (Revision (..)) +import Data.Git.Storage (Git) +import Data.Git.Types (Commit (..)) +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Graph.Inductive.Query.BFS (leveln) +import Data.Hashable (Hashable (..)) +import Data.HashMap.Lazy (HashMap) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Ord (Down (..)) + +--import qualified Data.DList as D +import qualified Data.HashMap.Lazy as M +import qualified Data.Set as S + +import Data.Git.Graph.Util + +-- | Each node in the commit graph represents a commit. +type NodeLabel = (ObjId, Commit) + +-- | Edges are tagged by numbers defining the order of parents of a commit. For +-- each commit, the out-edges pointing to its parents are numbered according to +-- the order in which the parents were specified in the 'commitParents' field. +-- +-- The 'Down' wrapper reverses the comparison (the 'Ord' instance), so that +-- merged-from branches are inserted earlier into the sorted list than +-- merged-to branches. +type EdgeLabel = Down Int + +type CommitGraph g = g NodeLabel EdgeLabel + +-- | Build a directed acyclic graph of commits. The commits in the graph are +-- the ones specified, and all their ancestors. The edges point from a commit +-- to its parents. +loadCommitGraph :: Graph g => Git -> [ObjId] -> IO (CommitGraph g) +loadCommitGraph git refs = do + let visit (_rChild, _cChild) rParent v@(nextNode, commits) = + if rParent `M.member` commits + then return (v, Nothing) + else do + cParent <- getCommit git $ unObjId rParent + let commits' = M.insert rParent (cParent, nextNode) commits + return ((nextNode + 1, commits'), Just cParent) + cmts <- traverse (getCommit git . unObjId) refs + let pairs = zip refs $ map Just cmts + firstNode = 1 + (next, commits) <- loadCommitsMulti git visit (firstNode, M.empty) pairs + let sources = zip3 refs cmts [next..] + alter cmt node Nothing = Just (cmt, node) + alter _ _ j@(Just _) = j + f cs (ref, cmt, node) = M.alter (alter cmt node) ref cs + commits' = foldl' f commits sources + nodeOf r = maybe (error "ref has no node") snd $ M.lookup r commits' + mkNode l r (c, n) = (n, (r, c)) : l + nodes = M.foldlWithKey' mkNode [] commits' + mkEdge n l (r, e) = (n, nodeOf r, e) : l + edgeNums = map Down [1..] + parents = map ObjId . commitParents + mkEdges l (c, n) = foldl' (mkEdge n) l $ zip (parents c) edgeNums + edges = M.foldl' mkEdges [] commits' + return $ mkGraph nodes edges + +loadCommitGraphPT :: Git -> [ObjId] -> IO (CommitGraph Gr) +loadCommitGraphPT = loadCommitGraph + +type Depth = Int + +-- | Determine the depths of all the commits in the graph. Orphan commits (i.e. +-- which don't have parents are assigned depth 1, and any other commit gets a +-- higher depth. A commit's depth depends on the length of the shortest path +-- between that commit and any of the orphan commits. +commitDepths :: Graph g => CommitGraph g -> [(Node, Depth)] +commitDepths g = + let orphans = filter ((== 0) . indeg g) $ nodes g + in leveln (zip orphans (repeat 1)) g + +getDepth' :: HashMap Node Depth -> Node -> Depth +getDepth' depths node = + case M.lookup node depths of + Nothing -> error "node not found in depth map" + Just d -> d + +getLabel' :: Graph g => g a b -> Node -> a +getLabel' g n = + case lab g n of + Nothing -> error "node not found in graph" + Just l -> l + +parentRefs :: Graph g => CommitGraph g -> Node -> [ObjId] +parentRefs g n = map ObjId $ commitParents $ snd $ getLabel' g n + +-- | Return a subgraph containing only commits whose depth is up to the depth +-- specified. +filterDepth :: DynGraph g => Depth -> CommitGraph g -> CommitGraph g +filterDepth dmax g = subgraph [n | (n, d) <- commitDepths g, d <= dmax] g + +-- | Given a depth threshold /D/, the commits in the graph can be partitioned +-- into 3 groups: +-- +-- (1) Commits at depth /D/ or below, whose parents (if any) are all present in +-- the graph and as well at depth /D/ or below +-- (2) Commits at depth /D/ which have parents, and the parents are at depth +-- /D+1/ or missing from the graph +-- (3) Commits at depth /D+1/ or above +-- +-- In this library, these groups are called /healthy/, /shallow/ and /excluded/ +-- respectively. +partitionDepth + :: Graph g + => CommitGraph g + -> HashMap Node Depth + -> Depth + -> ([LNode NodeLabel], [LNode NodeLabel], [LNode NodeLabel]) +partitionDepth g depths thresh = + let getDepth = getDepth' depths + f (healthy, shallow, excluded) l@(n, (_r, c)) = + let d = getDepth n + in if d > thresh + then (healthy, shallow, l : excluded) + else + let parentsN = suc g n + parentsC = commitParents c + allHere = length parentsN == length parentsC + inThresh p = getDepth p <= thresh + in if allHere && all inThresh parentsN + then (l : healthy , shallow , excluded) + else (healthy , l : shallow , excluded) + in foldl f ([], [], []) $ labNodes g + +-- | Determine whether a given commit is healthy (see 'partitionDepth'). +isHealthy + :: Graph g + => CommitGraph g + -> HashMap Node Depth + -> Depth + -> Node + -> Bool +isHealthy g depths thresh node = + let inThresh n = getDepth' depths n <= thresh + parents = suc g node + in inThresh node && + length parents == length (parentRefs g node) && + all inThresh parents + +-- | Determine whether a given commit is shallow (see 'partitionDepth'). +isShallow + :: Graph g + => CommitGraph g + -> HashMap Node Depth + -> Depth + -> Node + -> Bool +isShallow g depths thresh node = + let inThresh n = getDepth' depths n <= thresh + parents = suc g node + in inThresh node && + not ( length parents == length (parentRefs g node) && + all inThresh parents + ) + +-- | Determine whether a given commit is excluded (see 'partitionDepth'). +isExcluded + :: Graph g + => CommitGraph g + -> HashMap Node Depth + -> Depth + -> Node + -> Bool +isExcluded _g depths thresh node = getDepth' depths node > thresh + +-- / Like 'loadCommitGraphByRef', but lets you specify a named ref, such as a +-- branch or tag name. Returns 'Nothing' if ref isn't found. +{-loadCommitGraphByNameMaybe :: + Graph g => Git -> String -> IO (Maybe (CommitGraph g)) +loadCommitGraphByNameMaybe git name = do + mref <- resolveNameMaybe git name + case mref of + Nothing -> return Nothing + Just ref -> Just <$> loadCommitGraphByRef git ref +-} + +-- / Like 'loadCommitGraphByNameMaybe', but throws an exception if the ref name +-- can't be resolved. +{-loadCommitGraphByName :: Graph g => Git -> String -> IO (CommitGraph g) +loadCommitGraphByName git name = do + mg <- loadCommitGraphByNameMaybe git name + case mg of + Nothing -> error "no such ref" + Just g -> return g +-} + +-- / Load a commit graph and topsort the commits. The resulting list starts +-- with the last commit in the repo and ends with the initial commit. +{-loadCommitsTopsort + :: (ResultList l, Functor l) + => Git + -> String + -> IO (l (Ref, Commit)) +loadCommitsTopsort git name = do + let load :: IO (CommitGraph Gr) + load = loadCommitGraphByName git name + graph <- load + let mnodes = topsortUnmixOrder graph (NodeStack [rootN]) + nodes = case mnodes of + Nothing -> error "commit graph contains a cycle" + Just ns -> ns + return $ fmap (nodeLabel graph) nodes +-} + +{-instance ResultList D.DList where + emptyList = D.empty + appendItem = flip D.snoc +-} + +-- / Runs 'loadCommitsTopsort' with a 'D.DList', then converts to list and +-- returns it. At least at the time of writing, DList mapping and folding goes +-- through a regular list anyway. +{-loadCommitsTopsortList :: Git -> String -> IO [(Ref, Commit)] +loadCommitsTopsortList git name = D.toList <$> loadCommitsTopsort git name +-} diff --git a/src/Data/Git/Graph/Util.hs b/src/Data/Git/Graph/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Git/Graph/Util.hs @@ -0,0 +1,144 @@ +{- This file is part of hit-graph. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Data.Git.Graph.Util + ( ObjId (..) + , resolveNameMaybe + , resolveName + , listReferences + , loadCommits + , loadCommitsMulti + ) +where + +import Control.Monad.IO.Class +import Data.Foldable (foldl', foldlM) +import Data.Git.Named (RefName (..)) +import Data.Git.Ref (Ref, toBinary) +import Data.Git.Repository (getCommit, resolveRevision, branchList, tagList) +import Data.Git.Revision (Revision (..)) +import Data.Git.Storage (Git) +import Data.Git.Types (Commit (..)) +import Data.Graph.Inductive.Graph (Graph (mkGraph), Node) +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Hashable (Hashable (..)) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Ord (Down (..)) + +--import qualified Data.DList as D +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S + +import Data.Graph.Inductive.Query.Topsort + +-- | A git object identifier. This is a SHA-1 hash. Its common textual +-- representation is a 40-byte ASCII hexadecimal string. +newtype ObjId = ObjId { unObjId :: Ref } deriving Eq + +instance Hashable ObjId where + hashWithSalt salt = hashWithSalt salt . toBinary . unObjId + hash = hash . toBinary . unObjId + +-- | For a given ref name - HEAD or branch or tag - determine its ref hash. +resolveNameMaybe :: Git -> String -> IO (Maybe ObjId) +resolveNameMaybe git name = + fmap ObjId <$> resolveRevision git (Revision name []) + +-- | For a given ref name - HEAD or branch or tag - determine its ref hash. +resolveName :: Git -> String -> IO ObjId +resolveName git name = do + moid <- resolveNameMaybe git name + return $ fromMaybe (error "No such ref name in the repo") moid + +-- | List the available references in a git repo, sorted by ref name. The list +-- includes HEAD, branches and tags. +listReferences :: Git -> IO [(ObjId, String)] +listReferences git = do + branches <- S.mapMonotonic refNameRaw <$> branchList git + tags <- S.mapMonotonic refNameRaw <$> tagList git + let names = S.toAscList $ S.insert "HEAD" $ S.union branches tags + mentries <- + traverse + (\ name -> fmap (flip (,) name) <$> resolveNameMaybe git name) + names + return $ catMaybes mentries + +-- | Load the entire graph of commits which are ancestors of the given ref +-- (and that ref itself). Fold the commit structure into a value of type @a@ +-- inside monad @m@. +-- +-- This is a low-level function which operates on a commit tree, i.e. the same +-- ref may be visited more than once (if it has more than one child commit). +-- You can use the provided flexibility to implement graph algorithms over the +-- commits, or build a graph using some graph library and use that library's +-- tools for further processing. +loadCommits + :: MonadIO m + => Git + -- ^ Open git repository context + -> ((ObjId, Commit) -> ObjId -> a -> m (a, Maybe Commit)) + -- ^ Given a child commit, one of its parent commits and an @a@ value, + -- generate an updated @a@ value. The second returned value determines + -- whether traversal should proceed to the parent of the parent commit. If + -- you return 'Nothing', it won't. If you load the parent commit (e.g. with + -- 'getCommit') and return 'Just' it, traversal will proceed to its + -- parents. + -> a + -- ^ Initial value + -> ObjId + -- ^ Hash of the commit whose ancestor graph should be loaded + -> Maybe Commit + -- ^ If you already read the commit for the ref passed as the previous + -- parameter, pass the commit here to avoid repeated loading of it. + -- Otherwise, pass 'Nothing' and it will be read from the repo. + -> m a +loadCommits git func val oid mcmt = readCommitMaybe oid mcmt >>= go val oid + where + readCommit = liftIO . getCommit git . unObjId + readCommitMaybe r = maybe (readCommit r) return + step p v r = do + (v', mc) <- func p r v + case mc of + Nothing -> return v' + Just c -> go v' r c + go v r c = foldlM (step (r, c)) v $ map ObjId $ commitParents c + +-- | Like 'loadCommits', but takes a list of refs and goes over all their +-- ancestors. This is just a convenience shortcut which folds a list with +-- 'loadCommits'. Passing a list with a single element is the same as running +-- 'loadCommits'. +loadCommitsMulti + :: MonadIO m + => Git + -- ^ Open git repository context + -> ((ObjId, Commit) -> ObjId -> a -> m (a, Maybe Commit)) + -- ^ Given a child commit, one of its parent commits and an @a@ value, + -- generate an updated @a@ value. The second returned value determines + -- whether traversal should proceed to the parent of the parent commit. If + -- you return 'Nothing', it won't. If you load the parent commit (e.g. with + -- 'getCommit') and return 'Just' it, traversal will proceed to its + -- parents. + -> a + -- ^ Initial value + -> [(ObjId, Maybe Commit)] + -- ^ Commits whose ancestors to scan. For each commit, pass: + -- + -- (1) Hash of the commit + -- (2) If you already loaded the commit from the ref, pass the commit here + -- to avoid repeated loading of it. Otherwise, pass 'Nothing' and it + -- will be read from the repo. + -> m a +loadCommitsMulti git func val pairs = + foldlM (\ v (r, mc) -> loadCommits git func v r mc) val pairs diff --git a/src/Data/Graph/Inductive/Query/Topsort.hs b/src/Data/Graph/Inductive/Query/Topsort.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Inductive/Query/Topsort.hs @@ -0,0 +1,175 @@ +{- This file is part of hit-graph. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Data.Graph.Inductive.Query.Topsort + ( nodeLabel + , NodeSet (..) + , TraversalOrder (..) + , ResultList (..) + , topsortKahn + , NodeStack (..) + , topsortUnmix + , topsortUnmixOrder + ) +where + +import Prelude + +import Data.Foldable (foldl') +import Data.Graph.Inductive.Graph +import Data.List (sortBy) + +-- | Find the label for a 'Node', assuming you know the node exists in the +-- graph. If the node isn't found, an exception is thrown. +nodeLabel :: Graph g => g a b -> Node -> a +nodeLabel g n = + case lab g n of + Nothing -> error "node not found in graph" + Just l -> l + +-- | A graph node container to be used with Kanh's topsort algorithm. +class NodeSet s where + -- | Take a graph node and a container, insert the node into it and return + -- the resulting container. + --insert :: LNode a -> s a -> s a + insertNode :: Node -> s -> s + -- | Remove a node from the container. Return the removed node and the + -- resulting container after removal. If the container is empty (i.e. there + -- is no node to remove), return 'Nothing'. + --extract :: s a -> Maybe (LNode a, s a) + extractNode :: s -> Maybe (Node, s) + +-- | Specification of the order in which a node's outgoing edges should be +-- traversed. +data TraversalOrder b + -- | The order in which they're listed by FGL functions. The FGL + -- documentation doesn't seem to specify the order, which means it may + -- depend entirely on the 'Graph' instance you are using. + = InOrder + -- | Reverse of 'InOrder'. + | ReverseOrder + -- | Sort the outgoing edge list before traversal, using the given ordering + -- function. It takes two pairs, each pair having a labeled node and the + -- label of the edge, and determines the order they should be visited. 'LT' + -- means the first edge is visited first. 'GT' means the second edge is + -- visited first. 'EQ' means it doesn't matter and the implementation can + -- choose arbitrarily. + | SortedOrder ((Node, b) -> (Node, b) -> Ordering) + -- | Lets you reorder the edge list in an arbitrary way before it gets + -- traversed. Note that it's up to you to make sure the list you return + -- really contains all the items of the input list. + | CustomOrder ([(Node, b)] -> [(Node, b)]) + +sortNodes :: TraversalOrder b -> [(Node, b)] -> [(Node, b)] +sortNodes InOrder = id +sortNodes ReverseOrder = reverse +sortNodes (SortedOrder f) = sortBy f +sortNodes (CustomOrder f) = f + +-- | A container for storing the result of the sorting. Kahn's algorithm begins +-- with an empty structure and then appends nodes to produce the result. +-- Therefore almost any sequence container could work. +-- +-- You can also use a regular Haskell list. Implement 'append' using list +-- prepend and remember to 'reverse' the list returned by the algorithm. +class ResultList l where + emptyList :: l a + appendItem :: a -> l a -> l a + +-- | Flexible topological sort using Kahn's algorithm. +-- +-- It seems that Haskell graph libraries (and perhaps graph libraries in +-- general) tend to implement topological sort using depth-first search (DFS). +-- While it's probably easier (since these libraries also implement DFS), the +-- result is that you pass a graph to a function and get back the sorted list. +-- There is no room left for specifying variable parts of the algorithm, which +-- means you can't control which topsort order (out of potentially many orders +-- possible) you get. Sometimes you don't care, but sometimes you do. +-- +-- Kahn's algorithm has room for variations in two places: +-- +-- (1) When traversing a node's outgoing edges, the order in which this +-- traversal happens isn't specified. +-- (2) The internals of structure S, the set of nodes with no inbound edges, +-- aren't specified. Therefore, so is the order in which nodes are removed +-- from it. +-- +-- https://en.wikipedia.org/wiki/Topological_sort#Kahn.27s_algorithm +topsortKahn + :: (DynGraph g, NodeSet s, ResultList l) + => g a b + -- ^ Graph whose nodes to sort + -> s + -- ^ The set of graph nodes which don't have inbound edges + -> TraversalOrder b + -- ^ In which order to go over the outgoing edges of a node + -> Maybe (l Node) + -- ^ Topologically sorted list. For each edge from node @u@ to node @v@, + -- @u@ appears before @v@ in this list. If the graph is empty or the + -- initial node set is empty, an empty list is returned. If the graph + -- contains a cycle, 'Nothing' is returned. +topsortKahn graph set order = f graph set emptyList + where + nEdges = length . labEdges + sort = sortNodes order + visit n (g, s) m = + let g' = delEdge (n, m) g + s' = + if indeg g' m > 0 + then s + else insertNode m s + in (g', s') + f g s l = + case extractNode s of + Nothing -> + if nEdges g > 0 + then Nothing + else Just l + Just (n, s') -> + let l' = appendItem n l + children = map fst $ sort $ lsuc g n + (g', s'') = foldl' (visit n) (g, s') children + in f g' s'' l' + +newtype NodeStack = NodeStack [Node] + +instance NodeSet NodeStack where + insertNode n (NodeStack l) = NodeStack $ n : l + extractNode (NodeStack l) = + case l of + [] -> Nothing + (n:ns) -> Just (n, NodeStack ns) + +-- | Topologically sort commits so that parallel lines of work, e.g. a master +-- branch and a short topic branch merged into it, don't get their commits +-- mixed in the sorted order. +topsortUnmix + :: (DynGraph g, ResultList l) + => g a b + -> NodeStack + -> TraversalOrder b + -> Maybe (l Node) +topsortUnmix = topsortKahn + +-- | Adds an additioal constraint to 'topsortUnmix': When traversing a node's +-- outgoing edges, do so using the 'Ord' instance of the labels of the edges. +topsortUnmixOrder + :: (Ord b, DynGraph g, ResultList l) + => g a b + -> NodeStack + -> Maybe (l Node) +topsortUnmixOrder graph stack = + let order (_, i) (_, j) = compare i j + in topsortUnmix graph stack (SortedOrder order)