{-# 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 Char
'<'
Bool
closing <- (Char -> Parser Char
char Char
'/' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Text
tagname <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'?' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'!')
let tagname' :: Text
tagname' = Text -> Text
T.toLower Text
tagname
let attr :: Parser Text
attr = do Text
ss <- (Char -> Bool) -> Parser Text
takeWhile Char -> Bool
isSpace
Char
x <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isLetter
Text
xs <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
':')
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'=')
Text
v <- Char -> Parser Text
pQuoted Char
'"' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text
pQuoted Char
'\'' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAlphaNum
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
ss forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x forall a. Semigroup a => a -> a -> a
<> Text
xs forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
v
Text
attrs <- [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
attr
Text
final <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'/')
Char -> Parser Char
char Char
'>'
let tagtype :: HtmlTagType
tagtype = if Bool
closing
then Text -> HtmlTagType
Closing Text
tagname'
else case Text -> Text -> Maybe Text
T.stripSuffix Text
"/" Text
final of
Just Text
_ -> Text -> HtmlTagType
SelfClosing Text
tagname'
Maybe Text
Nothing -> Text -> HtmlTagType
Opening Text
tagname'
forall (m :: * -> *) a. Monad m => a -> m a
return (HtmlTagType
tagtype,
[Char] -> Text
T.pack (Char
'<' forall a. a -> [a] -> [a]
: [Char
'/' | Bool
closing]) forall a. Semigroup a => a -> a -> a
<> Text
tagname forall a. Semigroup a => a -> a -> a
<> Text
attrs forall a. Semigroup a => a -> a -> a
<> Text
final forall a. Semigroup a => a -> a -> a
<> Text
">")
pQuoted :: Char -> Parser Text
pQuoted :: Char -> Parser Text
pQuoted Char
c = do
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
c)
Text
contents <- (Char -> Bool) -> Parser Text
takeTill (forall a. Eq a => a -> a -> Bool
== Char
c)
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
== Char
c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Text
T.singleton Char
c forall a. Semigroup a => a -> a -> a
<> Text
contents forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
c)
pHtmlComment :: Parser Text
= do
Text -> Parser Text
string Text
"<!--"
[Char]
rest <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (Text -> Parser Text
string Text
"-->")
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"<!--" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
rest forall a. Semigroup a => a -> a -> a
<> Text
"-->"
pLinkLabel :: Parser Text
pLinkLabel :: Parser Text
pLinkLabel = Char -> Parser Char
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
bracketed forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
codeChunk) (Char -> Parser Char
char Char
']')))
where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/=Char
'`' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/=Char
'[' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/=Char
']' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/=Char
'\\')
codeChunk :: Parser Text
codeChunk = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Inlines, Text)
pCode'
bracketed :: Parser Text
bracketed = forall {a}. (Semigroup a, IsString a) => a -> a
inBrackets forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkLabel
inBrackets :: a -> a
inBrackets a
t = a
"[" forall a. Semigroup a => a -> a -> a
<> a
t forall a. Semigroup a => a -> a -> a
<> a
"]"
pLinkUrl :: Parser Text
pLinkUrl :: Parser Text
pLinkUrl = do
Bool
inPointy <- (Char -> Parser Char
char Char
'<' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
if Bool
inPointy
then [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill
((Char -> Bool) -> Parser Char
pSatisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/=Char
'\r' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/=Char
'\n')) (Char -> Parser Char
char Char
'>')
else [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk)
where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 ([Char] -> Char -> Bool
notInClass [Char]
" \n()\\") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
parenChunk :: Parser Text
parenChunk = forall {a}. (Semigroup a, IsString a) => a -> a
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk) (Char -> Parser Char
char Char
')'))
parenthesize :: a -> a
parenthesize a
x = a
"(" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
")"
pLinkTitle :: Parser Text
pLinkTitle :: Parser Text
pLinkTitle = do
Char
c <- (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'(')
Maybe Char
next <- Parser (Maybe Char)
peekChar
case Maybe Char
next of
Maybe Char
Nothing -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
Just Char
x
| Char -> Bool
isWhitespace Char
x -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Char
x forall a. Eq a => a -> a -> Bool
== Char
')' -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
let ender :: Char
ender = if Char
c forall a. Eq a => a -> a -> Bool
== Char
'(' then Char
')' else Char
c
let pEnder :: Parser Char
pEnder = Char -> Parser Char
char Char
ender forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser a -> Parser ()
nfb ((Char -> Bool) -> Parser ()
skip Char -> Bool
isAlphaNum)
let regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
x -> Char
x forall a. Eq a => a -> a -> Bool
/= Char
ender Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\\') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
let nestedChunk :: Parser Text
nestedChunk = (\Text
x -> Char -> Text
T.singleton Char
c forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
ender)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkTitle
[Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
nestedChunk) Parser Char
pEnder
pReference :: Parser (Text, Text, Text)
pReference :: Parser (Text, Text, Text)
pReference = do
Text
lab <- Parser Text
pLinkLabel
Char -> Parser Char
char Char
':'
Parser ()
scanSpnl
Text
url <- Parser Text
pLinkUrl
Text
tit <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
T.empty forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkTitle
Parser ()
endOfInput
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
lab, Text
url, Text
tit)
pEscaped :: Parser Text
pEscaped :: Parser Text
pEscaped = Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'\\') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable)
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy Char -> Bool
p =
(Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char -> Bool
p Char
c)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char -> Bool
isEscapable Char
c Bool -> Bool -> Bool
&& Char -> Bool
p Char
c))
parseInlines :: ReferenceMap -> Text -> Inlines
parseInlines :: ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
t =
case forall a. Parser a -> Text -> Either ParseError a
parse (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
endOfInput) Text
t of
Left ParseError
e -> forall a. HasCallStack => [Char] -> a
error ([Char]
"parseInlines: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParseError
e)
Right Inlines
r -> Inlines
r
pInline :: ReferenceMap -> Parser Inlines
pInline :: ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap =
Parser Inlines
pAsciiStr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSpace
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'*' ReferenceMap
refmap
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ()
notAfter Char -> Bool
isAlphaNum forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'_' ReferenceMap
refmap)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pCode
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pRawHtml
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pAutolink
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSym
pSpace :: Parser Inlines
pSpace :: Parser Inlines
pSpace = do
Text
ss <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isWhitespace
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton
forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
==Char
'\n') Text
ss
then if Text
" " Text -> Text -> Bool
`T.isPrefixOf` Text
ss
then Inline
LineBreak
else Inline
SoftBreak
else Inline
Space
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum Char
c =
(Char
c forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z') Bool -> Bool -> Bool
||
(Char
c forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
||
(Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9')
pAsciiStr :: Parser Inlines
pAsciiStr :: Parser Inlines
pAsciiStr = do
Text
t <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAsciiAlphaNum
Maybe Char
mbc <- Parser (Maybe Char)
peekChar
case Maybe Char
mbc of
Just Char
':' -> if Text
t forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet
then Text -> Parser Inlines
pUri Text
t
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t
Maybe Char
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t
pSym :: Parser Inlines
pSym :: Parser Inlines
pSym = do
Char
c <- Parser Char
anyChar
let ch :: Char -> Inlines
ch = forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton
if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\'
then Char -> Inlines
ch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Seq a
singleton Inline
LineBreak forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Parser Char
satisfy (forall a. Eq a => a -> a -> Bool
==Char
'\n')
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Inlines
ch Char
'\\')
else forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Inlines
ch Char
c)
schemes :: [Text]
schemes :: [Text]
schemes = [
Text
"coap",Text
"doi",Text
"javascript"
,Text
"aaa",Text
"aaas",Text
"about",Text
"acap"
,Text
"cap",Text
"cid",Text
"crid",Text
"data",Text
"dav",Text
"dict",Text
"dns",Text
"file",Text
"ftp"
,Text
"geo",Text
"go",Text
"gopher",Text
"h323",Text
"http",Text
"https",Text
"iax",Text
"icap",Text
"im"
,Text
"imap",Text
"info",Text
"ipp",Text
"iris",Text
"iris.beep",Text
"iris.xpc",Text
"iris.xpcs"
,Text
"iris.lwz",Text
"ldap",Text
"mailto",Text
"mid",Text
"msrp",Text
"msrps",Text
"mtqp"
,Text
"mupdate",Text
"news",Text
"nfs",Text
"ni",Text
"nih",Text
"nntp",Text
"opaquelocktoken",Text
"pop"
,Text
"pres",Text
"rtsp",Text
"service",Text
"session",Text
"shttp",Text
"sieve",Text
"sip",Text
"sips"
,Text
"sms",Text
"snmp",Text
"soap.beep",Text
"soap.beeps",Text
"tag",Text
"tel",Text
"telnet",Text
"tftp"
,Text
"thismessage",Text
"tn3270",Text
"tip",Text
"tv",Text
"urn",Text
"vemmi",Text
"ws",Text
"wss"
,Text
"xcon",Text
"xcon-userid",Text
"xmlrpc.beep",Text
"xmlrpc.beeps",Text
"xmpp",Text
"z39.50r"
,Text
"z39.50s"
,Text
"adiumxtra",Text
"afp",Text
"afs",Text
"aim",Text
"apt",Text
"attachment",Text
"aw"
,Text
"beshare",Text
"bitcoin",Text
"bolo",Text
"callto",Text
"chrome",Text
"chrome-extension"
,Text
"com-eventbrite-attendee",Text
"content",Text
"cvs",Text
"dlna-playsingle"
,Text
"dlna-playcontainer",Text
"dtn",Text
"dvb",Text
"ed2k",Text
"facetime",Text
"feed"
,Text
"finger",Text
"fish",Text
"gg",Text
"git",Text
"gizmoproject",Text
"gtalk"
,Text
"hcp",Text
"icon",Text
"ipn",Text
"irc",Text
"irc6",Text
"ircs",Text
"itms",Text
"jar"
,Text
"jms",Text
"keyparc",Text
"lastfm",Text
"ldaps",Text
"magnet",Text
"maps",Text
"market"
,Text
"message",Text
"mms",Text
"ms-help",Text
"msnim",Text
"mumble",Text
"mvn",Text
"notes"
,Text
"oid",Text
"palm",Text
"paparazzi",Text
"platform",Text
"proxy",Text
"psyc",Text
"query"
,Text
"res",Text
"resource",Text
"rmi",Text
"rsync",Text
"rtmp",Text
"secondlife",Text
"sftp"
,Text
"sgn",Text
"skype",Text
"smb",Text
"soldat",Text
"spotify",Text
"ssh",Text
"steam",Text
"svn"
,Text
"teamspeak",Text
"things",Text
"udp",Text
"unreal",Text
"ut2004",Text
"ventrilo"
,Text
"view-source",Text
"webcal",Text
"wtai",Text
"wyciwyg",Text
"xfire",Text
"xri"
,Text
"ymsgr" ]
schemeSet :: Set.Set Text
schemeSet :: Set Text
schemeSet = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ [Text]
schemes forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toUpper [Text]
schemes
pUri :: Text -> Parser Inlines
pUri :: Text -> Parser Inlines
pUri Text
scheme = do
Char -> Parser Char
char Char
':'
Text
x <- forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan (Int -> OpenParens
OpenParens Int
0) OpenParens -> Char -> Maybe OpenParens
uriScanner
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
x
let (Text
rawuri, Inlines
endingpunct) =
case Text -> Char
T.last Text
x of
Char
c | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
".;?!:," :: String) ->
(Text
scheme forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.init Text
x, forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)))
Char
_ -> (Text
scheme forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
x, forall a. Monoid a => a
mempty)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Inlines
autoLink Text
rawuri forall a. Semigroup a => a -> a -> a
<> Inlines
endingpunct
data OpenParens = OpenParens Int
uriScanner :: OpenParens -> Char -> Maybe OpenParens
uriScanner :: OpenParens -> Char -> Maybe OpenParens
uriScanner OpenParens
_ Char
' ' = forall a. Maybe a
Nothing
uriScanner OpenParens
_ Char
'\n' = forall a. Maybe a
Nothing
uriScanner (OpenParens Int
n) Char
'(' = forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n forall a. Num a => a -> a -> a
+ Int
1))
uriScanner (OpenParens Int
n) Char
')'
| Int
n forall a. Ord a => a -> a -> Bool
> Int
0 = forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n forall a. Num a => a -> a -> a
- Int
1))
| Bool
otherwise = forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
'+' = forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
st Char
'/' = forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
_ Char
c | Char -> Bool
isSpace Char
c = forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
_ = forall a. a -> Maybe a
Just OpenParens
st
pEnclosure :: Char -> ReferenceMap -> Parser Inlines
pEnclosure :: Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
c ReferenceMap
refmap = do
Text
cs <- (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
== Char
c)
(Text -> Inline
Str Text
cs forall a. a -> Seq a -> Seq a
<|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines
pSpace
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case Text -> Int
T.length Text
cs of
Int
3 -> Char -> ReferenceMap -> Parser Inlines
pThree Char
c ReferenceMap
refmap
Int
2 -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap forall a. Monoid a => a
mempty
Int
1 -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap forall a. Monoid a => a
mempty
Int
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
cs)
single :: (Inlines -> Inline) -> Inlines -> Inlines
single :: (Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
constructor Inlines
ils = if forall a. Seq a -> Bool
Seq.null Inlines
ils
then forall a. Monoid a => a
mempty
else forall a. a -> Seq a
singleton (Inlines -> Inline
constructor Inlines
ils)
pOne :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap Inlines
prefix = do
Inlines
contents <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ( (Char -> Parser ()
nfbChar Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Char -> Parser ()
nfbChar Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap forall a. Monoid a => a
mempty) )
(Char -> Parser Char
char Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph forall a b. (a -> b) -> a -> b
$ Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)) forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
pTwo :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap Inlines
prefix = do
let ender :: Parser Text
ender = Text -> Parser Text
string forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]
Inlines
contents <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall a. Parser a -> Parser ()
nfb Parser Text
ender forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
(Parser Text
ender forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong forall a b. (a -> b) -> a -> b
$ Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]) forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
pThree :: Char -> ReferenceMap -> Parser Inlines
pThree :: Char -> ReferenceMap -> Parser Inlines
pThree Char
c ReferenceMap
refmap = do
Inlines
contents <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser ()
nfbChar Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap))
(Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong Inlines
contents)))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph Inlines
contents)))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c,Char
c]) forall a. Semigroup a => a -> a -> a
<> Inlines
contents)
pCode :: Parser Inlines
pCode :: Parser Inlines
pCode = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Inlines, Text)
pCode'
pCode' :: Parser (Inlines, Text)
pCode' :: Parser (Inlines, Text)
pCode' = do
Text
ticks <- (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
== Char
'`')
let end :: Parser ()
end = Text -> Parser Text
string Text
ticks forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Parser a -> Parser ()
nfb (Char -> Parser Char
char Char
'`')
let nonBacktickSpan :: Parser Text
nonBacktickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'`')
let backtickSpan :: Parser Text
backtickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
== Char
'`')
Text
contents <- [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
nonBacktickSpan forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
backtickSpan) Parser ()
end
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Code forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ Text
contents, Text
ticks forall a. Semigroup a => a -> a -> a
<> Text
contents forall a. Semigroup a => a -> a -> a
<> Text
ticks)
pLink :: ReferenceMap -> Parser Inlines
pLink :: ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap = do
Text
lab <- Parser Text
pLinkLabel
let lab' :: Inlines
lab' = ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
lab
Inlines -> Parser Inlines
pInlineLink Inlines
lab' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink ReferenceMap
refmap Text
lab Inlines
lab'
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"[") forall a. Semigroup a => a -> a -> a
<> Inlines
lab' forall a. Semigroup a => a -> a -> a
<> forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"]"))
pInlineLink :: Inlines -> Parser Inlines
pInlineLink :: Inlines -> Parser Inlines
pInlineLink Inlines
lab = do
Char -> Parser Char
char Char
'('
Parser ()
scanSpaces
Text
url <- Parser Text
pLinkUrl
Text
tit <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
"" forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pLinkTitle forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scanSpaces
Char -> Parser Char
char Char
')'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link Inlines
lab Text
url Text
tit
lookupLinkReference :: ReferenceMap
-> Text
-> Maybe (Text, Text)
lookupLinkReference :: ReferenceMap -> Text -> Maybe (Text, Text)
lookupLinkReference ReferenceMap
refmap Text
key = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Text
normalizeReference Text
key) ReferenceMap
refmap
pReferenceLink :: ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink :: ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink ReferenceMap
refmap Text
rawlab Inlines
lab = do
Text
ref <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
rawlab forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkLabel
let ref' :: Text
ref' = if Text -> Bool
T.null Text
ref then Text
rawlab else Text
ref
case ReferenceMap -> Text -> Maybe (Text, Text)
lookupLinkReference ReferenceMap
refmap Text
ref' of
Just (Text
url,Text
tit) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link Inlines
lab Text
url Text
tit
Maybe (Text, Text)
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Reference not found"
pImage :: ReferenceMap -> Parser Inlines
pImage :: ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap = do
Char -> Parser Char
char Char
'!'
(Inlines -> Inlines
linkToImage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!"))
linkToImage :: Inlines -> Inlines
linkToImage :: Inlines -> Inlines
linkToImage Inlines
ils =
case forall a. Seq a -> ViewL a
viewl Inlines
ils of
(Link Inlines
lab Text
url Text
tit :< Inlines
x)
| forall a. Seq a -> Bool
Seq.null Inlines
x -> forall a. a -> Seq a
singleton (Inlines -> Text -> Text -> Inline
Image Inlines
lab Text
url Text
tit)
ViewL Inline
_ -> forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!") forall a. Semigroup a => a -> a -> a
<> Inlines
ils
pEntity :: Parser Inlines
pEntity :: Parser Inlines
pEntity = do
Char -> Parser Char
char Char
'&'
Text
res <- Parser Text
pCharEntity forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pDecEntity forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pHexEntity
Char -> Parser Char
char Char
';'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Entity forall a b. (a -> b) -> a -> b
$ Text
"&" forall a. Semigroup a => a -> a -> a
<> Text
res forall a. Semigroup a => a -> a -> a
<> Text
";"
pCharEntity :: Parser Text
pCharEntity :: Parser Text
pCharEntity = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLetter Char
c)
pDecEntity :: Parser Text
pDecEntity :: Parser Text
pDecEntity = do
Char -> Parser Char
char Char
'#'
Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
res
pHexEntity :: Parser Text
pHexEntity :: Parser Text
pHexEntity = do
Char -> Parser Char
char Char
'#'
Char
x <- Char -> Parser Char
char Char
'X' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'x'
Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isHexDigit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"#" forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x forall a. Semigroup a => a -> a -> a
<> Text
res
pRawHtml :: Parser Inlines
pRawHtml :: Parser Inlines
pRawHtml = forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
RawHtml forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (HtmlTagType, Text)
pHtmlTag forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pHtmlComment)
pAutolink :: Parser Inlines
pAutolink :: Parser Inlines
pAutolink = do
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'<')
Text
s <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'@')
Text
rest <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/=Char
'>' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
' ')
(Char -> Bool) -> Parser ()
skip (forall a. Eq a => a -> a -> Bool
==Char
'>')
case Bool
True of
Bool
_ | Text
"@" Text -> Text -> Bool
`T.isPrefixOf` Text
rest -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Inlines
emailLink (Text
s forall a. Semigroup a => a -> a -> a
<> Text
rest)
| Text
s forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Inlines
autoLink (Text
s forall a. Semigroup a => a -> a -> a
<> Text
rest)
| Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unknown contents of <>"
autoLink :: Text -> Inlines
autoLink :: Text -> Inlines
autoLink Text
t = forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link (Text -> Inlines
toInlines Text
t) Text
t (Text
T.empty)
where toInlines :: Text -> Inlines
toInlines Text
t' = case forall a. Parser a -> Text -> Either ParseError a
parse Parser Inlines
pToInlines Text
t' of
Right Inlines
r -> Inlines
r
Left ParseError
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"autolink: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParseError
e
pToInlines :: Parser Inlines
pToInlines = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Inlines
strOrEntity
strOrEntity :: Parser Inlines
strOrEntity = ((forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
/=Char
'&'))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((forall a. a -> Seq a
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text
string Text
"&")
emailLink :: Text -> Inlines
emailLink :: Text -> Inlines
emailLink Text
t = forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link (forall a. a -> Seq a
singleton forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t)
(Text
"mailto:" forall a. Semigroup a => a -> a -> a
<> Text
t) (Text
T.empty)