module Emanote.Pandoc.ExternalLink
  ( setExternalLinkIcon,
  )
where

import Relude
import Text.Pandoc.Definition qualified as B
import Text.Pandoc.Walk qualified as W
import Text.Parsec qualified as P
import Text.Parsec.Char qualified as PC

-- Add a data-linkicon=external attribute to external links that contain some
-- text in their description, provided that they do not already have a
-- data-linkicon attribute.
setExternalLinkIcon :: W.Walkable B.Inline b => b -> b
setExternalLinkIcon :: forall b. Walkable Inline b => b -> b
setExternalLinkIcon =
  (Inline -> Inline) -> b -> b
forall a b. Walkable a b => (a -> a) -> b -> b
W.walk ((Inline -> Inline) -> b -> b) -> (Inline -> Inline) -> b -> b
forall a b. (a -> b) -> a -> b
$ \case
    B.Link (Text
id', [Text]
classes, [(Text, Text)]
attrs) [Inline]
inlines (Text
url, Text
title)
      | Text -> Bool
hasURIScheme Text
url Bool -> Bool -> Bool
&& [Inline] -> Bool
containsText [Inline]
inlines ->
          let showLinkIconAttr :: (Text, Text)
showLinkIconAttr = (Text
"data-linkicon", Text
"external")
              newAttrs :: [(Text, Text)]
newAttrs = [(Text, Text)] -> (Text, Text) -> [(Text, Text)]
forall a b. Eq a => [(a, b)] -> (a, b) -> [(a, b)]
insert [(Text, Text)]
attrs (Text, Text)
showLinkIconAttr
           in (Text, [Text], [(Text, Text)])
-> [Inline] -> (Text, Text) -> Inline
B.Link (Text
id', [Text]
classes, [(Text, Text)]
newAttrs) [Inline]
inlines (Text
url, Text
title)
    Inline
x -> Inline
x
  where
    -- Inserts an element in a key-value list if the element's key is not
    -- already in the list.
    insert :: Eq a => [(a, b)] -> (a, b) -> [(a, b)]
    insert :: forall a b. Eq a => [(a, b)] -> (a, b) -> [(a, b)]
insert [(a, b)]
as (a, b)
a
      | (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
a a -> [a] -> Bool
forall (f :: Type -> Type) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ((a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> [(a, b)] -> [a]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b)]
as) = [(a, b)]
as
      | Bool
otherwise = (a, b)
a (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
as
    -- Checks whether the given text begins with an RFC 3986 compliant URI
    -- scheme.
    hasURIScheme :: Text -> Bool
    hasURIScheme :: Text -> Bool
hasURIScheme =
      Either ParseError [Char] -> Bool
forall a b. Either a b -> Bool
isRight (Either ParseError [Char] -> Bool)
-> (Text -> Either ParseError [Char]) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Text () [Char] -> [Char] -> Text -> Either ParseError [Char]
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
P.parse Parsec Text () [Char]
forall {u}. ParsecT Text u Identity [Char]
schemeP [Char]
""
      where
        schemeP :: ParsecT Text u Identity [Char]
schemeP = do
          Char
c <- ParsecT Text u Identity Char
forall s (m :: Type -> Type) u.
Stream s m Char =>
ParsecT s u m Char
PC.letter
          [Char]
cs <- ParsecT Text u Identity Char -> ParsecT Text u Identity [Char]
forall s u (m :: Type -> Type) a.
ParsecT s u m a -> ParsecT s u m [a]
P.many (ParsecT Text u Identity Char -> ParsecT Text u Identity [Char])
-> ParsecT Text u Identity Char -> ParsecT Text u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT Text u Identity Char
forall s (m :: Type -> Type) u.
Stream s m Char =>
ParsecT s u m Char
PC.alphaNum ParsecT Text u Identity Char
-> ParsecT Text u Identity Char -> ParsecT Text u Identity Char
forall s u (m :: Type -> Type) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> [Char] -> ParsecT Text u Identity Char
forall s (m :: Type -> Type) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
".-+"
          ParsecT Text u Identity Char -> ParsecT Text u Identity ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (ParsecT Text u Identity Char -> ParsecT Text u Identity ())
-> ParsecT Text u Identity Char -> ParsecT Text u Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT Text u Identity Char
forall s (m :: Type -> Type) u.
Stream s m Char =>
Char -> ParsecT s u m Char
PC.char Char
':'
          [Char] -> ParsecT Text u Identity [Char]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs)
    -- Checks whether a list of inlines contains a (perhaps nested) "textual
    -- element", understood as a Pandoc `Str`, `Code` or `Math`.
    containsText :: [B.Inline] -> Bool
    containsText :: [Inline] -> Bool
containsText =
      Any -> Bool
getAny
        (Any -> Bool) -> ([Inline] -> Any) -> [Inline] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Any) -> [Inline] -> Any
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query
          ( \case
              B.Str Text
_ -> Bool -> Any
Any Bool
True
              B.Code (Text, [Text], [(Text, Text)])
_ Text
_ -> Bool -> Any
Any Bool
True
              B.Math MathType
_ Text
_ -> Bool -> Any
Any Bool
True
              Inline
_ -> Bool -> Any
Any Bool
False
          )