{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Commonmark.Extensions.Wikilinks
  ( wikilinksSpec
  , TitlePosition(..)
  , HasWikilinks(..)
  )
where
import Commonmark.Entity
import Commonmark.Types
import Commonmark.Tokens
import Commonmark.Syntax
import Commonmark.SourceMap
import Commonmark.TokParsers
import Commonmark.Html
import Text.Parsec
import Data.Text (Text, strip)

class HasWikilinks il where
  wikilink :: Text -> il -> il

instance Rangeable (Html a) => HasWikilinks (Html a) where
  wikilink :: Text -> Html a -> Html a
wikilink Text
url Html a
il = Text -> Text -> Html a -> Html a
forall a. IsInline a => Text -> Text -> a -> a
link Text
url Text
"wikilink" Html a
il

instance (HasWikilinks il, Semigroup il, Monoid il)
        => HasWikilinks (WithSourceMap il) where
  wikilink :: Text -> WithSourceMap il -> WithSourceMap il
wikilink Text
url WithSourceMap il
il = (Text -> il -> il
forall il. HasWikilinks il => Text -> il -> il
wikilink Text
url (il -> il) -> WithSourceMap il -> WithSourceMap il
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap il
il) WithSourceMap il -> WithSourceMap () -> WithSourceMap il
forall a b. WithSourceMap a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"wikilink"

-- | Determines whether @[[foo|bar]]@ is a link to page @bar@
-- with title (description) @foo@ ('TitleBeforePipe'), as in
-- GitHub wikis, or a link to page @foo@ with title @bar@
-- ('TitleAfterPipe'), as in Obsidian and Foam.
data TitlePosition = TitleBeforePipe | TitleAfterPipe
  deriving (Int -> TitlePosition -> ShowS
[TitlePosition] -> ShowS
TitlePosition -> String
(Int -> TitlePosition -> ShowS)
-> (TitlePosition -> String)
-> ([TitlePosition] -> ShowS)
-> Show TitlePosition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TitlePosition -> ShowS
showsPrec :: Int -> TitlePosition -> ShowS
$cshow :: TitlePosition -> String
show :: TitlePosition -> String
$cshowList :: [TitlePosition] -> ShowS
showList :: [TitlePosition] -> ShowS
Show, TitlePosition -> TitlePosition -> Bool
(TitlePosition -> TitlePosition -> Bool)
-> (TitlePosition -> TitlePosition -> Bool) -> Eq TitlePosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TitlePosition -> TitlePosition -> Bool
== :: TitlePosition -> TitlePosition -> Bool
$c/= :: TitlePosition -> TitlePosition -> Bool
/= :: TitlePosition -> TitlePosition -> Bool
Eq)

wikilinksSpec :: (Monad m, IsInline il, HasWikilinks il)
              => TitlePosition
              -> SyntaxSpec m il bl
wikilinksSpec :: forall (m :: * -> *) il bl.
(Monad m, IsInline il, HasWikilinks il) =>
TitlePosition -> SyntaxSpec m il bl
wikilinksSpec TitlePosition
titlepos = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxInlineParsers = [ pWikilink ]
  }
  where
   pWikilink :: ParsecT [Tok] u (StateT Enders m) il
pWikilink = ParsecT [Tok] u (StateT Enders m) il
-> ParsecT [Tok] u (StateT Enders m) il
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] u (StateT Enders m) il
 -> ParsecT [Tok] u (StateT Enders m) il)
-> ParsecT [Tok] u (StateT Enders m) il
-> ParsecT [Tok] u (StateT Enders m) il
forall a b. (a -> b) -> a -> b
$ do
     Char -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'['
     Char -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'['
     ParsecT [Tok] u (StateT Enders m) Tok
-> ParsecT [Tok] u (StateT Enders m) ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (Char -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'[')
     [Tok]
toks <- ParsecT [Tok] u (StateT Enders m) Tok
-> ParsecT [Tok] u (StateT Enders m) [Tok]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Tok -> Bool) -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (Bool -> Bool
not (Bool -> Bool) -> (Tok -> Bool) -> Tok -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
']')))
     let isPipe :: Tok -> Bool
isPipe (Tok (Symbol Char
'|') SourcePos
_ Text
_) = Bool
True
         isPipe Tok
_ = Bool
False
     let (Text
title, Text
url) =
           case (Tok -> Bool) -> [Tok] -> ([Tok], [Tok])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Tok -> Bool
isPipe [Tok]
toks of
              ([Tok]
xs, [])   -> ([Tok] -> Text
unEntity [Tok]
xs, [Tok] -> Text
unEntity [Tok]
xs)
              ([Tok]
xs, Tok
_:[Tok]
ys) ->
                case TitlePosition
titlepos of
                  TitlePosition
TitleBeforePipe -> ([Tok] -> Text
unEntity [Tok]
xs, [Tok] -> Text
unEntity [Tok]
ys)
                  TitlePosition
TitleAfterPipe  -> ([Tok] -> Text
unEntity [Tok]
ys, [Tok] -> Text
unEntity [Tok]
xs)
     Char -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
']'
     Char -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
']'
     il -> ParsecT [Tok] u (StateT Enders m) il
forall a. a -> ParsecT [Tok] u (StateT Enders m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (il -> ParsecT [Tok] u (StateT Enders m) il)
-> il -> ParsecT [Tok] u (StateT Enders m) il
forall a b. (a -> b) -> a -> b
$ Text -> il -> il
forall il. HasWikilinks il => Text -> il -> il
wikilink (Text -> Text
strip Text
url) (Text -> il
forall a. IsInline a => Text -> a
str (Text -> Text
strip Text
title))