{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Commonmark.Extensions.Autolink
  ( autolinkSpec )
where
import Commonmark.Types
import Commonmark.Tokens
import Commonmark.Syntax
import Commonmark.Inlines
import Commonmark.TokParsers
import Control.Monad (guard, void)
import Text.Parsec
import Data.Text (Text)

autolinkSpec :: (Monad m, IsBlock il bl, IsInline il)
             => SyntaxSpec m il bl
autolinkSpec :: SyntaxSpec m il bl
autolinkSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxInlineParsers :: [InlineParser m il]
syntaxInlineParsers = [InlineParser m il
forall (m :: * -> *) a. (Monad m, IsInline a) => InlineParser m a
parseAutolink]
  }

parseAutolink :: (Monad m, IsInline a) => InlineParser m a
parseAutolink :: InlineParser m a
parseAutolink = do
  ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) ())
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok)
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall a b. (a -> b) -> a -> b
$ (Tok -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok ((Tok -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok)
-> (Tok -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall a b. (a -> b) -> a -> b
$ \Tok
t ->
    case Tok -> TokType
tokType Tok
t of
      TokType
WordChars -> Bool
True
      Symbol Char
c  -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
      TokType
_         -> Bool
False
  (Text
prefix, [Tok]
linktext) <- ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) (Text, [Tok])
forall (m :: * -> *) s a.
Monad m =>
ParsecT [Tok] s m a -> ParsecT [Tok] s m (a, [Tok])
withRaw (ParsecT [Tok] (IPState m) (StateT Enders m) Text
 -> ParsecT [Tok] (IPState m) (StateT Enders m) (Text, [Tok]))
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) (Text, [Tok])
forall a b. (a -> b) -> a -> b
$ ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall (m :: * -> *). Monad m => InlineParser m Text
wwwAutolink ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall (m :: * -> *). Monad m => InlineParser m Text
urlAutolink ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall (m :: * -> *). Monad m => InlineParser m Text
emailAutolink
  a -> InlineParser m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> InlineParser m a) -> a -> InlineParser m a
forall a b. (a -> b) -> a -> b
$! Text -> Text -> a -> a
forall a. IsInline a => Text -> Text -> a -> a
link (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Tok] -> Text
untokenize [Tok]
linktext) Text
"" (Text -> a
forall a. IsInline a => Text -> a
str (Text -> a) -> ([Tok] -> Text) -> [Tok] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tok] -> Text
untokenize ([Tok] -> a) -> [Tok] -> a
forall a b. (a -> b) -> a -> b
$ [Tok]
linktext)

wwwAutolink :: Monad m => InlineParser m Text
wwwAutolink :: InlineParser m Text
wwwAutolink = InlineParser m Text -> InlineParser m Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (InlineParser m Text -> InlineParser m Text)
-> InlineParser m Text -> InlineParser m Text
forall a b. (a -> b) -> a -> b
$ do
  ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok)
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"www")
  InlineParser m ()
forall (m :: * -> *). Monad m => InlineParser m ()
validDomain
  InlineParser m ()
forall (m :: * -> *). Monad m => InlineParser m ()
linkSuffix
  Text -> InlineParser m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"http://"

validDomain :: Monad m => InlineParser m ()
validDomain :: InlineParser m ()
validDomain = do
  let domainPart :: ParsecT [Tok] u (StateT Enders m) ()
domainPart = do
        [Tok]
ds <- ParsecT [Tok] u (StateT Enders m) Tok
-> ParsecT [Tok] u (StateT Enders m) [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Tok] u (StateT Enders m) Tok
 -> ParsecT [Tok] u (StateT Enders m) [Tok])
-> ParsecT [Tok] u (StateT Enders m) Tok
-> ParsecT [Tok] u (StateT Enders m) [Tok]
forall a b. (a -> b) -> a -> b
$ (Tok -> Bool) -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (TokType -> Tok -> Bool
hasType TokType
WordChars)
                           ParsecT [Tok] u (StateT Enders m) Tok
-> 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 -> ParsecT s u m a
<|> 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) Tok
-> ParsecT [Tok] u (StateT Enders m) Tok
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT [Tok] u (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'_'
        Bool -> ParsecT [Tok] u (StateT Enders m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT [Tok] u (StateT Enders m) ())
-> Bool -> ParsecT [Tok] u (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ case [Tok] -> [Tok]
forall a. [a] -> [a]
reverse [Tok]
ds of
                     (Tok TokType
WordChars SourcePos
_ Text
_ : [Tok]
_) -> Bool
True
                     [Tok]
_ -> Bool
False
  InlineParser m ()
forall u. ParsecT [Tok] u (StateT Enders m) ()
domainPart
  InlineParser m () -> InlineParser m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 (InlineParser m () -> InlineParser m ())
-> InlineParser m () -> InlineParser m ()
forall a b. (a -> b) -> a -> b
$ InlineParser m () -> InlineParser m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'.' ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> InlineParser m () -> InlineParser m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InlineParser m ()
forall u. ParsecT [Tok] u (StateT Enders m) ()
domainPart)

linkSuffix :: Monad m => InlineParser m ()
linkSuffix :: InlineParser m ()
linkSuffix = InlineParser m () -> InlineParser m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (InlineParser m () -> InlineParser m ())
-> InlineParser m () -> InlineParser m ()
forall a b. (a -> b) -> a -> b
$ do
  [Tok]
toks <- ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  let possibleSuffixTok :: Tok -> Bool
possibleSuffixTok (Tok (Symbol Char
c) SourcePos
_ Text
_) =
        Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'<',Char
'>',Char
'{',Char
'}',Char
'|',Char
'\\',Char
'^',Char
'[',Char
']',Char
'`']
      possibleSuffixTok (Tok TokType
WordChars SourcePos
_ Text
_) = Bool
True
      possibleSuffixTok Tok
_ = Bool
False
  let isDroppable :: Tok -> Bool
isDroppable (Tok (Symbol Char
c) SourcePos
_ Text
_) =
         Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'?',Char
'!',Char
'.',Char
',',Char
':',Char
'*',Char
'_',Char
'~']
      isDroppable Tok
_ = Bool
False
  let numToks :: Int
numToks = case (Tok -> Bool) -> [Tok] -> [Tok]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Tok -> Bool
isDroppable ([Tok] -> [Tok]) -> [Tok] -> [Tok]
forall a b. (a -> b) -> a -> b
$
                    [Tok] -> [Tok]
forall a. [a] -> [a]
reverse ((Tok -> Bool) -> [Tok] -> [Tok]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Tok -> Bool
possibleSuffixTok [Tok]
toks) of
                     (Tok (Symbol Char
')') SourcePos
_ Text
_ : [Tok]
xs)
                       | [Tok] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok
t | t :: Tok
t@(Tok (Symbol Char
'(') SourcePos
_ Text
_) <- [Tok]
xs] Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=
                         [Tok] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok
t | t :: Tok
t@(Tok (Symbol Char
')') SourcePos
_ Text
_) <- [Tok]
xs]
                       -> [Tok] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
xs
                     (Tok (Symbol Char
';') SourcePos
_ Text
_
                        : Tok TokType
WordChars SourcePos
_ Text
_
                        : Tok (Symbol Char
'&') SourcePos
_ Text
_
                        : [Tok]
xs) -> [Tok] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
xs
                     [Tok]
xs -> [Tok] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
xs
  Int
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
numToks ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok
  () -> InlineParser m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

urlAutolink :: Monad m => InlineParser m Text
urlAutolink :: InlineParser m Text
urlAutolink = InlineParser m Text -> InlineParser m Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (InlineParser m Text -> InlineParser m Text)
-> InlineParser m Text -> InlineParser m Text
forall a b. (a -> b) -> a -> b
$ do
  (Text -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"http", Text
"https", Text
"ftp"])
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
':'
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'/'
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'/'
  InlineParser m ()
forall (m :: * -> *). Monad m => InlineParser m ()
validDomain
  InlineParser m ()
forall (m :: * -> *). Monad m => InlineParser m ()
linkSuffix
  Text -> InlineParser m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""

emailAutolink :: Monad m => InlineParser m Text
emailAutolink :: InlineParser m Text
emailAutolink = InlineParser m Text -> InlineParser m Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (InlineParser m Text -> InlineParser m Text)
-> InlineParser m Text -> InlineParser m Text
forall a b. (a -> b) -> a -> b
$ do
  let emailNameTok :: Tok -> Bool
emailNameTok (Tok TokType
WordChars SourcePos
_ Text
_) = Bool
True
      emailNameTok (Tok (Symbol Char
c) SourcePos
_ Text
_) =
         Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
      emailNameTok Tok
_ = Bool
False
  ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) ())
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ (Tok -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok Tok -> Bool
emailNameTok
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'@'
  ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall (m :: * -> *). Monad m => InlineParser m ()
validDomain
  Text -> InlineParser m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"mailto:"