{-# 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
pHtmlTag :: Parser (HtmlTagType, Text)
pHtmlTag :: Parser (HtmlTagType, Text)
pHtmlTag = do
Char -> Parser Char
char '<'
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
<> ">")
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)
pHtmlComment :: Parser Text
= 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
<> "-->"
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
<> "]"
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
<> ")"
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
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)
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)
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))
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)
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
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
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
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)
schemes :: [Text]
schemes :: [Text]
schemes = [
"coap","doi","javascript"
,"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"
,"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" ]
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
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
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
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)
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)
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))
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))
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)
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'
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'
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 "]"))
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
-> Maybe (Text, Text)
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
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"
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
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
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)
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)