{-# 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 {Tag -> Text
unTag :: Text}
  deriving (Tag -> Tag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq, Eq Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
Ord, Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> String
$cshow :: Tag -> String
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show, forall x. Rep Tag x -> Tag
forall x. Tag -> Rep Tag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Tag x -> Tag
$cfrom :: forall x. Tag -> Rep Tag x
Generic)
  deriving newtype
    ( [Tag] -> Encoding
[Tag] -> Value
Tag -> Encoding
Tag -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Tag] -> Encoding
$ctoEncodingList :: [Tag] -> Encoding
toJSONList :: [Tag] -> Value
$ctoJSONList :: [Tag] -> Value
toEncoding :: Tag -> Encoding
$ctoEncoding :: Tag -> Encoding
toJSON :: Tag -> Value
$ctoJSON :: Tag -> Value
ToJSON,
      Value -> Parser [Tag]
Value -> Parser Tag
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Tag]
$cparseJSONList :: Value -> Parser [Tag]
parseJSON :: Value -> Parser Tag
$cparseJSON :: Value -> Parser Tag
FromJSON,
      ToJSONKeyFunction [Tag]
ToJSONKeyFunction Tag
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [Tag]
$ctoJSONKeyList :: ToJSONKeyFunction [Tag]
toJSONKey :: ToJSONKeyFunction Tag
$ctoJSONKey :: ToJSONKeyFunction Tag
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 {TagPattern -> String
unTagPattern :: FilePattern}
  deriving
    ( TagPattern -> TagPattern -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagPattern -> TagPattern -> Bool
$c/= :: TagPattern -> TagPattern -> Bool
== :: TagPattern -> TagPattern -> Bool
$c== :: TagPattern -> TagPattern -> Bool
Eq,
      Eq TagPattern
TagPattern -> TagPattern -> Bool
TagPattern -> TagPattern -> Ordering
TagPattern -> TagPattern -> TagPattern
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagPattern -> TagPattern -> TagPattern
$cmin :: TagPattern -> TagPattern -> TagPattern
max :: TagPattern -> TagPattern -> TagPattern
$cmax :: TagPattern -> TagPattern -> TagPattern
>= :: TagPattern -> TagPattern -> Bool
$c>= :: TagPattern -> TagPattern -> Bool
> :: TagPattern -> TagPattern -> Bool
$c> :: TagPattern -> TagPattern -> Bool
<= :: TagPattern -> TagPattern -> Bool
$c<= :: TagPattern -> TagPattern -> Bool
< :: TagPattern -> TagPattern -> Bool
$c< :: TagPattern -> TagPattern -> Bool
compare :: TagPattern -> TagPattern -> Ordering
$ccompare :: TagPattern -> TagPattern -> Ordering
Ord,
      Int -> TagPattern -> ShowS
[TagPattern] -> ShowS
TagPattern -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagPattern] -> ShowS
$cshowList :: [TagPattern] -> ShowS
show :: TagPattern -> String
$cshow :: TagPattern -> String
showsPrec :: Int -> TagPattern -> ShowS
$cshowsPrec :: Int -> TagPattern -> ShowS
Show,
      forall x. Rep TagPattern x -> TagPattern
forall x. TagPattern -> Rep TagPattern x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TagPattern x -> TagPattern
$cfrom :: forall x. TagPattern -> Rep TagPattern x
Generic
    )
  deriving newtype
    ( [TagPattern] -> Encoding
[TagPattern] -> Value
TagPattern -> Encoding
TagPattern -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TagPattern] -> Encoding
$ctoEncodingList :: [TagPattern] -> Encoding
toJSONList :: [TagPattern] -> Value
$ctoJSONList :: [TagPattern] -> Value
toEncoding :: TagPattern -> Encoding
$ctoEncoding :: TagPattern -> Encoding
toJSON :: TagPattern -> Value
$ctoJSON :: TagPattern -> Value
ToJSON,
      Value -> Parser [TagPattern]
Value -> Parser TagPattern
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TagPattern]
$cparseJSONList :: Value -> Parser [TagPattern]
parseJSON :: Value -> Parser TagPattern
$cparseJSON :: Value -> Parser TagPattern
FromJSON
    )

mkTagPattern :: Text -> TagPattern
mkTagPattern :: Text -> TagPattern
mkTagPattern =
  String -> TagPattern
TagPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString

mkTagPatternFromTag :: Tag -> TagPattern
mkTagPatternFromTag :: Tag -> TagPattern
mkTagPatternFromTag (Tag Text
t) =
  String -> TagPattern
TagPattern forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> String
toString Text
t

tagMatch :: TagPattern -> Tag -> Bool
tagMatch :: TagPattern -> Tag -> Bool
tagMatch (TagPattern String
pat) (Tag Text
tag) =
  String
pat String -> String -> Bool
?== forall a. ToString a => a -> String
toString Text
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 {TagNode -> Text
unTagNode :: Text}
  deriving (TagNode -> TagNode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagNode -> TagNode -> Bool
$c/= :: TagNode -> TagNode -> Bool
== :: TagNode -> TagNode -> Bool
$c== :: TagNode -> TagNode -> Bool
Eq, Int -> TagNode -> ShowS
[TagNode] -> ShowS
TagNode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagNode] -> ShowS
$cshowList :: [TagNode] -> ShowS
show :: TagNode -> String
$cshow :: TagNode -> String
showsPrec :: Int -> TagNode -> ShowS
$cshowsPrec :: Int -> TagNode -> ShowS
Show, Eq TagNode
TagNode -> TagNode -> Bool
TagNode -> TagNode -> Ordering
TagNode -> TagNode -> TagNode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagNode -> TagNode -> TagNode
$cmin :: TagNode -> TagNode -> TagNode
max :: TagNode -> TagNode -> TagNode
$cmax :: TagNode -> TagNode -> TagNode
>= :: TagNode -> TagNode -> Bool
$c>= :: TagNode -> TagNode -> Bool
> :: TagNode -> TagNode -> Bool
$c> :: TagNode -> TagNode -> Bool
<= :: TagNode -> TagNode -> Bool
$c<= :: TagNode -> TagNode -> Bool
< :: TagNode -> TagNode -> Bool
$c< :: TagNode -> TagNode -> Bool
compare :: TagNode -> TagNode -> Ordering
$ccompare :: TagNode -> TagNode -> Ordering
Ord, forall x. Rep TagNode x -> TagNode
forall x. TagNode -> Rep TagNode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TagNode x -> TagNode
$cfrom :: forall x. TagNode -> Rep TagNode x
Generic)
  deriving newtype ([TagNode] -> Encoding
[TagNode] -> Value
TagNode -> Encoding
TagNode -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TagNode] -> Encoding
$ctoEncodingList :: [TagNode] -> Encoding
toJSONList :: [TagNode] -> Value
$ctoJSONList :: [TagNode] -> Value
toEncoding :: TagNode -> Encoding
$ctoEncoding :: TagNode -> Encoding
toJSON :: TagNode -> Value
$ctoJSON :: TagNode -> Value
ToJSON)

deconstructTag :: HasCallStack => Tag -> NonEmpty TagNode
deconstructTag :: HasCallStack => Tag -> NonEmpty TagNode
deconstructTag (Tag Text
s) =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a t. (HasCallStack, IsText t) => t -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> String -> Text -> Either Text a
parse Parser (NonEmpty TagNode)
tagParser (forall a. ToString a => a -> String
toString Text
s) Text
s
  where
    tagParser :: Parser (NonEmpty TagNode)
    tagParser :: Parser (NonEmpty TagNode)
tagParser =
      Parser TagNode
nodeParser forall (m :: * -> *) a sep.
MonadPlus m =>
m a -> m sep -> m (NonEmpty a)
`sepBy1` forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
M.char Char
'/'
    nodeParser :: Parser TagNode
    nodeParser :: Parser TagNode
nodeParser =
      Text -> TagNode
TagNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToText a => a -> Text
toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.some (forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.anySingleBut Char
'/')

constructTag :: NonEmpty TagNode -> Tag
constructTag :: NonEmpty TagNode -> Tag
constructTag (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TagNode -> Text
unTagNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [Text]
nodes) =
  Text -> Tag
Tag forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
nodes

-- | Construct the tree from a list of hierarchical tags
tagTree :: (Eq a, Default a) => Map Tag a -> Forest (TagNode, a)
tagTree :: forall a. (Eq a, Default a) => Map Tag a -> Forest (TagNode, a)
tagTree Map Tag a
tags =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a ann. (NonEmpty a -> ann) -> Tree a -> Tree (a, ann)
annotatePathsWith forall a b. (a -> b) -> a -> b
$ forall {a}. Default a => Map Tag a -> NonEmpty TagNode -> a
countFor Map Tag a
tags) forall a b. (a -> b) -> a -> b
$
    forall a. Ord a => [[a]] -> Forest a
mkTreeFromPaths forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Tag -> NonEmpty TagNode
deconstructTag
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [k]
Map.keys Map Tag a
tags
  where
    countFor :: Map Tag a -> NonEmpty TagNode -> a
countFor Map Tag a
tags' NonEmpty TagNode
path =
      forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NonEmpty TagNode -> Tag
constructTag NonEmpty TagNode
path) Map Tag a
tags'

foldTagTree :: (Eq a, Default a) => Forest (TagNode, a) -> Forest (NonEmpty TagNode, a)
foldTagTree :: forall a.
(Eq a, Default a) =>
Forest (TagNode, a) -> Forest (NonEmpty TagNode, a)
foldTagTree Forest (TagNode, a)
tree =
  forall a. (a -> a -> Maybe a) -> Tree a -> Tree a
foldSingleParentsWith forall {a} {a} {b}.
(Eq a, Default a, Semigroup a) =>
(a, a) -> (a, b) -> Maybe (a, b)
foldNodes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. a -> [a] -> NonEmpty a
:| []))) Forest (TagNode, a)
tree
  where
    foldNodes :: (a, a) -> (a, b) -> Maybe (a, b)
foldNodes (a
parent, a
x) (a
child, b
y) = do
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
x forall a. Eq a => a -> a -> Bool
== forall a. Default a => a
def)
      forall a. a -> Maybe a
Just (a
parent forall a. Semigroup a => a -> a -> a
<> a
child, b
y)

type Parser a = M.Parsec Void Text a

parse :: Parser a -> String -> Text -> Either Text a
parse :: forall a. Parser a -> String -> Text -> Either Text a
parse Parser a
p String
fn Text
s =
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. ToText a => a -> Text
toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
M.errorBundlePretty) forall a b. (a -> b) -> a -> b
$
    forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
M.parse (Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
M.eof) String
fn Text
s