1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE UndecidableInstances #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7module Commonmark.Extensions.Wikilinks
8  ( wikilinksSpec
9  , TitlePosition(..)
10  , HasWikilinks(..)
11  )
12where
13import Commonmark.Types
14import Commonmark.Tokens
15import Commonmark.Syntax
16import Commonmark.SourceMap
17import Commonmark.TokParsers
18import Commonmark.Html
19import Text.Parsec
20#if !MIN_VERSION_base(4,11,0)
21import Data.Semigroup hiding (option)
22#endif
23import Data.Text (Text, strip)
24
25class HasWikilinks il where
26  wikilink :: Text -> il -> il
27
28instance Rangeable (Html a) => HasWikilinks (Html a) where
29  wikilink url il = link url "wikilink" il
30
31instance (HasWikilinks il, Semigroup il, Monoid il)
32        => HasWikilinks (WithSourceMap il) where
33  wikilink url il = (wikilink url <$> il) <* addName "wikilink"
34
35-- | Determines whether @[[foo|bar]]@ is a link to page @bar@
36-- with title (description) @foo@ ('TitleBeforePipe'), as in
37-- GitHub wikis, or a link to page @foo@ with title @bar@
38-- ('TitleAfterPipe'), as in Obsidian and Foam.
39data TitlePosition = TitleBeforePipe | TitleAfterPipe
40  deriving (Show, Eq)
41
42wikilinksSpec :: (Monad m, IsInline il, HasWikilinks il)
43              => TitlePosition
44              -> SyntaxSpec m il bl
45wikilinksSpec titlepos = mempty
46  { syntaxInlineParsers = [ pWikilink ]
47  }
48  where
49   pWikilink = try $ do
50     symbol '['
51     symbol '['
52     notFollowedBy (symbol '[')
53     toks <- many (satisfyTok (not . hasType (Symbol ']')))
54     let isPipe (Tok (Symbol '|') _ _) = True
55         isPipe _ = False
56     let (title, url) =
57           case break isPipe toks of
58              (xs, [])   -> (untokenize xs, untokenize xs)
59              (xs, _:ys) ->
60                case titlepos of
61                  TitleBeforePipe -> (untokenize xs, untokenize ys)
62                  TitleAfterPipe  -> (untokenize ys, untokenize xs)
63     symbol ']'
64     symbol ']'
65     return $ wikilink (strip url) (str (strip title))
66