module Emanote.Model.Graph where
import Commonmark.Extensions.WikiLink qualified as WL
import Data.IxSet.Typed ((@+), (@=))
import Data.IxSet.Typed qualified as Ix
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Tree (Forest, Tree (Node))
import Emanote.Model.Calendar qualified as Calendar
import Emanote.Model.Link.Rel qualified as Rel
import Emanote.Model.Link.Resolve qualified as Resolve
import Emanote.Model.Meta (lookupRouteMeta)
import Emanote.Model.Note qualified as MN
import Emanote.Model.Type (Model, modelRels, resolveLmlRoute)
import Emanote.Route qualified as R
import Emanote.Route.ModelRoute (ModelRoute)
import Optics.Operators as Lens ((^.))
import Relude hiding (empty)
import Text.Pandoc.Definition qualified as B
modelFolgezettelAncestorTree :: ModelRoute -> Model -> Forest R.LMLRoute
modelFolgezettelAncestorTree :: ModelRoute -> Model -> Forest LMLRoute
modelFolgezettelAncestorTree ModelRoute
r0 Model
model =
forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall s a. s -> State s a -> (a, s)
usingState forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type).
MonadState (Set ModelRoute) m =>
ModelRoute -> m (Forest LMLRoute)
go ModelRoute
r0
where
go :: MonadState (Set ModelRoute) m => ModelRoute -> m (Forest R.LMLRoute)
go :: forall (m :: Type -> Type).
MonadState (Set ModelRoute) m =>
ModelRoute -> m (Forest LMLRoute)
go ModelRoute
r = do
let folgezettelBacklinks :: [LMLRoute]
folgezettelBacklinks =
ModelRoute -> Model -> [Rel]
backlinkRels ModelRoute
r Model
model
forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> [a] -> [a]
filter (UnresolvedRelTarget -> Bool
isFolgezettel forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' Rel UnresolvedRelTarget
Rel.relTo))
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' Rel LMLRoute
Rel.relFrom)
folgezettelFrontlinks :: [LMLRoute]
folgezettelFrontlinks =
ModelRoute -> Model -> [Rel]
frontlinkRels ModelRoute
r Model
model
forall a b. a -> (a -> b) -> b
& forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (WikiLink -> Maybe LMLRoute
lookupWikiLink forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< UnresolvedRelTarget -> Maybe WikiLink
selectReverseFolgezettel forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' Rel UnresolvedRelTarget
Rel.relTo))
folgezettelFolder :: [LMLRoute]
folgezettelFolder =
forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
LMLRoute
lmlR <- forall l r. Either l r -> Maybe l
leftToMaybe (ModelRoute -> Either LMLRoute StaticFileRoute
R.modelRouteCase ModelRoute
r)
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a (f :: Type -> Type).
FromJSON a =>
a -> NonEmpty Text -> LMLRoute -> ModelT f -> a
lookupRouteMeta Bool
True (Text
"emanote" forall a. a -> [a] -> NonEmpty a
:| [Text
"folder-folgezettel"]) LMLRoute
lmlR Model
model
Model -> LMLRoute -> Maybe LMLRoute
parentLmlRoute Model
model LMLRoute
lmlR
folgezettelParents :: [LMLRoute]
folgezettelParents =
forall a. Monoid a => [a] -> a
mconcat
[ [LMLRoute]
folgezettelBacklinks
, [LMLRoute]
folgezettelFrontlinks
, [LMLRoute]
folgezettelFolder
]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LMLRoute]
folgezettelParents forall a b. (a -> b) -> a -> b
$ \LMLRoute
parentR -> do
let parentModelR :: ModelRoute
parentModelR = LMLRoute -> ModelRoute
R.ModelRoute_LML LMLRoute
parentR
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets (ModelRoute
parentModelR `Set.member`) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Bool
False -> do
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert ModelRoute
parentModelR
Forest LMLRoute
sub <- forall (m :: Type -> Type).
MonadState (Set ModelRoute) m =>
ModelRoute -> m (Forest LMLRoute)
go ModelRoute
parentModelR
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Node LMLRoute
parentR Forest LMLRoute
sub
isFolgezettel :: UnresolvedRelTarget -> Bool
isFolgezettel = \case
Rel.URTWikiLink (WikiLinkType
WL.WikiLinkBranch, WikiLink
_wl) ->
Bool
True
UnresolvedRelTarget
_ ->
Bool
False
selectReverseFolgezettel :: Rel.UnresolvedRelTarget -> Maybe WL.WikiLink
selectReverseFolgezettel :: UnresolvedRelTarget -> Maybe WikiLink
selectReverseFolgezettel = \case
Rel.URTWikiLink (WikiLinkType
WL.WikiLinkTag, WikiLink
wl) -> forall a. a -> Maybe a
Just WikiLink
wl
UnresolvedRelTarget
_ -> forall a. Maybe a
Nothing
lookupWikiLink :: WL.WikiLink -> Maybe R.LMLRoute
lookupWikiLink :: WikiLink -> Maybe LMLRoute
lookupWikiLink WikiLink
wl = do
Note
note <- forall l r. Either l r -> Maybe l
leftToMaybe forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. ResolvedRelTarget a -> Maybe a
getFound forall a b. (a -> b) -> a -> b
$ Model -> WikiLink -> ResolvedRelTarget (Either Note StaticFile)
Resolve.resolveWikiLinkMustExist Model
model WikiLink
wl
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Note
note forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' Note LMLRoute
MN.noteRoute
getFound :: Rel.ResolvedRelTarget a -> Maybe a
getFound :: forall a. ResolvedRelTarget a -> Maybe a
getFound = \case
Rel.RRTFound a
x -> forall a. a -> Maybe a
Just a
x
ResolvedRelTarget a
_ -> forall a. Maybe a
Nothing
parentLmlRoute :: Model -> R.LMLRoute -> Maybe R.LMLRoute
parentLmlRoute :: Model -> LMLRoute -> Maybe LMLRoute
parentLmlRoute Model
model LMLRoute
r = do
R @() 'Folder
pr <- do
let lmlR :: Either (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
lmlR = LMLRoute
-> Either
(R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
R.lmlRouteCase LMLRoute
r
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Either (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
lmlR forall a. Eq a => a -> a -> Bool
/= forall a b. a -> Either a b
Left forall {a} (ext :: FileType a). R @a ext
R.indexRoute Bool -> Bool -> Bool
&& Either (R @SourceExt ('LMLType 'Md)) (R @SourceExt ('LMLType 'Org))
lmlR forall a. Eq a => a -> a -> Bool
/= forall a b. b -> Either a b
Right forall {a} (ext :: FileType a). R @a ext
R.indexRoute
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall {a} (ext :: FileType a). R @a ext
R.indexRoute forall a b. (a -> b) -> a -> b
$ 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 LMLRoute
r
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (lmlType :: LML) (f :: Type -> Type).
ModelT f -> R @SourceExt ('LMLType lmlType) -> LMLRoute
resolveLmlRoute Model
model forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible @Type a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ R @() 'Folder
pr
modelLookupBacklinks :: ModelRoute -> Model -> [(R.LMLRoute, NonEmpty [B.Block])]
modelLookupBacklinks :: ModelRoute -> Model -> [(LMLRoute, NonEmpty [Block])]
modelLookupBacklinks ModelRoute
r Model
model =
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Model -> LMLRoute -> Down Title
Calendar.backlinkSortKey Model
model forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
forall a b. Ord a => [(a, b)] -> [(a, NonEmpty b)]
groupNE forall a b. (a -> b) -> a -> b
$
ModelRoute -> Model -> [Rel]
backlinkRels ModelRoute
r Model
model forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \Rel
rel ->
(Rel
rel forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' Rel LMLRoute
Rel.relFrom, Rel
rel forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' Rel [Block]
Rel.relCtx)
where
groupNE :: forall a b. Ord a => [(a, b)] -> [(a, NonEmpty b)]
groupNE :: forall a b. Ord a => [(a, b)] -> [(a, NonEmpty b)]
groupNE =
forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map a (NonEmpty b) -> (a, b) -> Map a (NonEmpty b)
f forall k a. Map k a
Map.empty
where
f :: Map a (NonEmpty b) -> (a, b) -> Map a (NonEmpty b)
f :: Map a (NonEmpty b) -> (a, b) -> Map a (NonEmpty b)
f Map a (NonEmpty b)
m (a
x, b
y) =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a (NonEmpty b)
m of
Maybe (NonEmpty b)
Nothing -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
x (forall x. One x => OneItem x -> x
one b
y) Map a (NonEmpty b)
m
Just NonEmpty b
ys -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
x (NonEmpty b
ys forall a. Semigroup a => a -> a -> a
<> forall x. One x => OneItem x -> x
one b
y) Map a (NonEmpty b)
m
backlinkRels :: ModelRoute -> Model -> [Rel.Rel]
backlinkRels :: ModelRoute -> Model -> [Rel]
backlinkRels ModelRoute
r Model
model =
let allPossibleLinks :: [UnresolvedRelTarget]
allPossibleLinks = ModelRoute -> [UnresolvedRelTarget]
Rel.unresolvedRelsTo ModelRoute
r
in forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall a b. (a -> b) -> a -> b
$ (Model
model forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type).
Lens' (ModelT encF) (IxSet RelIxs Rel)
modelRels) forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> [ix] -> IxSet ixs a
@+ [UnresolvedRelTarget]
allPossibleLinks
frontlinkRels :: ModelRoute -> Model -> [Rel.Rel]
frontlinkRels :: ModelRoute -> Model -> [Rel]
frontlinkRels ModelRoute
r Model
model =
forall m. Monoid m => Maybe m -> m
maybeToMonoid forall a b. (a -> b) -> a -> b
$ do
LMLRoute
lmlR <- forall l r. Either l r -> Maybe l
leftToMaybe forall a b. (a -> b) -> a -> b
$ ModelRoute -> Either LMLRoute StaticFileRoute
R.modelRouteCase ModelRoute
r
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (ixs :: [Type]) a. IxSet ixs a -> [a]
Ix.toList forall a b. (a -> b) -> a -> b
$ (Model
model forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (encF :: Type -> Type).
Lens' (ModelT encF) (IxSet RelIxs Rel)
modelRels) forall (ixs :: [Type]) a ix.
(Indexable ixs a, IsIndexOf ix ixs) =>
IxSet ixs a -> ix -> IxSet ixs a
@= LMLRoute
lmlR