{-# 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 =
'[
R.LMLRoute
,
WL.WikiLink
,
R 'R.Html
,
RAncestor
,
R 'R.Folder
,
HT.Tag
,
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)
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
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
..} =
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
,
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: "
,
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
,
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
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 ->
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
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
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
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