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
(Query -> Query -> Bool) -> (Query -> Query -> Bool) -> Eq Query
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 ->
      Text -> FilePattern
forall a. ToString a => a -> FilePattern
toString (Text -> FilePattern) -> Text -> FilePattern
forall a b. (a -> b) -> a -> b
$ Text
"Pages tagged #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tag -> Text
HT.unTag Tag
tag
    QueryByTagPattern TagPattern
pat ->
      ShowS
forall a. ToString a => a -> FilePattern
toString ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ FilePattern
"Pages tagged by '" FilePattern -> ShowS
forall a. Semigroup a => a -> a -> a
<> TagPattern -> FilePattern
HT.unTagPattern TagPattern
pat FilePattern -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePattern
"'"
    QueryByPath FilePattern
p ->
      FilePattern
"Pages under path '/" FilePattern -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePattern
p FilePattern -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePattern
"'"
    QueryByPathPattern FilePattern
pat ->
      FilePattern
"Pages matching path '" FilePattern -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePattern
pat FilePattern -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePattern
"'"

parseQuery :: Text -> Maybe Query
parseQuery :: Text -> Maybe Query
parseQuery = do
  Either Text Query -> Maybe Query
forall l r. Either l r -> Maybe r
rightToMaybe (Either Text Query -> Maybe Query)
-> (Text -> Either Text Query) -> Text -> Maybe Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text Query -> FilePattern -> Text -> Either Text Query
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 =
      (ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) a -> Either Text a
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePattern -> Text
forall a. ToText a => a -> Text
toText (FilePattern -> Text)
-> (ParseErrorBundle Text Void -> FilePattern)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> FilePattern
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePattern
M.errorBundlePretty)
        (Either (ParseErrorBundle Text Void) a -> Either Text a)
-> (Text -> Either (ParseErrorBundle Text Void) a)
-> Text
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text a
-> FilePattern -> Text -> Either (ParseErrorBundle Text Void) a
forall e s a.
Parsec e s a -> FilePattern -> s -> Either (ParseErrorBundle s e) a
M.parse (Parsec Void Text a
p Parsec Void Text a
-> ParsecT Void Text Identity () -> Parsec Void Text a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
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
  (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"tag:#" ParsecT Void Text Identity Text
-> Parsec Void Text Query -> Parsec Void Text Query
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> (Text -> Query)
-> ParsecT Void Text Identity Text -> Parsec Void Text Query
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tag -> Query
QueryByTag (Tag -> Query) -> (Text -> Tag) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Tag
HT.Tag (Text -> Tag) -> (Text -> Text) -> Text -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ParsecT Void Text Identity Text
forall e s (m :: Type -> Type). MonadParsec e s m => m (Tokens s)
M.takeRest)
    Parsec Void Text Query
-> Parsec Void Text Query -> Parsec Void Text Query
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"tag:" ParsecT Void Text Identity Text
-> Parsec Void Text Query -> Parsec Void Text Query
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> (Text -> Query)
-> ParsecT Void Text Identity Text -> Parsec Void Text Query
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (TagPattern -> Query
QueryByTagPattern (TagPattern -> Query) -> (Text -> TagPattern) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TagPattern
HT.mkTagPattern (Text -> TagPattern) -> (Text -> Text) -> Text -> TagPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ParsecT Void Text Identity Text
forall e s (m :: Type -> Type). MonadParsec e s m => m (Tokens s)
M.takeRest)
    Parsec Void Text Query
-> Parsec Void Text Query -> Parsec Void Text Query
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"path:" ParsecT Void Text Identity Text
-> Parsec Void Text Query -> Parsec Void Text Query
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> (Text -> Query)
-> ParsecT Void Text Identity Text -> Parsec Void Text Query
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Query
fromUserPath (Text -> Query) -> (Text -> Text) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ParsecT Void Text Identity Text
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 (Text -> FilePattern
forall a. ToString a => a -> FilePattern
toString Text
s)
          | Text
"/" Text -> Text -> Bool
`T.isPrefixOf` Text
s ->
              FilePattern -> Query
QueryByPath (Text -> FilePattern
forall a. ToString a => a -> FilePattern
toString (Text -> FilePattern) -> Text -> FilePattern
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
s)
          | Bool
otherwise ->
              FilePattern -> Query
QueryByPathPattern (Text -> FilePattern
forall a. ToString a => a -> FilePattern
toString (Text -> FilePattern) -> Text -> FilePattern
forall a b. (a -> b) -> a -> b
$ Text
"**/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/**")

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