diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/bench/ProGit.hs b/bench/ProGit.hs new file mode 100644 --- /dev/null +++ b/bench/ProGit.hs @@ -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 + ] diff --git a/comark-html.cabal b/comark-html.cabal new file mode 100644 --- /dev/null +++ b/comark-html.cabal @@ -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 +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 diff --git a/prof/Main.hs b/prof/Main.hs new file mode 100644 --- /dev/null +++ b/prof/Main.hs @@ -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" diff --git a/src/Comark/Html.hs b/src/Comark/Html.hs new file mode 100644 --- /dev/null +++ b/src/Comark/Html.hs @@ -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 "&" "&" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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