{-# 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 '<'
  -- do not end the tag with a > character in a quoted attribute.
  Bool
closing <- (Char -> Parser Char
char '/' Parser Char -> Parser Bool -> Parser Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  Text
tagname <- (Char -> Bool) -> Parser Text
takeWhile1 (\c :: Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '?' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '!')
  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 (\c :: Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':')
                (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='=')
                Text
v <- Char -> Parser Text
pQuoted '"' Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text
pQuoted '\'' Parser Text -> Parser Text -> Parser Text
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return ""
                Text -> Parser Text
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
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 (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
attr
  Text
final <- (Char -> Bool) -> Parser Text
takeWhile (\c :: Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/')
  Char -> Parser Char
char '>'
  let tagtype :: HtmlTagType
tagtype = if Bool
closing
                   then Text -> HtmlTagType
Closing Text
tagname'
                   else case Text -> Text -> Maybe Text
T.stripSuffix "/" Text
final of
                         Just _  -> Text -> HtmlTagType
SelfClosing Text
tagname'
                         Nothing -> Text -> HtmlTagType
Opening Text
tagname'
  (HtmlTagType, Text) -> Parser (HtmlTagType, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (HtmlTagType
tagtype,
          String -> Text
T.pack ('<' Char -> String -> String
forall a. a -> [a] -> [a]
: ['/' | 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
<> ">")

-- Parses a quoted attribute value.
pQuoted :: Char -> Parser Text
pQuoted :: Char -> Parser Text
pQuoted c :: 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 (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 "<!--"
  String
rest <- Parser Char -> Parser Text -> Parser String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (Text -> Parser Text
string "-->")
  Text -> Parser Text
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
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
rest Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-->"

-- 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 '[' Parser Char -> Parser Text -> Parser Text
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
bracketed Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
codeChunk) (Char -> Parser Char
char ']')))
  where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='`' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='[' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=']' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='\\')
        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 t :: a
t = "[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup 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 '<' Parser Char -> Parser Bool -> Parser Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  if Bool
inPointy
     then String -> Text
T.pack (String -> Text) -> Parser String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser Char -> Parser String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill
           ((Char -> Bool) -> Parser Char
pSatisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='\r' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='\n')) (Char -> Parser 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 (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text
regChunk Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk)
    where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (String -> Char -> Bool
notInClass " \n()\\") Parser Text -> Parser Text -> Parser Text
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 '(' Parser Char -> Parser [Text] -> Parser [Text]
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk) (Char -> Parser Char
char ')'))
          parenthesize :: a -> a
parenthesize x :: a
x = "(" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup 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 (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '(')
  Maybe Char
next <- Parser (Maybe Char)
peekChar
  case Maybe Char
next of
       Nothing                 -> Parser ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       Just x :: Char
x
         | Char -> Bool
isWhitespace Char
x      -> Parser ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
         | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ')'            -> Parser ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
         | Bool
otherwise           -> () -> Parser ()
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
== '(' then ')' else Char
c
  let pEnder :: Parser Char
pEnder = Char -> Parser Char
char Char
ender Parser Char -> Parser () -> Parser Char
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 (\x :: 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
/= '\\') Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
  let nestedChunk :: Parser Text
nestedChunk = (\x :: 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 (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 ':'
  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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkTitle
  Parser ()
endOfInput
  (Text, Text, Text) -> Parser (Text, Text, Text)
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
=='\\') Parser () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable)

-- Parses a (possibly escaped) character satisfying the predicate.
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy p :: Char -> Bool
p =
  (Char -> Bool) -> Parser Char
satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\\' Bool -> Bool -> Bool
&& Char -> Bool
p Char
c)
   Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char '\\' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy (\c :: 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 refmap :: ReferenceMap
refmap t :: 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 (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap) Parser Inlines -> Parser () -> Parser Inlines
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
endOfInput) Text
t of
       Left e :: ParseError
e   -> String -> Inlines
forall a. HasCallStack => String -> a
error ("parseInlines: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
e) -- should not happen
       Right r :: Inlines
r  -> Inlines
r

pInline :: ReferenceMap -> Parser Inlines
pInline :: ReferenceMap -> Parser Inlines
pInline refmap :: ReferenceMap
refmap =
           Parser Inlines
pAsciiStr
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSpace
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReferenceMap -> Parser Inlines
pEnclosure '*' ReferenceMap
refmap  -- strong/emph
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ()
notAfter Char -> Bool
isAlphaNum Parser () -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReferenceMap -> Parser Inlines
pEnclosure '_' ReferenceMap
refmap)
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pCode
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pRawHtml
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pAutolink
       Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
       Parser Inlines -> Parser Inlines -> Parser Inlines
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 (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
=='\n') Text
ss
              then if "  " Text -> Text -> Bool
`T.isPrefixOf` Text
ss
                   then Inline
LineBreak
                   else Inline
SoftBreak
              else Inline
Space

isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum c :: Char
c =
  (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'z') Bool -> Bool -> Bool
||
  (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'Z') Bool -> Bool -> Bool
||
  (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '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 ':' -> 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 (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
       _        -> Inlines -> Parser Inlines
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
== '\\'
     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 (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 (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
=='\n')
          Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Inlines
ch '\\')
     else Inlines -> Parser Inlines
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
            "coap","doi","javascript"
           -- official
           ,"aaa","aaas","about","acap"
           ,"cap","cid","crid","data","dav","dict","dns","file","ftp"
           ,"geo","go","gopher","h323","http","https","iax","icap","im"
           ,"imap","info","ipp","iris","iris.beep","iris.xpc","iris.xpcs"
           ,"iris.lwz","ldap","mailto","mid","msrp","msrps","mtqp"
           ,"mupdate","news","nfs","ni","nih","nntp","opaquelocktoken","pop"
           ,"pres","rtsp","service","session","shttp","sieve","sip","sips"
           ,"sms","snmp","soap.beep","soap.beeps","tag","tel","telnet","tftp"
           ,"thismessage","tn3270","tip","tv","urn","vemmi","ws","wss"
           ,"xcon","xcon-userid","xmlrpc.beep","xmlrpc.beeps","xmpp","z39.50r"
           ,"z39.50s"
           -- provisional
           ,"adiumxtra","afp","afs","aim","apt","attachment","aw"
           ,"beshare","bitcoin","bolo","callto","chrome","chrome-extension"
           ,"com-eventbrite-attendee","content","cvs","dlna-playsingle"
           ,"dlna-playcontainer","dtn","dvb","ed2k","facetime","feed"
           ,"finger","fish","gg","git","gizmoproject","gtalk"
           ,"hcp","icon","ipn","irc","irc6","ircs","itms","jar"
           ,"jms","keyparc","lastfm","ldaps","magnet","maps","market"
           ,"message","mms","ms-help","msnim","mumble","mvn","notes"
           ,"oid","palm","paparazzi","platform","proxy","psyc","query"
           ,"res","resource","rmi","rsync","rtmp","secondlife","sftp"
           ,"sgn","skype","smb","soldat","spotify","ssh","steam","svn"
           ,"teamspeak","things","udp","unreal","ut2004","ventrilo"
           ,"view-source","webcal","wtai","wyciwyg","xfire","xri"
           ,"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 scheme :: Text
scheme = do
  Char -> Parser Char
char ':'
  Text
x <- OpenParens
-> (OpenParens -> Char -> Maybe OpenParens) -> Parser Text
forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan (Int -> OpenParens
OpenParens 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 (rawuri :: Text
rawuri, endingpunct :: Inlines
endingpunct) =
        case Text -> Char
T.last Text
x of
             c :: Char
c | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (".;?!:," :: String) ->
               (Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.init Text
x, Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)))
             _ -> (Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x, Inlines
forall a. Monoid a => a
mempty)
  Inlines -> Parser Inlines
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 _ ' '  = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner _ '\n' = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner (OpenParens n :: Int
n) '(' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1))
uriScanner (OpenParens n :: Int
n) ')'
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
- 1))
  | Bool
otherwise = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner st :: OpenParens
st '+' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just OpenParens
st
uriScanner st :: OpenParens
st '/' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just OpenParens
st
uriScanner _ c :: Char
c | Char -> Bool
isSpace Char
c = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner st :: OpenParens
st _ = 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 c :: Char
c refmap :: 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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case Text -> Int
T.length Text
cs of
            3  -> Char -> ReferenceMap -> Parser Inlines
pThree Char
c ReferenceMap
refmap
            2  -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap Inlines
forall a. Monoid a => a
mempty
            1  -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap Inlines
forall a. Monoid a => a
mempty
            _  -> Inlines -> Parser Inlines
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 constructor :: Inlines -> Inline
constructor ils :: 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 c :: Char
c refmap :: ReferenceMap
refmap prefix :: 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 (f :: * -> *) a. Alternative f => f a -> f [a]
many ( (Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text
string (String -> Text
T.pack [Char
c,Char
c]) Parser Text -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                  Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Inlines -> Parser Inlines
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
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 c :: Char
c refmap :: ReferenceMap
refmap prefix :: 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
$ String -> 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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Inlines -> Parser Inlines
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
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
$ String -> 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 c :: Char
c refmap :: 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 (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap))
  (Text -> Parser Text
string (String -> Text
T.pack [Char
c,Char
c]) Parser Text -> Parser Inlines -> Parser Inlines
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
c Parser Char -> Parser Inlines -> Parser Inlines
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
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
$ String -> 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
== '`')
  let end :: Parser ()
end = Text -> Parser Text
string Text
ticks Parser Text -> Parser () -> Parser ()
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 '`')
  let nonBacktickSpan :: Parser Text
nonBacktickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '`')
  let backtickSpan :: Parser Text
backtickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '`')
  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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
backtickSpan) Parser ()
end
  (Inlines, Text) -> Parser (Inlines, Text)
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 refmap :: 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 (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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str "[") 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 "]"))

-- An inline link: [label](/url "optional title")
pInlineLink :: Inlines -> Parser Inlines
pInlineLink :: Inlines -> Parser Inlines
pInlineLink lab :: Inlines
lab = do
  Char -> Parser 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 "" (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl Parser () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pLinkTitle Parser Text -> Parser () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scanSpaces
  Char -> Parser Char
char ')'
  Inlines -> Parser Inlines
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 refmap :: ReferenceMap
refmap key :: 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 refmap :: ReferenceMap
refmap rawlab :: Text
rawlab lab :: 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 (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 (url :: Text
url,tit :: Text
tit)  -> Inlines -> Parser Inlines
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
       Nothing         -> String -> Parser Inlines
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Reference not found"

-- An image:  ! followed by a link.
pImage :: ReferenceMap -> Parser Inlines
pImage :: ReferenceMap -> Parser Inlines
pImage refmap :: ReferenceMap
refmap = do
  Char -> Parser 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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str "!"))

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

pCharEntity :: Parser Text
pCharEntity :: Parser Text
pCharEntity = (Char -> Bool) -> Parser Text
takeWhile1 (\c :: 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 '#'
  Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
  Text -> Parser Text
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
forall a. Semigroup a => a -> a -> a
<> Text
res

pHexEntity :: Parser Text
pHexEntity :: Parser Text
pHexEntity = do
  Char -> Parser Char
char '#'
  Char
x <- Char -> Parser Char
char 'X' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char 'x'
  Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isHexDigit
  Text -> Parser Text
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
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 (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
=='<')
  Text
s <- (Char -> Bool) -> Parser Text
takeWhile1 (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ':' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '@')
  Text
rest <- (Char -> Bool) -> Parser Text
takeWhile1 (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='>' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ')
  (Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='>')
  case Bool
True of
       _ | "@" Text -> Text -> Bool
`T.isPrefixOf` Text
rest -> Inlines -> Parser Inlines
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 (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   -> String -> Parser Inlines
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unknown contents of <>"

autoLink :: Text -> Inlines
autoLink :: Text -> Inlines
autoLink t :: 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 t' :: 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 r :: Inlines
r   -> Inlines
r
                         Left e :: ParseError
e    -> String -> Inlines
forall a. HasCallStack => String -> a
error (String -> Inlines) -> String -> Inlines
forall a b. (a -> b) -> a -> b
$ "autolink: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
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 (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
/='&'))
                   Parser Inlines -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
                   Parser Inlines -> Parser Inlines -> Parser Inlines
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 "&")

emailLink :: Text -> Inlines
emailLink :: Text -> Inlines
emailLink t :: 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)
                               ("mailto:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t) (Text
T.empty)