{-# LANGUAGE CPP #-} {-# 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) #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif 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 $ \t :: Tok t -> case Tok -> TokType tokType Tok t of WordChars -> Bool True Symbol c :: Char c -> Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '.' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '-' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '_' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '+' _ -> Bool False (prefix :: Text prefix, linktext :: [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 -> 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 == "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 "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 '-' 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 '_' 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 WordChars _ _ : _) -> Bool True _ -> 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 '.' 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 c :: Char c) _ _) = Char c Char -> [Char] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `notElem` ['<','>','{','}','|','\\','^','[',']','`'] possibleSuffixTok (Tok WordChars _ _) = Bool True possibleSuffixTok _ = Bool False let isDroppable :: Tok -> Bool isDroppable (Tok (Symbol c :: Char c) _ _) = Char c Char -> [Char] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` ['?','!','.',',',':','*','_','~'] isDroppable _ = 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 ')') _ _ : xs :: [Tok] xs) | [Tok] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Tok t | t :: Tok t@(Tok (Symbol '(') _ _) <- [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 ')') _ _) <- [Tok] xs] -> [Tok] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Tok] xs (Tok (Symbol ';') _ _ : Tok WordChars _ _ : Tok (Symbol '&') _ _ : xs :: [Tok] xs) -> [Tok] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Tok] xs 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` ["http", "https", "ftp"]) 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 forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok symbol '/' Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok symbol '/' 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 "" 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 WordChars _ _) = Bool True emailNameTok (Tok (Symbol c :: Char c) _ _) = Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '.' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '-' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '_' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == '+' emailNameTok _ = 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 '@' 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 "mailto:"