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

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

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

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

linkSuffix :: Monad m => InlineParser m ()
linkSuffix :: forall (m :: * -> *). Monad m => InlineParser m ()
linkSuffix = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  [Tok]
toks <- 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 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 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 forall a. (a -> Bool) -> [a] -> [a]
dropWhile Tok -> Bool
isDroppable forall a b. (a -> b) -> a -> b
$
                    forall a. [a] -> [a]
reverse (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Tok -> Bool
possibleSuffixTok [Tok]
toks) of
                     (Tok (Symbol Char
')') SourcePos
_ Text
_ : [Tok]
xs)
                       | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok
t | t :: Tok
t@(Tok (Symbol Char
'(') SourcePos
_ Text
_) <- [Tok]
xs] forall a. Ord a => a -> a -> Bool
<=
                         forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok
t | t :: Tok
t@(Tok (Symbol Char
')') SourcePos
_ Text
_) <- [Tok]
xs]
                       -> 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) -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
xs
                     [Tok]
xs -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
xs
  forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
numToks forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

emailAutolink :: Monad m => InlineParser m Text
emailAutolink :: forall (m :: * -> *). Monad m => InlineParser m Text
emailAutolink = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try 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 forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'+'
      emailNameTok Tok
_ = Bool
False
  forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok Tok -> Bool
emailNameTok
  forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'@'
  forall (m :: * -> *). Monad m => InlineParser m ()
validDomain
  forall (m :: * -> *) a. Monad m => a -> m a
return Text
"mailto:"