{-# 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:"