tagtree (empty) → 0.1.0.0

raw patch · 5 files changed

+290/−0 lines, 5 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, data-default, filepattern, megaparsec, parser-combinators, relude, text

Files

• LICENSE +30/−0
• README.md +15/−0
• src/Data/TagTree.hs +143/−0
• src/Data/TagTree/PathTree.hs +38/−0
• tagtree.cabal +64/−0

@@ -0,0 +1,30 @@+Copyright (c) 2021, Sridhar Ratnakumar++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sridhar Ratnakumar nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,15 @@+# tagtree++Haskell library for representing hierarchical tags, such as `foo/bar/qux`, as well as a tree of such tags and then searching them based on path patterns.++## Developing++- [Install Nix](https://nixos.org/download.html) & [enable Flakes](https://nixos.wiki/wiki/Flakes)+- Run `nix-shell --run haskell-language-server` to sanity check your environment +- [Open as single-folder workspace](https://code.visualstudio.com/docs/editor/workspaces#_singlefolder-workspaces) in Visual Studio Code+    - Install the [workspace recommended](https://code.visualstudio.com/docs/editor/extension-marketplace#_workspace-recommended-extensions) extensions+    - <kbd>Ctrl+Shift+P</kbd> to run command "Nix-Env: Select Environment" and select `shell.nix`. The extension will ask you to reload VSCode at the end.+- Press <kbd>Ctrl+Shift+B</kbd> in VSCode, or run `bin/run` (`bin/run-via-tmux` if you have tmux installed) in terminal, to launch Ghcid running your program.++All but the final step need to be done only once.+

@@ -0,0 +1,143 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}++module Data.TagTree+  ( -- * Types+    Tag (..),+    TagPattern (unTagPattern),+    TagNode (..),++    -- * Create Tags+    constructTag,+    deconstructTag,++    -- * Creating Tag Trees+    tagTree,++    -- * Searching Tags+    mkTagPattern,+    mkTagPatternFromTag,+    tagMatch,++    -- * Working with Tag Trees+    foldTagTree,+  )+where++import Control.Monad.Combinators.NonEmpty (sepBy1)+import Data.Aeson (FromJSON, ToJSON, ToJSONKey)+import Data.Default (Default (def))+import qualified Data.Map.Strict as Map+import Data.TagTree.PathTree (annotatePathsWith, foldSingleParentsWith, mkTreeFromPaths)+import qualified Data.Text as T+import Data.Tree (Forest)+import System.FilePattern (FilePattern, (?==))+import qualified Text.Megaparsec as M+import qualified Text.Megaparsec.Char as M++-- | A hierarchical tag+--+-- Tag nodes are separated by @/@+newtype Tag = Tag {unTag :: Text}+  deriving (Eq, Ord, Show, Generic)+  deriving newtype+    ( ToJSON,+      FromJSON,+      ToJSONKey+    )++--------------+-- Tag Pattern+---------------++-- | A glob-based pattern to match hierarchical tags+--+-- For example, the pattern+--+-- > foo/**+--+-- matches both the following+--+-- > foo/bar/baz+-- > foo/baz+newtype TagPattern = TagPattern {unTagPattern :: FilePattern}+  deriving+    ( Eq,+      Ord,+      Show,+      Generic+    )+  deriving newtype+    ( ToJSON,+      FromJSON+    )++mkTagPattern :: Text -> TagPattern+mkTagPattern =+  TagPattern . toString++mkTagPatternFromTag :: Tag -> TagPattern+mkTagPatternFromTag (Tag t) =+  TagPattern $ toString t++tagMatch :: TagPattern -> Tag -> Bool+tagMatch (TagPattern pat) (Tag tag) =+  pat ?== toString tag++-----------+-- Tag Tree+-----------++-- | An individual component of a hierarchical tag+--+-- The following hierarchical tag,+--+-- > foo/bar/baz+--+-- has three tag nodes: @foo@, @bar@ and @baz@+newtype TagNode = TagNode {unTagNode :: Text}+  deriving (Eq, Show, Ord, Generic)+  deriving newtype (ToJSON)++deconstructTag :: HasCallStack => Tag -> NonEmpty TagNode+deconstructTag (Tag s) =+  either error id $ parse tagParser (toString s) s+  where+    tagParser :: Parser (NonEmpty TagNode)+    tagParser =+      nodeParser `sepBy1` M.char '/'+    nodeParser :: Parser TagNode+    nodeParser =+      TagNode . toText <$> M.some (M.anySingleBut '/')++constructTag :: NonEmpty TagNode -> Tag+constructTag (fmap unTagNode . toList -> nodes) =+  Tag $ T.intercalate "/" nodes++-- | Construct the tree from a list of hierarchical tags+tagTree :: (Eq a, Default a) => Map Tag a -> Forest (TagNode, a)+tagTree tags =+  fmap (annotatePathsWith $ countFor tags) $+    mkTreeFromPaths $+      toList . deconstructTag+        <$> Map.keys tags+  where+    countFor tags' path =+      fromMaybe def $ Map.lookup (constructTag path) tags'++foldTagTree :: (Eq a, Default a) => Forest (TagNode, a) -> Forest (NonEmpty TagNode, a)+foldTagTree tree =+  foldSingleParentsWith foldNodes <$> fmap (fmap (first (:| []))) tree+  where+    foldNodes (parent, x) (child, y) = do+      guard (x == def)+      Just (parent <> child, y)++type Parser a = M.Parsec Void Text a++parse :: Parser a -> String -> Text -> Either Text a+parse p fn s =+  first (toText . M.errorBundlePretty) $+    M.parse (p <* M.eof) fn s

@@ -0,0 +1,38 @@+module Data.TagTree.PathTree+  ( mkTreeFromPaths,+    annotatePathsWith,+    foldSingleParentsWith,+  )+where++import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import Data.Tree (Forest, Tree (Node))+import Relude.Extra.Group (groupBy)++mkTreeFromPaths :: Ord a => [[a]] -> Forest a+mkTreeFromPaths paths = uncurry mkNode <$> Map.assocs groups+  where+    groups = fmap tail <$> groupBy head (mapMaybe nonEmpty paths)+    mkNode label children =+      Node label $ mkTreeFromPaths $ toList children++annotatePathsWith :: (NonEmpty a -> ann) -> Tree a -> Tree (a, ann)+annotatePathsWith f = go []+  where+    go ancestors (Node rel children) =+      let path = rel :| ancestors+       in Node (rel, f $ NE.reverse path) $ fmap (go $ toList path) children++-- | Fold nodes with one child using the given function+--+-- The function is called with the parent and the only child. If a Just value is+-- returned, folding happens with that value, otherwise there is no effect.+foldSingleParentsWith :: (a -> a -> Maybe a) -> Tree a -> Tree a+foldSingleParentsWith f = go+  where+    go (Node parent children) =+      case fmap go children of+        [Node child grandChildren]+          | Just new <- f parent child -> Node new grandChildren+        xs -> Node parent xs

@@ -0,0 +1,64 @@+cabal-version:      2.4+name:               tagtree+version:            0.1.0.0+license:            BSD-3-Clause+copyright:          2021 Sridhar Ratnakumar+maintainer:         srid@srid.ca+author:             Sridhar Ratnakumar+category:           Web++-- TODO: Before hackage release.+-- A short (one-line) description of the package.+synopsis:           Hierarchical Tags & Tag Trees++-- A longer description of the package.+description:+  Haskell library for representing hierarchical tags (eg: @foo\/bar\/qux@) and trees of such tags, as well as for searching them based on filepath patterns.++-- A URL where users can report bugs.+-- bug-reports:++extra-source-files:+  LICENSE+  README.md++library+  build-depends:+    , aeson+    , base >= 4.13.0.0 && <=4.17.0.0+    , bytestring+    , containers+    , data-default+    , filepattern+    , megaparsec+    , parser-combinators+    , relude+    , text++  mixins:+    base hiding (Prelude),+    relude (Relude as Prelude, Relude.Container.One),+    relude++  ghc-options:+    -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns++  exposed-modules:+    Data.TagTree+    Data.TagTree.PathTree++  default-extensions:+    DerivingStrategies+    FlexibleContexts+    FlexibleInstances+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    OverloadedStrings+    ScopedTypeVariables+    TupleSections+    ViewPatterns++  hs-source-dirs:     src+  default-language:   Haskell2010