module Text.Pandoc.LinkContext (queryLinksWithContext) where

import Data.List (nub)
import qualified Data.Map.Strict as Map
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Definition (Block, Inline (Link), Pandoc (..))
import qualified Text.Pandoc.Walk as W

type Url = Text

-- | Query the pandoc document for all links
--
-- Return a map, containing the "surrounding context" (as Pandoc blocks) for
-- each link.
queryLinksWithContext :: Pandoc -> Map Url [Block]
queryLinksWithContext :: Pandoc -> Map Url [Block]
queryLinksWithContext =
  ([Block] -> [Block]) -> Map Url [Block] -> Map Url [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Block] -> [Block]
forall a. Eq a => [a] -> [a]
nub
    (Map Url [Block] -> Map Url [Block])
-> (Pandoc -> Map Url [Block]) -> Pandoc -> Map Url [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Block] -> [Block] -> [Block])
-> [(Url, [Block])] -> Map Url [Block]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Block] -> [Block] -> [Block]
forall a. Semigroup a => a -> a -> a
(<>)
    ([(Url, [Block])] -> Map Url [Block])
-> (Pandoc -> [(Url, [Block])]) -> Pandoc -> Map Url [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Url, Block) -> (Url, [Block]))
-> [(Url, Block)] -> [(Url, [Block])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Block -> [Block]) -> (Url, Block) -> (Url, [Block])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Block -> [Block]
forall x. One x => OneItem x -> x
one)
    ([(Url, Block)] -> [(Url, [Block])])
-> (Pandoc -> [(Url, Block)]) -> Pandoc -> [(Url, [Block])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> [(Url, Block)]) -> Pandoc -> [(Url, Block)]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query Block -> [(Url, Block)]
go
  where
    go :: Block -> [(Url, Block)]
    go :: Block -> [(Url, Block)]
go blk :: Block
blk =
      (Url -> (Url, Block)) -> [Url] -> [(Url, Block)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Block
blk) ([Url] -> [(Url, Block)]) -> [Url] -> [(Url, Block)]
forall a b. (a -> b) -> a -> b
$ case Block
blk of
        B.Para is :: [Inline]
is ->
          [Inline] -> [Url]
forall b. Walkable Inline b => b -> [Url]
queryLinkUrls [Inline]
is
        B.Plain is :: [Inline]
is ->
          [Inline] -> [Url]
forall b. Walkable Inline b => b -> [Url]
queryLinkUrls [Inline]
is
        B.LineBlock is :: [[Inline]]
is ->
          [[Inline]] -> [Url]
forall b. Walkable Inline b => b -> [Url]
queryLinkUrls [[Inline]]
is
        B.Header _ _ is :: [Inline]
is ->
          [Inline] -> [Url]
forall b. Walkable Inline b => b -> [Url]
queryLinkUrls [Inline]
is
        B.DefinitionList xs :: [([Inline], [[Block]])]
xs ->
          -- Gather all filenames linked, and have them put (see above) in the
          -- same definition list block.
          [[Url]] -> [Url]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Url]] -> [Url]) -> [[Url]] -> [Url]
forall a b. (a -> b) -> a -> b
$
            [([Inline], [[Block]])]
xs [([Inline], [[Block]])]
-> (([Inline], [[Block]]) -> [Url]) -> [[Url]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(is :: [Inline]
is, bss :: [[Block]]
bss) ->
              let def :: [Url]
def = [Inline] -> [Url]
forall b. Walkable Inline b => b -> [Url]
queryLinkUrls [Inline]
is
                  body :: [[[Url]]]
body = ([Block] -> [[Url]]) -> [[Block]] -> [[[Url]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Block -> [Url]) -> [Block] -> [[Url]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Url, Block) -> Url) -> [(Url, Block)] -> [Url]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Url, Block) -> Url
forall a b. (a, b) -> a
fst ([(Url, Block)] -> [Url])
-> (Block -> [(Url, Block)]) -> Block -> [Url]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [(Url, Block)]
go)) [[Block]]
bss
               in [Url]
def [Url] -> [Url] -> [Url]
forall a. Semigroup a => a -> a -> a
<> [[Url]] -> [Url]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Url]]] -> [[Url]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Url]]]
body)
        _ -> [Url]
forall a. Monoid a => a
mempty

    queryLinkUrls :: W.Walkable Inline b => b -> [Url]
    queryLinkUrls :: b -> [Url]
queryLinkUrls =
      (Inline -> [Url]) -> b -> [Url]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query (Maybe Url -> [Url]
forall a. Maybe a -> [a]
maybeToList (Maybe Url -> [Url]) -> (Inline -> Maybe Url) -> Inline -> [Url]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inline -> Maybe Url
getLinkUrl)

    getLinkUrl :: Inline -> Maybe Url
    getLinkUrl :: Inline -> Maybe Url
getLinkUrl = \case
      Link _attr :: Attr
_attr _inlines :: [Inline]
_inlines (url :: Url
url, _title :: Url
_title) -> do
        Url -> Maybe Url
forall (f :: * -> *) a. Applicative f => a -> f a
pure Url
url
      _ ->
        Maybe Url
forall a. Maybe a
Nothing