{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Emanote.Model.Note where

import Commonmark.Extensions.WikiLink (plainify)
import Commonmark.Extensions.WikiLink qualified as WL
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Writer (MonadWriter (tell), WriterT, runWriterT)
import Data.Aeson qualified as Aeson
import Data.Aeson.Optics qualified as AO
import Data.Default (Default (def))
import Data.IxSet.Typed (Indexable (..), IxSet, ixFun, ixList)
import Data.IxSet.Typed qualified as Ix
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Emanote.Model.Note.Filter (applyPandocFilters)
import Emanote.Model.SData qualified as SData
import Emanote.Model.Title qualified as Tit
import Emanote.Pandoc.Markdown.Parser qualified as Markdown
import Emanote.Pandoc.Markdown.Syntax.HashTag qualified as HT
import Emanote.Route (FileType (Folder), R)
import Emanote.Route qualified as R
import Network.URI.Slug (Slug)
import Optics.Core ((%), (.~))
import Optics.TH (makeLenses)
import Relude
import System.FilePath ((</>))
import Text.Pandoc (runPure)
import Text.Pandoc.Builder qualified as B
import Text.Pandoc.Definition (Pandoc (..))
import Text.Pandoc.Readers.Org (readOrg)
import Text.Pandoc.Walk qualified as W

data Note = Note
  { Note -> LMLRoute
_noteRoute :: R.LMLRoute,
    Note -> Pandoc
_noteDoc :: Pandoc,
    Note -> Value
_noteMeta :: Aeson.Value,
    Note -> Title
_noteTitle :: Tit.Title,
    Note -> [Text]
_noteErrors :: [Text]
  }
  deriving stock (Note -> Note -> Bool
(Note -> Note -> Bool) -> (Note -> Note -> Bool) -> Eq Note
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c== :: Note -> Note -> Bool
Eq, Eq Note
Eq Note
-> (Note -> Note -> Ordering)
-> (Note -> Note -> Bool)
-> (Note -> Note -> Bool)
-> (Note -> Note -> Bool)
-> (Note -> Note -> Bool)
-> (Note -> Note -> Note)
-> (Note -> Note -> Note)
-> Ord Note
Note -> Note -> Bool
Note -> Note -> Ordering
Note -> Note -> Note
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 :: Note -> Note -> Note
$cmin :: Note -> Note -> Note
max :: Note -> Note -> Note
$cmax :: Note -> Note -> Note
>= :: Note -> Note -> Bool
$c>= :: Note -> Note -> Bool
> :: Note -> Note -> Bool
$c> :: Note -> Note -> Bool
<= :: Note -> Note -> Bool
$c<= :: Note -> Note -> Bool
< :: Note -> Note -> Bool
$c< :: Note -> Note -> Bool
compare :: Note -> Note -> Ordering
$ccompare :: Note -> Note -> Ordering
Ord, Int -> Note -> ShowS
[Note] -> ShowS
Note -> String
(Int -> Note -> ShowS)
-> (Note -> String) -> ([Note] -> ShowS) -> Show Note
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note] -> ShowS
$cshowList :: [Note] -> ShowS
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Int -> Note -> ShowS
$cshowsPrec :: Int -> Note -> ShowS
Show, (forall x. Note -> Rep Note x)
-> (forall x. Rep Note x -> Note) -> Generic Note
forall x. Rep Note x -> Note
forall x. Note -> Rep Note x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Note x -> Note
$cfrom :: forall x. Note -> Rep Note x
Generic)
  deriving anyclass ([Note] -> Encoding
[Note] -> Value
Note -> Encoding
Note -> Value
(Note -> Value)
-> (Note -> Encoding)
-> ([Note] -> Value)
-> ([Note] -> Encoding)
-> ToJSON Note
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Note] -> Encoding
$ctoEncodingList :: [Note] -> Encoding
toJSONList :: [Note] -> Value
$ctoJSONList :: [Note] -> Value
toEncoding :: Note -> Encoding
$ctoEncoding :: Note -> Encoding
toJSON :: Note -> Value
$ctoJSON :: Note -> Value
Aeson.ToJSON)

newtype RAncestor = RAncestor {RAncestor -> R @() 'Folder
unRAncestor :: R 'R.Folder}
  deriving stock (RAncestor -> RAncestor -> Bool
(RAncestor -> RAncestor -> Bool)
-> (RAncestor -> RAncestor -> Bool) -> Eq RAncestor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RAncestor -> RAncestor -> Bool
$c/= :: RAncestor -> RAncestor -> Bool
== :: RAncestor -> RAncestor -> Bool
$c== :: RAncestor -> RAncestor -> Bool
Eq, Eq RAncestor
Eq RAncestor
-> (RAncestor -> RAncestor -> Ordering)
-> (RAncestor -> RAncestor -> Bool)
-> (RAncestor -> RAncestor -> Bool)
-> (RAncestor -> RAncestor -> Bool)
-> (RAncestor -> RAncestor -> Bool)
-> (RAncestor -> RAncestor -> RAncestor)
-> (RAncestor -> RAncestor -> RAncestor)
-> Ord RAncestor
RAncestor -> RAncestor -> Bool
RAncestor -> RAncestor -> Ordering
RAncestor -> RAncestor -> RAncestor
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 :: RAncestor -> RAncestor -> RAncestor
$cmin :: RAncestor -> RAncestor -> RAncestor
max :: RAncestor -> RAncestor -> RAncestor
$cmax :: RAncestor -> RAncestor -> RAncestor
>= :: RAncestor -> RAncestor -> Bool
$c>= :: RAncestor -> RAncestor -> Bool
> :: RAncestor -> RAncestor -> Bool
$c> :: RAncestor -> RAncestor -> Bool
<= :: RAncestor -> RAncestor -> Bool
$c<= :: RAncestor -> RAncestor -> Bool
< :: RAncestor -> RAncestor -> Bool
$c< :: RAncestor -> RAncestor -> Bool
compare :: RAncestor -> RAncestor -> Ordering
$ccompare :: RAncestor -> RAncestor -> Ordering
Ord, Int -> RAncestor -> ShowS
[RAncestor] -> ShowS
RAncestor -> String
(Int -> RAncestor -> ShowS)
-> (RAncestor -> String)
-> ([RAncestor] -> ShowS)
-> Show RAncestor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RAncestor] -> ShowS
$cshowList :: [RAncestor] -> ShowS
show :: RAncestor -> String
$cshow :: RAncestor -> String
showsPrec :: Int -> RAncestor -> ShowS
$cshowsPrec :: Int -> RAncestor -> ShowS
Show, (forall x. RAncestor -> Rep RAncestor x)
-> (forall x. Rep RAncestor x -> RAncestor) -> Generic RAncestor
forall x. Rep RAncestor x -> RAncestor
forall x. RAncestor -> Rep RAncestor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RAncestor x -> RAncestor
$cfrom :: forall x. RAncestor -> Rep RAncestor x
Generic)
  deriving anyclass ([RAncestor] -> Encoding
[RAncestor] -> Value
RAncestor -> Encoding
RAncestor -> Value
(RAncestor -> Value)
-> (RAncestor -> Encoding)
-> ([RAncestor] -> Value)
-> ([RAncestor] -> Encoding)
-> ToJSON RAncestor
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RAncestor] -> Encoding
$ctoEncodingList :: [RAncestor] -> Encoding
toJSONList :: [RAncestor] -> Value
$ctoJSONList :: [RAncestor] -> Value
toEncoding :: RAncestor -> Encoding
$ctoEncoding :: RAncestor -> Encoding
toJSON :: RAncestor -> Value
$ctoJSON :: RAncestor -> Value
Aeson.ToJSON)

type NoteIxs =
  '[ -- Route to this note
     R.LMLRoute,
     -- Allowed ways to wiki-link to this note.
     WL.WikiLink,
     -- HTML route for this note
     R 'R.Html,
     -- Ancestor folder routes
     RAncestor,
     -- Parent folder
     R 'R.Folder,
     -- Tag
     HT.Tag,
     -- Alias route for this note. Can be "foo" or "foo/bar".
     NonEmpty Slug
   ]

type IxNote = IxSet NoteIxs Note

instance Indexable NoteIxs Note where
  indices :: IxList NoteIxs Note
indices =
    Ix LMLRoute Note
-> Ix WikiLink Note
-> Ix (R @() 'Html) Note
-> Ix RAncestor Note
-> Ix (R @() 'Folder) Note
-> Ix Tag Note
-> Ix (NonEmpty Slug) Note
-> IxList NoteIxs Note
forall (ixs :: [Type]) a r. MkIxList ixs ixs a r => r
ixList
      ((Note -> [LMLRoute]) -> Ix LMLRoute Note
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((Note -> [LMLRoute]) -> Ix LMLRoute Note)
-> (Note -> [LMLRoute]) -> Ix LMLRoute Note
forall a b. (a -> b) -> a -> b
$ LMLRoute -> [LMLRoute]
forall x. One x => OneItem x -> x
one (LMLRoute -> [LMLRoute])
-> (Note -> LMLRoute) -> Note -> [LMLRoute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> LMLRoute
_noteRoute)
      ((Note -> [WikiLink]) -> Ix WikiLink Note
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((Note -> [WikiLink]) -> Ix WikiLink Note)
-> (Note -> [WikiLink]) -> Ix WikiLink Note
forall a b. (a -> b) -> a -> b
$ NonEmpty WikiLink -> [WikiLink]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (NonEmpty WikiLink -> [WikiLink])
-> (Note -> NonEmpty WikiLink) -> Note -> [WikiLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> NonEmpty WikiLink
noteSelfRefs)
      ((Note -> [R @() 'Html]) -> Ix (R @() 'Html) Note
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((Note -> [R @() 'Html]) -> Ix (R @() 'Html) Note)
-> (Note -> [R @() 'Html]) -> Ix (R @() 'Html) Note
forall a b. (a -> b) -> a -> b
$ R @() 'Html -> [R @() 'Html]
forall x. One x => OneItem x -> x
one (R @() 'Html -> [R @() 'Html])
-> (Note -> R @() 'Html) -> Note -> [R @() 'Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> R @() 'Html
noteHtmlRoute)
      ((Note -> [RAncestor]) -> Ix RAncestor Note
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun Note -> [RAncestor]
noteAncestors)
      ((Note -> [R @() 'Folder]) -> Ix (R @() 'Folder) Note
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((Note -> [R @() 'Folder]) -> Ix (R @() 'Folder) Note)
-> (Note -> [R @() 'Folder]) -> Ix (R @() 'Folder) Note
forall a b. (a -> b) -> a -> b
$ Maybe (R @() 'Folder) -> [R @() 'Folder]
forall a. Maybe a -> [a]
maybeToList (Maybe (R @() 'Folder) -> [R @() 'Folder])
-> (Note -> Maybe (R @() 'Folder)) -> Note -> [R @() 'Folder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe (R @() 'Folder)
noteParent)
      ((Note -> [Tag]) -> Ix Tag Note
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun Note -> [Tag]
noteTags)
      ((Note -> [NonEmpty Slug]) -> Ix (NonEmpty Slug) Note
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((Note -> [NonEmpty Slug]) -> Ix (NonEmpty Slug) Note)
-> (Note -> [NonEmpty Slug]) -> Ix (NonEmpty Slug) Note
forall a b. (a -> b) -> a -> b
$ Maybe (NonEmpty Slug) -> [NonEmpty Slug]
forall a. Maybe a -> [a]
maybeToList (Maybe (NonEmpty Slug) -> [NonEmpty Slug])
-> (Note -> Maybe (NonEmpty Slug)) -> Note -> [NonEmpty Slug]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe (NonEmpty Slug)
noteSlug)

-- | All possible wiki-links that refer to this note.
noteSelfRefs :: Note -> NonEmpty WL.WikiLink
noteSelfRefs :: Note -> NonEmpty WikiLink
noteSelfRefs =
  LMLRoute -> NonEmpty WikiLink
routeSelfRefs
    (LMLRoute -> NonEmpty WikiLink)
-> (Note -> LMLRoute) -> Note -> NonEmpty WikiLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> LMLRoute
_noteRoute
  where
    routeSelfRefs :: R.LMLRoute -> NonEmpty WL.WikiLink
    routeSelfRefs :: LMLRoute -> NonEmpty WikiLink
routeSelfRefs =
      ((WikiLinkType, WikiLink) -> WikiLink)
-> NonEmpty (WikiLinkType, WikiLink) -> NonEmpty WikiLink
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (WikiLinkType, WikiLink) -> WikiLink
forall a b. (a, b) -> b
snd
        (NonEmpty (WikiLinkType, WikiLink) -> NonEmpty WikiLink)
-> (LMLRoute -> NonEmpty (WikiLinkType, WikiLink))
-> LMLRoute
-> NonEmpty WikiLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType)
 -> NonEmpty (WikiLinkType, WikiLink))
-> LMLRoute -> NonEmpty (WikiLinkType, WikiLink)
forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute (HasCallStack => NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink)
NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink)
WL.allowedWikiLinks (NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink))
-> (R @SourceExt ('LMLType lmlType) -> NonEmpty Slug)
-> R @SourceExt ('LMLType lmlType)
-> NonEmpty (WikiLinkType, WikiLink)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R @SourceExt ('LMLType lmlType) -> NonEmpty Slug
forall a (ext :: FileType a). R @a ext -> NonEmpty Slug
R.unRoute)

noteAncestors :: Note -> [RAncestor]
noteAncestors :: Note -> [RAncestor]
noteAncestors =
  [RAncestor]
-> (R @() 'Folder -> [RAncestor])
-> Maybe (R @() 'Folder)
-> [RAncestor]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (NonEmpty RAncestor -> [RAncestor]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (NonEmpty RAncestor -> [RAncestor])
-> (R @() 'Folder -> NonEmpty RAncestor)
-> R @() 'Folder
-> [RAncestor]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (R @() 'Folder -> RAncestor)
-> NonEmpty (R @() 'Folder) -> NonEmpty RAncestor
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap R @() 'Folder -> RAncestor
RAncestor (NonEmpty (R @() 'Folder) -> NonEmpty RAncestor)
-> (R @() 'Folder -> NonEmpty (R @() 'Folder))
-> R @() 'Folder
-> NonEmpty RAncestor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R @() 'Folder -> NonEmpty (R @() 'Folder)
forall {a} (ext :: FileType a). R @a ext -> NonEmpty (R @a ext)
R.routeInits) (Maybe (R @() 'Folder) -> [RAncestor])
-> (Note -> Maybe (R @() 'Folder)) -> Note -> [RAncestor]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe (R @() 'Folder)
noteParent

noteParent :: Note -> Maybe (R 'R.Folder)
noteParent :: Note -> Maybe (R @() 'Folder)
noteParent = (forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> Maybe (R @() 'Folder))
-> LMLRoute -> Maybe (R @() 'Folder)
forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute forall {a} (ext :: FileType a). R @a ext -> Maybe (R @() 'Folder)
forall (lmlType :: LML).
HasExt @SourceExt ('LMLType lmlType) =>
R @SourceExt ('LMLType lmlType) -> Maybe (R @() 'Folder)
R.routeParent (LMLRoute -> Maybe (R @() 'Folder))
-> (Note -> LMLRoute) -> Note -> Maybe (R @() 'Folder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> LMLRoute
_noteRoute

hasChildNotes :: R 'Folder -> IxNote -> Bool
hasChildNotes :: R @() 'Folder -> IxNote -> Bool
hasChildNotes R @() 'Folder
r =
  Bool -> Bool
not (Bool -> Bool) -> (IxNote -> Bool) -> IxNote -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IxNote -> Bool
forall (ixs :: [Type]) a. IxSet ixs a -> Bool
Ix.null (IxNote -> Bool) -> (IxNote -> IxNote) -> IxNote -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R @() 'Folder -> IxNote -> IxNote
forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
ix -> IxSet ixs a -> IxSet ixs a
Ix.getEQ R @() 'Folder
r

noteTags :: Note -> [HT.Tag]
noteTags :: Note -> [Tag]
noteTags =
  (Text -> Tag) -> [Text] -> [Tag]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Tag
HT.Tag ([Text] -> [Tag]) -> (Note -> [Text]) -> Note -> [Tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Text] -> [Text]
forall m. Monoid m => Maybe m -> m
maybeToMonoid (Maybe [Text] -> [Text])
-> (Note -> Maybe [Text]) -> Note -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> Note -> Maybe [Text]
forall a. FromJSON a => NonEmpty Text -> Note -> Maybe a
lookupMeta (OneItem (NonEmpty Text) -> NonEmpty Text
forall x. One x => OneItem x -> x
one OneItem (NonEmpty Text)
"tags")

noteSlug :: Note -> Maybe (NonEmpty Slug)
noteSlug :: Note -> Maybe (NonEmpty Slug)
noteSlug Note
note = do
  Text
slugPath :: Text <- NonEmpty Text -> Note -> Maybe Text
forall a. FromJSON a => NonEmpty Text -> Note -> Maybe a
lookupMeta (OneItem (NonEmpty Text) -> NonEmpty Text
forall x. One x => OneItem x -> x
one OneItem (NonEmpty Text)
"slug") Note
note
  (R @SourceExt 'AnyExt -> NonEmpty Slug)
-> Maybe (R @SourceExt 'AnyExt) -> Maybe (NonEmpty Slug)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap R @SourceExt 'AnyExt -> NonEmpty Slug
forall a (ext :: FileType a). R @a ext -> NonEmpty Slug
R.unRoute (Maybe (R @SourceExt 'AnyExt) -> Maybe (NonEmpty Slug))
-> Maybe (R @SourceExt 'AnyExt) -> Maybe (NonEmpty Slug)
forall a b. (a -> b) -> a -> b
$ forall a (ext :: FileType a).
HasExt @a ext =>
String -> Maybe (R @a ext)
R.mkRouteFromFilePath @_ @'R.AnyExt (String -> Maybe (R @SourceExt 'AnyExt))
-> String -> Maybe (R @SourceExt 'AnyExt)
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
slugPath

lookupMeta :: Aeson.FromJSON a => NonEmpty Text -> Note -> Maybe a
lookupMeta :: forall a. FromJSON a => NonEmpty Text -> Note -> Maybe a
lookupMeta NonEmpty Text
k =
  Maybe a -> NonEmpty Text -> Value -> Maybe a
forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson Maybe a
forall a. Maybe a
Nothing NonEmpty Text
k (Value -> Maybe a) -> (Note -> Value) -> Note -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Value
_noteMeta

queryNoteTitle :: R.LMLRoute -> Pandoc -> Aeson.Value -> (Pandoc, Tit.Title)
queryNoteTitle :: LMLRoute -> Pandoc -> Value -> (Pandoc, Title)
queryNoteTitle LMLRoute
r Pandoc
doc Value
meta =
  let yamlNoteTitle :: Maybe Title
yamlNoteTitle = String -> Title
forall a. IsString a => String -> a
fromString (String -> Title) -> Maybe String -> Maybe Title
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> NonEmpty Text -> Value -> Maybe String
forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson Maybe String
forall a. Maybe a
Nothing (OneItem (NonEmpty Text) -> NonEmpty Text
forall x. One x => OneItem x -> x
one OneItem (NonEmpty Text)
"title") Value
meta
      fileNameTitle :: Title
fileNameTitle = LMLRoute -> Title
Tit.fromRoute LMLRoute
r
      notePandocTitle :: Maybe Title
notePandocTitle = do
        case LMLRoute
r of
          R.LMLRoute_Md R @SourceExt ('LMLType 'Md)
_ ->
            Pandoc -> Maybe Title
getPandocTitle Pandoc
doc
          R.LMLRoute_Org R @SourceExt ('LMLType 'Org)
_ ->
            Pandoc -> Maybe Title
getPandocMetaTitle Pandoc
doc
   in (Pandoc, Title) -> Maybe (Pandoc, Title) -> (Pandoc, Title)
forall a. a -> Maybe a -> a
fromMaybe (Pandoc
doc, Title
fileNameTitle) (Maybe (Pandoc, Title) -> (Pandoc, Title))
-> Maybe (Pandoc, Title) -> (Pandoc, Title)
forall a b. (a -> b) -> a -> b
$
        (Title -> (Pandoc, Title)) -> Maybe Title -> Maybe (Pandoc, Title)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pandoc
doc,) Maybe Title
yamlNoteTitle Maybe (Pandoc, Title)
-> Maybe (Pandoc, Title) -> Maybe (Pandoc, Title)
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Title -> (Pandoc, Title)) -> Maybe Title -> Maybe (Pandoc, Title)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pandoc -> Pandoc
withoutH1 Pandoc
doc,) Maybe Title
notePandocTitle
  where
    getPandocTitle :: Pandoc -> Maybe Tit.Title
    getPandocTitle :: Pandoc -> Maybe Title
getPandocTitle =
      ([Inline] -> Title) -> Maybe [Inline] -> Maybe Title
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> Title
Tit.fromInlines (Maybe [Inline] -> Maybe Title)
-> (Pandoc -> Maybe [Inline]) -> Pandoc -> Maybe Title
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> Maybe [Inline]
getPandocH1
      where
        getPandocH1 :: Pandoc -> Maybe [B.Inline]
        getPandocH1 :: Pandoc -> Maybe [Inline]
getPandocH1 (Pandoc Meta
_ (B.Header Int
1 Attr
_ [Inline]
inlines : [Block]
_rest)) =
          [Inline] -> Maybe [Inline]
forall a. a -> Maybe a
Just [Inline]
inlines
        getPandocH1 Pandoc
_ =
          Maybe [Inline]
forall a. Maybe a
Nothing
    getPandocMetaTitle :: Pandoc -> Maybe Tit.Title
    getPandocMetaTitle :: Pandoc -> Maybe Title
getPandocMetaTitle (Pandoc Meta
docMeta [Block]
_) = do
      B.MetaInlines [Inline]
inlines <- Text -> Meta -> Maybe MetaValue
B.lookupMeta Text
"title" Meta
docMeta
      Title -> Maybe Title
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Title -> Maybe Title) -> Title -> Maybe Title
forall a b. (a -> b) -> a -> b
$ [Inline] -> Title
Tit.fromInlines [Inline]
inlines
    withoutH1 :: B.Pandoc -> B.Pandoc
    withoutH1 :: Pandoc -> Pandoc
withoutH1 (B.Pandoc Meta
m (B.Header Int
1 Attr
_ [Inline]
_ : [Block]
rest)) =
      Meta -> [Block] -> Pandoc
B.Pandoc Meta
m [Block]
rest
    withoutH1 Pandoc
x =
      Pandoc
x

-- | The HTML route intended by user for this note.
noteHtmlRoute :: Note -> R 'R.Html
noteHtmlRoute :: Note -> R @() 'Html
noteHtmlRoute note :: Note
note@Note {[Text]
Value
Pandoc
LMLRoute
Title
_noteErrors :: [Text]
_noteTitle :: Title
_noteMeta :: Value
_noteDoc :: Pandoc
_noteRoute :: LMLRoute
_noteErrors :: Note -> [Text]
_noteTitle :: Note -> Title
_noteMeta :: Note -> Value
_noteDoc :: Note -> Pandoc
_noteRoute :: Note -> LMLRoute
..} =
  -- Favour slug if one exists, otherwise use the full path.
  case Note -> Maybe (NonEmpty Slug)
noteSlug Note
note of
    Maybe (NonEmpty Slug)
Nothing ->
      (forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> R @() 'Html)
-> LMLRoute -> R @() 'Html
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 @() 'Html
coerce LMLRoute
_noteRoute
    Just NonEmpty Slug
slugs ->
      NonEmpty Slug -> R @() 'Html
forall {a} (ext :: FileType a). NonEmpty Slug -> R @a ext
R.mkRouteFromSlugs NonEmpty Slug
slugs

lookupNotesByHtmlRoute :: R 'R.Html -> IxNote -> [Note]
lookupNotesByHtmlRoute :: R @() 'Html -> IxNote -> [Note]
lookupNotesByHtmlRoute R @() 'Html
htmlRoute =
  IxNote -> [Note]
forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList (IxNote -> [Note]) -> (IxNote -> IxNote) -> IxNote -> [Note]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R @() 'Html -> IxNote -> IxNote
forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
ix -> IxSet ixs a -> IxSet ixs a
Ix.getEQ R @() 'Html
htmlRoute

lookupNotesByRoute :: HasCallStack => R.LMLRoute -> IxNote -> Maybe Note
lookupNotesByRoute :: HasCallStack => LMLRoute -> IxNote -> Maybe Note
lookupNotesByRoute LMLRoute
r IxNote
ix = do
  NonEmpty Note
res <- [Note] -> Maybe (NonEmpty Note)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Note] -> Maybe (NonEmpty Note))
-> [Note] -> Maybe (NonEmpty Note)
forall a b. (a -> b) -> a -> b
$ IxNote -> [Note]
forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList (IxNote -> [Note]) -> IxNote -> [Note]
forall a b. (a -> b) -> a -> b
$ LMLRoute -> IxNote -> IxNote
forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
ix -> IxSet ixs a -> IxSet ixs a
Ix.getEQ LMLRoute
r IxNote
ix
  case NonEmpty Note
res of
    Note
note :| [] -> Note -> Maybe Note
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Note
note
    NonEmpty Note
_ -> Text -> Maybe Note
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Maybe Note) -> Text -> Maybe Note
forall a b. (a -> b) -> a -> b
$ Text
"ambiguous notes for route " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LMLRoute -> Text
forall b a. (Show a, IsString b) => a -> b
show LMLRoute
r

ancestorPlaceholderNote :: R.R 'Folder -> Note
ancestorPlaceholderNote :: R @() 'Folder -> Note
ancestorPlaceholderNote R @() 'Folder
r =
  let placeHolder :: [Block]
placeHolder =
        [ Block
folderListingQuery,
          -- TODO: Ideally, we should use semantic tags, like <aside> (rather
          -- than <div>), to render these non-relevant content.
          Attr -> [Block] -> Block
B.Div (Text -> Attr
cls Text
"emanote:placeholder-message") ([Block] -> Block) -> ([Inline] -> [Block]) -> [Inline] -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Block]
forall x. One x => OneItem x -> x
one (Block -> [Block]) -> ([Inline] -> Block) -> [Inline] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Block
B.Para ([Inline] -> Block) -> [Inline] -> Block
forall a b. (a -> b) -> a -> b
$
            [ Text -> Inline
B.Str
                Text
"Note: To override the auto-generated content here, create a file named one of: ",
              -- TODO: or, .org
              Attr -> [Inline] -> Inline
B.Span (Text -> Attr
cls Text
"font-mono text-sm") ([Inline] -> Inline) -> [Inline] -> Inline
forall a b. (a -> b) -> a -> b
$
                OneItem [Inline] -> [Inline]
forall x. One x => OneItem x -> x
one (OneItem [Inline] -> [Inline]) -> OneItem [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$
                  Text -> Inline
B.Str (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$
                    R @() 'Folder -> Text
forall {a} (ext :: FileType a). R @a ext -> Text
oneOfLmlFilenames R @() 'Folder
r
            ]
        ]
   in LMLRoute -> [Block] -> Note
mkEmptyNoteWith (R @() 'Folder -> LMLRoute
forall a (ext :: FileType a). R @a ext -> LMLRoute
R.defaultLmlRoute R @() 'Folder
r) [Block]
placeHolder
  where
    folderListingQuery :: Block
folderListingQuery =
      Attr -> Text -> Block
B.CodeBlock (Text -> Attr
cls Text
"query") Text
"path:./*"

cls :: Text -> B.Attr
cls :: Text -> Attr
cls Text
x =
  (Text
"", OneItem [Text] -> [Text]
forall x. One x => OneItem x -> x
one Text
OneItem [Text]
x, [(Text, Text)]
forall a. Monoid a => a
mempty) :: B.Attr

missingNote :: R.R ext -> Text -> Note
missingNote :: forall {a} (ext :: FileType a). R @a ext -> Text -> Note
missingNote R @a ext
route404 Text
urlPath =
  LMLRoute -> [Block] -> Note
mkEmptyNoteWith (R @a ext -> LMLRoute
forall a (ext :: FileType a). R @a ext -> LMLRoute
R.defaultLmlRoute R @a ext
route404) ([Block] -> Note) -> [Block] -> Note
forall a b. (a -> b) -> a -> b
$
    OneItem [Block] -> [Block]
forall x. One x => OneItem x -> x
one (OneItem [Block] -> [Block]) -> OneItem [Block] -> [Block]
forall a b. (a -> b) -> a -> b
$
      [Inline] -> Block
B.Para
        [ Text -> Inline
B.Str Text
"No note has the URL ",
          Attr -> Text -> Inline
B.Code Attr
B.nullAttr (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
urlPath,
          -- TODO: org
          Attr -> [Inline] -> Inline
B.Span (Text -> Attr
cls Text
"font-mono text-sm") ([Inline] -> Inline) -> [Inline] -> Inline
forall a b. (a -> b) -> a -> b
$
            OneItem [Inline] -> [Inline]
forall x. One x => OneItem x -> x
one (OneItem [Inline] -> [Inline]) -> OneItem [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$
              Text -> Inline
B.Str (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$
                Text
". You may create a file with that name, ie. one of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> R @a ext -> Text
forall {a} (ext :: FileType a). R @a ext -> Text
oneOfLmlFilenames R @a ext
route404
        ]

oneOfLmlFilenames :: R ext -> Text
oneOfLmlFilenames :: forall {a} (ext :: FileType a). R @a ext -> Text
oneOfLmlFilenames R @a ext
r =
  Text -> [Text] -> Text
T.intercalate
    Text
", "
    (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (LMLRoute -> String) -> LMLRoute -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> String)
-> LMLRoute -> String
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 -> String
forall (lmlType :: LML).
HasExt @SourceExt ('LMLType lmlType) =>
R @SourceExt ('LMLType lmlType) -> String
R.encodeRoute (LMLRoute -> Text) -> [LMLRoute] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> R @a ext -> [LMLRoute]
forall a (ext :: FileType a). R @a ext -> [LMLRoute]
R.possibleLmlRoutes R @a ext
r)

ambiguousNoteURL :: FilePath -> NonEmpty R.LMLRoute -> Note
ambiguousNoteURL :: String -> NonEmpty LMLRoute -> Note
ambiguousNoteURL String
urlPath NonEmpty LMLRoute
rs =
  LMLRoute -> [Block] -> Note
mkEmptyNoteWith (NonEmpty LMLRoute -> LMLRoute
forall (f :: Type -> Type) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty LMLRoute
rs) ([Block] -> Note) -> [Block] -> Note
forall a b. (a -> b) -> a -> b
$
    [ [Inline] -> Block
B.Para
        [ Text -> Inline
B.Str Text
"The URL ",
          Attr -> Text -> Inline
B.Code Attr
B.nullAttr (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
urlPath,
          Text -> Inline
B.Str Text
" is ambiguous, as more than one note (see list below) use it. To fix this, specify a different slug for these notes:"
        ]
    ]
      [Block] -> [Block] -> [Block]
forall a. Semigroup a => a -> a -> a
<> OneItem [Block] -> [Block]
forall x. One x => OneItem x -> x
one Block
OneItem [Block]
candidates
  where
    candidates :: B.Block
    candidates :: Block
candidates =
      [[Block]] -> Block
B.BulletList ([[Block]] -> Block) -> [[Block]] -> Block
forall a b. (a -> b) -> a -> b
$
        NonEmpty LMLRoute -> [LMLRoute]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty LMLRoute
rs [LMLRoute] -> (LMLRoute -> [Block]) -> [[Block]]
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \(LMLRoute
-> Either
     (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
R.lmlRouteCase -> Either (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
r) ->
          [ [Inline] -> Block
B.Plain ([Inline] -> Block) -> [Inline] -> Block
forall a b. (a -> b) -> a -> b
$ OneItem [Inline] -> [Inline]
forall x. One x => OneItem x -> x
one (OneItem [Inline] -> [Inline]) -> OneItem [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ Text -> Inline
B.Str Text
"  ",
            [Inline] -> Block
B.Plain ([Inline] -> Block) -> [Inline] -> Block
forall a b. (a -> b) -> a -> b
$ OneItem [Inline] -> [Inline]
forall x. One x => OneItem x -> x
one (OneItem [Inline] -> [Inline]) -> OneItem [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Inline
B.Code Attr
B.nullAttr (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ Either (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
-> Text
forall b a. (Show a, IsString b) => a -> b
show Either (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
r
          ]

mkEmptyNoteWith :: R.LMLRoute -> [B.Block] -> Note
mkEmptyNoteWith :: LMLRoute -> [Block] -> Note
mkEmptyNoteWith LMLRoute
someR (Meta -> [Block] -> Pandoc
Pandoc Meta
forall a. Monoid a => a
mempty -> Pandoc
doc) =
  LMLRoute -> Pandoc -> Value -> [Text] -> Note
mkNoteWith LMLRoute
someR Pandoc
doc Value
meta [Text]
forall a. Monoid a => a
mempty
  where
    meta :: Value
meta = Value
Aeson.Null

mkNoteWith :: R.LMLRoute -> Pandoc -> Aeson.Value -> [Text] -> Note
mkNoteWith :: LMLRoute -> Pandoc -> Value -> [Text] -> Note
mkNoteWith LMLRoute
r Pandoc
doc' Value
meta [Text]
errs =
  let (Pandoc
doc'', Title
tit) = LMLRoute -> Pandoc -> Value -> (Pandoc, Title)
queryNoteTitle LMLRoute
r Pandoc
doc' Value
meta
      doc :: Pandoc
doc = if [Text] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Text]
errs then Pandoc
doc'' else Block -> Pandoc -> Pandoc
pandocPrepend ([Text] -> Block
errorDiv [Text]
errs) Pandoc
doc''
   in LMLRoute -> Pandoc -> Value -> Title -> [Text] -> Note
Note LMLRoute
r Pandoc
doc Value
meta Title
tit [Text]
errs
  where
    -- Prepend to block to the beginning of a Pandoc document (never before H1)
    pandocPrepend :: B.Block -> Pandoc -> Pandoc
    pandocPrepend :: Block -> Pandoc -> Pandoc
pandocPrepend Block
prefix (Pandoc Meta
docMeta [Block]
blocks) =
      let blocks' :: [Block]
blocks' = case [Block]
blocks of
            (h1 :: Block
h1@(B.Header Int
1 Attr
_ [Inline]
_) : [Block]
rest) ->
              Block
h1 Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: Block
prefix Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
rest
            [Block]
_ -> Block
prefix Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
blocks
       in Meta -> [Block] -> Pandoc
Pandoc Meta
docMeta [Block]
blocks'
    errorDiv :: [Text] -> B.Block
    errorDiv :: [Text] -> Block
errorDiv [Text]
s =
      Attr -> [Block] -> Block
B.Div (Text -> Attr
cls Text
"emanote:error") ([Block] -> Block) -> [Block] -> Block
forall a b. (a -> b) -> a -> b
$ [Inline] -> Block
B.Para [[Inline] -> Inline
B.Strong ([Inline] -> Inline) -> [Inline] -> Inline
forall a b. (a -> b) -> a -> b
$ OneItem [Inline] -> [Inline]
forall x. One x => OneItem x -> x
one (OneItem [Inline] -> [Inline]) -> OneItem [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ Text -> Inline
B.Str Text
"Emanote Errors 😔"] Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: ([Inline] -> Block
B.Para ([Inline] -> Block) -> (Text -> [Inline]) -> Text -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inline -> [Inline]
forall x. One x => OneItem x -> x
one (Inline -> [Inline]) -> (Text -> Inline) -> Text -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
B.Str (Text -> Block) -> [Text] -> [Block]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
s)

parseNote ::
  forall m.
  (MonadIO m, MonadLogger m) =>
  FilePath ->
  R.LMLRoute ->
  FilePath ->
  Text ->
  m Note
parseNote :: forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
String -> LMLRoute -> String -> Text -> m Note
parseNote String
pluginBaseDir LMLRoute
r String
fp Text
s = do
  ((Pandoc
doc, Value
meta), [Text]
errs) <- WriterT [Text] m (Pandoc, Value) -> m ((Pandoc, Value), [Text])
forall w (m :: Type -> Type) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [Text] m (Pandoc, Value) -> m ((Pandoc, Value), [Text]))
-> WriterT [Text] m (Pandoc, Value) -> m ((Pandoc, Value), [Text])
forall a b. (a -> b) -> a -> b
$ do
    case LMLRoute
r of
      R.LMLRoute_Md R @SourceExt ('LMLType 'Md)
_ ->
        String -> String -> Text -> WriterT [Text] m (Pandoc, Value)
forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
String -> String -> Text -> WriterT [Text] m (Pandoc, Value)
parseNoteMarkdown String
pluginBaseDir String
fp Text
s
      R.LMLRoute_Org R @SourceExt ('LMLType 'Org)
_ -> do
        Text -> WriterT [Text] m (Pandoc, Value)
forall (m :: Type -> Type).
MonadWriter [Text] m =>
Text -> m (Pandoc, Value)
parseNoteOrg Text
s
  Note -> m Note
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Note -> m Note) -> Note -> m Note
forall a b. (a -> b) -> a -> b
$ LMLRoute -> Pandoc -> Value -> [Text] -> Note
mkNoteWith LMLRoute
r Pandoc
doc Value
meta [Text]
errs

parseNoteOrg :: (MonadWriter [Text] m) => Text -> m (Pandoc, Aeson.Value)
parseNoteOrg :: forall (m :: Type -> Type).
MonadWriter [Text] m =>
Text -> m (Pandoc, Value)
parseNoteOrg Text
s =
  case PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> PandocPure Pandoc -> Either PandocError Pandoc
forall a b. (a -> b) -> a -> b
$ ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: Type -> Type) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readOrg ReaderOptions
forall a. Default a => a
def Text
s of
    Left PandocError
err -> do
      [Text] -> m ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell [PandocError -> Text
forall b a. (Show a, IsString b) => a -> b
show PandocError
err]
      (Pandoc, Value) -> m (Pandoc, Value)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Pandoc
forall a. Monoid a => a
mempty, Value
defaultFrontMatter)
    Right Pandoc
doc ->
      -- TODO: Merge Pandoc's Meta in here?
      (Pandoc, Value) -> m (Pandoc, Value)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Pandoc
doc, Value
defaultFrontMatter)

parseNoteMarkdown :: (MonadIO m, MonadLogger m) => FilePath -> FilePath -> Text -> WriterT [Text] m (Pandoc, Aeson.Value)
parseNoteMarkdown :: forall (m :: Type -> Type).
(MonadIO m, MonadLogger m) =>
String -> String -> Text -> WriterT [Text] m (Pandoc, Value)
parseNoteMarkdown String
pluginBaseDir String
fp Text
md = do
  case String -> Text -> Either Text (Maybe Value, Pandoc)
Markdown.parseMarkdown String
fp Text
md of
    Left Text
err -> do
      [Text] -> WriterT [Text] m ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell [Text
err]
      (Pandoc, Value) -> WriterT [Text] m (Pandoc, Value)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Pandoc
forall a. Monoid a => a
mempty, Value
defaultFrontMatter)
    Right (Value -> Maybe Value -> Value
withAesonDefault Value
defaultFrontMatter -> Value
frontmatter, Pandoc
doc') -> do
      -- Apply the various transformation filters.
      --
      -- Some are user-defined; some builtin. They operate on Pandoc, or the
      -- frontmatter meta.
      let filterPaths :: [String]
filterPaths = (String
pluginBaseDir String -> ShowS
</>) ShowS -> [String] -> [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson @[FilePath] [String]
forall a. Monoid a => a
mempty (Text
"pandoc" Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [Text
"filters"]) Value
frontmatter
      Pandoc
doc <- [String] -> Pandoc -> WriterT [Text] m Pandoc
forall (m :: Type -> Type).
(MonadIO m, MonadLogger m, MonadWriter [Text] m) =>
[String] -> Pandoc -> m Pandoc
applyPandocFilters [String]
filterPaths Pandoc
doc'
      let meta :: Value
meta = Pandoc -> Value -> Value
applyNoteMetaFilters Pandoc
doc Value
frontmatter
      (Pandoc, Value) -> WriterT [Text] m (Pandoc, Value)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Pandoc
doc, Value
meta)
  where
    withAesonDefault :: Value -> Maybe Value -> Value
withAesonDefault Value
default_ Maybe Value
mv =
      Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
default_ Maybe Value
mv
        Value -> Value -> Value
`SData.mergeAeson` Value
default_

defaultFrontMatter :: Aeson.Value
defaultFrontMatter :: Value
defaultFrontMatter =
  Map Text [Text] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Map Text [Text] -> Value) -> Map Text [Text] -> Value
forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList @Text @[Text] ([(Text, [Text])] -> Map Text [Text])
-> [(Text, [Text])] -> Map Text [Text]
forall a b. (a -> b) -> a -> b
$ OneItem [(Text, [Text])] -> [(Text, [Text])]
forall x. One x => OneItem x -> x
one (Text
"tags", [])

applyNoteMetaFilters :: Pandoc -> Aeson.Value -> Aeson.Value
applyNoteMetaFilters :: Pandoc -> Value -> Value
applyNoteMetaFilters Pandoc
doc =
  Value -> Value
addTagsFromBody
    (Value -> Value) -> (Value -> Value) -> Value -> Value
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category @k cat =>
cat a b -> cat b c -> cat a c
>>> Value -> Value
addDescriptionFromBody
    (Value -> Value) -> (Value -> Value) -> Value -> Value
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category @k cat =>
cat a b -> cat b c -> cat a c
>>> Value -> Value
addImageFromBody
  where
    -- Merge frontmatter tags with inline tags in Pandoc document.
    -- DESIGN: In retrospect, this is like a Pandoc lua filter?
    addTagsFromBody :: Value -> Value
addTagsFromBody Value
frontmatter =
      Value
frontmatter
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Text -> AffineTraversal' Value Value
forall t. AsValue t => Text -> AffineTraversal' t Value
AO.key Text
"tags" AffineTraversal' Value Value
-> Optic A_Prism NoIx Value Value (Vector Value) (Vector Value)
-> Optic
     An_AffineTraversal NoIx Value Value (Vector Value) (Vector Value)
forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx Value Value (Vector Value) (Vector Value)
forall t. AsValue t => Prism' t (Vector Value)
AO._Array
          Optic
  An_AffineTraversal NoIx Value Value (Vector Value) (Vector Value)
-> Vector Value -> Value -> Value
forall k (is :: [Type]) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ( [Value] -> Vector Value
forall l. IsList l => [Item l] -> l
fromList ([Value] -> Vector Value)
-> ([Tag] -> [Value]) -> [Tag] -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag -> Value) -> [Tag] -> [Value]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Tag -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON ([Tag] -> Vector Value) -> [Tag] -> Vector Value
forall a b. (a -> b) -> a -> b
$
                 [Tag] -> [Tag]
forall a. Ord a => [a] -> [a]
ordNub ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$
                   forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson @[HT.Tag] [Tag]
forall a. Monoid a => a
mempty (OneItem (NonEmpty Text) -> NonEmpty Text
forall x. One x => OneItem x -> x
one OneItem (NonEmpty Text)
"tags") Value
frontmatter
                     [Tag] -> [Tag] -> [Tag]
forall a. Semigroup a => a -> a -> a
<> Pandoc -> [Tag]
HT.inlineTagsInPandoc Pandoc
doc
             )
    addDescriptionFromBody :: Value -> Value
addDescriptionFromBody =
      NonEmpty Text -> (Block -> [Text]) -> Value -> Value
forall a.
Walkable a Pandoc =>
NonEmpty Text -> (a -> [Text]) -> Value -> Value
overrideAesonText (Text
"page" Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [Text
"description"]) ((Block -> [Text]) -> Value -> Value)
-> (Block -> [Text]) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ \case
        B.Para [Inline]
is -> [[Inline] -> Text
plainify [Inline]
is]
        Block
_ -> [Text]
forall a. Monoid a => a
mempty
    -- FIXME this doesn't take splice rendering into account. Specifically,
    -- `![[foo.jpeg]]` is not handled at all.
    addImageFromBody :: Value -> Value
addImageFromBody =
      NonEmpty Text -> (Inline -> [Text]) -> Value -> Value
forall a.
Walkable a Pandoc =>
NonEmpty Text -> (a -> [Text]) -> Value -> Value
overrideAesonText (Text
"page" Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [Text
"image"]) ((Inline -> [Text]) -> Value -> Value)
-> (Inline -> [Text]) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ \case
        B.Image Attr
_ [Inline]
_ (Text
url, Text
_) -> [Text
url]
        Inline
_ -> [Text]
forall a. Monoid a => a
mempty
    overrideAesonText :: forall a. (W.Walkable a Pandoc) => NonEmpty Text -> (a -> [Text]) -> Aeson.Value -> Aeson.Value
    overrideAesonText :: forall a.
Walkable a Pandoc =>
NonEmpty Text -> (a -> [Text]) -> Value -> Value
overrideAesonText NonEmpty Text
key a -> [Text]
f Value
frontmatter =
      NonEmpty Value -> Value
SData.mergeAesons (NonEmpty Value -> Value) -> NonEmpty Value -> Value
forall a b. (a -> b) -> a -> b
$
        Value
frontmatter
          Value -> [Value] -> NonEmpty Value
forall a. a -> [a] -> NonEmpty a
:| Maybe Value -> [Value]
forall a. Maybe a -> [a]
maybeToList
            ( do
                Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text
"" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson @Text Text
"" NonEmpty Text
key Value
frontmatter
                Text
val <- (NonEmpty Text -> Text) -> [Text] -> Maybe Text
forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty NonEmpty Text -> Text
forall (f :: Type -> Type) a. IsNonEmpty f a a "head" => f a -> a
head ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (a -> [Text]) -> Pandoc -> [Text]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query a -> [Text]
f Pandoc
doc
                Value -> Maybe Value
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Value
SData.oneAesonText (NonEmpty Text -> [Text]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty Text
key) Text
val
            )

makeLenses ''Note