comark-html (empty) → 0.1.0
raw patch · 7 files changed
+399/−0 lines, 7 filesdep +basedep +cmarkdep +comark-htmlsetup-changed
Dependencies added: base, cmark, comark-html, comark-syntax, comark-testutils, criterion, deepseq, hspec, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/ProGit.hs +31/−0
- comark-html.cabal +86/−0
- prof/Main.hs +20/−0
- src/Comark/Html.hs +209/−0
- tests/Main.hs +21/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, 2016, 2017, Konstantin Zudov++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 Konstantin Zudov 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/ProGit.hs view
@@ -0,0 +1,31 @@+module Main where++import Criterion.Main+import qualified Data.Text as Text+import qualified Data.Text.IO as Text++import qualified CMark+import Comark.Html as Comark+import Comark.Syntax as Comark+import Comark.TestUtils.CMark (ListType, nodeToDoc)+import Control.DeepSeq++instance NFData CMark.Node+instance NFData CMark.PosInfo+instance NFData CMark.NodeType+instance NFData CMark.ListAttributes+instance NFData Comark.TestUtils.CMark.ListType+instance NFData CMark.DelimType++main :: IO ()+main = do+ input <- Text.readFile "progit.md"+ putStrLn "finished reading"+ let node = CMark.commonmarkToNode [CMark.optNormalize] input+ doc = nodeToDoc node+ node `deepseq` putStrLn "evaluated node"+ doc `deepseq` putStrLn "evaluated doc"+ defaultMain+ [ bench "cmark-hs" $ nf (CMark.nodeToHtml []) node+ , bench "comark" $ nf Comark.render doc+ ]
+ comark-html.cabal view
@@ -0,0 +1,86 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name: comark-html+version: 0.1.0+synopsis: Commonmark (markdown) to HTML renderer.+description: See <https://github.com/zudov/haskell-comark#readme README>+category: Text+author: Konstantin Zudov+maintainer: co@zudov.me+copyright: (c) Konstantin Zudov, 2015, 2016, 2017+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++flag profile+ description: Build profiling executables+ manual: True+ default: False++library+ hs-source-dirs:+ src/+ other-extensions: DeriveDataTypeable DeriveGeneric+ ghc-options: -Wall -O2+ build-depends:+ base >=4.7 && <5+ , text+ , comark-syntax+ , transformers+ exposed-modules:+ Comark.Html+ other-modules:+ Paths_comark_html+ default-language: Haskell2010++executable comark-html-profile+ main-is: Main.hs+ hs-source-dirs:+ prof+ ghc-options: -Wall -O2 -threaded+ if flag(profile)+ ghc-options: -Wall -O2 -threaded -fprof-auto -with-rtsopts=-N -p -s -h -i0.1+ build-depends:+ base >=4.7 && <5+ , text+ , comark-html+ , comark-syntax+ , comark-testutils+ , deepseq+ , cmark+ else+ buildable: False+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ tests/+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , comark-html+ , comark-testutils+ , hspec+ default-language: Haskell2010++benchmark progit-bench+ type: exitcode-stdio-1.0+ main-is: ProGit.hs+ hs-source-dirs:+ bench/+ ghc-options: -O2+ build-depends:+ base >=4.7 && <5+ , criterion+ , text+ , comark-html+ , comark-syntax+ , comark-testutils+ , cmark >=0.3.2+ , deepseq+ default-language: Haskell2010
+ prof/Main.hs view
@@ -0,0 +1,20 @@+module Main where++import qualified Data.Text as Text+import qualified Data.Text.IO as Text++import CMark+import Comark.Html+import Comark.Syntax+import Comark.TestUtils.CMark+import Control.DeepSeq++main :: IO ()+main = do+ file <- Text.readFile "benchinput.md"+ putStrLn "finished reading"+ let node = commonmarkToNode [optNormalize] file+ doc = nodeToDoc node+ html = docToHtml doc+ doc `deepseq` putStrLn "evaluated doc"+ html `deepseq` putStrLn "evaluated html"
+ src/Comark/Html.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+module Comark.Html+ ( render ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Writer.Strict+import Data.Char+import Data.Maybe (maybeToList)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder+ (Builder, fromString, fromText, singleton, toLazyText)+import Numeric (showIntAtBase)+import Prelude++import Data.Bits (shiftR, (.&.))++import Comark.Syntax++-- | Render a Commonmark document as HTML.+render :: Doc Text -> Text+render (Doc bs) =+ toStrict $ toLazyText $ buildHtml $ renderBlocks bs++type HtmlBuilder = WriterT Builder (State BuilderState) ()++newtype BuilderState+ = BuilderState+ { newlineAllowed :: Bool }++type Attribute = (String,Text)++buildAttr :: Attribute -> Builder+buildAttr (name,val) =+ singleton ' ' <> fromString name <> "=\"" <> escapedHtml val <> singleton '"'++type TagName = String+type TagContent = HtmlBuilder++-- | Build tag with attributes+tagWith :: [Attribute] -> TagName -> TagContent -> HtmlBuilder+tagWith !attrs !t content = do+ let !tagNameBuilder = fromString t+ tell (singleton '<' <> tagNameBuilder <> foldMap buildAttr attrs <> singleton '>')+ allowNL+ content+ tell ("</" <> tagNameBuilder <> singleton '>')+ allowNL++-- | Build tag without attributes+tag :: TagName -> TagContent -> HtmlBuilder+tag = tagWith []++-- | Build void tag+voidTag :: TagName -> HtmlBuilder+voidTag = voidTagWith []++-- | Build void tag with attributes+voidTagWith :: [Attribute] -> TagName -> HtmlBuilder+voidTagWith !attrs !t = do+ tell $ singleton '<' <> fromString t <> foldMap buildAttr attrs <> " />"+ allowNL++allowNL, disallowNL :: HtmlBuilder+allowNL = lift $ put (BuilderState True)+disallowNL = lift $ put (BuilderState False)++nl :: HtmlBuilder+nl = do+ allowed <- lift $ gets newlineAllowed+ when allowed $ do+ tell "\n"+ disallowNL++escapedText :: Text -> HtmlBuilder+escapedText t = tell (escapedHtml t) *> allowNL++unescapedText :: Text -> HtmlBuilder+unescapedText t = tell (fromText t) *> allowNL++buildHtml :: HtmlBuilder -> Builder+buildHtml m = evalState (execWriterT m) (BuilderState False)++renderBlocks :: Blocks Text -> HtmlBuilder+renderBlocks bs = nl *> mapM_ (\b -> nl *> renderBlock b *> nl) bs++renderBlock :: Block Text -> HtmlBuilder+renderBlock (Para is) = tag "p" (renderInlines is)+renderBlock (Heading n is) = tag hx (renderInlines is)+ where+ hx = case n of+ Heading1 -> "h1"+ Heading2 -> "h2"+ Heading3 -> "h3"+ Heading4 -> "h4"+ Heading5 -> "h5"+ Heading6 -> "h6"+renderBlock (CodeBlock mInfo t) =+ tag "pre"+ $ tagWith args "code"+ $ escapedText t+ where+ args = ("class",) . lang <$> maybeToList mInfo+ lang a = "language-" <> Text.takeWhile (/= ' ') a+renderBlock ThematicBreak = voidTag "hr"+renderBlock (HtmlBlock t) = unescapedText t+renderBlock (Quote bs) = tag "blockquote" $ renderBlocks bs+renderBlock (List listType tight items) =+ case listType of+ Bullet _ -> tag "ul" renderedItems+ Ordered _ 1 -> tag "ol" renderedItems+ Ordered _ n -> tagWith [("start", Text.pack $ show n)] "ol" renderedItems+ where+ renderedItems = nl *> mapM_ (\a -> renderItem a *> nl) items++ renderItem bs+ | tight = tag "li" (mapM_ renderTightBlock bs)+ | otherwise = tag "li" (when (null bs) disallowNL *> renderBlocks bs)++ renderTightBlock (Para zs) = mapM_ renderInline zs+ renderTightBlock x = nl *> renderBlock x *> nl++renderInlines :: Inlines Text -> HtmlBuilder+renderInlines = mapM_ renderInline++renderInline :: Inline Text -> HtmlBuilder+renderInline (Str t) = escapedText t+renderInline SoftBreak = tell "\n"+renderInline HardBreak = voidTag "br" *> nl+renderInline (RawHtml t) = unescapedText t+renderInline (Emph is) = tag "em" (renderInlines is)+renderInline (Strong is) = tag "strong" (renderInlines is)+renderInline (Code t) = tag "code" (escapedText t)+renderInline (Link is dest title) = tagWith attrs "a" (renderInlines is)+ where+ attrs = ("href", encodeHref dest) : maybeToList (("title",) <$> title)+renderInline (Image is dest title) = voidTagWith attrs "img"+ where+ attrs = ("src", encodeHref dest)+ : ("alt", foldMap asText is)+ : (("title",) <$> maybeToList title)++encodeHref :: Text -> Text+encodeHref = Text.concatMap (Text.pack . escapeURIChar predicate)+ where+ predicate c =+ (isAscii c && isAlphaNum c) || (lightSpecialPred c && specialPred c)+ lightSpecialPred c = c >= '!' && c <= '_'+ specialPred c =+ c == '-' || c == ',' || c == '+' || c == '$' || c == '/'+ || c == '_' || c == '.' || c == '+' || c == '!' || c == '*'+ || c == '\'' || c == '(' || c == ')' || c == ',' || c == '%'+ || c == '#' || c == '@' || c == '?' || c == '=' || c == ';'+ || c == ':' || c == '&'++-- |Escape character if supplied predicate is not satisfied,+-- otherwise return character as singleton string.+--+escapeURIChar :: (Char -> Bool) -> Char -> String+escapeURIChar p c+ | p c = [c]+ | otherwise = concatMap (\i -> '%' : myShowHex i "") (utf8EncodeChar c)+ where+ myShowHex :: Int -> ShowS+ myShowHex n r = case showIntAtBase 16 (toChrHex) n r of+ [] -> "00"+ [x] -> ['0',x]+ cs -> cs+ toChrHex d+ | d < 10 = chr (ord '0' + fromIntegral d)+ | otherwise = chr (ord 'A' + fromIntegral (d - 10))++-- From http://hackage.haskell.org/package/utf8-string+-- by Eric Mertens, BSD3+-- Returns [Int] for use with showIntAtBase+utf8EncodeChar :: Char -> [Int]+utf8EncodeChar = map fromIntegral . go . ord+ where+ go oc+ | oc <= 0x7f = [oc]++ | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6)+ , 0x80 + oc .&. 0x3f+ ]++ | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12)+ , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+ , 0x80 + oc .&. 0x3f+ ]+ | otherwise = [ 0xf0 + (oc `shiftR` 18)+ , 0x80 + ((oc `shiftR` 12) .&. 0x3f)+ , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+ , 0x80 + oc .&. 0x3f+ ]++escapedHtml :: Text -> Builder+escapedHtml =+ fromText+ . Text.replace ">" ">"+ . Text.replace "<" "<"+ . Text.replace "\"" """+ . Text.replace "&" "&"
+ tests/Main.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE RecordWildCards #-}+module Main where++import Control.Monad++import Test.Hspec++import Comark.TestUtils.CMark+import Comark.TestUtils.Spec++import Comark.Html++++main :: IO ()+main = hspec $+ describe "SpecTests" $+ forM_ spec $ \SpecTest{..} ->+ it (show testNumber ++ ": " ++ show testSection) $+ (render $ nodeToDoc $ commonmarkToNode [optNormalize] $ testIn)+ `shouldBe` testOut