diff --git a/Cheapskate.hs b/Cheapskate.hs new file mode 100644 --- /dev/null +++ b/Cheapskate.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cheapskate (markdown, + def, + walk, + walkM, + module Cheapskate.Types + ) where +import Cheapskate.Types +import Cheapskate.Parse +import Cheapskate.Html +import Data.Default (def) +import Data.Data +import Data.Generics.Uniplate.Data +import Text.Blaze.Html (ToMarkup(..)) + +instance ToMarkup Doc + where toMarkup = renderDoc + +-- | Apply a transformation bottom-up to every node of a parsed document. +-- This can be used, for example, to transform specially marked code blocks +-- to highlighted code or images. Here is a simple example that promotes +-- the levels of headers: +-- +-- > promoteHeaders :: Doc -> Doc +-- > promoteHeaders = walk promoteHeader +-- > where promoteHeader (Header n ils) = Header (n+1) ils +-- > promoteHeader x = x +walk :: (Data a, Data b) => (a -> a) -> (b -> b) +walk = transformBi + +-- | Monadic version of 'walk'. +walkM :: (Data a, Data b, Monad m) => (a -> m a) -> (b -> m b) +walkM = transformBiM diff --git a/Cheapskate/Html.hs b/Cheapskate/Html.hs new file mode 100644 --- /dev/null +++ b/Cheapskate/Html.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cheapskate.Html (renderDoc, renderBlocks, renderInlines) where +import Cheapskate.Types +import Data.Text (Text) +import Data.Char (isDigit, isHexDigit, isAlphaNum) +import qualified Text.Blaze.XHtml5 as H +import qualified Text.Blaze.Html5.Attributes as A +import qualified Text.Blaze.Html.Renderer.Text as BT +import Text.Blaze.Html hiding(contents) +import Data.Monoid +import Data.Foldable (foldMap, toList) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.List (intersperse) +import Text.HTML.SanitizeXSS (sanitizeBalance) + +-- | Render a markdown document as 'Html'. (This can be turned +-- into a 'Text' or 'ByteString' using a renderer from the @blaze-html@ +-- library.) +renderDoc :: Doc -> Html +renderDoc (Doc opts body) = mbsanitize $ (renderBlocks opts body <> "\n") + where mbsanitize = if sanitize opts + then preEscapedToMarkup . sanitizeBalance . + TL.toStrict . BT.renderHtml + else id + -- note: less efficient to do this at the whole document level, + -- rather than on individual raw html bits and attributes, but + -- this is needed for cases where open tags in one raw HTML + -- section are balanced by close tags in another. + +-- Render a sequence of blocks as HTML5. Currently a single +-- newline is used between blocks, and a newline is used as a +-- separator e.g. for list items. These can be changed by adjusting +-- nl and blocksep. Eventually we probably want these as parameters +-- or options. +renderBlocks :: Options -> Blocks -> Html +renderBlocks opts = mconcat . intersperse blocksep . map renderBlock . toList + where renderBlock :: Block -> Html + renderBlock (Header n ils) + | n >= 1 && n <= 6 = ([H.h1,H.h2,H.h3,H.h4,H.h5,H.h6] !! (n - 1)) + $ renderInlines opts ils + | otherwise = H.p (renderInlines opts ils) + renderBlock (Para ils) = H.p (renderInlines opts ils) + renderBlock (HRule) = H.hr + renderBlock (Blockquote bs) = H.blockquote $ nl <> renderBlocks opts bs <> nl + renderBlock (CodeBlock attr t) = + if T.null (codeLang attr) + then base + else base ! A.class_ (toValue' $ codeLang attr) + where base = H.pre $ H.code $ toHtml (t <> "\n") + -- add newline because Markdown.pl does + renderBlock (List tight (Bullet _) items) = + H.ul $ nl <> mapM_ (li tight) items + renderBlock (List tight (Numbered _ n) items) = + if n == 1 then base else base ! A.start (toValue n) + where base = H.ol $ nl <> mapM_ (li tight) items + renderBlock (HtmlBlock raw) = + if allowRawHtml opts + then H.preEscapedToMarkup raw + else toHtml raw + li :: Bool -> Blocks -> Html -- tight list handling + li True = (<> nl) . H.li . mconcat . intersperse blocksep . + map renderBlockTight . toList + li False = toLi + renderBlockTight (Para zs) = renderInlines opts zs + renderBlockTight x = renderBlock x + toLi x = (H.li $ renderBlocks opts x) <> nl + nl = "\n" + blocksep = "\n" + +-- Render a sequence of inlines as HTML5. +renderInlines :: Options -> Inlines -> Html +renderInlines opts = foldMap renderInline + where renderInline :: Inline -> Html + renderInline (Str t) = toHtml t + renderInline Space = " " + renderInline SoftBreak + | preserveHardBreaks opts = H.br <> "\n" + | otherwise = "\n" + -- this preserves the line breaks in the + -- markdown document; replace with " " if this isn't wanted. + renderInline LineBreak = H.br <> "\n" + renderInline (Emph ils) = H.em $ renderInlines opts ils + renderInline (Strong ils) = H.strong $ renderInlines opts ils + renderInline (Code t) = H.code $ toHtml t + renderInline (Link ils url tit) = + if T.null tit then base else base ! A.title (toValue' tit) + where base = H.a ! A.href (toValue' url) $ renderInlines opts ils + renderInline (Image ils url tit) = + if T.null tit then base else base ! A.title (toValue' tit) + where base = H.img ! A.src (toValue' url) + ! A.alt (toValue + $ BT.renderHtml $ renderInlines opts ils) + renderInline (Entity t) = H.preEscapedToMarkup t + renderInline (RawHtml t) = + if allowRawHtml opts + then H.preEscapedToMarkup t + else toHtml t + +toValue' :: Text -> AttributeValue +toValue' = preEscapedToValue . gentleEscape . T.unpack + +-- preserve existing entities +gentleEscape :: String -> String +gentleEscape [] = [] +gentleEscape ('"':xs) = """ ++ gentleEscape xs +gentleEscape ('\'':xs) = "'" ++ gentleEscape xs +gentleEscape ('&':'#':x:xs) + | x == 'x' || x == 'X' = + case span isHexDigit xs of + (ys,';':zs) | not (null ys) && length ys < 6 -> + '&':'#':x:ys ++ ";" ++ gentleEscape zs + _ -> "&#" ++ (x : gentleEscape xs) +gentleEscape ('&':'#':xs) = + case span isDigit xs of + (ys,';':zs) | not (null ys) && length ys < 6 -> + '&':'#':ys ++ ";" ++ gentleEscape zs + _ -> "&#" ++ gentleEscape xs +gentleEscape ('&':xs) = + case span isAlphaNum xs of + (ys,';':zs) | not (null ys) && length ys < 11 -> + '&':ys ++ ";" ++ gentleEscape zs + _ -> "&" ++ gentleEscape xs +gentleEscape (x:xs) = x : gentleEscape xs diff --git a/Cheapskate/Inlines.hs b/Cheapskate/Inlines.hs new file mode 100644 --- /dev/null +++ b/Cheapskate/Inlines.hs @@ -0,0 +1,435 @@ +{-# 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, (<|)) +import Prelude hiding (takeWhile) +import Control.Applicative +import Data.Monoid +import Control.Monad +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Set as Set + +-- Returns tag type and whole tag. +pHtmlTag :: Parser (HtmlTagType, Text) +pHtmlTag = do + char '<' + -- do not end the tag with a > character in a quoted attribute. + closing <- (char '/' >> return True) <|> return False + tagname <- takeWhile1 (\c -> isAsciiAlphaNum c || c == '?' || c == '!') + let tagname' = T.toLower tagname + let attr = do ss <- takeWhile isSpace + x <- satisfy isLetter + xs <- takeWhile (\c -> isAsciiAlphaNum c || c == ':') + skip (=='=') + v <- pQuoted '"' <|> pQuoted '\'' <|> takeWhile1 isAlphaNum + <|> return "" + return $ ss <> T.singleton x <> xs <> "=" <> v + attrs <- T.concat <$> many attr + final <- takeWhile (\c -> isSpace c || c == '/') + char '>' + let tagtype = if closing + then Closing tagname' + else case T.stripSuffix "/" final of + Just _ -> SelfClosing tagname' + Nothing -> Opening tagname' + return (tagtype, + T.pack ('<' : ['/' | closing]) <> tagname <> attrs <> final <> ">") + +-- Parses a quoted attribute value. +pQuoted :: Char -> Parser Text +pQuoted c = do + skip (== c) + contents <- takeTill (== c) + skip (== c) + return (T.singleton c <> contents <> T.singleton c) + +-- Parses an HTML comment. This isn't really correct to spec, but should +-- do for now. +pHtmlComment :: Parser Text +pHtmlComment = do + string "") + return $ "" + +-- A link label [like this]. Note the precedence: code backticks have +-- precedence over label bracket markers, which have precedence over +-- *, _, and other inline formatting markers. +-- So, 2 below contains a link while 1 does not: +-- 1. [a link `with a ](/url)` character +-- 2. [a link *with emphasized ](/url) text* +pLinkLabel :: Parser Text +pLinkLabel = char '[' *> (T.concat <$> + (manyTill (regChunk <|> pEscaped <|> bracketed <|> codeChunk) (char ']'))) + where regChunk = takeWhile1 (\c -> c /='`' && c /='[' && c /=']' && c /='\\') + codeChunk = snd <$> pCode' + bracketed = inBrackets <$> pLinkLabel + inBrackets t = "[" <> t <> "]" + +-- A URL in a link or reference. This may optionally be contained +-- in `<..>`; otherwise whitespace and unbalanced right parentheses +-- aren't allowed. Newlines aren't allowed in any case. +pLinkUrl :: Parser Text +pLinkUrl = do + inPointy <- (char '<' >> return True) <|> return False + if inPointy + then T.pack <$> manyTill + (pSatisfy (\c -> c /='\r' && c /='\n')) (char '>') + else T.concat <$> many (regChunk <|> parenChunk) + where regChunk = takeWhile1 (notInClass " \n()\\") <|> pEscaped + parenChunk = parenthesize . T.concat <$> (char '(' *> + manyTill (regChunk <|> parenChunk) (char ')')) + parenthesize x = "(" <> x <> ")" + +-- A link title, single or double quoted or in parentheses. +-- Note that Markdown.pl doesn't allow the parenthesized form in +-- inline links -- only in references -- but this restriction seems +-- arbitrary, so we remove it here. +pLinkTitle :: Parser Text +pLinkTitle = do + c <- satisfy (\c -> c == '"' || c == '\'' || c == '(') + next <- peekChar + case next of + Nothing -> mzero + Just x + | isWhitespace x -> mzero + | x == ')' -> mzero + | otherwise -> return () + let ender = if c == '(' then ')' else c + let pEnder = char ender <* nfb (skip isAlphaNum) + let regChunk = takeWhile1 (\x -> x /= ender && x /= '\\') <|> pEscaped + let nestedChunk = (\x -> T.singleton c <> x <> T.singleton ender) + <$> pLinkTitle + T.concat <$> manyTill (regChunk <|> nestedChunk) pEnder + +-- A link reference is a square-bracketed link label, a colon, +-- optional space or newline, a URL, optional space or newline, +-- and an optional link title. (Note: we assume the input is +-- pre-stripped, with no leading/trailing spaces.) +pReference :: Parser (Text, Text, Text) +pReference = do + lab <- pLinkLabel + char ':' + scanSpnl + url <- pLinkUrl + tit <- option T.empty $ scanSpnl >> pLinkTitle + endOfInput + return (lab, url, tit) + +-- Parses an escaped character and returns a Text. +pEscaped :: Parser Text +pEscaped = T.singleton <$> (skip (=='\\') *> satisfy isEscapable) + +-- Parses a (possibly escaped) character satisfying the predicate. +pSatisfy :: (Char -> Bool) -> Parser Char +pSatisfy p = + satisfy (\c -> c /= '\\' && p c) + <|> (char '\\' *> satisfy (\c -> isEscapable c && p c)) + +-- Parse a text into inlines, resolving reference links +-- using the reference map. +parseInlines :: ReferenceMap -> Text -> Inlines +parseInlines refmap t = + case parse (msum <$> many (pInline refmap) <* endOfInput) t of + Left e -> error ("parseInlines: " ++ show e) -- should not happen + Right r -> r + +pInline :: ReferenceMap -> Parser Inlines +pInline refmap = + pAsciiStr + <|> pSpace + <|> pEnclosure '*' refmap -- strong/emph + <|> (notAfter isAlphaNum *> pEnclosure '_' refmap) + <|> pCode + <|> pLink refmap + <|> pImage refmap + <|> pRawHtml + <|> pAutolink + <|> pEntity + <|> pSym + +-- Parse spaces or newlines, and determine whether +-- we have a regular space, a line break (two spaces before +-- a newline), or a soft break (newline without two spaces +-- before). +pSpace :: Parser Inlines +pSpace = do + ss <- takeWhile1 isWhitespace + return $ singleton + $ if T.any (=='\n') ss + then if " " `T.isPrefixOf` ss + then LineBreak + else SoftBreak + else Space + +isAsciiAlphaNum :: Char -> Bool +isAsciiAlphaNum c = + (c >= 'a' && c <= 'z') || + (c >= 'A' && c <= 'Z') || + (c >= '0' && c <= '9') + +pAsciiStr :: Parser Inlines +pAsciiStr = do + t <- takeWhile1 isAsciiAlphaNum + mbc <- peekChar + case mbc of + Just ':' -> if t `Set.member` schemeSet + then pUri t + else return $ singleton $ Str t + _ -> return $ singleton $ Str t + +-- Catch all -- parse an escaped character, an escaped +-- newline, or any remaining symbol character. +pSym :: Parser Inlines +pSym = do + c <- anyChar + let ch = singleton . Str . T.singleton + if c == '\\' + then ch <$> satisfy isEscapable + <|> singleton LineBreak <$ satisfy (=='\n') + <|> return (ch '\\') + else return (ch c) + +-- http://www.iana.org/assignments/uri-schemes.html plus +-- the unofficial schemes coap, doi, javascript. +schemes :: [Text] +schemes = [ -- unofficial + "coap","doi","javascript" + -- official + ,"aaa","aaas","about","acap" + ,"cap","cid","crid","data","dav","dict","dns","file","ftp" + ,"geo","go","gopher","h323","http","https","iax","icap","im" + ,"imap","info","ipp","iris","iris.beep","iris.xpc","iris.xpcs" + ,"iris.lwz","ldap","mailto","mid","msrp","msrps","mtqp" + ,"mupdate","news","nfs","ni","nih","nntp","opaquelocktoken","pop" + ,"pres","rtsp","service","session","shttp","sieve","sip","sips" + ,"sms","snmp","soap.beep","soap.beeps","tag","tel","telnet","tftp" + ,"thismessage","tn3270","tip","tv","urn","vemmi","ws","wss" + ,"xcon","xcon-userid","xmlrpc.beep","xmlrpc.beeps","xmpp","z39.50r" + ,"z39.50s" + -- provisional + ,"adiumxtra","afp","afs","aim","apt","attachment","aw" + ,"beshare","bitcoin","bolo","callto","chrome","chrome-extension" + ,"com-eventbrite-attendee","content","cvs","dlna-playsingle" + ,"dlna-playcontainer","dtn","dvb","ed2k","facetime","feed" + ,"finger","fish","gg","git","gizmoproject","gtalk" + ,"hcp","icon","ipn","irc","irc6","ircs","itms","jar" + ,"jms","keyparc","lastfm","ldaps","magnet","maps","market" + ,"message","mms","ms-help","msnim","mumble","mvn","notes" + ,"oid","palm","paparazzi","platform","proxy","psyc","query" + ,"res","resource","rmi","rsync","rtmp","secondlife","sftp" + ,"sgn","skype","smb","soldat","spotify","ssh","steam","svn" + ,"teamspeak","things","udp","unreal","ut2004","ventrilo" + ,"view-source","webcal","wtai","wyciwyg","xfire","xri" + ,"ymsgr" ] + +-- Make them a set for more efficient lookup. +schemeSet :: Set.Set Text +schemeSet = Set.fromList $ schemes ++ map T.toUpper schemes + +-- Parse a URI, using heuristics to avoid capturing final punctuation. +pUri :: Text -> Parser Inlines +pUri scheme = do + char ':' + x <- scan (OpenParens 0) uriScanner + guard $ not $ T.null x + let (rawuri, endingpunct) = + case T.last x of + c | c `elem` ".;?!:," -> + (scheme <> ":" <> T.init x, singleton (Str (T.singleton c))) + _ -> (scheme <> ":" <> x, mempty) + return $ autoLink rawuri <> endingpunct + +-- Scan non-ascii characters and ascii characters allowed in a URI. +-- We allow punctuation except when followed by a space, since +-- we don't want the trailing '.' in 'http://google.com.' +-- We want to allow +-- http://en.wikipedia.org/wiki/State_of_emergency_(disambiguation) +-- as a URL, while NOT picking up the closing paren in +-- (http://wikipedia.org) +-- So we include balanced parens in the URL. + +data OpenParens = OpenParens Int + +uriScanner :: OpenParens -> Char -> Maybe OpenParens +uriScanner _ ' ' = Nothing +uriScanner _ '\n' = Nothing +uriScanner (OpenParens n) '(' = Just (OpenParens (n + 1)) +uriScanner (OpenParens n) ')' + | n > 0 = Just (OpenParens (n - 1)) + | otherwise = Nothing +uriScanner st '+' = Just st +uriScanner st '/' = Just st +uriScanner _ c | isSpace c = Nothing +uriScanner st _ = Just st + +-- Parses material enclosed in *s, **s, _s, or __s. +-- Designed to avoid backtracking. +pEnclosure :: Char -> ReferenceMap -> Parser Inlines +pEnclosure c refmap = do + cs <- takeWhile1 (== c) + (Str cs <|) <$> pSpace + <|> case T.length cs of + 3 -> pThree c refmap + 2 -> pTwo c refmap mempty + 1 -> pOne c refmap mempty + _ -> return (singleton $ Str cs) + +-- singleton sequence or empty if contents are empty +single :: (Inlines -> Inline) -> Inlines -> Inlines +single constructor ils = if Seq.null ils + then mempty + else singleton (constructor ils) + +-- parse inlines til you hit a c, and emit Emph. +-- if you never hit a c, emit '*' + inlines parsed. +pOne :: Char -> ReferenceMap -> Inlines -> Parser Inlines +pOne c refmap prefix = do + contents <- msum <$> many ( (nfbChar c >> pInline refmap) + <|> (string (T.pack [c,c]) >> + nfbChar c >> pTwo c refmap mempty) ) + (char c >> return (single Emph $ prefix <> contents)) + <|> return (singleton (Str (T.singleton c)) <> (prefix <> contents)) + +-- parse inlines til you hit two c's, and emit Strong. +-- if you never do hit two c's, emit '**' plus + inlines parsed. +pTwo :: Char -> ReferenceMap -> Inlines -> Parser Inlines +pTwo c refmap prefix = do + let ender = string $ T.pack [c,c] + contents <- msum <$> many (nfb ender >> pInline refmap) + (ender >> return (single Strong $ prefix <> contents)) + <|> return (singleton (Str $ T.pack [c,c]) <> (prefix <> contents)) + +-- parse inlines til you hit one c or a sequence of two c's. +-- If one c, emit Emph and then parse pTwo. +-- if two c's, emit Strong and then parse pOne. +pThree :: Char -> ReferenceMap -> Parser Inlines +pThree c refmap = do + contents <- msum <$> (many (nfbChar c >> pInline refmap)) + (string (T.pack [c,c]) >> (pOne c refmap (single Strong contents))) + <|> (char c >> (pTwo c refmap (single Emph contents))) + <|> return (singleton (Str $ T.pack [c,c,c]) <> contents) + +-- Inline code span. +pCode :: Parser Inlines +pCode = fst <$> pCode' + +-- this is factored out because it needed in pLinkLabel. +pCode' :: Parser (Inlines, Text) +pCode' = do + ticks <- takeWhile1 (== '`') + let end = string ticks >> nfb (char '`') + let nonBacktickSpan = takeWhile1 (/= '`') + let backtickSpan = takeWhile1 (== '`') + contents <- T.concat <$> manyTill (nonBacktickSpan <|> backtickSpan) end + return (singleton . Code . T.strip $ contents, ticks <> contents <> ticks) + +pLink :: ReferenceMap -> Parser Inlines +pLink refmap = do + lab <- pLinkLabel + let lab' = parseInlines refmap lab + pInlineLink lab' <|> pReferenceLink refmap lab lab' + -- fallback without backtracking if it's not a link: + <|> return (singleton (Str "[") <> lab' <> singleton (Str "]")) + +-- An inline link: [label](/url "optional title") +pInlineLink :: Inlines -> Parser Inlines +pInlineLink lab = do + char '(' + scanSpaces + url <- pLinkUrl + tit <- option "" $ scanSpnl *> pLinkTitle <* scanSpaces + char ')' + return $ singleton $ Link lab url tit + +lookupLinkReference :: ReferenceMap + -> Text -- reference label + -> Maybe (Text, Text) -- (url, title) +lookupLinkReference refmap key = M.lookup (normalizeReference key) refmap + +-- A reference link: [label], [foo][label], or [label][]. +pReferenceLink :: ReferenceMap -> Text -> Inlines -> Parser Inlines +pReferenceLink refmap rawlab lab = do + ref <- option rawlab $ scanSpnl >> pLinkLabel + let ref' = if T.null ref then rawlab else ref + case lookupLinkReference refmap ref' of + Just (url,tit) -> return $ singleton $ Link lab url tit + Nothing -> fail "Reference not found" + +-- An image: ! followed by a link. +pImage :: ReferenceMap -> Parser Inlines +pImage refmap = do + char '!' + let linkToImage (Link lab url tit) = Image lab url tit + linkToImage x = x + fmap linkToImage <$> pLink refmap + +-- An entity. We store these in a special inline element. +-- This ensures that entities in the input come out as +-- entities in the output. Alternatively we could simply +-- convert them to characters and store them as Str inlines. +pEntity :: Parser Inlines +pEntity = do + char '&' + res <- pCharEntity <|> pDecEntity <|> pHexEntity + char ';' + return $ singleton $ Entity $ "&" <> res <> ";" + +pCharEntity :: Parser Text +pCharEntity = takeWhile1 (\c -> isAscii c && isLetter c) + +pDecEntity :: Parser Text +pDecEntity = do + char '#' + res <- takeWhile1 isDigit + return $ "#" <> res + +pHexEntity :: Parser Text +pHexEntity = do + char '#' + x <- char 'X' <|> char 'x' + res <- takeWhile1 isHexDigit + return $ "#" <> T.singleton x <> res + +-- Raw HTML tag or comment. +pRawHtml :: Parser Inlines +pRawHtml = singleton . RawHtml <$> (snd <$> pHtmlTag <|> pHtmlComment) + +-- A link like this: or . +-- Markdown.pl does email obfuscation; we don't bother with that here. +pAutolink :: Parser Inlines +pAutolink = do + skip (=='<') + s <- takeWhile1 (\c -> c /= ':' && c /= '@') + rest <- takeWhile1 (\c -> c /='>' && c /= ' ') + skip (=='>') + case True of + _ | "@" `T.isPrefixOf` rest -> return $ emailLink (s <> rest) + | s `Set.member` schemeSet -> return $ autoLink (s <> rest) + | otherwise -> fail "Unknown contents of <>" + +autoLink :: Text -> Inlines +autoLink t = singleton $ Link (toInlines t) t (T.empty) + where toInlines t' = case parse pToInlines t' of + Right r -> r + Left e -> error $ "autolink: " ++ show e + pToInlines = mconcat <$> many strOrEntity + strOrEntity = ((singleton . Str) <$> takeWhile1 (/='&')) + <|> pEntity + <|> ((singleton . Str) <$> string "&") + +emailLink :: Text -> Inlines +emailLink t = singleton $ Link (singleton $ Str t) + ("mailto:" <> t) (T.empty) + + diff --git a/Cheapskate/Parse.hs b/Cheapskate/Parse.hs new file mode 100644 --- /dev/null +++ b/Cheapskate/Parse.hs @@ -0,0 +1,592 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cheapskate.Parse ( + markdown + ) where +import Cheapskate.ParserCombinators +import Cheapskate.Util +import Cheapskate.Inlines +import Cheapskate.Types +import Data.Char hiding (Space) +import qualified Data.Set as Set +import Prelude hiding (takeWhile) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Monoid +import Data.Foldable (toList) +import Data.Sequence ((|>), viewr, ViewR(..), singleton, Seq) +import qualified Data.Sequence as Seq +import Control.Monad.RWS +import Control.Applicative +import qualified Data.Map as M +import Data.List (intercalate) + +import Debug.Trace + +-- | Parses the input as a markdown document. Note that 'Doc' is an instance +-- of 'ToMarkup', so the document can be converted to 'Html' using 'toHtml'. +-- A simple 'Text' to 'Html' filter would be +-- +-- > markdownToHtml :: Text -> Html +-- > markdownToHtml = toHtml . markdown def +markdown :: Options -> Text -> Doc +markdown opts + | debug opts = (\x -> trace (show x) $ Doc opts mempty) . processLines + | otherwise = Doc opts . processDocument . processLines + +-- General parsing strategy: +-- +-- Step 1: processLines +-- +-- We process the input line by line. Each line modifies the +-- container stack, by adding a leaf to the current open container, +-- sometimes after closing old containers and/or opening new ones. +-- +-- To open a container is to add it to the top of the container stack, +-- so that new content will be added under this container. +-- To close a container is to remove it from the container stack and +-- make it a child of the container above it on the container stack. +-- +-- When all the input has been processed, we close all open containers +-- except the root (Document) container. At this point we should also +-- have a ReferenceMap containing any defined link references. +-- +-- Step 2: processDocument +-- +-- We then convert this container structure into an AST. This principally +-- involves (a) gathering consecutive ListItem containers into lists, (b) +-- gathering TextLine nodes that don't belong to verbatim containers into +-- paragraphs, and (c) parsing the inline contents of non-verbatim TextLines. + +-------- + +-- Container stack definitions: + +data ContainerStack = + ContainerStack Container {- top -} [Container] {- rest -} + +type LineNumber = Int + +-- Generic type for a container or a leaf. +data Elt = C Container + | L LineNumber Leaf + deriving Show + +data Container = Container{ + containerType :: ContainerType + , children :: Seq Elt + } + +data ContainerType = Document + | BlockQuote + | ListItem { markerColumn :: Int + , padding :: Int + , listType :: ListType } + | FencedCode { startColumn :: Int + , fence :: Text + , info :: Text } + | IndentedCode + | RawHtmlBlock + | Reference + deriving (Eq, Show) + +instance Show Container where + show c = show (containerType c) ++ "\n" ++ + nest 2 (intercalate "\n" (map showElt $ toList $ children c)) + +nest :: Int -> String -> String +nest num = intercalate "\n" . map ((replicate num ' ') ++) . lines + +showElt :: Elt -> String +showElt (C c) = show c +showElt (L _ (TextLine s)) = show s +showElt (L _ lf) = show lf + +-- Scanners that must be satisfied if the current open container +-- is to be continued on a new line (ignoring lazy continuations). +containerContinue :: Container -> Scanner +containerContinue c = + case containerType c of + BlockQuote -> scanNonindentSpace *> scanBlockquoteStart + IndentedCode -> scanIndentSpace + FencedCode{startColumn = col} -> + scanSpacesToColumn col + RawHtmlBlock -> nfb scanBlankline + li@ListItem{} -> scanBlankline + <|> + (do scanSpacesToColumn + (markerColumn li + 1) + upToCountChars (padding li - 1) + (==' ') + return ()) + Reference{} -> nfb scanBlankline >> + nfb (scanNonindentSpace *> scanReference) + _ -> return () +{-# INLINE containerContinue #-} + +-- Defines parsers that open new containers. +containerStart :: Bool -> Parser ContainerType +containerStart _lastLineIsText = scanNonindentSpace *> + ( (BlockQuote <$ scanBlockquoteStart) + <|> parseListMarker + ) + +-- Defines parsers that open new verbatim containers (containers +-- that take only TextLine and BlankLine as children). +verbatimContainerStart :: Bool -> Parser ContainerType +verbatimContainerStart lastLineIsText = scanNonindentSpace *> + ( parseCodeFence + <|> (guard (not lastLineIsText) *> (IndentedCode <$ char ' ' <* nfb scanBlankline)) + <|> (guard (not lastLineIsText) *> (RawHtmlBlock <$ parseHtmlBlockStart)) + <|> (guard (not lastLineIsText) *> (Reference <$ scanReference)) + ) + +-- Leaves of the container structure (they don't take children). +data Leaf = TextLine Text + | BlankLine Text + | ATXHeader Int Text + | SetextHeader Int Text + | Rule + deriving (Show) + +type ContainerM = RWS () ReferenceMap ContainerStack + +-- Close the whole container stack, leaving only the root Document container. +closeStack :: ContainerM Container +closeStack = do + ContainerStack top rest <- get + if null rest + then return top + else closeContainer >> closeStack + +-- Close the top container on the stack. If the container is a Reference +-- container, attempt to parse the reference and update the reference map. +-- If it is a list item container, move a final BlankLine outside the list +-- item. +closeContainer :: ContainerM () +closeContainer = do + ContainerStack top rest <- get + case top of + (Container Reference{} cs'') -> + case parse pReference + (T.strip $ joinLines $ map extractText $ toList cs'') of + Right (lab, lnk, tit) -> do + tell (M.singleton (normalizeReference lab) (lnk, tit)) + case rest of + (Container ct' cs' : rs) -> + put $ ContainerStack (Container ct' (cs' |> C top)) rs + [] -> return () + Left _ -> -- pass over in silence if ref doesn't parse? + case rest of + (c:cs) -> put $ ContainerStack c cs + [] -> return () + (Container li@ListItem{} cs'') -> + case rest of + -- move final BlankLine outside of list item + (Container ct' cs' : rs) -> + case viewr cs'' of + (zs :> b@(L _ BlankLine{})) -> + put $ ContainerStack + (if Seq.null zs + then Container ct' (cs' |> C (Container li zs)) + else Container ct' (cs' |> + C (Container li zs) |> b)) rs + _ -> put $ ContainerStack (Container ct' (cs' |> C top)) rs + [] -> return () + _ -> case rest of + (Container ct' cs' : rs) -> + put $ ContainerStack (Container ct' (cs' |> C top)) rs + [] -> return () + +-- Add a leaf to the top container. +addLeaf :: LineNumber -> Leaf -> ContainerM () +addLeaf lineNum lf = do + ContainerStack top rest <- get + case (top, lf) of + (Container ct@(ListItem{}) cs, BlankLine{}) -> + case viewr cs of + (_ :> L _ BlankLine{}) -> -- two blanks break out of list item: + closeContainer >> addLeaf lineNum lf + _ -> put $ ContainerStack (Container ct (cs |> L lineNum lf)) rest + (Container ct cs, _) -> + put $ ContainerStack (Container ct (cs |> L lineNum lf)) rest + +-- Add a container to the container stack. +addContainer :: ContainerType -> ContainerM () +addContainer ct = modify $ \(ContainerStack top rest) -> + ContainerStack (Container ct mempty) (top:rest) + +-- Step 2 + +-- Convert Document container and reference map into an AST. +processDocument :: (Container, ReferenceMap) -> Blocks +processDocument (Container ct cs, refmap) = + case ct of + Document -> processElts refmap (toList cs) + _ -> error "top level container is not Document" + +-- Turn the result of `processLines` into a proper AST. +-- This requires grouping text lines into paragraphs +-- and list items into lists, handling blank lines, +-- parsing inline contents of texts and resolving referencess. +processElts :: ReferenceMap -> [Elt] -> Blocks +processElts _ [] = mempty + +processElts refmap (L _lineNumber lf : rest) = + case lf of + -- Gobble text lines and make them into a Para: + TextLine t -> singleton (Para $ parseInlines refmap txt) <> + processElts refmap rest' + where txt = T.stripEnd $ joinLines $ map T.stripStart + $ t : map extractText textlines + (textlines, rest') = span isTextLine rest + isTextLine (L _ (TextLine _)) = True + isTextLine _ = False + + -- Blanks at outer level are ignored: + BlankLine{} -> processElts refmap rest + + -- Headers: + ATXHeader lvl t -> singleton (Header lvl $ parseInlines refmap t) <> + processElts refmap rest + SetextHeader lvl t -> singleton (Header lvl $ parseInlines refmap t) <> + processElts refmap rest + + -- Horizontal rule: + Rule -> singleton HRule <> processElts refmap rest + +processElts refmap (C (Container ct cs) : rest) = + case ct of + Document -> error "Document container found inside Document" + + BlockQuote -> singleton (Blockquote $ processElts refmap (toList cs)) <> + processElts refmap rest + + -- List item? Gobble up following list items of the same type + -- (skipping blank lines), determine whether the list is tight or + -- loose, and generate a List. + ListItem { listType = listType' } -> + singleton (List isTight listType' items') <> processElts refmap rest' + where xs = takeListItems rest + + rest' = drop (length xs) rest + + -- take list items as long as list type matches and we + -- don't hit two blank lines: + takeListItems + (C c@(Container ListItem { listType = lt' } _) : zs) + | listTypesMatch lt' listType' = C c : takeListItems zs + takeListItems (lf@(L _ (BlankLine _)) : + c@(C (Container ListItem { listType = lt' } _)) : zs) + | listTypesMatch lt' listType' = lf : c : takeListItems zs + takeListItems _ = [] + + listTypesMatch (Bullet c1) (Bullet c2) = c1 == c2 + listTypesMatch (Numbered w1 _) (Numbered w2 _) = w1 == w2 + listTypesMatch _ _ = False + + items = mapMaybe getItem (Container ct cs : [c | C c <- xs]) + + getItem (Container ListItem{} cs') = Just $ toList cs' + getItem _ = Nothing + + items' = map (processElts refmap) items + + isTight = tightListItem xs && all tightListItem items + + FencedCode _ _ info' -> singleton (CodeBlock attr txt) <> + processElts refmap rest + where txt = joinLines $ map extractText $ toList cs + attr = CodeAttr x (T.strip y) + (x,y) = T.break (==' ') info' + + IndentedCode -> singleton (CodeBlock (CodeAttr "" "") txt) + <> processElts refmap rest' + where txt = joinLines $ stripTrailingEmpties + $ concatMap extractCode cbs + + stripTrailingEmpties = reverse . + dropWhile (T.all (==' ')) . reverse + + -- explanation for next line: when we parsed + -- the blank line, we dropped 0-3 spaces. + -- but for this, code block context, we want + -- to have dropped 4 spaces. we simply drop + -- one more: + extractCode (L _ (BlankLine t)) = [T.drop 1 t] + extractCode (C (Container IndentedCode cs')) = + map extractText $ toList cs' + extractCode _ = [] + + (cbs, rest') = span isIndentedCodeOrBlank + (C (Container ct cs) : rest) + + isIndentedCodeOrBlank (L _ BlankLine{}) = True + isIndentedCodeOrBlank (C (Container IndentedCode _)) + = True + isIndentedCodeOrBlank _ = False + + RawHtmlBlock -> singleton (HtmlBlock txt) <> processElts refmap rest + where txt = joinLines (map extractText (toList cs)) + + -- References have already been taken into account in the reference map, + -- so we just skip. + Reference{} -> processElts refmap rest + + where isBlankLine (L _ BlankLine{}) = True + isBlankLine _ = False + + tightListItem [] = True + tightListItem xs = not $ any isBlankLine xs + +extractText :: Elt -> Text +extractText (L _ (TextLine t)) = t +extractText _ = mempty + +-- Step 1 + +processLines :: Text -> (Container, ReferenceMap) +processLines t = (doc, refmap) + where + (doc, refmap) = evalRWS (mapM_ processLine lns >> closeStack) () startState + lns = zip [1..] (map tabFilter $ T.lines t) + startState = ContainerStack (Container Document mempty) [] + +-- The main block-parsing function. +-- We analyze a line of text and modify the container stack accordingly, +-- adding a new leaf, or closing or opening containers. +processLine :: (LineNumber, Text) -> ContainerM () +processLine (lineNumber, txt) = do + ContainerStack top@(Container ct cs) rest <- get + + -- Apply the line-start scanners appropriate for each nested container. + -- Return the remainder of the string, and the number of unmatched + -- containers. + let (t', numUnmatched) = tryOpenContainers (reverse $ top:rest) txt + + -- Some new containers can be started only after a blank. + let lastLineIsText = numUnmatched == 0 && + case viewr cs of + (_ :> L _ (TextLine _)) -> True + _ -> False + + -- Process the rest of the line in a way that makes sense given + -- the container type at the top of the stack (ct): + case ct of + -- If it's a verbatim line container, add the line. + RawHtmlBlock{} | numUnmatched == 0 -> addLeaf lineNumber (TextLine t') + IndentedCode | numUnmatched == 0 -> addLeaf lineNumber (TextLine t') + FencedCode{ fence = fence' } -> + -- here we don't check numUnmatched because we allow laziness + if fence' `T.isPrefixOf` t' + -- closing code fence + then closeContainer + else addLeaf lineNumber (TextLine t') + + -- otherwise, parse the remainder to see if we have new container starts: + _ -> case tryNewContainers lastLineIsText (T.length txt - T.length t') t' of + + -- lazy continuation: text line, last line was text, no new containers, + -- some unmatched containers: + ([], TextLine t) + | numUnmatched > 0 + , case viewr cs of + (_ :> L _ (TextLine _)) -> True + _ -> False + , ct /= IndentedCode -> addLeaf lineNumber (TextLine t) + + -- if it's a setext header line and the top container has a textline + -- as last child, add a setext header: + ([], SetextHeader lev _) | numUnmatched == 0 -> + case viewr cs of + (cs' :> L _ (TextLine t)) -> -- replace last text line with setext header + put $ ContainerStack (Container ct + (cs' |> L lineNumber (SetextHeader lev t))) rest + -- Note: the following case should not occur, since + -- we don't add a SetextHeader leaf unless lastLineIsText. + _ -> error "setext header line without preceding text line" + + -- otherwise, close all the unmatched containers, add the new + -- containers, and finally add the new leaf: + (ns, lf) -> do -- close unmatched containers, add new ones + replicateM numUnmatched closeContainer + mapM_ addContainer ns + case (reverse ns, lf) of + -- don't add extra blank at beginning of fenced code block + (FencedCode{}:_, BlankLine{}) -> return () + _ -> addLeaf lineNumber lf + +-- Try to match the scanners corresponding to any currently open containers. +-- Return remaining text after matching scanners, plus the number of open +-- containers whose scanners did not match. (These will be closed unless +-- we have a lazy text line.) +tryOpenContainers :: [Container] -> Text -> (Text, Int) +tryOpenContainers cs t = case parse (scanners $ map containerContinue cs) t of + Right (t', n) -> (t', n) + Left e -> error $ "error parsing scanners: " ++ + show e + where scanners [] = (,) <$> takeText <*> pure 0 + scanners (p:ps) = (p *> scanners ps) + <|> ((,) <$> takeText <*> pure (length (p:ps))) + +-- Try to match parsers for new containers. Return list of new +-- container types, and the leaf to add inside the new containers. +tryNewContainers :: Bool -> Int -> Text -> ([ContainerType], Leaf) +tryNewContainers lastLineIsText offset t = + case parse newContainers t of + Right (cs,t') -> (cs, t') + Left err -> error (show err) + where newContainers = do + getPosition >>= \pos -> setPosition pos{ column = offset + 1 } + regContainers <- many (containerStart lastLineIsText) + verbatimContainers <- option [] + $ count 1 (verbatimContainerStart lastLineIsText) + if null verbatimContainers + then (,) <$> pure regContainers <*> leaf lastLineIsText + else (,) <$> pure (regContainers ++ verbatimContainers) <*> + textLineOrBlank + +textLineOrBlank :: Parser Leaf +textLineOrBlank = consolidate <$> takeText + where consolidate ts | T.all (==' ') ts = BlankLine ts + | otherwise = TextLine ts + +-- Parse a leaf node. +leaf :: Bool -> Parser Leaf +leaf lastLineIsText = scanNonindentSpace *> ( + (ATXHeader <$> parseAtxHeaderStart <*> + (T.strip . removeATXSuffix <$> takeText)) + <|> (guard lastLineIsText *> (SetextHeader <$> parseSetextHeaderLine <*> pure mempty)) + <|> (Rule <$ scanHRuleLine) + <|> textLineOrBlank + ) + where removeATXSuffix t = case T.dropWhileEnd (`elem` " #") t of + t' | T.null t' -> t' + -- an escaped \# + | T.last t' == '\\' -> t' <> "#" + | otherwise -> t' + +-- Scanners + +scanReference :: Scanner +scanReference = () <$ lookAhead (pLinkLabel >> scanChar ':') + +-- Scan the beginning of a blockquote: up to three +-- spaces indent, the `>` character, and an optional space. +scanBlockquoteStart :: Scanner +scanBlockquoteStart = scanChar '>' >> option () (scanChar ' ') + +-- Parse the sequence of `#` characters that begins an ATX +-- header, and return the number of characters. We require +-- a space after the initial string of `#`s, as not all markdown +-- implementations do. This is because (a) the ATX reference +-- implementation requires a space, and (b) since we're allowing +-- headers without preceding blank lines, requiring the space +-- avoids accidentally capturing a line like `#8 toggle bolt` as +-- a header. +parseAtxHeaderStart :: Parser Int +parseAtxHeaderStart = do + char '#' + hashes <- upToCountChars 5 (== '#') + -- hashes must be followed by space unless empty header: + notFollowedBy (skip (/= ' ')) + return $ T.length hashes + 1 + +parseSetextHeaderLine :: Parser Int +parseSetextHeaderLine = do + d <- satisfy (\c -> c == '-' || c == '=') + let lev = if d == '=' then 1 else 2 + skipWhile (== d) + scanBlankline + return lev + +-- Scan a horizontal rule line: "...three or more hyphens, asterisks, +-- or underscores on a line by themselves. If you wish, you may use +-- spaces between the hyphens or asterisks." +scanHRuleLine :: Scanner +scanHRuleLine = do + c <- satisfy (\c -> c == '*' || c == '_' || c == '-') + count 2 $ scanSpaces >> skip (== c) + skipWhile (\x -> x == ' ' || x == c) + endOfInput + +-- Parse an initial code fence line, returning +-- the fence part and the rest (after any spaces). +parseCodeFence :: Parser ContainerType +parseCodeFence = do + col <- column <$> getPosition + cs <- takeWhile1 (=='`') <|> takeWhile1 (=='~') + guard $ T.length cs >= 3 + scanSpaces + rawattr <- takeWhile (\c -> c /= '`' && c /= '~') + endOfInput + return $ FencedCode { startColumn = col + , fence = cs + , info = rawattr } + +-- Parse the start of an HTML block: either an HTML tag or an +-- HTML comment, with no indentation. +parseHtmlBlockStart :: Parser () +parseHtmlBlockStart = () <$ lookAhead + ((do t <- pHtmlTag + guard $ f $ fst t + return $ snd t) + <|> string "" + ) + where f (Opening name) = name `Set.member` blockHtmlTags + f (SelfClosing name) = name `Set.member` blockHtmlTags + f (Closing name) = name `Set.member` blockHtmlTags + +-- List of block level tags for HTML 5. +blockHtmlTags :: Set.Set Text +blockHtmlTags = Set.fromList + [ "article", "header", "aside", "hgroup", "blockquote", "hr", + "body", "li", "br", "map", "button", "object", "canvas", "ol", + "caption", "output", "col", "p", "colgroup", "pre", "dd", + "progress", "div", "section", "dl", "table", "dt", "tbody", + "embed", "textarea", "fieldset", "tfoot", "figcaption", "th", + "figure", "thead", "footer", "footer", "tr", "form", "ul", + "h1", "h2", "h3", "h4", "h5", "h6", "video"] + +-- Parse a list marker and return the list type. +parseListMarker :: Parser ContainerType +parseListMarker = do + col <- column <$> getPosition + ty <- parseBullet <|> parseListNumber + -- padding is 1 if list marker followed by a blank line + -- or indented code. otherwise it's the length of the + -- whitespace between the list marker and the following text: + padding' <- (1 <$ scanBlankline) + <|> (1 <$ (skip (==' ') *> lookAhead (count 4 (char ' ')))) + <|> (T.length <$> takeWhile (==' ')) + -- text can't immediately follow the list marker: + guard $ padding' > 0 + return $ ListItem { listType = ty + , markerColumn = col + , padding = padding' + listMarkerWidth ty + } + +listMarkerWidth :: ListType -> Int +listMarkerWidth (Bullet _) = 1 +listMarkerWidth (Numbered _ n) | n < 10 = 2 + | n < 100 = 3 + | n < 1000 = 4 + | otherwise = 5 + +-- Parse a bullet and return list type. +parseBullet :: Parser ListType +parseBullet = do + c <- satisfy (\c -> c == '+' || c == '*' || c == '-') + unless (c == '+') + $ nfb $ (count 2 $ scanSpaces >> skip (== c)) >> + skipWhile (\x -> x == ' ' || x == c) >> endOfInput -- hrule + return $ Bullet c + +-- Parse a list number marker and return list type. +parseListNumber :: Parser ListType +parseListNumber = do + num <- (read . T.unpack) <$> takeWhile1 isDigit + wrap <- PeriodFollowing <$ skip (== '.') + <|> ParenFollowing <$ skip (== ')') + return $ Numbered wrap num diff --git a/Cheapskate/ParserCombinators.hs b/Cheapskate/ParserCombinators.hs new file mode 100644 --- /dev/null +++ b/Cheapskate/ParserCombinators.hs @@ -0,0 +1,297 @@ +module Cheapskate.ParserCombinators ( + Position(..) + , Parser + , parse + , satisfy + , peekChar + , peekLastChar + , notAfter + , inClass + , notInClass + , endOfInput + , char + , anyChar + , getPosition + , setPosition + , takeWhile + , takeTill + , takeWhile1 + , takeText + , skip + , skipWhile + , string + , scan + , lookAhead + , notFollowedBy + , option + , many1 + , manyTill + , skipMany + , skipMany1 + , count + ) where +import Prelude hiding (takeWhile) +import Data.Text (Text) +import qualified Data.Text as T +import Control.Monad +import Control.Applicative +import qualified Data.Set as Set + +data Position = Position { line :: Int, column :: Int } + +instance Show Position where + show (Position ln cn) = "line " ++ show ln ++ " column " ++ show cn + +data ParseError = ParseError Position String deriving Show + +data ParserState = ParserState { subject :: Text + , position :: Position + , lastChar :: Maybe Char + } + +advance :: ParserState -> Text -> ParserState +advance = T.foldl' go + where go :: ParserState -> Char -> ParserState + go st c = st{ subject = T.drop 1 (subject st) + , position = case c of + '\n' -> Position { line = + line (position st) + 1 + , column = 1 } + _ -> Position { line = + line (position st) + , column = + column (position st) + 1 + } + , lastChar = Just c } + +newtype Parser a = Parser { + evalParser :: ParserState -> Either ParseError (ParserState, a) + } + +instance Functor Parser where + fmap f (Parser g) = Parser $ \st -> + case g st of + Right (st', x) -> Right (st', f x) + Left e -> Left e + {-# INLINE fmap #-} + +instance Applicative Parser where + pure x = Parser $ \st -> Right (st, x) + (Parser f) <*> (Parser g) = Parser $ \st -> + case f st of + Left e -> Left e + Right (st', h) -> case g st' of + Right (st'', x) -> Right (st'', h x) + Left e -> Left e + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + +instance Alternative Parser where + empty = Parser $ \st -> Left $ ParseError (position st) "empty" + (Parser f) <|> (Parser g) = Parser $ \st -> + case f st of + Right res -> Right res + _ -> g st + {-# INLINE empty #-} + {-# INLINE (<|>) #-} + +instance Monad Parser where + return x = Parser $ \st -> Right (st, x) + fail e = Parser $ \st -> Left $ ParseError (position st) e + p >>= g = Parser $ \st -> + case evalParser p st of + Left e -> Left e + Right (st',x) -> evalParser (g x) st' + {-# INLINE return #-} + {-# INLINE (>>=) #-} + +instance MonadPlus Parser where + mzero = Parser $ \st -> Left $ ParseError (position st) "mzero" + mplus p1 p2 = Parser $ \st -> + case evalParser p1 st of + Right res -> Right res + Left _ -> evalParser p2 st + {-# INLINE mzero #-} + {-# INLINE mplus #-} + +parse :: Parser a -> Text -> Either ParseError a +parse p t = + fmap snd $ evalParser p ParserState{ subject = t + , position = Position 1 1 + , lastChar = Nothing } + +failure :: ParserState -> String -> Either ParseError (ParserState, a) +failure st msg = Left $ ParseError (position st) msg +{-# INLINE failure #-} + +success :: ParserState -> a -> Either ParseError (ParserState, a) +success st x = Right (st, x) +{-# INLINE success #-} + +satisfy :: (Char -> Bool) -> Parser Char +satisfy f = Parser g + where g st = case T.uncons (subject st) of + Just (c, _) | f c -> + success (advance st (T.singleton c)) c + _ -> failure st "satisfy" +{-# INLINE satisfy #-} + +peekChar :: Parser (Maybe Char) +peekChar = Parser $ \st -> + case T.uncons (subject st) of + Just (c, _) -> success st (Just c) + Nothing -> success st Nothing +{-# INLINE peekChar #-} + +peekLastChar :: Parser (Maybe Char) +peekLastChar = Parser $ \st -> success st (lastChar st) +{-# INLINE peekLastChar #-} + +notAfter :: (Char -> Bool) -> Parser () +notAfter f = do + mbc <- peekLastChar + case mbc of + Nothing -> return () + Just c -> if f c then mzero else return () + +-- low-grade version of attoparsec's: +charClass :: String -> Set.Set Char +charClass = Set.fromList . go + where go (a:'-':b:xs) = [a..b] ++ go xs + go (x:xs) = x : go xs + go _ = "" +{-# INLINE charClass #-} + +inClass :: String -> Char -> Bool +inClass s c = c `Set.member` s' + where s' = charClass s +{-# INLINE inClass #-} + +notInClass :: String -> Char -> Bool +notInClass s = not . inClass s +{-# INLINE notInClass #-} + +endOfInput :: Parser () +endOfInput = Parser $ \st -> + if T.null (subject st) + then success st () + else failure st "endOfInput" +{-# INLINE endOfInput #-} + +char :: Char -> Parser Char +char c = satisfy (== c) +{-# INLINE char #-} + +anyChar :: Parser Char +anyChar = satisfy (const True) +{-# INLINE anyChar #-} + +getPosition :: Parser Position +getPosition = Parser $ \st -> success st (position st) +{-# INLINE getPosition #-} + +-- note: this does not actually change the position in the subject; +-- it only changes what column counts as column N. It is intended +-- to be used in cases where we're parsing a partial line but need to +-- have accurate column information. +setPosition :: Position -> Parser () +setPosition pos = Parser $ \st -> success st{ position = pos } () +{-# INLINE setPosition #-} + +takeWhile :: (Char -> Bool) -> Parser Text +takeWhile f = Parser $ \st -> + let t = T.takeWhile f (subject st) in + success (advance st t) t +{-# INLINE takeWhile #-} + +takeTill :: (Char -> Bool) -> Parser Text +takeTill f = takeWhile (not . f) +{-# INLINE takeTill #-} + +takeWhile1 :: (Char -> Bool) -> Parser Text +takeWhile1 f = Parser $ \st -> + case T.takeWhile f (subject st) of + t | T.null t -> failure st "takeWhile1" + | otherwise -> success (advance st t) t +{-# INLINE takeWhile1 #-} + +takeText :: Parser Text +takeText = Parser $ \st -> + let t = subject st in + success (advance st t) t +{-# INLINE takeText #-} + +skip :: (Char -> Bool) -> Parser () +skip f = Parser $ \st -> + case T.uncons (subject st) of + Just (c,_) | f c -> success (advance st (T.singleton c)) () + _ -> failure st "skip" +{-# INLINE skip #-} + +skipWhile :: (Char -> Bool) -> Parser () +skipWhile f = Parser $ \st -> + let t' = T.takeWhile f (subject st) in + success (advance st t') () +{-# INLINE skipWhile #-} + +string :: Text -> Parser Text +string s = Parser $ \st -> + if s `T.isPrefixOf` (subject st) + then success (advance st s) s + else failure st "string" +{-# INLINE string #-} + +scan :: s -> (s -> Char -> Maybe s) -> Parser Text +scan s0 f = Parser $ go s0 [] + where go s cs st = + case T.uncons (subject st) of + Nothing -> finish st cs + Just (c, _) -> case f s c of + Just s' -> go s' (c:cs) + (advance st (T.singleton c)) + Nothing -> finish st cs + finish st cs = + success st (T.pack (reverse cs)) +{-# INLINE scan #-} + +lookAhead :: Parser a -> Parser a +lookAhead p = Parser $ \st -> + case evalParser p st of + Right (_,x) -> success st x + Left _ -> failure st "lookAhead" +{-# INLINE lookAhead #-} + +notFollowedBy :: Parser a -> Parser () +notFollowedBy p = Parser $ \st -> + case evalParser p st of + Right (_,_) -> failure st "notFollowedBy" + Left _ -> success st () +{-# INLINE notFollowedBy #-} + +-- combinators (definitions borrowed from attoparsec) + +option :: Alternative f => a -> f a -> f a +option x p = p <|> pure x +{-# INLINE option #-} + +many1 :: Alternative f => f a -> f [a] +many1 p = liftA2 (:) p (many p) +{-# INLINE many1 #-} + +manyTill :: Alternative f => f a -> f b -> f [a] +manyTill p end = go + where go = (end *> pure []) <|> liftA2 (:) p go +{-# INLINE manyTill #-} + +skipMany :: Alternative f => f a -> f () +skipMany p = go + where go = (p *> go) <|> pure () +{-# INLINE skipMany #-} + +skipMany1 :: Alternative f => f a -> f () +skipMany1 p = p *> skipMany p +{-# INLINE skipMany1 #-} + +count :: Monad m => Int -> m a -> m [a] +count n p = sequence (replicate n p) +{-# INLINE count #-} diff --git a/Cheapskate/Types.hs b/Cheapskate/Types.hs new file mode 100644 --- /dev/null +++ b/Cheapskate/Types.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Cheapskate.Types where +import Data.Sequence (Seq) +import Data.Default +import Data.Text (Text) +import qualified Data.Map as M +import Data.Data + +-- | Structured representation of a document. The 'Options' affect +-- how the document is rendered by `toHtml`. +data Doc = Doc Options Blocks + deriving (Show, Data, Typeable) + +-- | Block-level elements. +data Block = Para Inlines + | Header Int Inlines + | Blockquote Blocks + | List Bool ListType [Blocks] + | CodeBlock CodeAttr Text + | HtmlBlock Text + | HRule + deriving (Show, Data, Typeable) + +-- | Attributes for fenced code blocks. 'codeLang' is the +-- first word of the attribute line, 'codeInfo' is the rest. +data CodeAttr = CodeAttr { codeLang :: Text, codeInfo :: Text } + deriving (Show, Data, Typeable) + +data ListType = Bullet Char | Numbered NumWrapper Int deriving (Eq,Show,Data,Typeable) +data NumWrapper = PeriodFollowing | ParenFollowing deriving (Eq,Show,Data,Typeable) + +-- | Simple representation of HTML tag. +data HtmlTagType = Opening Text | Closing Text | SelfClosing Text deriving (Show, Data, Typeable) + +-- We operate with sequences instead of lists, because +-- they allow more efficient appending on to the end. +type Blocks = Seq Block + +-- | Inline elements. +data Inline = Str Text + | Space + | SoftBreak + | LineBreak + | Emph Inlines + | Strong Inlines + | Code Text + | Link Inlines Text {- URL -} Text {- title -} + | Image Inlines Text {- URL -} Text {- title -} + | Entity Text + | RawHtml Text + deriving (Show, Data, Typeable) + +type Inlines = Seq Inline + +type ReferenceMap = M.Map Text (Text, Text) + +-- | Rendering and parsing options. +data Options = Options{ + sanitize :: Bool -- ^ Sanitize raw HTML, link/image attributes + , allowRawHtml :: Bool -- ^ Allow raw HTML (if false it gets escaped) + , preserveHardBreaks :: Bool -- ^ Preserve hard line breaks in the source + , debug :: Bool -- ^ Print container structure for debugging + } + deriving (Show, Data, Typeable) + +instance Default Options where + def = Options{ + sanitize = True + , allowRawHtml = True + , preserveHardBreaks = False + , debug = False + } + diff --git a/Cheapskate/Util.hs b/Cheapskate/Util.hs new file mode 100644 --- /dev/null +++ b/Cheapskate/Util.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cheapskate.Util ( + joinLines + , tabFilter + , isWhitespace + , isEscapable + , normalizeReference + , Scanner + , scanIndentSpace + , scanNonindentSpace + , scanSpacesToColumn + , scanChar + , scanBlankline + , scanSpaces + , scanSpnl + , nfb + , nfbChar + , upToCountChars + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Char +import Control.Applicative +import Cheapskate.ParserCombinators + +-- Utility functions. + +-- Like T.unlines but does not add a final newline. +-- Concatenates lines with newlines between. +joinLines :: [Text] -> Text +joinLines = T.intercalate "\n" + +-- Convert tabs to spaces using a 4-space tab stop. +tabFilter :: Text -> Text +tabFilter = T.concat . pad . T.split (== '\t') + where pad [] = [] + pad [t] = [t] + pad (t:ts) = let tl = T.length t + n = tl + 4 - (tl `mod` 4) + in T.justifyLeft n ' ' t : pad ts + +-- These are the whitespace characters that are significant in +-- parsing markdown. We can treat \160 (nonbreaking space) etc. +-- as regular characters. This function should be considerably +-- faster than the unicode-aware isSpace from Data.Char. +isWhitespace :: Char -> Bool +isWhitespace ' ' = True +isWhitespace '\t' = True +isWhitespace '\n' = True +isWhitespace '\r' = True +isWhitespace _ = False + +-- The original Markdown only allowed certain symbols +-- to be backslash-escaped. It was hard to remember +-- which ones could be, so we now allow any ascii punctuation mark or +-- symbol to be escaped, whether or not it has a use in Markdown. +isEscapable :: Char -> Bool +isEscapable c = isAscii c && (isSymbol c || isPunctuation c) + +-- Link references are case sensitive and ignore line breaks +-- and repeated spaces. +-- So, [APPLES are good] == [Apples are good] == +-- [Apples +-- are good]. +normalizeReference :: Text -> Text +normalizeReference = T.toCaseFold . T.concat . T.split isWhitespace + +-- Scanners are implemented here as attoparsec parsers, +-- which consume input and capture nothing. They could easily +-- be implemented as regexes in other languages, or hand-coded. +-- With the exception of scanSpnl, they are all intended to +-- operate on a single line of input (so endOfInput = endOfLine). +type Scanner = Parser () + +-- Scan four spaces. +scanIndentSpace :: Scanner +scanIndentSpace = () <$ count 4 (skip (==' ')) + +scanSpacesToColumn :: Int -> Scanner +scanSpacesToColumn col = do + currentCol <- column <$> getPosition + case col - currentCol of + n | n >= 1 -> () <$ (count n (skip (==' '))) + | otherwise -> return () + +-- Scan 0-3 spaces. +scanNonindentSpace :: Scanner +scanNonindentSpace = () <$ upToCountChars 3 (==' ') + +-- Scan a specified character. +scanChar :: Char -> Scanner +scanChar c = skip (== c) >> return () + +-- Scan a blankline. +scanBlankline :: Scanner +scanBlankline = scanSpaces *> endOfInput + +-- Scan 0 or more spaces +scanSpaces :: Scanner +scanSpaces = skipWhile (==' ') + +-- Scan 0 or more spaces, and optionally a newline +-- and more spaces. +scanSpnl :: Scanner +scanSpnl = scanSpaces *> option () (char '\n' *> scanSpaces) + +-- Not followed by: Succeed without consuming input if the specified +-- scanner would not succeed. +nfb :: Parser a -> Scanner +nfb = notFollowedBy + +-- Succeed if not followed by a character. Consumes no input. +nfbChar :: Char -> Scanner +nfbChar c = nfb (skip (==c)) + +upToCountChars :: Int -> (Char -> Bool) -> Parser Text +upToCountChars cnt f = + scan 0 (\n c -> if n < cnt && f c then Just (n+1) else Nothing) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,338 @@ +# Cheapskate + +This is an experimental Markdown processor in pure Haskell. (A cheapskate is +always in search of the best markdown.) It aims to process Markdown efficiently +and in the most forgiving possible way. It is about seven times faster than +`pandoc` and uses a fifth the memory. It is also faster, and considerably +more accurate, than the `markdown` package on Hackage. + +There is no such thing as an invalid Markdown document. Any string of +characters is valid Markdown. So the processor should finish efficiently no +matter what input it gets. Garbage in should not cause an error or exponential +slowdowns. This processor has been tested on many large inputs consisting of +random strings of characters, with performance that is consistently linear with +the input size. (Try `make fuzztest`.) + +## Installing + +To build, get the Haskell Platform, then: + + cabal update && cabal install + +This will install both the `cheapskate` executable and the Haskell +library. A man page can be found in `man/man1` in the source. + +## Usage + +As an executable: + + cheapskate [FILE*] + +As a library: + +``` haskell +import Cheapskate +import Text.Blaze.Html + +toMarkdown :: Text -> Html +toMarkdown = toHtml . markdown def +``` + +If the markdown input you are converting comes from an untrusted source +(e.g. a web form), you should *always* set `sanitize` to `True`. This causes +the generated HTML to be filtered through `xss-sanitize`'s +`sanitizeBalance` function. Otherwise you risk a XSS attack from +raw HTML or a markdown link or image attribute attribute. + +You may also wish to disallow users from entering raw HTML for aesthetic, +rather than security reasons. In that case, set `allowRawHtml` to `True`, +but let `sanitize` stay `True`, since it still affects attributes coming +from markdown links and images. + +## Manipulating the parsed document + +You can manipulate the parsed document before rendering using the `walk` +and `walkM` functions. For example, you might want to highlight code blocks +using highlighting-kate: + +``` haskell +import Data.Text as T +import Data.Text.Lazy as TL +import Cheapskate +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Text +import Text.Highlighting.Kate + +markdownWithHighlighting :: Text -> Html +markdownWithHighlighting = toHtml . walk addHighlighting . markdown def + +addHighlighting :: Block -> Block +addHighlighting (CodeBlock (CodeAttr lang _) t) = + HtmlBlock (T.concat $ TL.toChunks + $ renderHtml $ toHtml + $ formatHtmlBlock defaultFormatOpts + $ highlightAs (T.unpack lang) (T.unpack t)) +addHighlighting x = x +``` + +## Extensions + +This processor adds the following Markdown extensions: + +### Hyperlinked URLs + +All absolute URLs are automatically made into hyperlinks, where +inside `<>` or not. + +### Fenced code blocks + +Fenced code blocks with attributes are allowed. These begin with +a line of three or more backticks or tildes, followed by an +optional language name and possibly other metadata. They end +with a line of backticks or tildes (the same character as started +the code block) of at least the length of the starting line. + +### Explicit hard line breaks + +A hard line break can be indicated with a backslash before a +newline. The standard method of two spaces before a newline also +works, but this gives a more "visible" alternative. + +### Backslash escapes + +All ASCII symbols and punctuation marks can be backslash-escaped, +not just those with a use in Markdown. + +## Revisions + +In departs from the markdown syntax document in the following ways: + +### Intraword emphasis + +Underscores cannot be used for word-internal emphasis. This +prevents common mistakes with filenames, usernames, and indentifiers. +Asterisks can still be used if word in*ter*nal emphasis is needed. + +The exact rule is this: an underscore that appears directly after +an alphanumeric character does not begin an emphasized span. (However, +an underscore directly before an alphanumeric can end an emphasized +span.) + +### Ordered lists + +The starting number of an ordered list is now significant. +Other numbers are ignored, so you can still use `1.` for each +list item. + +In addition to the `1.` form, you can use `1)` in your ordered lists. +A new list starts if you change the form of the delimiter. So, the +following is two lists: + + 1. one + 2. two + 1) one + 2) two + +### Bullet lists + +A new bullet lists starts if you change the bullet marker. +So, the following is two consecutive bullet lists: + + + one + + two + - one + - two + +### List separation + +Two blank lines breaks out of a list. This allows you to +have consecutive lists: + + - one + + - two + + + - one (new list) + +The blank lines break out of a list no matter how deeply it +is nested: + + - one + - two + - three + + + - new top-level list + +### Indentation of list continuations + +Block elements inside list items need not be indented four +spaces. If they are indented beyond the bullet or numerical +list marker, they will be considered additional blocks inside +the list item. So, the following is a list item with two paragraphs: + + - one + + two + +The amount of indentation required for an indented code block +inside a list item depends on the first line of the list item. +Generally speaking, code must be indented four spaces past the +first non-space character after the list marker. Thus: + + - My code + + {code here} + + - My code + + {code here} + +The following diagram shows how the first line of a list item +divides the following lines into three regions: + + - My code + | | + +-----+ + +Content to the left of the marked region will not be part of the list +item. Content to the right of the marked region will be indented code +under the list item. Regular blocks that belong under the +list item should start inside the marked region. + +When the first line itself contains indented code, this code +and subsequent indented code blocks should be indented five spaces past the +list marker: + + - { code } + + { more code } + +### Raw HTML blocks + +Raw HTML blocks work a bit differently than in `Markdown.pl`. +A raw HTML block starts with a block-level HTML tag (opening or +closing), or a comment start ``, and goes until +the next blank line. The whole block is included as raw HTML. +No attempt is made to parse balanced tags. This means that +in the following, the asterisks are literal asterisks: + +
+ *hello* +
+ +while in the following, the asterisks are interpreted as markdown +emphasis: + +
+ + *hello* + +
+ +In the first example, we have a single raw HTML block; in the second, +we have two raw HTML blocks with an intervening paragraph. This system +provides flexibility to authors to use enclose markdown sections +in html block-level tags if they wish, while also allowing them +to include verbatim HTML blocks (taking care that the don't include +any blank lines). + +As a consequence of this rule, HTML blocks may not contain blank lines. + +## Clarifications + +This implementation resolves the following issues left vague in the markdown +syntax document: + +### Tight vs. loose lists + +A list is considered "tight" if (a) it has only one item or +there is no blank space between any two consecutive items, and +(b) no item has blank lines as its immediate children. +If a list is "tight," then list items consisting of a single +paragraph or a paragraph followed by a sublist will be rendered +without `

` tags. + +### Sublists + +Sublists work like other block elements inside list items; +they must be indented past the bullet or numerical list marker +(but no more than three spaces past, or they will be interpreted +as indented code). + +### ATX headers + +ATX headers must have a space after the initial `###`s. + +### Separation of block quotes + +A blank line will end a blockquote. So, the following is a single +blockquote: + + > hi + > + > there + +But this is two blockquotes: + + > hi + + > there + +Blank lines are not required before horizontal rules, blockquotes, +lists, code blocks, or headers. They are not required after, either, +though in many cases "laziness" will effectively require a blank +line after. For example, in + + Hello there. + > A quote. + Still a quote. + +the "Still a quote." is part of the block quote, because of laziness +(the ability to leave off the > from the beginning of subsequent +lines). Laziness also affects lists. However, we can have a code +block, ATX header, or horizontal rule between two paragraphs without any +blank lines. + +### Link references + +Link references may occur anywhere in the document, even in nested +list contexts. They need not be at the outer level. + +## Tests + +The `tests` subdirectory contains an extensive suite of tests, +including all of John Gruber's original Markdown tests, plus +many of the tests from Michel Fortin's `mdtest` suite. Each +test consists in two files with the same basename, a markdown +source and an expected HTML output. + +To run the test suite, do + + make test + +To run only tests that match a regex pattern, do + + PATT=Orig make test + +Setting the environment variable `TIDY=1` will run the expected and +actual output through tidy before comparing them. You can run this +test suite on another markdown processor by doing + + PROG=myothermarkdown make test + +## Benchmarks + +To run a crude benchmark comparing `cheapskate` to `pandoc`, do +`make bench`. Set the `BENCHPROGS` environment variable to +compare to other implementations. + +## License + +Copyright © 2012, 2013, 2014 John MacFarlane. + +The library is released under the BSD license; see LICENSE for terms. + +Some of the test cases are borrowed from Michel Fortin's mdtest suite +and John Gruber's original markdown test suite. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bin/main.hs b/bin/main.hs new file mode 100644 --- /dev/null +++ b/bin/main.hs @@ -0,0 +1,57 @@ +module Main where + +import Cheapskate +import Text.Blaze.Html.Renderer.Utf8 (renderHtmlToByteStringIO) +import Text.Blaze.Html +import System.Environment +import Data.Text (Text) +import qualified Data.ByteString as B +import qualified Data.Text.IO as T +import qualified Data.Text as T +import System.Console.GetOpt +import System.IO (stderr, hPutStr) +import System.Exit +import Data.Version (showVersion) +import Paths_cheapskate (version) +import Control.Monad + +convert :: [Option] -> Text -> IO () +convert opts t = renderHtmlToByteStringIO B.putStr $ toHtml $ + markdown def{ sanitize = Sanitize `elem` opts + , allowRawHtml = EscapeRawHtml `notElem` opts + , preserveHardBreaks = HardBreaks `elem` opts + , debug = Debug `elem` opts + } t + +main :: IO () +main = do + argv <- getArgs + let (flags, args, errs) = getOpt Permute options argv + let header = "Usage: citeproc [OPTION..] [FILE..]" + unless (null errs) $ do + hPutStr stderr $ usageInfo (unlines $ errs ++ [header]) options + exitWith $ ExitFailure 1 + when (Version `elem` flags) $ do + putStrLn $ "biblio2yaml " ++ showVersion version + exitWith ExitSuccess + when (Help `elem` flags) $ do + putStrLn $ usageInfo header options + exitWith ExitSuccess + let handle = convert flags + case args of + [] -> T.getContents >>= handle + _ -> mapM T.readFile args >>= handle . T.unlines + +data Option = + Help | Version | Debug | Sanitize | EscapeRawHtml | HardBreaks + deriving (Ord, Eq, Show) + +options :: [OptDescr Option] +options = + [ Option ['h'] ["help"] (NoArg Help) "show usage information" + , Option ['V'] ["version"] (NoArg Version) "show program version" + , Option [] ["debug"] (NoArg Debug) "print container structure" + , Option ['s'] ["sanitize"] (NoArg Sanitize) "sanitize output" + , Option ['e'] ["escape-raw-html"] (NoArg EscapeRawHtml) "escape raw HTML" + , Option ['b'] ["hard-line-breaks"] (NoArg HardBreaks) "treat newlines as hard breaks" + ] diff --git a/cheapskate.cabal b/cheapskate.cabal new file mode 100644 --- /dev/null +++ b/cheapskate.cabal @@ -0,0 +1,62 @@ +name: cheapskate +version: 0.1 +synopsis: Experimental markdown processor. +description: This is an experimental Markdown processor in pure + Haskell. It aims to process Markdown efficiently and in + the most forgiving possible way. It is designed to deal + with any input, including garbage, with linear + performance. Output is sanitized by default for + protection against XSS attacks. + . + Several markdown extensions are implemented, including + fenced code blocks, significant list start numbers, and + autolinked URLs. See README.markdown for details. +homepage: http://github.com/jgm/cheapskate +license: BSD3 +license-file: LICENSE +author: John MacFarlane +maintainer: jgm@berkeley.edu +copyright: (C) 2012-2013 John MacFarlane +category: Text +build-type: Simple +extra-source-files: README.markdown + man/man1/cheapskate.1 +cabal-version: >=1.10 +Source-repository head + type: git + location: git://github.com/jgm/cheapskate.git + +library + hs-source-dirs: . + exposed-modules: Cheapskate + Cheapskate.Parse + Cheapskate.Types + Cheapskate.Html + other-modules: Cheapskate.Util + Cheapskate.Inlines + Cheapskate.ParserCombinators + build-depends: base >=4.4 && <4.8, + containers >=0.4 && <0.6, + mtl >=2.1 && <2.2, + text >= 0.9 && <1.1, + blaze-html >=0.6 && <0.7, + xss-sanitize >= 0.3 && < 0.4, + data-default >= 0.5 && < 0.6, + syb, + uniplate >= 1.6 && < 1.7 + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind + ghc-prof-options: -auto-all -caf-all -rtsopts + +executable cheapskate + main-is: main.hs + hs-source-dirs: bin + other-extensions: OverloadedStrings + build-depends: base >=4.4 && <4.8, + cheapskate, + bytestring, + blaze-html >=0.6 && <0.7, + text >= 0.9 && <1.1 + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind + ghc-prof-options: -auto-all -caf-all -rtsopts diff --git a/man/man1/cheapskate.1 b/man/man1/cheapskate.1 new file mode 100644 --- /dev/null +++ b/man/man1/cheapskate.1 @@ -0,0 +1,55 @@ +.TH "cheapskate" "1" "January 4, 2014" "cheapskate manual" "" +.SH NAME +.PP +cheapskate \- convert markdown to HTML. +.SH SYNOPSIS +.PP +cheapskate [\f[I]options..\f[]] [\f[I]file..\f[]] +.SH DESCRIPTION +.PP +\f[C]cheapskate\f[] will convert the input text (which may come from +stdin or from any number of input files) from markdown to HTML. +Output will be written to stdout. +.SH OPTIONS +.TP +.B \f[C]\-s,\ \-\-sanitize\f[] +Sanitize raw HTML and link and image attributes to protect from XSS +attacks. +.RS +.RE +.TP +.B \f[C]\-e,\ \-\-escape\-raw\-html\f[] +Escape all raw HTML. +(Note: for safety, use \f[C]\-\-sanitize\f[]. +This option is for those who want to disallow raw HTML to enforce +uniformity of formatting.) +.RS +.RE +.TP +.B \f[C]\-b,\ \-\-hard\-line\-breaks\f[] +Treat all newlines as hard line breaks (\f[C]\f[] tags in HTML). +.RS +.RE +.TP +.B \f[C]\-\-debug\f[] +Print the container structure obtained from phase 1 of parsing. +For debugging only. +.RS +.RE +.TP +.B \f[C]\-h,\ \-\-help\f[] +Print usage information. +.RS +.RE +.TP +.B \f[C]\-V,\ \-\-version\f[] +Print version. +.RS +.RE +.SH AUTHORS +.PP +John MacFarlane. +.SH SEE ALSO +.PP +The \f[C]cheapskate\f[] source code and all documentation may be +downloaded from .