{-# LANGUAGE OverloadedStrings #-}
module Cheapskate.Inlines (
        parseInlines
      , pHtmlTag
      , pReference
      , pLinkLabel)
where
import Cheapskate.ParserCombinators
import Cheapskate.Util
import Cheapskate.Types
import Data.Char hiding (Space)
import qualified Data.Sequence as Seq
import Data.Sequence (singleton, (<|), viewl, ViewL(..))
import Prelude hiding (takeWhile)
import Control.Applicative
import Data.Monoid
import Control.Monad
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Set as Set

-- Returns tag type and whole tag.
pHtmlTag :: Parser (HtmlTagType, Text)
pHtmlTag :: Parser (HtmlTagType, Text)
pHtmlTag = do
  Char -> Parser Char
char Char
'<'
  -- do not end the tag with a > character in a quoted attribute.
  Bool
closing <- (Char -> Parser Char
char Char
'/' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  Text
tagname <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c 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
'!')
  let tagname' :: Text
tagname' = Text -> Text
T.toLower Text
tagname
  let attr :: Parser Text
attr = do Text
ss <- (Char -> Bool) -> Parser Text
takeWhile Char -> Bool
isSpace
                Char
x <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isLetter
                Text
xs <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
':')
                (Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'=')
                Text
v <- Char -> Parser Text
pQuoted Char
'"' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text
pQuoted Char
'\'' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAlphaNum
                      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
ss forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x forall a. Semigroup a => a -> a -> a
<> Text
xs forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
v
  Text
attrs <- [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
attr
  Text
final <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'/')
  Char -> Parser Char
char Char
'>'
  let tagtype :: HtmlTagType
tagtype = if Bool
closing
                   then Text -> HtmlTagType
Closing Text
tagname'
                   else case Text -> Text -> Maybe Text
T.stripSuffix Text
"/" Text
final of
                         Just Text
_  -> Text -> HtmlTagType
SelfClosing Text
tagname'
                         Maybe Text
Nothing -> Text -> HtmlTagType
Opening Text
tagname'
  forall (m :: * -> *) a. Monad m => a -> m a
return (HtmlTagType
tagtype,
          [Char] -> Text
T.pack (Char
'<' forall a. a -> [a] -> [a]
: [Char
'/' | Bool
closing]) forall a. Semigroup a => a -> a -> a
<> Text
tagname forall a. Semigroup a => a -> a -> a
<> Text
attrs forall a. Semigroup a => a -> a -> a
<> Text
final forall a. Semigroup a => a -> a -> a
<> Text
">")

-- Parses a quoted attribute value.
pQuoted :: Char -> Parser Text
pQuoted :: Char -> Parser Text
pQuoted Char
c = do
  (Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
c)
  Text
contents <- (Char -> Bool) -> Parser Text
takeTill (forall a. Eq a => a -> a -> Bool
== Char
c)
  (Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
c)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Text
T.singleton Char
c forall a. Semigroup a => a -> a -> a
<> Text
contents forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
c)

-- Parses an HTML comment. This isn't really correct to spec, but should
-- do for now.
pHtmlComment :: Parser Text
pHtmlComment :: Parser Text
pHtmlComment = do
  Text -> Parser Text
string Text
"<!--"
  [Char]
rest <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (Text -> Parser Text
string Text
"-->")
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"<!--" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
rest forall a. Semigroup a => a -> a -> a
<> Text
"-->"

-- A link label [like this].  Note the precedence:  code backticks have
-- precedence over label bracket markers, which have precedence over
-- *, _, and other inline formatting markers.
-- So, 2 below contains a link while 1 does not:
-- 1. [a link `with a ](/url)` character
-- 2. [a link *with emphasized ](/url) text*
pLinkLabel :: Parser Text
pLinkLabel :: Parser Text
pLinkLabel = Char -> Parser Char
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
bracketed forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
codeChunk) (Char -> Parser Char
char Char
']')))
  where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\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
'\\')
        codeChunk :: Parser Text
codeChunk = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Inlines, Text)
pCode'
        bracketed :: Parser Text
bracketed = forall {a}. (Semigroup a, IsString a) => a -> a
inBrackets forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkLabel
        inBrackets :: a -> a
inBrackets a
t = a
"[" forall a. Semigroup a => a -> a -> a
<> a
t forall a. Semigroup a => a -> a -> a
<> a
"]"

-- A URL in a link or reference.  This may optionally be contained
-- in `<..>`; otherwise whitespace and unbalanced right parentheses
-- aren't allowed.  Newlines aren't allowed in any case.
pLinkUrl :: Parser Text
pLinkUrl :: Parser Text
pLinkUrl = do
  Bool
inPointy <- (Char -> Parser Char
char Char
'<' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  if Bool
inPointy
     then [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill
           ((Char -> Bool) -> Parser Char
pSatisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/=Char
'\r' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/=Char
'\n')) (Char -> Parser Char
char Char
'>')
     else [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk)
    where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 ([Char] -> Char -> Bool
notInClass [Char]
" \n()\\") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
          parenChunk :: Parser Text
parenChunk = forall {a}. (Semigroup a, IsString a) => a -> a
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                         forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk) (Char -> Parser Char
char Char
')'))
          parenthesize :: a -> a
parenthesize a
x = a
"(" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
")"

-- A link title, single or double quoted or in parentheses.
-- Note that Markdown.pl doesn't allow the parenthesized form in
-- inline links -- only in references -- but this restriction seems
-- arbitrary, so we remove it here.
pLinkTitle :: Parser Text
pLinkTitle :: Parser Text
pLinkTitle = do
  Char
c <- (Char -> Bool) -> Parser Char
satisfy (\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
'(')
  Maybe Char
next <- Parser (Maybe Char)
peekChar
  case Maybe Char
next of
       Maybe Char
Nothing                 -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
       Just Char
x
         | Char -> Bool
isWhitespace Char
x      -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
         | Char
x forall a. Eq a => a -> a -> Bool
== Char
')'            -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
         | Bool
otherwise           -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  let ender :: Char
ender = if Char
c forall a. Eq a => a -> a -> Bool
== Char
'(' then Char
')' else Char
c
  let pEnder :: Parser Char
pEnder = Char -> Parser Char
char Char
ender forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser a -> Parser ()
nfb ((Char -> Bool) -> Parser ()
skip Char -> Bool
isAlphaNum)
  let regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
x -> Char
x forall a. Eq a => a -> a -> Bool
/= Char
ender Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\\') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
  let nestedChunk :: Parser Text
nestedChunk = (\Text
x -> Char -> Text
T.singleton Char
c forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
ender)
                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkTitle
  [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
nestedChunk) Parser Char
pEnder

-- A link reference is a square-bracketed link label, a colon,
-- optional space or newline, a URL, optional space or newline,
-- and an optional link title.  (Note:  we assume the input is
-- pre-stripped, with no leading/trailing spaces.)
pReference :: Parser (Text, Text, Text)
pReference :: Parser (Text, Text, Text)
pReference = do
  Text
lab <- Parser Text
pLinkLabel
  Char -> Parser Char
char Char
':'
  Parser ()
scanSpnl
  Text
url <- Parser Text
pLinkUrl
  Text
tit <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
T.empty forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkTitle
  Parser ()
endOfInput
  forall (m :: * -> *) a. Monad m => a -> m a
return (Text
lab, Text
url, Text
tit)

-- Parses an escaped character and returns a Text.
pEscaped :: Parser Text
pEscaped :: Parser Text
pEscaped = Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'\\') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable)

-- Parses a (possibly escaped) character satisfying the predicate.
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy Char -> Bool
p =
  (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char -> Bool
p Char
c)
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char -> Bool
isEscapable Char
c Bool -> Bool -> Bool
&& Char -> Bool
p Char
c))

-- Parse a text into inlines, resolving reference links
-- using the reference map.
parseInlines :: ReferenceMap -> Text -> Inlines
parseInlines :: ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
t =
  case forall a. Parser a -> Text -> Either ParseError a
parse (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
endOfInput) Text
t of
       Left ParseError
e   -> forall a. HasCallStack => [Char] -> a
error ([Char]
"parseInlines: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParseError
e) -- should not happen
       Right Inlines
r  -> Inlines
r

pInline :: ReferenceMap -> Parser Inlines
pInline :: ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap =
           Parser Inlines
pAsciiStr
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSpace
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'*' ReferenceMap
refmap  -- strong/emph
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ()
notAfter Char -> Bool
isAlphaNum forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'_' ReferenceMap
refmap)
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pCode
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pRawHtml
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pAutolink
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
       forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSym

-- Parse spaces or newlines, and determine whether
-- we have a regular space, a line break (two spaces before
-- a newline), or a soft break (newline without two spaces
-- before).
pSpace :: Parser Inlines
pSpace :: Parser Inlines
pSpace = do
  Text
ss <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isWhitespace
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton
         forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
==Char
'\n') Text
ss
              then if Text
"  " Text -> Text -> Bool
`T.isPrefixOf` Text
ss
                   then Inline
LineBreak
                   else Inline
SoftBreak
              else Inline
Space

isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum Char
c =
  (Char
c forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z') Bool -> Bool -> Bool
||
  (Char
c forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
||
  (Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9')

pAsciiStr :: Parser Inlines
pAsciiStr :: Parser Inlines
pAsciiStr = do
  Text
t <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAsciiAlphaNum
  Maybe Char
mbc <- Parser (Maybe Char)
peekChar
  case Maybe Char
mbc of
       Just Char
':' -> if Text
t forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet
                      then Text -> Parser Inlines
pUri Text
t
                      else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t
       Maybe Char
_        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t

-- Catch all -- parse an escaped character, an escaped
-- newline, or any remaining symbol character.
pSym :: Parser Inlines
pSym :: Parser Inlines
pSym = do
  Char
c <- Parser Char
anyChar
  let ch :: Char -> Inlines
ch = forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton
  if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\'
     then Char -> Inlines
ch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Seq a
singleton Inline
LineBreak forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Parser Char
satisfy (forall a. Eq a => a -> a -> Bool
==Char
'\n')
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Inlines
ch Char
'\\')
     else forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Inlines
ch Char
c)

-- http://www.iana.org/assignments/uri-schemes.html plus
-- the unofficial schemes coap, doi, javascript.
schemes :: [Text]
schemes :: [Text]
schemes = [ -- unofficial
            Text
"coap",Text
"doi",Text
"javascript"
           -- official
           ,Text
"aaa",Text
"aaas",Text
"about",Text
"acap"
           ,Text
"cap",Text
"cid",Text
"crid",Text
"data",Text
"dav",Text
"dict",Text
"dns",Text
"file",Text
"ftp"
           ,Text
"geo",Text
"go",Text
"gopher",Text
"h323",Text
"http",Text
"https",Text
"iax",Text
"icap",Text
"im"
           ,Text
"imap",Text
"info",Text
"ipp",Text
"iris",Text
"iris.beep",Text
"iris.xpc",Text
"iris.xpcs"
           ,Text
"iris.lwz",Text
"ldap",Text
"mailto",Text
"mid",Text
"msrp",Text
"msrps",Text
"mtqp"
           ,Text
"mupdate",Text
"news",Text
"nfs",Text
"ni",Text
"nih",Text
"nntp",Text
"opaquelocktoken",Text
"pop"
           ,Text
"pres",Text
"rtsp",Text
"service",Text
"session",Text
"shttp",Text
"sieve",Text
"sip",Text
"sips"
           ,Text
"sms",Text
"snmp",Text
"soap.beep",Text
"soap.beeps",Text
"tag",Text
"tel",Text
"telnet",Text
"tftp"
           ,Text
"thismessage",Text
"tn3270",Text
"tip",Text
"tv",Text
"urn",Text
"vemmi",Text
"ws",Text
"wss"
           ,Text
"xcon",Text
"xcon-userid",Text
"xmlrpc.beep",Text
"xmlrpc.beeps",Text
"xmpp",Text
"z39.50r"
           ,Text
"z39.50s"
           -- provisional
           ,Text
"adiumxtra",Text
"afp",Text
"afs",Text
"aim",Text
"apt",Text
"attachment",Text
"aw"
           ,Text
"beshare",Text
"bitcoin",Text
"bolo",Text
"callto",Text
"chrome",Text
"chrome-extension"
           ,Text
"com-eventbrite-attendee",Text
"content",Text
"cvs",Text
"dlna-playsingle"
           ,Text
"dlna-playcontainer",Text
"dtn",Text
"dvb",Text
"ed2k",Text
"facetime",Text
"feed"
           ,Text
"finger",Text
"fish",Text
"gg",Text
"git",Text
"gizmoproject",Text
"gtalk"
           ,Text
"hcp",Text
"icon",Text
"ipn",Text
"irc",Text
"irc6",Text
"ircs",Text
"itms",Text
"jar"
           ,Text
"jms",Text
"keyparc",Text
"lastfm",Text
"ldaps",Text
"magnet",Text
"maps",Text
"market"
           ,Text
"message",Text
"mms",Text
"ms-help",Text
"msnim",Text
"mumble",Text
"mvn",Text
"notes"
           ,Text
"oid",Text
"palm",Text
"paparazzi",Text
"platform",Text
"proxy",Text
"psyc",Text
"query"
           ,Text
"res",Text
"resource",Text
"rmi",Text
"rsync",Text
"rtmp",Text
"secondlife",Text
"sftp"
           ,Text
"sgn",Text
"skype",Text
"smb",Text
"soldat",Text
"spotify",Text
"ssh",Text
"steam",Text
"svn"
           ,Text
"teamspeak",Text
"things",Text
"udp",Text
"unreal",Text
"ut2004",Text
"ventrilo"
           ,Text
"view-source",Text
"webcal",Text
"wtai",Text
"wyciwyg",Text
"xfire",Text
"xri"
           ,Text
"ymsgr" ]

-- Make them a set for more efficient lookup.
schemeSet :: Set.Set Text
schemeSet :: Set Text
schemeSet = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ [Text]
schemes forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toUpper [Text]
schemes

-- Parse a URI, using heuristics to avoid capturing final punctuation.
pUri :: Text -> Parser Inlines
pUri :: Text -> Parser Inlines
pUri Text
scheme = do
  Char -> Parser Char
char Char
':'
  Text
x <- forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan (Int -> OpenParens
OpenParens Int
0) OpenParens -> Char -> Maybe OpenParens
uriScanner
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
x
  let (Text
rawuri, Inlines
endingpunct) =
        case Text -> Char
T.last Text
x of
             Char
c | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
".;?!:," :: String) ->
               (Text
scheme forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.init Text
x, forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)))
             Char
_ -> (Text
scheme forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
x, forall a. Monoid a => a
mempty)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Inlines
autoLink Text
rawuri forall a. Semigroup a => a -> a -> a
<> Inlines
endingpunct

-- Scan non-ascii characters and ascii characters allowed in a URI.
-- We allow punctuation except when followed by a space, since
-- we don't want the trailing '.' in 'http://google.com.'
-- We want to allow
-- http://en.wikipedia.org/wiki/State_of_emergency_(disambiguation)
-- as a URL, while NOT picking up the closing paren in
-- (http://wikipedia.org)
-- So we include balanced parens in the URL.

data OpenParens = OpenParens Int

uriScanner :: OpenParens -> Char -> Maybe OpenParens
uriScanner :: OpenParens -> Char -> Maybe OpenParens
uriScanner OpenParens
_ Char
' '  = forall a. Maybe a
Nothing
uriScanner OpenParens
_ Char
'\n' = forall a. Maybe a
Nothing
uriScanner (OpenParens Int
n) Char
'(' = forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n forall a. Num a => a -> a -> a
+ Int
1))
uriScanner (OpenParens Int
n) Char
')'
  | Int
n forall a. Ord a => a -> a -> Bool
> Int
0 = forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n forall a. Num a => a -> a -> a
- Int
1))
  | Bool
otherwise = forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
'+' = forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
st Char
'/' = forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
_ Char
c | Char -> Bool
isSpace Char
c = forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
_ = forall a. a -> Maybe a
Just OpenParens
st

-- Parses material enclosed in *s, **s, _s, or __s.
-- Designed to avoid backtracking.
pEnclosure :: Char -> ReferenceMap -> Parser Inlines
pEnclosure :: Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
c ReferenceMap
refmap = do
  Text
cs <- (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
== Char
c)
  (Text -> Inline
Str Text
cs forall a. a -> Seq a -> Seq a
<|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines
pSpace
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case Text -> Int
T.length Text
cs of
            Int
3  -> Char -> ReferenceMap -> Parser Inlines
pThree Char
c ReferenceMap
refmap
            Int
2  -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap forall a. Monoid a => a
mempty
            Int
1  -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap forall a. Monoid a => a
mempty
            Int
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
cs)

-- singleton sequence or empty if contents are empty
single :: (Inlines -> Inline) -> Inlines -> Inlines
single :: (Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
constructor Inlines
ils = if forall a. Seq a -> Bool
Seq.null Inlines
ils
                            then forall a. Monoid a => a
mempty
                            else forall a. a -> Seq a
singleton (Inlines -> Inline
constructor Inlines
ils)

-- parse inlines til you hit a c, and emit Emph.
-- if you never hit a c, emit '*' + inlines parsed.
pOne :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap Inlines
prefix = do
  Inlines
contents <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ( (Char -> Parser ()
nfbChar Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
                             forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                  Char -> Parser ()
nfbChar Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap forall a. Monoid a => a
mempty) )
  (Char -> Parser Char
char Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph forall a b. (a -> b) -> a -> b
$ Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)) forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))

-- parse inlines til you hit two c's, and emit Strong.
-- if you never do hit two c's, emit '**' plus + inlines parsed.
pTwo :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap Inlines
prefix = do
  let ender :: Parser Text
ender = Text -> Parser Text
string forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]
  Inlines
contents <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall a. Parser a -> Parser ()
nfb Parser Text
ender forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
  (Parser Text
ender forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong forall a b. (a -> b) -> a -> b
$ Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]) forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))

-- parse inlines til you hit one c or a sequence of two c's.
-- If one c, emit Emph and then parse pTwo.
-- if two c's, emit Strong and then parse pOne.
pThree :: Char -> ReferenceMap -> Parser Inlines
pThree :: Char -> ReferenceMap -> Parser Inlines
pThree Char
c ReferenceMap
refmap = do
  Inlines
contents <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser ()
nfbChar Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap))
  (Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong Inlines
contents)))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph Inlines
contents)))
   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c,Char
c]) forall a. Semigroup a => a -> a -> a
<> Inlines
contents)

-- Inline code span.
pCode :: Parser Inlines
pCode :: Parser Inlines
pCode = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Inlines, Text)
pCode'

-- this is factored out because it needed in pLinkLabel.
pCode' :: Parser (Inlines, Text)
pCode' :: Parser (Inlines, Text)
pCode' = do
  Text
ticks <- (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
== Char
'`')
  let end :: Parser ()
end = Text -> Parser Text
string Text
ticks forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Parser a -> Parser ()
nfb (Char -> Parser Char
char Char
'`')
  let nonBacktickSpan :: Parser Text
nonBacktickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'`')
  let backtickSpan :: Parser Text
backtickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
== Char
'`')
  Text
contents <- [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
nonBacktickSpan forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
backtickSpan) Parser ()
end
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Code forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ Text
contents, Text
ticks forall a. Semigroup a => a -> a -> a
<> Text
contents forall a. Semigroup a => a -> a -> a
<> Text
ticks)

pLink :: ReferenceMap -> Parser Inlines
pLink :: ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap = do
  Text
lab <- Parser Text
pLinkLabel
  let lab' :: Inlines
lab' = ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
lab
  Inlines -> Parser Inlines
pInlineLink Inlines
lab' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink ReferenceMap
refmap Text
lab Inlines
lab'
    -- fallback without backtracking if it's not a link:
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"[") forall a. Semigroup a => a -> a -> a
<> Inlines
lab' forall a. Semigroup a => a -> a -> a
<> forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"]"))

-- An inline link: [label](/url "optional title")
pInlineLink :: Inlines -> Parser Inlines
pInlineLink :: Inlines -> Parser Inlines
pInlineLink Inlines
lab = do
  Char -> Parser Char
char Char
'('
  Parser ()
scanSpaces
  Text
url <- Parser Text
pLinkUrl
  Text
tit <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
"" forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pLinkTitle forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scanSpaces
  Char -> Parser Char
char Char
')'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link Inlines
lab Text
url Text
tit

lookupLinkReference :: ReferenceMap
                    -> Text                -- reference label
                    -> Maybe (Text, Text)  -- (url, title)
lookupLinkReference :: ReferenceMap -> Text -> Maybe (Text, Text)
lookupLinkReference ReferenceMap
refmap Text
key = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Text
normalizeReference Text
key) ReferenceMap
refmap

-- A reference link: [label], [foo][label], or [label][].
pReferenceLink :: ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink :: ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink ReferenceMap
refmap Text
rawlab Inlines
lab = do
  Text
ref <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
rawlab forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkLabel
  let ref' :: Text
ref' = if Text -> Bool
T.null Text
ref then Text
rawlab else Text
ref
  case ReferenceMap -> Text -> Maybe (Text, Text)
lookupLinkReference ReferenceMap
refmap Text
ref' of
       Just (Text
url,Text
tit)  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link Inlines
lab Text
url Text
tit
       Maybe (Text, Text)
Nothing         -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Reference not found"

-- An image:  ! followed by a link.
pImage :: ReferenceMap -> Parser Inlines
pImage :: ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap = do
  Char -> Parser Char
char Char
'!'
  (Inlines -> Inlines
linkToImage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!"))

linkToImage :: Inlines -> Inlines
linkToImage :: Inlines -> Inlines
linkToImage Inlines
ils =
  case forall a. Seq a -> ViewL a
viewl Inlines
ils of
        (Link Inlines
lab Text
url Text
tit :< Inlines
x)
          | forall a. Seq a -> Bool
Seq.null Inlines
x -> forall a. a -> Seq a
singleton (Inlines -> Text -> Text -> Inline
Image Inlines
lab Text
url Text
tit)
        ViewL Inline
_ -> forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!") forall a. Semigroup a => a -> a -> a
<> Inlines
ils

-- An entity.  We store these in a special inline element.
-- This ensures that entities in the input come out as
-- entities in the output. Alternatively we could simply
-- convert them to characters and store them as Str inlines.
pEntity :: Parser Inlines
pEntity :: Parser Inlines
pEntity = do
  Char -> Parser Char
char Char
'&'
  Text
res <- Parser Text
pCharEntity forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pDecEntity forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pHexEntity
  Char -> Parser Char
char Char
';'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Entity forall a b. (a -> b) -> a -> b
$ Text
"&" forall a. Semigroup a => a -> a -> a
<> Text
res forall a. Semigroup a => a -> a -> a
<> Text
";"

pCharEntity :: Parser Text
pCharEntity :: Parser Text
pCharEntity = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLetter Char
c)

pDecEntity :: Parser Text
pDecEntity :: Parser Text
pDecEntity = do
  Char -> Parser Char
char Char
'#'
  Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
res

pHexEntity :: Parser Text
pHexEntity :: Parser Text
pHexEntity = do
  Char -> Parser Char
char Char
'#'
  Char
x <- Char -> Parser Char
char Char
'X' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'x'
  Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isHexDigit
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"#" forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x forall a. Semigroup a => a -> a -> a
<> Text
res

-- Raw HTML tag or comment.
pRawHtml :: Parser Inlines
pRawHtml :: Parser Inlines
pRawHtml = forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
RawHtml forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (HtmlTagType, Text)
pHtmlTag forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pHtmlComment)

-- A link like this: <http://whatever.com> or <me@mydomain.edu>.
-- Markdown.pl does email obfuscation; we don't bother with that here.
pAutolink :: Parser Inlines
pAutolink :: Parser Inlines
pAutolink = do
  (Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'<')
  Text
s <- (Char -> Bool) -> Parser Text
takeWhile1 (\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
'@')
  Text
rest <- (Char -> Bool) -> Parser Text
takeWhile1 (\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
' ')
  (Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'>')
  case Bool
True of
       Bool
_ | Text
"@" Text -> Text -> Bool
`T.isPrefixOf` Text
rest -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Inlines
emailLink (Text
s forall a. Semigroup a => a -> a -> a
<> Text
rest)
         | Text
s forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Inlines
autoLink (Text
s forall a. Semigroup a => a -> a -> a
<> Text
rest)
         | Bool
otherwise   -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unknown contents of <>"

autoLink :: Text -> Inlines
autoLink :: Text -> Inlines
autoLink Text
t = forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link (Text -> Inlines
toInlines Text
t) Text
t (Text
T.empty)
  where toInlines :: Text -> Inlines
toInlines Text
t' = case forall a. Parser a -> Text -> Either ParseError a
parse Parser Inlines
pToInlines Text
t' of
                         Right Inlines
r   -> Inlines
r
                         Left ParseError
e    -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"autolink: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParseError
e
        pToInlines :: Parser Inlines
pToInlines = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Inlines
strOrEntity
        strOrEntity :: Parser Inlines
strOrEntity = ((forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
/=Char
'&'))
                   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
                   forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text
string Text
"&")

emailLink :: Text -> Inlines
emailLink :: Text -> Inlines
emailLink Text
t = forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link (forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t)
                               (Text
"mailto:" forall a. Semigroup a => a -> a -> a
<> Text
t) (Text
T.empty)