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