{-# 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
'/' 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
  Text
tagname <- (Char -> Bool) -> Parser Text
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
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
                (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=')
                Text
v <- Char -> Parser Text
pQuoted 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
<|> Char -> Parser Text
pQuoted 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
<|> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAlphaNum
                      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
<|> Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
                Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
ss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v
  Text
attrs <- [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 [Text]
forall a. Parser a -> Parser [a]
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 Char -> Char -> Bool
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'
  (HtmlTagType, Text) -> Parser (HtmlTagType, Text)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (HtmlTagType
tagtype,
          [Char] -> Text
T.pack (Char
'<' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char
'/' | Bool
closing]) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
final Text -> Text -> Text
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  Text
contents <- (Char -> Bool) -> Parser Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Text
T.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contents Text -> Text -> Text
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 <- 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
"-->")
  Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
"<!--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
rest Text -> Text -> Text
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
'[' 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
  Bool
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 Bool
inPointy
     then [Char] -> Text
T.pack ([Char] -> Text) -> Parser [Char] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser Char -> Parser [Char]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill
           ((Char -> Bool) -> Parser Char
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 -> Parser Char
char Char
'>')
     else [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 [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (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)
    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
  Char
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
'(')
  Maybe Char
next <- Parser (Maybe Char)
peekChar
  case Maybe Char
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 :: Char
ender = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' then Char
')' else Char
c
  let pEnder :: Parser Char
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 :: Parser Text
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 :: Parser Text
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
  [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
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 <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
T.empty (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
pLinkTitle
  Parser ()
endOfInput
  (Text, Text, Text) -> Parser (Text, Text, Text)
forall a. a -> Parser a
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 (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
  Text
ss <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isWhitespace
  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
$ if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
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 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
  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 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
  Char
c <- Parser Char
anyChar
  let ch :: Char -> Inlines
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 Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
     then Char -> Inlines
ch (Char -> Inlines) -> Parser Char -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable
          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
LineBreak Inlines -> Parser Char -> Parser Inlines
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Parser Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')
          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 (Char -> Inlines
ch Char
'\\')
     else Inlines -> Parser Inlines
forall a. a -> Parser a
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 = [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
':'
  Text
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
  Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
x
  let (Text
rawuri, Inlines
endingpunct) =
        case HasCallStack => Text -> Char
Text -> Char
T.last Text
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)
  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
rawuri Inlines -> Inlines -> Inlines
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
' '  = 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
  Text
cs <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
  (Text -> Inline
Str Text
cs Inline -> Inlines -> Inlines
forall a. a -> Seq a -> Seq a
<|) (Inlines -> Inlines) -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
<|> 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 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
  Inlines
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 -> Parser Char
char Char
c Parser Char -> 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
>> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines
prefix Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
    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 (Char -> Text
T.singleton Char
c)) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix Inlines -> Inlines -> Inlines
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 (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]
  Inlines
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)
  (Parser Text
ender Parser Text -> 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
>> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines
prefix Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
    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 -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix Inlines -> Inlines -> Inlines
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 <- [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))
  (Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) Parser Text -> 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
pOne Char
c ReferenceMap
refmap ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong Inlines
contents)))
   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 -> Parser Char
char Char
c Parser Char -> 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 -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph Inlines
contents)))
   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 -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c,Char
c]) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
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
  Text
ticks <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`')
  let end :: Parser ()
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 :: Parser Text
nonBacktickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'`')
  let backtickSpan :: Parser Text
backtickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`')
  Text
contents <- [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 () -> Parser [Text]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
nonBacktickSpan 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
backtickSpan) Parser ()
end
  (Inlines, Text) -> Parser (Inlines, Text)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (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
Code (Text -> Inline) -> (Text -> Text) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Text
contents, Text
ticks Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contents Text -> Text -> Text
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' 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 -> Text -> Inlines -> Parser Inlines
pReferenceLink ReferenceMap
refmap Text
lab Inlines
lab'
    -- fallback without backtracking if it's not a link:
    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
"[") Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
lab' Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inline -> Inlines
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 <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
"" (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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pLinkTitle Parser Text -> Parser () -> Parser Text
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scanSpaces
  Char -> Parser Char
char 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
$ 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 = 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
  Text
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' :: 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)  -> 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
'&'
  Text
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 -> Parser Char
char 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
Entity (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ Text
"&" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
res Text -> Text -> Text
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
  Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> 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' 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'
  Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isHexDigit
  Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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
'<')
  Text
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
'@')
  Text
rest <- (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
' ')
  (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'>')
  case Bool
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)