diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Sridhar Ratnakumar + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# path-tree + diff --git a/path-tree.cabal b/path-tree.cabal new file mode 100644 --- /dev/null +++ b/path-tree.cabal @@ -0,0 +1,84 @@ +cabal-version: 2.4 +name: path-tree +version: 0.2.0.0 +license: MIT +copyright: 2022 Sridhar Ratnakumar +maintainer: srid@srid.ca +author: Sridhar Ratnakumar +category: Data Structures + +-- A short (one-line) description of the package. +synopsis: `Data.Tree` for file paths + +-- A longer description of the package. +description: `Data.Tree` for file paths + +-- A URL where users can report bugs. +bug-reports: https://github.com/srid/pathtree + +extra-source-files: + LICENSE + README.md + +library + build-depends: + , base >=4.13.0.0 && <=4.18.0.0 + , containers + , relude + + mixins: + base hiding (Prelude), + relude (Relude as Prelude, Relude.Container.One), + relude + + ghc-options: + -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wmissing-deriving-strategies -Wunused-foralls -Wunused-foralls + -fprint-explicit-foralls -fprint-explicit-kinds + + default-extensions: + NoStarIsType + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTSyntax + GeneralisedNewtypeDeriving + ImportQualifiedPost + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NumericUnderscores + OverloadedStrings + PolyKinds + PostfixOperators + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + + exposed-modules: + Data.Tree.Path + + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Data/Tree/Path.hs b/src/Data/Tree/Path.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Path.hs @@ -0,0 +1,70 @@ +module Data.Tree.Path where + +import Data.List qualified as List +import Data.List.NonEmpty qualified as NE +import Data.Tree (Tree (Node)) +import Data.Tree qualified as Tree + +treeInsertPath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a] +treeInsertPath = + treeInsertPathMaintainingOrder void + +-- | Insert a node by path into a tree with descendants that are ordered. +-- +-- Insertion will guarantee that descendants continue to be ordered as expected. +-- +-- The order of descendents is determined by the given order function, which +-- takes the path to a node and return that node's order. The intention is to +-- lookup the actual order value which exists *outside* of the tree +-- datastructure itself. +treeInsertPathMaintainingOrder :: (Eq a, Ord ord) => (NonEmpty a -> ord) -> NonEmpty a -> [Tree a] -> [Tree a] +treeInsertPathMaintainingOrder ordF path t = + orderedTreeInsertPath ordF (toList path) t [] + where + orderedTreeInsertPath :: (Eq a, Ord b) => (NonEmpty a -> b) -> [a] -> [Tree a] -> [a] -> [Tree a] + orderedTreeInsertPath _ [] trees _ = + trees + orderedTreeInsertPath pathOrder (top : rest) trees ancestors = + case treeFindChild top trees of + Nothing -> + let newChild = Node top $ orderedTreeInsertPath pathOrder rest [] (top : ancestors) + in sortChildrenOn pathOrder (trees <> one newChild) + Just (Node _match grandChildren) -> + let oneDead = treeDeleteChild top trees + newChild = Node top $ orderedTreeInsertPath pathOrder rest grandChildren (top : ancestors) + in sortChildrenOn pathOrder (oneDead <> one newChild) + where + treeFindChild x xs = + List.find (\n -> Tree.rootLabel n == x) xs + sortChildrenOn f = + sortOn $ (\s -> f $ NE.reverse $ s :| ancestors) . Tree.rootLabel + +treeDeletePath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a] +treeDeletePath = + treeDeletePathWithLastBehavingAs $ \lastInPath ts -> + List.deleteBy (\x y -> Tree.rootLabel x == Tree.rootLabel y) (Node lastInPath []) ts + +treeDeleteLeafPath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a] +treeDeleteLeafPath = + treeDeletePathWithLastBehavingAs $ \lastInPath ts -> + case ts of + [t] -> [t | Tree.rootLabel t /= lastInPath] + _ -> ts + +treeDeletePathWithLastBehavingAs :: forall a. Eq a => (a -> [Tree a] -> [Tree a]) -> NonEmpty a -> [Tree a] -> [Tree a] +treeDeletePathWithLastBehavingAs f slugs = + go (toList slugs) + where + go :: [a] -> [Tree a] -> [Tree a] + go [] t = t + go [p] ts = + f p ts + go (p : ps) t = + t <&> \node@(Node x xs) -> + if x == p + then Node x $ go ps xs + else node + +treeDeleteChild :: Eq a => a -> [Tree a] -> [Tree a] +treeDeleteChild x = + List.deleteBy (\p q -> Tree.rootLabel p == Tree.rootLabel q) (Node x [])