{-# 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
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
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
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. 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
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
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
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
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. 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
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 =
    forall (ixs :: [Type]) a r. MkIxList ixs ixs a r => r
ixList
      (forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> LMLRoute
_noteRoute)
      (forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> NonEmpty WikiLink
noteSelfRefs)
      (forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> R @() 'Html
noteHtmlRoute)
      (forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun Note -> [RAncestor]
noteAncestors)
      (forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe (R @() 'Folder)
noteParent)
      (forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun Note -> [Tag]
noteTags)
      (forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList 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
    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 =
      forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute (HasCallStack => NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink)
WL.allowedWikiLinks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ext :: FileType a). R @a ext -> NonEmpty Slug
R.unRoute)

noteAncestors :: Note -> [RAncestor]
noteAncestors :: Note -> [RAncestor]
noteAncestors =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap R @() 'Folder -> RAncestor
RAncestor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} (ext :: FileType a). R @a ext -> NonEmpty (R @a ext)
R.routeInits) 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 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)
R.routeParent 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ixs :: [Type]) a. IxSet ixs a -> Bool
Ix.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Tag
HT.Tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Monoid m => Maybe m -> m
maybeToMonoid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => NonEmpty Text -> Note -> Maybe a
lookupMeta (forall x. One x => OneItem x -> x
one Text
"tags")

noteSlug :: Note -> Maybe (NonEmpty Slug)
noteSlug :: Note -> Maybe (NonEmpty Slug)
noteSlug Note
note = do
  Text
slugPath :: Text <- forall a. FromJSON a => NonEmpty Text -> Note -> Maybe a
lookupMeta (forall x. One x => OneItem x -> x
one Text
"slug") Note
note
  forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a (ext :: FileType a). R @a ext -> NonEmpty Slug
R.unRoute forall a b. (a -> b) -> a -> b
$ forall a (ext :: FileType a).
HasExt @a ext =>
String -> Maybe (R @a ext)
R.mkRouteFromFilePath @_ @('R.AnyExt) forall a b. (a -> b) -> a -> b
$ 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 =
  forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson forall a. Maybe a
Nothing NonEmpty Text
k 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 = forall a. IsString a => String -> a
fromString 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 forall a. Maybe a
Nothing (forall x. One x => OneItem x -> x
one 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 forall a. a -> Maybe a -> a
fromMaybe (Pandoc
doc, Title
fileNameTitle) forall a b. (a -> b) -> a -> b
$
        forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pandoc
doc,) Maybe Title
yamlNoteTitle forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> 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 =
      forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Inline] -> Title
Tit.fromInlines 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)) =
          forall a. a -> Maybe a
Just [Inline]
inlines
        getPandocH1 Pandoc
_ =
          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
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure 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 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
_noteRoute
    Just NonEmpty Slug
slugs ->
      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 =
  forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall a b. (a -> b) -> a -> b
$ 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 :| [] -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Note
note
    NonEmpty Note
_ -> forall a t. (HasCallStack, IsText t) => t -> a
error forall a b. (a -> b) -> a -> b
$ Text
"ambiguous notes for route " forall a. Semigroup a => a -> a -> a
<> 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") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. One x => OneItem x -> x
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Block
B.Para 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") forall a b. (a -> b) -> a -> b
$
                forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$
                  Text -> Inline
B.Str forall a b. (a -> b) -> a -> b
$
                    forall {a} (ext :: FileType a). R @a ext -> Text
oneOfLmlFilenames R @() 'Folder
r
            ]
        ]
   in LMLRoute -> [Block] -> Note
mkEmptyNoteWith (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
"", forall x. One x => OneItem x -> x
one Text
x, 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 (forall a (ext :: FileType a). R @a ext -> LMLRoute
R.defaultLmlRoute R @a ext
route404) forall a b. (a -> b) -> a -> b
$
    forall x. One x => OneItem x -> x
one 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 forall a b. (a -> b) -> a -> b
$ 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") forall a b. (a -> b) -> a -> b
$
            forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$
              Text -> Inline
B.Str forall a b. (a -> b) -> a -> b
$
                Text
". You may create a file with that name, ie. one of: " forall a. Semigroup a => a -> a -> a
<> 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
", "
    (forall a. ToText a => a -> Text
toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
R.encodeRoute forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall (f :: Type -> Type) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty LMLRoute
rs) 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 forall a b. (a -> b) -> a -> b
$ 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:"
        ]
    ]
      forall a. Semigroup a => a -> a -> a
<> forall x. One x => OneItem x -> x
one Block
candidates
  where
    candidates :: B.Block
    candidates :: Block
candidates =
      [[Block]] -> Block
B.BulletList forall a b. (a -> b) -> a -> b
$
        forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty LMLRoute
rs 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 forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ Text -> Inline
B.Str Text
"  "
          , [Inline] -> Block
B.Plain forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Inline
B.Code Attr
B.nullAttr forall a b. (a -> b) -> a -> b
$ 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 forall a. Monoid a => a
mempty -> Pandoc
doc) =
  LMLRoute -> Pandoc -> Value -> [Text] -> Note
mkNoteWith LMLRoute
someR Pandoc
doc Value
meta 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 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 forall a. a -> [a] -> [a]
: Block
prefix forall a. a -> [a] -> [a]
: [Block]
rest
            [Block]
_ -> Block
prefix 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") forall a b. (a -> b) -> a -> b
$ [Inline] -> Block
B.Para [[Inline] -> Inline
B.Strong forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ Text -> Inline
B.Str Text
"Emanote Errors 😔"] forall a. a -> [a] -> [a]
: ([Inline] -> Block
B.Para forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. One x => OneItem x -> x
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
B.Str 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) <- forall w (m :: Type -> Type) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ do
    case LMLRoute
r of
      R.LMLRoute_Md R @SourceExt ('LMLType 'Md)
_ ->
        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
        forall (m :: Type -> Type).
MonadWriter [Text] m =>
Text -> m (Pandoc, Value)
parseNoteOrg Text
s
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure 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 forall a. PandocPure a -> Either PandocError a
runPure forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readOrg forall a. Default a => a
def Text
s of
    Left PandocError
err -> do
      forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell [forall b a. (Show a, IsString b) => a -> b
show PandocError
err]
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty, Value
defaultFrontMatter)
    Right Pandoc
doc ->
      -- TODO: Merge Pandoc's Meta in here?
      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
      forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell [Text
err]
      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (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 </>) 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] forall a. Monoid a => a
mempty (Text
"pandoc" forall a. a -> [a] -> NonEmpty a
:| [Text
"filters"]) Value
frontmatter
      Pandoc
doc <- 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
      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 =
      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 =
  forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList @Text @[Text] forall a b. (a -> b) -> a -> b
$ 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
    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
    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
        forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> AffineTraversal' t Value
AO.key Key
"tags" 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
% forall t. AsValue t => Prism' t (Vector Value)
AO._Array
          forall k (is :: [Type]) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ( forall l. IsList l => [Item l] -> l
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$
                forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$
                  forall a. FromJSON a => a -> NonEmpty Text -> Value -> a
SData.lookupAeson @[HT.Tag] forall a. Monoid a => a
mempty (forall x. One x => OneItem x -> x
one Text
"tags") Value
frontmatter
                    forall a. Semigroup a => a -> a -> a
<> Pandoc -> [Tag]
HT.inlineTagsInPandoc Pandoc
doc
             )
    addDescriptionFromBody :: Value -> Value
addDescriptionFromBody =
      forall a.
Walkable a Pandoc =>
NonEmpty Text -> (a -> [Text]) -> Value -> Value
overrideAesonText (Text
"page" forall a. a -> [a] -> NonEmpty a
:| [Text
"description"]) forall a b. (a -> b) -> a -> b
$ \case
        B.Para [Inline]
is -> [[Inline] -> Text
plainify [Inline]
is]
        Block
_ -> 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 =
      forall a.
Walkable a Pandoc =>
NonEmpty Text -> (a -> [Text]) -> Value -> Value
overrideAesonText (Text
"page" forall a. a -> [a] -> NonEmpty a
:| [Text
"image"]) forall a b. (a -> b) -> a -> b
$ \case
        B.Image Attr
_ [Inline]
_ (Text
url, Text
_) -> [Text
url]
        Inline
_ -> 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 forall a b. (a -> b) -> a -> b
$
        Value
frontmatter
          forall a. a -> [a] -> NonEmpty a
:| forall a. Maybe a -> [a]
maybeToList
            ( do
                forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
"" 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 <- forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty forall (f :: Type -> Type) a. IsNonEmpty f a a "head" => f a -> a
head forall a b. (a -> b) -> a -> b
$ forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query a -> [Text]
f Pandoc
doc
                forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Value
SData.oneAesonText (forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty Text
key) Text
val
            )

makeLenses ''Note