module Emanote.Model.Query where

import Data.IxSet.Typed ((@+), (@=))
import Data.IxSet.Typed qualified as Ix
import Data.Text qualified as T
import Emanote.Model.Calendar qualified as Calendar
import Emanote.Model.Note (Note)
import Emanote.Model.Note qualified as N
import Emanote.Model.Type (Model, modelNotes, modelTags)
import Emanote.Pandoc.Markdown.Syntax.HashTag (TagPattern)
import Emanote.Pandoc.Markdown.Syntax.HashTag qualified as HT
import Emanote.Route qualified as R
import Optics.Operators ((^.))
import Relude
import System.FilePattern (FilePattern, (?==))
import Text.Megaparsec qualified as M
import Text.Megaparsec.Char qualified as M
import Text.Show qualified as Show

data Query
  = QueryByTag HT.Tag
  | QueryByTagPattern TagPattern
  | QueryByPath FilePath
  | QueryByPathPattern FilePattern
  deriving stock (Query -> Query -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Query -> Query -> Bool
$c/= :: Query -> Query -> Bool
== :: Query -> Query -> Bool
$c== :: Query -> Query -> Bool
Eq)

instance Show.Show Query where
  show :: Query -> FilePattern
show = \case
    QueryByTag Tag
tag ->
      forall a. ToString a => a -> FilePattern
toString forall a b. (a -> b) -> a -> b
$ Text
"Pages tagged #" forall a. Semigroup a => a -> a -> a
<> Tag -> Text
HT.unTag Tag
tag
    QueryByTagPattern TagPattern
pat ->
      forall a. ToString a => a -> FilePattern
toString forall a b. (a -> b) -> a -> b
$ FilePattern
"Pages tagged by '" forall a. Semigroup a => a -> a -> a
<> TagPattern -> FilePattern
HT.unTagPattern TagPattern
pat forall a. Semigroup a => a -> a -> a
<> FilePattern
"'"
    QueryByPath FilePattern
p ->
      FilePattern
"Pages under path '/" forall a. Semigroup a => a -> a -> a
<> FilePattern
p forall a. Semigroup a => a -> a -> a
<> FilePattern
"'"
    QueryByPathPattern FilePattern
pat ->
      FilePattern
"Pages matching path '" forall a. Semigroup a => a -> a -> a
<> FilePattern
pat forall a. Semigroup a => a -> a -> a
<> FilePattern
"'"

parseQuery :: Text -> Maybe Query
parseQuery :: Text -> Maybe Query
parseQuery = do
  forall l r. Either l r -> Maybe r
rightToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Parsec Void Text a -> FilePattern -> Text -> Either Text a
parse Parsec Void Text Query
queryParser FilePattern
"<pandoc:code:query>"
  where
    parse :: M.Parsec Void Text a -> String -> Text -> Either Text a
    parse :: forall a.
Parsec Void Text a -> FilePattern -> Text -> Either Text a
parse Parsec Void Text a
p FilePattern
fn =
      forall (p :: Type -> Type -> Type) 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 -> FilePattern
M.errorBundlePretty)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> FilePattern -> s -> Either (ParseErrorBundle s e) a
M.parse (Parsec Void Text a
p forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: Type -> Type). MonadParsec e s m => m ()
M.eof) FilePattern
fn

queryParser :: M.Parsec Void Text Query
queryParser :: Parsec Void Text Query
queryParser = do
  (forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"tag:#" forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tag -> Query
QueryByTag forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Tag
HT.Tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) forall e s (m :: Type -> Type). MonadParsec e s m => m (Tokens s)
M.takeRest)
    forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"tag:" forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (TagPattern -> Query
QueryByTagPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TagPattern
HT.mkTagPattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) forall e s (m :: Type -> Type). MonadParsec e s m => m (Tokens s)
M.takeRest)
    forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"path:" forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Query
fromUserPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) forall e s (m :: Type -> Type). MonadParsec e s m => m (Tokens s)
M.takeRest)
  where
    fromUserPath :: Text -> Query
fromUserPath Text
s =
      if
          | Text
"*" Text -> Text -> Bool
`T.isInfixOf` Text
s ->
              FilePattern -> Query
QueryByPathPattern (forall a. ToString a => a -> FilePattern
toString Text
s)
          | Text
"/" Text -> Text -> Bool
`T.isPrefixOf` Text
s ->
              FilePattern -> Query
QueryByPath (forall a. ToString a => a -> FilePattern
toString forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
s)
          | Bool
otherwise ->
              FilePattern -> Query
QueryByPathPattern (forall a. ToString a => a -> FilePattern
toString forall a b. (a -> b) -> a -> b
$ Text
"**/" forall a. Semigroup a => a -> a -> a
<> Text
s forall a. Semigroup a => a -> a -> a
<> Text
"/**")

runQuery :: R.LMLRoute -> Model -> Query -> [Note]
runQuery :: LMLRoute -> Model -> Query -> [Note]
runQuery LMLRoute
currentRoute Model
model =
  forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Note -> (Down (Maybe Text), LMLRoute)
Calendar.noteSortKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    QueryByTag Tag
tag ->
      forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall a b. (a -> b) -> a -> b
$ (Model
model forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type).
Lens' (ModelT encF) (IxSet NoteIxs Note)
modelNotes) forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= Tag
tag
    QueryByTagPattern TagPattern
pat ->
      let allTags :: [Tag]
allTags = forall a b. (a, b) -> a
fst forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Type -> Type). ModelT f -> [(Tag, [Note])]
modelTags Model
model
          matchingTags :: [Tag]
matchingTags = forall a. (a -> Bool) -> [a] -> [a]
filter (TagPattern -> Tag -> Bool
HT.tagMatch TagPattern
pat) [Tag]
allTags
       in forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall a b. (a -> b) -> a -> b
$ (Model
model forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type).
Lens' (ModelT encF) (IxSet NoteIxs Note)
modelNotes) forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> [ix] -> IxSet ixs a
@+ [Tag]
matchingTags
    QueryByPath FilePattern
path ->
      forall m. Monoid m => Maybe m -> m
maybeToMonoid forall a b. (a -> b) -> a -> b
$ do
        R @() 'Folder
r <- forall a (ext :: FileType a).
HasExt @a ext =>
FilePattern -> Maybe (R @a ext)
R.mkRouteFromFilePath FilePattern
path
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall a b. (a -> b) -> a -> b
$ (Model
model forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type).
Lens' (ModelT encF) (IxSet NoteIxs Note)
modelNotes) forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= R @() 'Folder -> RAncestor
N.RAncestor R @() 'Folder
r
    QueryByPathPattern (ShowS
resolveDotInFilePattern -> FilePattern
pat) ->
      let notes :: [Note]
notes = forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall a b. (a -> b) -> a -> b
$ Model
model forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type).
Lens' (ModelT encF) (IxSet NoteIxs Note)
modelNotes
       in forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Note]
notes forall a b. (a -> b) -> a -> b
$ \Note
note -> do
            forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ FilePattern
pat FilePattern -> FilePattern -> Bool
?== forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute forall a (ft :: FileType a). HasExt @a ft => R @a ft -> FilePattern
R.encodeRoute (Note
note forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' Note LMLRoute
N.noteRoute)
            forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Note
note
  where
    -- Resolve the ./ prefix which will for substituting "$PWD" in current
    -- note's route context.
    resolveDotInFilePattern :: ShowS
resolveDotInFilePattern (forall a. ToText a => a -> Text
toText -> Text
pat) =
      if Text
"./" Text -> Text -> Bool
`T.isPrefixOf` Text
pat
        then
          let R @() 'Folder
folderR :: R.R 'R.Folder = forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute coerce :: forall a b. Coercible @Type a b => a -> b
coerce LMLRoute
currentRoute
           in if R @() 'Folder
folderR forall a. Eq a => a -> a -> Bool
== forall {a} (ext :: FileType a). R @a ext
R.indexRoute
                then -- If in "index.md", discard the ./
                  forall a. ToString a => a -> FilePattern
toString (Int -> Text -> Text
T.drop Int
2 Text
pat)
                else -- If in "$folder.md", discard the ./ and prepend with folder path prefix
                  forall a (ft :: FileType a). HasExt @a ft => R @a ft -> FilePattern
R.encodeRoute R @() 'Folder
folderR forall a. Semigroup a => a -> a -> a
<> FilePattern
"/" forall a. Semigroup a => a -> a -> a
<> forall a. ToString a => a -> FilePattern
toString (Int -> Text -> Text
T.drop Int
2 Text
pat)
        else forall a. ToString a => a -> FilePattern
toString Text
pat