cheapskate (empty) → 0.1
raw patch · 13 files changed
+2218/−0 lines, 13 filesdep +basedep +blaze-htmldep +bytestringsetup-changed
Dependencies added: base, blaze-html, bytestring, cheapskate, containers, data-default, mtl, syb, text, uniplate, xss-sanitize
Files
- Cheapskate.hs +34/−0
- Cheapskate/Html.hs +124/−0
- Cheapskate/Inlines.hs +435/−0
- Cheapskate/Parse.hs +592/−0
- Cheapskate/ParserCombinators.hs +297/−0
- Cheapskate/Types.hs +73/−0
- Cheapskate/Util.hs +119/−0
- LICENSE +30/−0
- README.markdown +338/−0
- Setup.hs +2/−0
- bin/main.hs +57/−0
- cheapskate.cabal +62/−0
- man/man1/cheapskate.1 +55/−0
+ Cheapskate.hs view
@@ -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
+ Cheapskate/Html.hs view
@@ -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
+ Cheapskate/Inlines.hs view
@@ -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 "<!--"+ rest <- manyTill anyChar (string "-->")+ return $ "<!--" <> T.pack rest <> "-->"++-- 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: <http://whatever.com> or <me@mydomain.edu>.+-- 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)++
+ Cheapskate/Parse.hs view
@@ -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 "<!--"+ <|> 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
+ Cheapskate/ParserCombinators.hs view
@@ -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 #-}
+ Cheapskate/Types.hs view
@@ -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+ }+
+ Cheapskate/Util.hs view
@@ -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)
+ LICENSE view
@@ -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.
+ README.markdown view
@@ -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 `<!--` or end `-->`, 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:++ <div>+ *hello*+ </div>++while in the following, the asterisks are interpreted as markdown+emphasis:++ <div>++ *hello*++ </div>++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 `<p>` 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bin/main.hs view
@@ -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"+ ]
+ cheapskate.cabal view
@@ -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
+ man/man1/cheapskate.1 view
@@ -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]<br\ />\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 <http://github.com/jgm/cheapskate/>.