{-# 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
'/' Parser Char -> Parser Bool -> Parser Bool
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Text
tagname <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!')
let tagname' :: Text
tagname' = Text -> Text
T.toLower Text
tagname
let attr :: Parser Text
attr = do Text
ss <- (Char -> Bool) -> Parser Text
takeWhile Char -> Bool
isSpace
Char
x <- (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isLetter
Text
xs <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char -> Bool
isAsciiAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
(Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=')
Text
v <- Char -> Parser Text
pQuoted Char
'"' Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text
pQuoted Char
'\'' Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAlphaNum
Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
ss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v
Text
attrs <- [Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
attr
Text
final <- (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
Char -> Parser Char
char Char
'>'
let tagtype :: HtmlTagType
tagtype = if Bool
closing
then Text -> HtmlTagType
Closing Text
tagname'
else case Text -> Text -> Maybe Text
T.stripSuffix Text
"/" Text
final of
Just Text
_ -> Text -> HtmlTagType
SelfClosing Text
tagname'
Maybe Text
Nothing -> Text -> HtmlTagType
Opening Text
tagname'
(HtmlTagType, Text) -> Parser (HtmlTagType, Text)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (HtmlTagType
tagtype,
[Char] -> Text
T.pack (Char
'<' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char
'/' | Bool
closing]) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tagname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
final Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">")
pQuoted :: Char -> Parser Text
pQuoted :: Char -> Parser Text
pQuoted Char
c = do
(Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
Text
contents <- (Char -> Bool) -> Parser Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
(Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Text
T.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contents Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
c)
pHtmlComment :: Parser Text
= do
Text -> Parser Text
string Text
"<!--"
[Char]
rest <- Parser Char -> Parser Text -> Parser [Char]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill Parser Char
anyChar (Text -> Parser Text
string Text
"-->")
Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
"<!--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
rest Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-->"
pLinkLabel :: Parser Text
pLinkLabel :: Parser Text
pLinkLabel = Char -> Parser Char
char Char
'[' Parser Char -> Parser Text -> Parser Text
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Parser Text -> Parser Char -> Parser [Text]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
bracketed Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
codeChunk) (Char -> Parser Char
char Char
']')))
where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'`' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'[' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
']' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\\')
codeChunk :: Parser Text
codeChunk = (Inlines, Text) -> Text
forall a b. (a, b) -> b
snd ((Inlines, Text) -> Text) -> Parser (Inlines, Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Inlines, Text)
pCode'
bracketed :: Parser Text
bracketed = Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
inBrackets (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkLabel
inBrackets :: a -> a
inBrackets a
t = a
"[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"]"
pLinkUrl :: Parser Text
pLinkUrl :: Parser Text
pLinkUrl = do
Bool
inPointy <- (Char -> Parser Char
char Char
'<' Parser Char -> Parser Bool -> Parser Bool
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Bool
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
if Bool
inPointy
then [Char] -> Text
T.pack ([Char] -> Text) -> Parser [Char] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser Char -> Parser [Char]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill
((Char -> Bool) -> Parser Char
pSatisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\r' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')) (Char -> Parser Char
char Char
'>')
else [Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text
regChunk Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk)
where regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 ([Char] -> Char -> Bool
notInClass [Char]
" \n()\\") Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
parenChunk :: Parser Text
parenChunk = Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
parenthesize (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
char Char
'(' Parser Char -> Parser [Text] -> Parser [Text]
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
Parser Text -> Parser Char -> Parser [Text]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
parenChunk) (Char -> Parser Char
char Char
')'))
parenthesize :: a -> a
parenthesize a
x = a
"(" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")"
pLinkTitle :: Parser Text
pLinkTitle :: Parser Text
pLinkTitle = do
Char
c <- (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(')
Maybe Char
next <- Parser (Maybe Char)
peekChar
case Maybe Char
next of
Maybe Char
Nothing -> Parser ()
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
Just Char
x
| Char -> Bool
isWhitespace Char
x -> Parser ()
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' -> Parser ()
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
| Bool
otherwise -> () -> Parser ()
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let ender :: Char
ender = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' then Char
')' else Char
c
let pEnder :: Parser Char
pEnder = Char -> Parser Char
char Char
ender Parser Char -> Parser () -> Parser Char
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser () -> Parser ()
forall a. Parser a -> Parser ()
nfb ((Char -> Bool) -> Parser ()
skip Char -> Bool
isAlphaNum)
let regChunk :: Parser Text
regChunk = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
ender Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\') Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pEscaped
let nestedChunk :: Parser Text
nestedChunk = (\Text
x -> Char -> Text
T.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
ender)
(Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pLinkTitle
[Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Char -> Parser [Text]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
regChunk Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
nestedChunk) Parser Char
pEnder
pReference :: Parser (Text, Text, Text)
pReference :: Parser (Text, Text, Text)
pReference = do
Text
lab <- Parser Text
pLinkLabel
Char -> Parser Char
char Char
':'
Parser ()
scanSpnl
Text
url <- Parser Text
pLinkUrl
Text
tit <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
T.empty (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl Parser () -> Parser Text -> Parser Text
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkTitle
Parser ()
endOfInput
(Text, Text, Text) -> Parser (Text, Text, Text)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
lab, Text
url, Text
tit)
pEscaped :: Parser Text
pEscaped :: Parser Text
pEscaped = Char -> Text
T.singleton (Char -> Text) -> Parser Char -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\\') Parser () -> Parser Char -> Parser Char
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable)
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy :: (Char -> Bool) -> Parser Char
pSatisfy Char -> Bool
p =
(Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char -> Bool
p Char
c)
Parser Char -> Parser Char -> Parser Char
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
'\\' Parser Char -> Parser Char -> Parser Char
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy (\Char
c -> Char -> Bool
isEscapable Char
c Bool -> Bool -> Bool
&& Char -> Bool
p Char
c))
parseInlines :: ReferenceMap -> Text -> Inlines
parseInlines :: ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
t =
case Parser Inlines -> Text -> Either ParseError Inlines
forall a. Parser a -> Text -> Either ParseError a
parse ([Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap) Parser Inlines -> Parser () -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
endOfInput) Text
t of
Left ParseError
e -> [Char] -> Inlines
forall a. HasCallStack => [Char] -> a
error ([Char]
"parseInlines: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
e)
Right Inlines
r -> Inlines
r
pInline :: ReferenceMap -> Parser Inlines
pInline :: ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap =
Parser Inlines
pAsciiStr
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSpace
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'*' ReferenceMap
refmap
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ()
notAfter Char -> Bool
isAlphaNum Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
'_' ReferenceMap
refmap)
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pCode
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pRawHtml
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pAutolink
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pSym
pSpace :: Parser Inlines
pSpace :: Parser Inlines
pSpace = do
Text
ss <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isWhitespace
Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton
(Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') Text
ss
then if Text
" " Text -> Text -> Bool
`T.isPrefixOf` Text
ss
then Inline
LineBreak
else Inline
SoftBreak
else Inline
Space
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum Char
c =
(Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z') Bool -> Bool -> Bool
||
(Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
||
(Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
pAsciiStr :: Parser Inlines
pAsciiStr :: Parser Inlines
pAsciiStr = do
Text
t <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isAsciiAlphaNum
Maybe Char
mbc <- Parser (Maybe Char)
peekChar
case Maybe Char
mbc of
Just Char
':' -> if Text
t Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet
then Text -> Parser Inlines
pUri Text
t
else Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t
Maybe Char
_ -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t
pSym :: Parser Inlines
pSym :: Parser Inlines
pSym = do
Char
c <- Parser Char
anyChar
let ch :: Char -> Inlines
ch = Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> (Char -> Inline) -> Char -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str (Text -> Inline) -> (Char -> Text) -> Char -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
then Char -> Inlines
ch (Char -> Inlines) -> Parser Char -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isEscapable
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inline -> Inlines
forall a. a -> Seq a
singleton Inline
LineBreak Inlines -> Parser Char -> Parser Inlines
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Parser Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Inlines
ch Char
'\\')
else Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Inlines
ch Char
c)
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 = [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 Text
scheme = do
Char -> Parser Char
char Char
':'
Text
x <- OpenParens
-> (OpenParens -> Char -> Maybe OpenParens) -> Parser Text
forall s. s -> (s -> Char -> Maybe s) -> Parser Text
scan (Int -> OpenParens
OpenParens Int
0) OpenParens -> Char -> Maybe OpenParens
uriScanner
Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
x
let (Text
rawuri, Inlines
endingpunct) =
case HasCallStack => Text -> Char
Text -> Char
T.last Text
x of
Char
c | Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
".;?!:," :: String) ->
(Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text
Text -> Text
T.init Text
x, Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)))
Char
_ -> (Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x, Inlines
forall a. Monoid a => a
mempty)
Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
autoLink Text
rawuri Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
endingpunct
data OpenParens = OpenParens Int
uriScanner :: OpenParens -> Char -> Maybe OpenParens
uriScanner :: OpenParens -> Char -> Maybe OpenParens
uriScanner OpenParens
_ Char
' ' = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner OpenParens
_ Char
'\n' = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner (OpenParens Int
n) Char
'(' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
uriScanner (OpenParens Int
n) Char
')'
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just (Int -> OpenParens
OpenParens (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
| Bool
otherwise = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
'+' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
st Char
'/' = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just OpenParens
st
uriScanner OpenParens
_ Char
c | Char -> Bool
isSpace Char
c = Maybe OpenParens
forall a. Maybe a
Nothing
uriScanner OpenParens
st Char
_ = OpenParens -> Maybe OpenParens
forall a. a -> Maybe a
Just OpenParens
st
pEnclosure :: Char -> ReferenceMap -> Parser Inlines
pEnclosure :: Char -> ReferenceMap -> Parser Inlines
pEnclosure Char
c ReferenceMap
refmap = do
Text
cs <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
(Text -> Inline
Str Text
cs Inline -> Inlines -> Inlines
forall a. a -> Seq a -> Seq a
<|) (Inlines -> Inlines) -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines
pSpace
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case Text -> Int
T.length Text
cs of
Int
3 -> Char -> ReferenceMap -> Parser Inlines
pThree Char
c ReferenceMap
refmap
Int
2 -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap Inlines
forall a. Monoid a => a
mempty
Int
1 -> Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap Inlines
forall a. Monoid a => a
mempty
Int
_ -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
cs)
single :: (Inlines -> Inline) -> Inlines -> Inlines
single :: (Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
constructor Inlines
ils = if Inlines -> Bool
forall a. Seq a -> Bool
Seq.null Inlines
ils
then Inlines
forall a. Monoid a => a
mempty
else Inline -> Inlines
forall a. a -> Seq a
singleton (Inlines -> Inline
constructor Inlines
ils)
pOne :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap Inlines
prefix = do
Inlines
contents <- [Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ( (Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) Parser Text -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap Inlines
forall a. Monoid a => a
mempty) )
(Char -> Parser Char
char Char
c Parser Char -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines
prefix Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str (Char -> Text
T.singleton Char
c)) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
pTwo :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo :: Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap Inlines
prefix = do
let ender :: Parser Text
ender = Text -> Parser Text
string (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]
Inlines
contents <- [Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text -> Parser ()
forall a. Parser a -> Parser ()
nfb Parser Text
ender Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap)
(Parser Text
ender Parser Text -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines
prefix Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c]) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> (Inlines
prefix Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
contents))
pThree :: Char -> ReferenceMap -> Parser Inlines
pThree :: Char -> ReferenceMap -> Parser Inlines
pThree Char
c ReferenceMap
refmap = do
Inlines
contents <- [Inlines] -> Inlines
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser ()
nfbChar Char
c Parser () -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReferenceMap -> Parser Inlines
pInline ReferenceMap
refmap))
(Text -> Parser Text
string ([Char] -> Text
T.pack [Char
c,Char
c]) Parser Text -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> ReferenceMap -> Inlines -> Parser Inlines
pOne Char
c ReferenceMap
refmap ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Strong Inlines
contents)))
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
char Char
c Parser Char -> Parser Inlines -> Parser Inlines
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> ReferenceMap -> Inlines -> Parser Inlines
pTwo Char
c ReferenceMap
refmap ((Inlines -> Inline) -> Inlines -> Inlines
single Inlines -> Inline
Emph Inlines
contents)))
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char
c,Char
c,Char
c]) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
contents)
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
== Char
'`')
let end :: Parser ()
end = Text -> Parser Text
string Text
ticks Parser Text -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char -> Parser ()
forall a. Parser a -> Parser ()
nfb (Char -> Parser Char
char Char
'`')
let nonBacktickSpan :: Parser Text
nonBacktickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'`')
let backtickSpan :: Parser Text
backtickSpan = (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`')
Text
contents <- [Text] -> Text
T.concat ([Text] -> Text) -> Parser [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser () -> Parser [Text]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
manyTill (Parser Text
nonBacktickSpan Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
backtickSpan) Parser ()
end
(Inlines, Text) -> Parser (Inlines, Text)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> (Text -> Inline) -> Text -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Code (Text -> Inline) -> (Text -> Text) -> Text -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Text
contents, Text
ticks Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contents Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ticks)
pLink :: ReferenceMap -> Parser Inlines
pLink :: ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap = do
Text
lab <- Parser Text
pLinkLabel
let lab' :: Inlines
lab' = ReferenceMap -> Text -> Inlines
parseInlines ReferenceMap
refmap Text
lab
Inlines -> Parser Inlines
pInlineLink Inlines
lab' Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink ReferenceMap
refmap Text
lab Inlines
lab'
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"[") Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
lab' Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"]"))
pInlineLink :: Inlines -> Parser Inlines
pInlineLink :: Inlines -> Parser Inlines
pInlineLink Inlines
lab = do
Char -> Parser Char
char Char
'('
Parser ()
scanSpaces
Text
url <- Parser Text
pLinkUrl
Text
tit <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
"" (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl Parser () -> Parser Text -> Parser Text
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
pLinkTitle Parser Text -> Parser () -> Parser Text
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scanSpaces
Char -> Parser Char
char Char
')'
Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link Inlines
lab Text
url Text
tit
lookupLinkReference :: ReferenceMap
-> Text
-> Maybe (Text, Text)
lookupLinkReference :: ReferenceMap -> Text -> Maybe (Text, Text)
lookupLinkReference ReferenceMap
refmap Text
key = Text -> ReferenceMap -> Maybe (Text, Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Text
normalizeReference Text
key) ReferenceMap
refmap
pReferenceLink :: ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink :: ReferenceMap -> Text -> Inlines -> Parser Inlines
pReferenceLink ReferenceMap
refmap Text
rawlab Inlines
lab = do
Text
ref <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
rawlab (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser ()
scanSpnl Parser () -> Parser Text -> Parser Text
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
pLinkLabel
let ref' :: Text
ref' = if Text -> Bool
T.null Text
ref then Text
rawlab else Text
ref
case ReferenceMap -> Text -> Maybe (Text, Text)
lookupLinkReference ReferenceMap
refmap Text
ref' of
Just (Text
url,Text
tit) -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link Inlines
lab Text
url Text
tit
Maybe (Text, Text)
Nothing -> [Char] -> Parser Inlines
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Reference not found"
pImage :: ReferenceMap -> Parser Inlines
pImage :: ReferenceMap -> Parser Inlines
pImage ReferenceMap
refmap = do
Char -> Parser Char
char Char
'!'
(Inlines -> Inlines
linkToImage (Inlines -> Inlines) -> Parser Inlines -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReferenceMap -> Parser Inlines
pLink ReferenceMap
refmap) Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!"))
linkToImage :: Inlines -> Inlines
linkToImage :: Inlines -> Inlines
linkToImage Inlines
ils =
case Inlines -> ViewL Inline
forall a. Seq a -> ViewL a
viewl Inlines
ils of
(Link Inlines
lab Text
url Text
tit :< Inlines
x)
| Inlines -> Bool
forall a. Seq a -> Bool
Seq.null Inlines
x -> Inline -> Inlines
forall a. a -> Seq a
singleton (Inlines -> Text -> Text -> Inline
Image Inlines
lab Text
url Text
tit)
ViewL Inline
_ -> Inline -> Inlines
forall a. a -> Seq a
singleton (Text -> Inline
Str Text
"!") Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
ils
pEntity :: Parser Inlines
pEntity :: Parser Inlines
pEntity = do
Char -> Parser Char
char Char
'&'
Text
res <- Parser Text
pCharEntity Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pDecEntity Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pHexEntity
Char -> Parser Char
char Char
';'
Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Entity (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ Text
"&" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
res Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
pCharEntity :: Parser Text
pCharEntity :: Parser Text
pCharEntity = (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isLetter Char
c)
pDecEntity :: Parser Text
pDecEntity :: Parser Text
pDecEntity = do
Char -> Parser Char
char Char
'#'
Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
res
pHexEntity :: Parser Text
pHexEntity :: Parser Text
pHexEntity = do
Char -> Parser Char
char Char
'#'
Char
x <- Char -> Parser Char
char Char
'X' Parser Char -> Parser Char -> Parser Char
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'x'
Text
res <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isHexDigit
Text -> Parser Text
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
res
pRawHtml :: Parser Inlines
pRawHtml :: Parser Inlines
pRawHtml = Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> (Text -> Inline) -> Text -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
RawHtml (Text -> Inlines) -> Parser Text -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((HtmlTagType, Text) -> Text
forall a b. (a, b) -> b
snd ((HtmlTagType, Text) -> Text)
-> Parser (HtmlTagType, Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (HtmlTagType, Text)
pHtmlTag Parser Text -> Parser Text -> Parser Text
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pHtmlComment)
pAutolink :: Parser Inlines
pAutolink :: Parser Inlines
pAutolink = do
(Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'<')
Text
s <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@')
Text
rest <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'>' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
(Char -> Bool) -> Parser ()
skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'>')
case Bool
True of
Bool
_ | Text
"@" Text -> Text -> Bool
`T.isPrefixOf` Text
rest -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
emailLink (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest)
| Text
s Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemeSet -> Inlines -> Parser Inlines
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> Parser Inlines) -> Inlines -> Parser Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
autoLink (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest)
| Bool
otherwise -> [Char] -> Parser Inlines
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unknown contents of <>"
autoLink :: Text -> Inlines
autoLink :: Text -> Inlines
autoLink Text
t = Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link (Text -> Inlines
toInlines Text
t) Text
t (Text
T.empty)
where toInlines :: Text -> Inlines
toInlines Text
t' = case Parser Inlines -> Text -> Either ParseError Inlines
forall a. Parser a -> Text -> Either ParseError a
parse Parser Inlines
pToInlines Text
t' of
Right Inlines
r -> Inlines
r
Left ParseError
e -> [Char] -> Inlines
forall a. HasCallStack => [Char] -> a
error ([Char] -> Inlines) -> [Char] -> Inlines
forall a b. (a -> b) -> a -> b
$ [Char]
"autolink: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
e
pToInlines :: Parser Inlines
pToInlines = [Inlines] -> Inlines
forall a. Monoid a => [a] -> a
mconcat ([Inlines] -> Inlines) -> Parser [Inlines] -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Inlines -> Parser [Inlines]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Inlines
strOrEntity
strOrEntity :: Parser Inlines
strOrEntity = ((Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> (Text -> Inline) -> Text -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str) (Text -> Inlines) -> Parser Text -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'&'))
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Inlines
pEntity
Parser Inlines -> Parser Inlines -> Parser Inlines
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> (Text -> Inline) -> Text -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
Str) (Text -> Inlines) -> Parser Text -> Parser Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text
string Text
"&")
emailLink :: Text -> Inlines
emailLink :: Text -> Inlines
emailLink Text
t = Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Text -> Text -> Inline
Link (Inline -> Inlines
forall a. a -> Seq a
singleton (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
Str Text
t)
(Text
"mailto:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t) (Text
T.empty)