{-# 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.
  closing <- (Char -> Parser Char
char Char
'/' Parser Char -> Parser Bool -> Parser Bool
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  tagname <- takeWhile1 (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c 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
'!')
  let tagname' = Text -> Text
T.toLower Text
tagname
  let attr = do ss <- (Char -> Bool) -> Parser Text
takeWhile Char -> Bool
isSpace
                x <- satisfy isLetter
                xs <- takeWhile (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
                skip (=='=')
                v <- pQuoted '"' <|> pQuoted '\'' <|> takeWhile1 isAlphaNum
                      <|> return ""
                return $ ss <> T.singleton x <> xs <> "=" <> v
  attrs <- T.concat <$> many attr
  final <- takeWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
  char '>'
  let 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'
  return (tagtype,
          T.pack ('<' : ['/' | closing]) <> tagname <> attrs <> final <> ">")

-- Parses a quoted attribute value.
pQuoted :: Char -> Parser Text
pQuoted :: Char -> Parser Text
pQuoted Char
c = do
  (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  contents <- (Char -> Bool) -> Parser Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  skip (== c)
  return (T.singleton c <> contents <> T.singleton 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
"<!--"
  rest <- Parser Char -> Parser Text -> Parser [Char]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (Text -> Parser Text
string Text
"-->")
  return $ "<!--" <> T.pack rest <> "-->"

-- 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
'[' Parser Char -> Parser Text -> Parser Text
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (Parser Text -> Parser Char -> Parser [Text]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
bracketed Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
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 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
'\\')
        codeChunk :: Parser Text
codeChunk = (Inlines, Text) -> Text
forall a b. (a, b) -> b
snd ((Inlines, Text) -> Text) -> Parser (Inlines, Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Inlines, Text)
pCode'
        bracketed :: Parser Text
bracketed = Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
inBrackets (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkLabel
        inBrackets :: a -> a
inBrackets a
t = a
"[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
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
  inPointy <- (Char -> Parser Char
char Char
'<' Parser Char -> Parser Bool -> Parser Bool
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  if inPointy
     then T.pack <$> manyTill
           (pSatisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\r' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')) (char '>')
     else T.concat <$> many (regChunk <|> parenChunk)
    where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 ([Char] -> Char -> Bool
notInClass [Char]
" \n()\\") Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
          parenChunk :: Parser Text
parenChunk = Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
parenthesize (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
'(' Parser Char -> Parser [Text] -> Parser [Text]
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                         Parser Text -> Parser Char -> Parser [Text]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
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
"(" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
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
  c <- (Char -> Bool) -> Parser Char
satisfy (\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
'(')
  next <- peekChar
  case next of
       Maybe Char
Nothing                 -> Parser ()
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       Just Char
x
         | Char -> Bool
isWhitespace Char
x      -> Parser ()
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
         | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')'            -> Parser ()
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
         | Bool
otherwise           -> () -> Parser ()
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  let ender = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' then Char
')' else Char
c
  let pEnder = Char -> Parser Char
char Char
ender Parser Char -> Parser () -> Parser Char
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> Parser ()
forall a. Parser a -> Parser ()
nfb ((Char -> Bool) -> Parser ()
skip Char -> Bool
isAlphaNum)
  let regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
ender Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\') Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
  let nestedChunk = (\Text
x -> Char -> Text
T.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
ender)
                      (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkTitle
  T.concat <$> manyTill (regChunk <|> nestedChunk) 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
  lab <- Parser Text
pLinkLabel
  char ':'
  scanSpnl
  url <- pLinkUrl
  tit <- option T.empty $ scanSpnl >> pLinkTitle
  endOfInput
  return (lab, url, tit)

-- Parses an escaped character and returns a Text.
pEscaped :: Parser Text
pEscaped :: Parser Text
pEscaped = Char -> Text
T.singleton (Char -> Text) -> Parser Char -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\\') Parser () -> Parser Char -> Parser Char
forall a b. Parser a -> Parser b -> Parser b
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char -> Bool
p Char
c)
   Parser Char -> Parser Char -> Parser Char
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
'\\' Parser Char -> Parser Char -> Parser Char
forall a b. Parser a -> Parser b -> Parser b
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 Parser Inlines -> Text -> Either ParseError Inlines
forall a. Parser a -> Text -> Either ParseError a
parse ([Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap) Parser Inlines -> Parser () -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
endOfInput) Text
t of
       Left ParseError
e   -> [Char] -> Inlines
forall a. HasCallStack => [Char] -> a
error ([Char]
"parseInlines: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ParseError -> [Char]
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
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSpace
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'*' ReferenceMap
refmap  -- strong/emph
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ()
notAfter Char -> Bool
isAlphaNum Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'_' ReferenceMap
refmap)
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pCode
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pRawHtml
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pAutolink
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
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
  ss <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isWhitespace
  return $ singleton
         $ if T.any (=='\n') ss
              then if "  " `T.isPrefixOf` ss
                   then LineBreak
                   else SoftBreak
              else Space

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

pAsciiStr :: Parser Inlines
pAsciiStr :: Parser Inlines
pAsciiStr = do
  t <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAsciiAlphaNum
  mbc <- peekChar
  case mbc of
       Just Char
':' -> if Text
t Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet
                      then Text -> Parser Inlines
pUri Text
t
                      else Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t
       Maybe Char
_        -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
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
  c <- Parser Char
anyChar
  let ch = Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> (Char -> Inline) -> Char -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str (Text -> Inline) -> (Char -> Text) -> Char -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton
  if c == '\\'
     then ch <$> satisfy isEscapable
          <|> singleton LineBreak <$ satisfy (=='\n')
          <|> return (ch '\\')
     else return (ch 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 = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ [Text]
schemes [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Text -> Text) -> [Text] -> [Text]
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
':'
  x <- OpenParens
-> (OpenParens -> Char -> Maybe OpenParens) -> Parser Text
forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan (Int -> OpenParens
OpenParens Int
0) OpenParens -> Char -> Maybe OpenParens
uriScanner
  guard $ not $ T.null x
  let (rawuri, endingpunct) =
        case T.last x of
             Char
c | Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
".;?!:," :: String) ->
               (Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text
Text -> Text
T.init Text
x, Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)))
             Char
_ -> (Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x, Inlines
forall a. Monoid a => a
mempty)
  return $ autoLink rawuri <> 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
' '  = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner OpenParens
_ Char
'\n' = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner (OpenParens Int
n) Char
'(' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
uriScanner (OpenParens Int
n) Char
')'
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  | Bool
otherwise = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
'+' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
st Char
'/' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
_ Char
c | Char -> Bool
isSpace Char
c = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
_ = OpenParens -> Maybe OpenParens
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
  cs <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  (Str cs <|) <$> pSpace
   <|> case T.length 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 Inlines
forall a. Monoid a => a
mempty
            Int
1  -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap Inlines
forall a. Monoid a => a
mempty
            Int
_  -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
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 Inlines -> Bool
forall a. Seq a -> Bool
Seq.null Inlines
ils
                            then Inlines
forall a. Monoid a => a
mempty
                            else Inline -> Inlines
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
  contents <- [Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ( (Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
                             Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) Parser Text -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                  Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap Inlines
forall a. Monoid a => a
mempty) )
  (char c >> return (single Emph $ prefix <> contents))
    <|> return (singleton (Str (T.singleton c)) <> (prefix <> 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 (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]
  contents <- [Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text -> Parser ()
forall a. Parser a -> Parser ()
nfb Parser Text
ender Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
  (ender >> return (single Strong $ prefix <> contents))
    <|> return (singleton (Str $ T.pack [c,c]) <> (prefix <> 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
  contents <- [Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap))
  (string (T.pack [c,c]) >> (pOne c refmap (single Strong contents)))
   <|> (char c >> (pTwo c refmap (single Emph contents)))
   <|> return (singleton (Str $ T.pack [c,c,c]) <> contents)

-- Inline code span.
pCode :: Parser Inlines
pCode :: Parser Inlines
pCode = (Inlines, Text) -> Inlines
forall a b. (a, b) -> a
fst ((Inlines, Text) -> Inlines)
-> Parser (Inlines, Text) -> Parser Inlines
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
  ticks <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`')
  let end = Text -> Parser Text
string Text
ticks Parser Text -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char -> Parser ()
forall a. Parser a -> Parser ()
nfb (Char -> Parser Char
char Char
'`')
  let nonBacktickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'`')
  let backtickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`')
  contents <- T.concat <$> manyTill (nonBacktickSpan <|> backtickSpan) end
  return (singleton . Code . T.strip $ contents, ticks <> contents <> ticks)

pLink :: ReferenceMap -> Parser Inlines
pLink :: ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap = do
  lab <- Parser Text
pLinkLabel
  let lab' = ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
lab
  pInlineLink lab' <|> pReferenceLink refmap lab lab'
    -- fallback without backtracking if it's not a link:
    <|> return (singleton (Str "[") <> lab' <> singleton (Str "]"))

-- 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
  url <- Parser Text
pLinkUrl
  tit <- option "" $ scanSpnl *> pLinkTitle <* scanSpaces
  char ')'
  return $ singleton $ Link lab url tit

lookupLinkReference :: ReferenceMap
                    -> Text                -- reference label
                    -> Maybe (Text, Text)  -- (url, title)
lookupLinkReference :: ReferenceMap -> Text -> Maybe (Text, Text)
lookupLinkReference ReferenceMap
refmap Text
key = Text -> ReferenceMap -> Maybe (Text, Text)
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
  ref <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
rawlab (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl Parser () -> Parser Text -> Parser Text
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkLabel
  let ref' = if Text -> Bool
T.null Text
ref then Text
rawlab else Text
ref
  case lookupLinkReference refmap ref' of
       Just (Text
url,Text
tit)  -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link Inlines
lab Text
url Text
tit
       Maybe (Text, Text)
Nothing         -> [Char] -> Parser Inlines
forall a. [Char] -> Parser a
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 (Inlines -> Inlines) -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap) Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!"))

linkToImage :: Inlines -> Inlines
linkToImage :: Inlines -> Inlines
linkToImage Inlines
ils =
  case Inlines -> ViewL Inline
forall a. Seq a -> ViewL a
viewl Inlines
ils of
        (Link Inlines
lab Text
url Text
tit :< Inlines
x)
          | Inlines -> Bool
forall a. Seq a -> Bool
Seq.null Inlines
x -> Inline -> Inlines
forall a. a -> Seq a
singleton (Inlines -> Text -> Text -> Inline
Image Inlines
lab Text
url Text
tit)
        ViewL Inline
_ -> Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!") Inlines -> Inlines -> Inlines
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
'&'
  res <- Parser Text
pCharEntity Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pDecEntity Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pHexEntity
  char ';'
  return $ singleton $ Entity $ "&" <> res <> ";"

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
'#'
  res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
  return $ "#" <> res

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

-- Raw HTML tag or comment.
pRawHtml :: Parser Inlines
pRawHtml :: Parser Inlines
pRawHtml = Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> (Text -> Inline) -> Text -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
RawHtml (Text -> Inlines) -> Parser Text -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((HtmlTagType, Text) -> Text
forall a b. (a, b) -> b
snd ((HtmlTagType, Text) -> Text)
-> Parser (HtmlTagType, Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (HtmlTagType, Text)
pHtmlTag Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'<')
  s <- (Char -> Bool) -> Parser Text
takeWhile1 (\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
'@')
  rest <- takeWhile1 (\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
' ')
  skip (=='>')
  case True of
       Bool
_ | Text
"@" Text -> Text -> Bool
`T.isPrefixOf` Text
rest -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
emailLink (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest)
         | Text
s Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
autoLink (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest)
         | Bool
otherwise   -> [Char] -> Parser Inlines
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unknown contents of <>"

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