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

-- TODO: Do breadth-first instead of depth-first
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)
          -- Handle reverse folgezettel links here
          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))
          -- Folders are automatically made a folgezettel
          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

{- | Return the route to parent folder (unless indexRoute is passed).

  This will return the existing note (.org or .md) if possible. Otherwise
  fallback to .md even if missing.
-}
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
    -- Root index do not have a parent folder.
    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
    -- Consider the index route as parent folder for all
    -- top-level notes.
    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