diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## MMark Ext 0.1.0.0 + +* This version has little in common with previous versions. + ## MMark Ext 0.0.1.2 * Compiles with `modern-uri-0.2.0.0` and later. diff --git a/Text/MMark/Extension/Comment.hs b/Text/MMark/Extension/Comment.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/Comment.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Text.MMark.Extension.Comment +-- Copyright : © 2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Turn paragraphs into comments by prefixing them with a certain sequence +-- of characters. + +module Text.MMark.Extension.Comment + ( commentParagraph ) +where + +import Control.Monad +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Text.MMark.Extension (Extension, Block (..), Inline (..)) +import qualified Data.Text as T +import qualified Text.MMark.Extension as Ext + +-- | This extension removes top-level paragraphs starting with the given +-- sequence of non-markup characters. + +commentParagraph + :: Text -- ^ Sequence of characters that starts a comment + -> Extension +commentParagraph commentPrefix = Ext.blockRender $ \old block -> + case block of + p@(Paragraph (ois, _)) -> + case Ext.getOis ois of + (Plain txt :| _) -> + unless (commentPrefix `T.isPrefixOf` txt) $ + old p + _ -> old p + other -> old other diff --git a/Text/MMark/Extension/Common.hs b/Text/MMark/Extension/Common.hs --- a/Text/MMark/Extension/Common.hs +++ b/Text/MMark/Extension/Common.hs @@ -20,7 +20,7 @@ -- > -- > module Main (main) where -- > --- > import Data.Default.Class +-- > import Skylighting (defaultFormatOpts) -- > import qualified Data.Text.IO as T -- > import qualified Data.Text.Lazy.IO as TL -- > import qualified Lucid as L @@ -34,237 +34,32 @@ -- > case MMark.parse input txt of -- > Left errs -> putStrLn (MMark.parseErrorsPretty txt errs) -- > Right r -> --- > let toc = MMark.runScanner r (Ext.tocScanner 4) +-- > let toc = MMark.runScanner r (Ext.tocScanner (> 1)) -- > in TL.writeFile "output.html" -- > . L.renderText -- > . MMark.render -- > . MMark.useExtensions -- > [ Ext.toc "toc" toc --- > , Ext.punctuationPrettifier def --- > , Ext.obfuscateEmail "protected-email" --- > , Ext.fontAwesome ] +-- > , Ext.punctuationPrettifier +-- > , Ext.skylighting defaultFormatOpts ] -- > $ r -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Text.MMark.Extension.Common - ( -- * Table of contents - -- $table-of-contents - Toc - , tocScanner - , toc - -- * Punctuation prettifier - , Punctuation (..) - , punctuationPrettifier - -- * Email address obfuscation - , obfuscateEmail - -- * Font Awesome icons - , fontAwesome ) + ( module Text.MMark.Extension.Comment + , module Text.MMark.Extension.FontAwesome + , module Text.MMark.Extension.Kbd + , module Text.MMark.Extension.LinkTarget + , module Text.MMark.Extension.ObfuscateEmail + , module Text.MMark.Extension.PunctuationPrettifier + , module Text.MMark.Extension.Skylighting + , module Text.MMark.Extension.TableOfContents ) where -import Data.Data (Data) -import Data.Default.Class -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (maybeToList, fromJust) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Typeable (Typeable) -import GHC.Generics -import Lens.Micro ((^.)) -import Lucid -import Text.MMark -import Text.MMark.Extension (Bni, Block (..), Inline (..)) -import Text.URI.Lens (uriPath) -import qualified Control.Foldl as L -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import qualified Text.MMark.Extension as Ext -import qualified Text.URI as URI - ----------------------------------------------------------------------------- --- Table of contents - --- $table-of-contents --- --- Place this markup in markdown document where you want table of contents --- to be inserted: --- --- > ```toc --- > ``` --- --- You may use something different than @\"toc\"@ as the info string of the --- code block. - --- | An opaque type representing table of contents produced by the --- 'tocScanner' scanner. - -newtype Toc = Toc [(Int, NonEmpty Inline)] - --- | The scanner builds table of contents 'Toc' that can then be passed to --- 'toc' to obtain an extension that renders the table of contents in HTML. --- --- __Note__: Top level header (level 1) is never added to the table of --- contents. Open an issue if you think it's not a good behavior. - -tocScanner - :: Int -- ^ Up to which level (inclusive) to collect headers? Values from - -- 2 to 6 make sense here. - -> L.Fold Bni Toc -tocScanner cutoff = fmap (Toc . reverse) . Ext.scanner [] $ \xs block -> - case block of - Heading2 x -> f 2 x xs - Heading3 x -> f 3 x xs - Heading4 x -> f 4 x xs - Heading5 x -> f 5 x xs - Heading6 x -> f 6 x xs - _ -> xs - where - f n a as = - if n > cutoff - then as - else (n, a) : as - --- | Create an extension that replaces a certain code block with previously --- constructed table of contents. - -toc - :: Text -- ^ Label of the code block to replace by the table of contents - -> Toc -- ^ Previously generated by 'tocScanner' - -> Extension -toc label (Toc xs) = Ext.blockTrans $ \case - old@(CodeBlock mlabel _) -> - case NE.nonEmpty xs of - Nothing -> old - Just ns -> - if mlabel == pure label - then renderToc ns - else old - other -> other - --- | Construct 'Bni' for a table of contents from given collection of --- headers. This is a non-public helper. - -renderToc :: NonEmpty (Int, NonEmpty Inline) -> Bni -renderToc = UnorderedList . NE.unfoldr f - where - f ((n,x) :| xs) = - let (sitems, fitems) = span ((> n) . fst) xs - url = Ext.headerFragment (Ext.headerId x) - in ( Naked (Link x url Nothing :| []) - : maybeToList (renderToc <$> NE.nonEmpty sitems) - , NE.nonEmpty fitems ) - ----------------------------------------------------------------------------- --- Punctuation prettifier - --- | Settings for the punctuation-prettifying extension. - -data Punctuation = Punctuation - { punctEnDash :: !Bool - -- ^ Whether to replace double hyphen @--@ by an en dash @–@ (default: - -- 'True') - , punctEmDash :: !Bool - -- ^ Whether to replace triple hyphen @---@ by an em dash @—@ (default: - -- 'True') - } deriving (Eq, Ord, Show, Read, Data, Typeable, Generic) - -instance Default Punctuation where - def = Punctuation - { punctEnDash = True - , punctEmDash = True } - --- | Prettify punctuation according to the settings in 'Punctuation'. - -punctuationPrettifier :: Punctuation -> Extension -punctuationPrettifier Punctuation {..} = Ext.inlineTrans $ \case - Plain txt -> Plain - . f punctEnDash (T.replace "--" "–") - . f punctEmDash (T.replace "---" "—") - $ txt - other -> other - where - f b g = if b then g else id - ----------------------------------------------------------------------------- --- Email address obfuscation - --- | This extension makes email addresses in links be rendered as something --- like this: --- --- > data-email="something@example.org" --- > href="javascript:void(0)">Enable JavaScript to see the email --- --- You'll also need to include jQuery and this bit of JS code for the magic --- to work: --- --- > $(document).ready(function () { --- > $(".protected-email").each(function () { --- > var item = $(this); --- > var email = item.data('email'); --- > item.attr('href', 'mailto:' + email); --- > item.html(email); --- > }); --- > }); - -obfuscateEmail - :: Text - -- ^ Name of class to assign to the links, e.g. @\"protected-email\"@ - -> Extension -obfuscateEmail class' = Ext.inlineRender $ \old inline -> - case inline of - l@(Link _ email mtitle) -> - if URI.uriScheme email == URI.mkScheme "mailto" - then let txt = Plain "Enable JavaScript to see the email" :| [] - js = fromJust (URI.mkURI "javascript:void(0)") - in with (old (Link txt js mtitle)) - [ class_ class' - , data_ "email" - (URI.render email { URI.uriScheme = Nothing }) ] - else old l - other -> old other - ----------------------------------------------------------------------------- --- Font Awesome icons - --- | Allow to insert @span@s with font awesome icons using autolinks like --- this: --- --- > --- --- This @user@ identifier is the name of icon you want to insert. You can --- also control the size of the icon like this: --- --- > -- fixed width --- > -- large --- > --- > --- > --- > --- --- In general, all path components in this URI that go after the name of --- icon will be prefixed with @\"fa-\"@ and added as classes, so you can do --- a lot of fancy stuff, see : --- --- > --- --- See also: . - -fontAwesome :: Extension -fontAwesome = Ext.inlineRender $ \old inline -> - case inline of - l@(Link _ fa _) -> - if URI.uriScheme fa == URI.mkScheme "fa" - then case fa ^. uriPath of - [] -> old l - xs -> - let g x = "fa-" <> URI.unRText x - in span_ - [ (class_ . T.intercalate " ") ("fa" : fmap g xs) ] - "" - else old l - other -> old other +import Text.MMark.Extension.Comment +import Text.MMark.Extension.FontAwesome +import Text.MMark.Extension.Kbd +import Text.MMark.Extension.LinkTarget +import Text.MMark.Extension.ObfuscateEmail +import Text.MMark.Extension.PunctuationPrettifier +import Text.MMark.Extension.Skylighting +import Text.MMark.Extension.TableOfContents diff --git a/Text/MMark/Extension/FontAwesome.hs b/Text/MMark/Extension/FontAwesome.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/FontAwesome.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Text.MMark.Extension.FontAwesome +-- Copyright : © 2017–2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Turn links into Font Awesome icons. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Text.MMark.Extension.FontAwesome + ( fontAwesome ) +where + +import Data.Semigroup ((<>)) +import Lens.Micro ((^.)) +import Lucid +import Text.MMark.Extension (Extension, Inline (..)) +import Text.URI.Lens (uriPath) +import Text.URI.QQ (scheme) +import qualified Data.Text as T +import qualified Text.MMark.Extension as Ext +import qualified Text.URI as URI + +-- | Allow to insert @span@s with font awesome icons using autolinks like +-- this: +-- +-- > +-- +-- This @user@ identifier is the name of icon you want to insert. You can +-- also control the size of the icon like this: +-- +-- > -- fixed width +-- > -- large +-- > +-- > +-- > +-- > +-- +-- In general, all path components in this URI that go after the name of +-- icon will be prefixed with @\"fa-\"@ and added as classes, so you can do +-- a lot of fancy stuff, see : +-- +-- > +-- +-- See also: . + +fontAwesome :: Extension +fontAwesome = Ext.inlineRender $ \old inline -> + case inline of + l@(Link _ uri _) -> + if URI.uriScheme uri == Just [scheme|fa|] + then case uri ^. uriPath of + [] -> old l + xs -> + let g x = "fa-" <> URI.unRText x + in span_ + [ (class_ . T.intercalate " ") ("fa" : fmap g xs) ] + "" + else old l + other -> old other diff --git a/Text/MMark/Extension/Kbd.hs b/Text/MMark/Extension/Kbd.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/Kbd.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Text.MMark.Extension.Kbd +-- Copyright : © 2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Introduce @kbd@ tags into resulting HTML document by wrapping content in +-- links with URL with @kbd@ scheme. + +{-# LANGUAGE QuasiQuotes #-} + +module Text.MMark.Extension.Kbd + ( kbd ) +where + +import Lucid +import Text.MMark.Extension (Extension, Inline (..)) +import Text.URI.QQ (scheme) +import qualified Text.MMark.Extension as Ext +import qualified Text.URI as URI + +-- | Introduce @kbd@ tags into resulting HTML document by wrapping content +-- in links with URL with @kbd@ scheme. +-- +-- For example: +-- +-- > To enable that mode press [Ctrl+A][kbd]. +-- > +-- > [kbd]: kbd: +-- +-- The use of reference-style links seems more aesthetically pleasant to the +-- author, but you can of course do somethnig like this instead: +-- +-- > To enable that mode press [Ctrl+A](kbd:). + +kbd :: Extension +kbd = Ext.inlineRender $ \old inline -> + case inline of + l@(Link inner uri _) -> + if URI.uriScheme uri == Just [scheme|kbd|] + then kbd_ (mapM_ old inner) + else old l + other -> old other diff --git a/Text/MMark/Extension/LinkTarget.hs b/Text/MMark/Extension/LinkTarget.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/LinkTarget.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Text.MMark.Extension.LinkTarget +-- Copyright : © 2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Specify the @target@ attribute of links in link titles. This allows, e.g. +-- make a link open in new tab. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Text.MMark.Extension.LinkTarget + ( linkTarget ) +where + +import Data.Foldable (asum) +import Data.Maybe (fromMaybe) +import Lucid +import Text.MMark.Extension (Extension, Inline (..)) +import qualified Data.Text as T +import qualified Text.MMark.Extension as Ext + +-- | When title of a link starts with the word @\"_blank\"@, @\"_self\"@, +-- @\"_parent\"@, or @\"_top\"@, it's stripped from title (as well as all +-- whitespace after it) and added as the value of @target@ attribute of the +-- resulting link. +-- +-- For example: +-- +-- > This [link](/url '_blank My title') opens in new tab. + +linkTarget :: Extension +linkTarget = Ext.inlineRender $ \old inline -> + case inline of + l@(Link txt url (Just title)) -> fromMaybe (old l) $ do + let f prefix = (prefix,) . T.stripStart + <$> T.stripPrefix prefix title + (prefix, title') <- asum $ + f <$> ["_blank", "_self", "_parent", "_top"] + let mtitle = if T.null title' then Nothing else Just title' + return $ with (old (Link txt url mtitle)) [target_ prefix] + other -> old other diff --git a/Text/MMark/Extension/ObfuscateEmail.hs b/Text/MMark/Extension/ObfuscateEmail.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/ObfuscateEmail.hs @@ -0,0 +1,61 @@ +-- | +-- Module : Text.MMark.Extension.ObfuscateEmail +-- Copyright : © 2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Obfuscate email addresses. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Text.MMark.Extension.ObfuscateEmail + ( obfuscateEmail ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Lucid +import Text.MMark.Extension (Extension, Inline (..)) +import Text.URI.QQ (scheme, uri) +import qualified Text.MMark.Extension as Ext +import qualified Text.URI as URI + +-- | This extension makes email addresses in autolinks be rendered as +-- something like this: +-- +-- > data-email="something@example.org" +-- > href="javascript:void(0)">Enable JavaScript to see this email +-- +-- You'll also need to include jQuery and this bit of JS code for the magic +-- to work: +-- +-- > $(document).ready(function () { +-- > $(".protected-email").each(function () { +-- > var item = $(this); +-- > var email = item.data('email'); +-- > item.attr('href', 'mailto:' + email); +-- > item.html(email); +-- > }); +-- > }); + +obfuscateEmail + :: Text + -- ^ Name of class to assign to the links, e.g. @\"protected-email\"@ + -> Extension +obfuscateEmail class' = Ext.inlineRender $ \old inline -> + case inline of + l@(Link _ email mtitle) -> + if URI.uriScheme email == Just [scheme|mailto|] + then let txt = Plain "Enable JavaScript to see this email" :| [] + js = [uri|javascript:void(0)|] + in with (old (Link txt js mtitle)) + [ class_ class' + , data_ "email" + (URI.render email { URI.uriScheme = Nothing }) ] + else old l + other -> old other diff --git a/Text/MMark/Extension/PunctuationPrettifier.hs b/Text/MMark/Extension/PunctuationPrettifier.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/PunctuationPrettifier.hs @@ -0,0 +1,69 @@ +-- | +-- Module : Text.MMark.Extension.PunctuationPrettifier +-- Copyright : © 2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Punctuation prettifier. + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.PunctuationPrettifier + ( punctuationPrettifier ) +where + +import Data.Char (isSpace) +import Data.Text (Text) +import Text.MMark.Extension (Extension, Inline (..)) +import qualified Data.Text as T +import qualified Text.MMark.Extension as Ext + +-- | Prettify punctuation (only affects plain text in inlines): +-- +-- * Replace @...@ with ellipsis @…@ +-- * Replace @---@ with em-dash @—@ +-- * Replace @--@ with en-dash @–@ +-- * Replace @\"@ with left double quote @“@ when previous character was +-- a space character, otherwise replace it with right double quote @”@ +-- * Replace @'@ with left single quote @‘@ when previous character was +-- a space character, otherwise replace it with right single quote @’@ +-- aka apostrophe + +punctuationPrettifier :: Extension +punctuationPrettifier = Ext.inlineTrans $ \case + Plain txt -> Plain (T.unfoldr gen (True, txt)) + other -> other + +gen + :: (Bool, Text) + -- ^ Whether the previous character was a space and remaining input + -> Maybe (Char, (Bool, Text)) + -- ^ Next generated char and the state +gen (s, i) = + case T.uncons i of + Nothing -> Nothing + Just ('.', i') -> + case T.splitAt 2 i' of + ("..", i'') -> Just ('…', (False, i'')) + _ -> Just ('.', (False, i')) + Just ('-', i') -> + case T.splitAt 2 i' of + ("--", i'') -> Just ('—', (False, i'')) + _ -> + case T.splitAt 1 i' of + ("-", i'') -> Just ('–', (False, i'')) + _ -> Just ('-', (False, i')) + Just ('\"', i') -> + if s -- whether previous character was a space character + then Just ('“', (False, i')) + else Just ('”', (False, i')) + Just ('\'', i') -> + if s + then Just ('‘', (False, i')) + else Just ('’', (False, i')) + Just (ch, i') -> + Just (ch, (isSpace ch, i')) diff --git a/Text/MMark/Extension/Skylighting.hs b/Text/MMark/Extension/Skylighting.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/Skylighting.hs @@ -0,0 +1,48 @@ +-- | +-- Module : Text.MMark.Extension.Skylighting +-- Copyright : © 2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Use the Skylighting library to highlight code snippets. + +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.Skylighting + ( skylighting ) +where + +import Lucid (toHtmlRaw) +import Text.Blaze.Html.Renderer.Text +import Text.MMark.Extension (Extension, Block (..)) +import qualified Data.Text as T +import qualified Skylighting as S +import qualified Text.MMark.Extension as Ext + +-- | Use the @skylighting@ package to render code blocks with info strings +-- that result in a successful lookup from 'S.defaultSyntaxMap'. +-- +-- The resulting markup is wrapped with spans as described in the docs for +-- 'S.formatHtmlInline'. + +skylighting + :: S.FormatOptions -- ^ Skylighting formatting options + -> Extension +skylighting fmtOpts = Ext.blockRender $ \old block -> + case block of + cb@(CodeBlock (Just infoString') txt) -> + let tokenizerConfig = S.TokenizerConfig + { S.syntaxMap = S.defaultSyntaxMap + , S.traceOutput = False } + infoString = T.replace "-" " " infoString' + in case S.lookupSyntax infoString S.defaultSyntaxMap of + Nothing -> old cb + Just syntax -> + case S.tokenize tokenizerConfig syntax txt of + Left _ -> old cb + Right sourceLines -> toHtmlRaw . renderHtml $ + S.formatHtmlBlock fmtOpts sourceLines + other -> old other diff --git a/Text/MMark/Extension/TableOfContents.hs b/Text/MMark/Extension/TableOfContents.hs new file mode 100644 --- /dev/null +++ b/Text/MMark/Extension/TableOfContents.hs @@ -0,0 +1,90 @@ +-- | +-- Module : Text.MMark.Extension.TableOfContents +-- Copyright : © 2017–2018 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Place this markup in markdown document where you want table of contents +-- to be inserted: +-- +-- > ```toc +-- > ``` +-- +-- You may use something different than @\"toc\"@ as the info string of the +-- code block. + +{-# LANGUAGE LambdaCase #-} + +module Text.MMark.Extension.TableOfContents + ( Toc + , tocScanner + , toc ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (maybeToList) +import Data.Text (Text) +import Text.MMark.Extension (Extension, Block (..), Inline (..), Bni) +import qualified Control.Foldl as L +import qualified Data.List.NonEmpty as NE +import qualified Text.MMark.Extension as Ext + +-- | An opaque type representing table of contents produced by the +-- 'tocScanner' scanner. + +newtype Toc = Toc [(Int, NonEmpty Inline)] + +-- | The scanner builds table of contents 'Toc' that can then be passed to +-- 'toc' to obtain an extension that renders the table of contents in HTML. + +tocScanner + :: (Int -> Bool) + -- ^ Whether to include a header of this level (1–6) + -> L.Fold Bni Toc +tocScanner p = fmap (Toc . ($ [])) . Ext.scanner id $ \xs block -> + case block of + Heading1 x -> f 1 x xs + Heading2 x -> f 2 x xs + Heading3 x -> f 3 x xs + Heading4 x -> f 4 x xs + Heading5 x -> f 5 x xs + Heading6 x -> f 6 x xs + _ -> xs + where + f n a as = + if p n + then as . ((n, a):) + else as + +-- | Create an extension that replaces a certain code block with previously +-- constructed table of contents. + +toc + :: Text -- ^ Label of the code block to replace by the table of contents + -> Toc -- ^ Previously generated by 'tocScanner' + -> Extension +toc label (Toc xs) = Ext.blockTrans $ \case + old@(CodeBlock mlabel _) -> + case NE.nonEmpty xs of + Nothing -> old + Just ns -> + if mlabel == pure label + then renderToc ns + else old + other -> other + +-- | Construct 'Bni' for a table of contents from given collection of +-- headers. This is a non-public helper. + +renderToc :: NonEmpty (Int, NonEmpty Inline) -> Bni +renderToc = UnorderedList . NE.unfoldr f + where + f ((n,x) :| xs) = + let (sitems, fitems) = span ((> n) . fst) xs + url = Ext.headerFragment (Ext.headerId x) + in ( Naked (Link x url Nothing :| []) + : maybeToList (renderToc <$> NE.nonEmpty sitems) + , NE.nonEmpty fitems ) diff --git a/mmark-ext.cabal b/mmark-ext.cabal --- a/mmark-ext.cabal +++ b/mmark-ext.cabal @@ -1,7 +1,7 @@ name: mmark-ext -version: 0.0.1.2 +version: 0.1.0.0 cabal-version: >= 1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 +tested-with: GHC==8.0.2, GHC==8.2.2 license: BSD3 license-file: LICENSE.md author: Mark Karpov @@ -11,7 +11,11 @@ category: Text synopsis: Commonly useful extensions for MMark markdown processor build-type: Simple -description: Commonly useful extensions for MMark markdown processor. +description: + + Commonly useful extensions for MMark markdown processor. + Click on "Text.MMark.Extension.Common" to get started. + extra-doc-files: CHANGELOG.md , README.md data-files: data/*.md @@ -27,17 +31,26 @@ default: False library - build-depends: base >= 4.8 && < 5.0 - , data-default-class + build-depends: base >= 4.9 && < 5.0 + , blaze-html >= 0.9 && < 0.10 , foldl >= 1.2 && < 1.4 , lucid >= 2.6 && < 3.0 , microlens >= 0.4 && < 0.5 - , mmark >= 0.0.2 && <= 0.1 + , mmark >= 0.0.4 && <= 0.1 , modern-uri >= 0.1.1 && < 0.3 + , skylighting >= 0.5 && < 0.6 , text >= 0.2 && < 1.3 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* exposed-modules: Text.MMark.Extension.Common + , Text.MMark.Extension.Comment + , Text.MMark.Extension.FontAwesome + , Text.MMark.Extension.Kbd + , Text.MMark.Extension.LinkTarget + , Text.MMark.Extension.ObfuscateEmail + , Text.MMark.Extension.PunctuationPrettifier + , Text.MMark.Extension.Skylighting + , Text.MMark.Extension.TableOfContents if flag(dev) ghc-options: -O0 -Wall -Werror else @@ -48,16 +61,22 @@ main-is: Spec.hs hs-source-dirs: tests type: exitcode-stdio-1.0 - build-depends: base >= 4.8 && < 5.0 - , data-default-class + build-depends: base >= 4.9 && < 5.0 , hspec >= 2.0 && < 3.0 , lucid >= 2.6 && < 3.0 - , mmark >= 0.0.2 && <= 0.1 + , mmark >= 0.0.4 && <= 0.1 , mmark-ext , text >= 0.2 && < 1.3 if flag(dev) ghc-options: -O0 -Wall -Werror else ghc-options: -O2 -Wall - other-modules: Text.MMark.Extension.CommonSpec + other-modules: Text.MMark.Extension.CommentSpec + , Text.MMark.Extension.FontAwesomeSpec + , Text.MMark.Extension.KbdSpec + , Text.MMark.Extension.LinkTargetSpec + , Text.MMark.Extension.ObfuscateEmailSpec + , Text.MMark.Extension.PunctuationPrettifierSpec + , Text.MMark.Extension.TableOfContentsSpec + , Text.MMark.Extension.TestUtils default-language: Haskell2010 diff --git a/tests/Text/MMark/Extension/CommentSpec.hs b/tests/Text/MMark/Extension/CommentSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/CommentSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.CommentSpec (spec) where + +import Test.Hspec +import Text.MMark.Extension.Comment +import Text.MMark.Extension.TestUtils + +spec :: Spec +spec = + describe "commentParagraph" $ do + let to = withExt (commentParagraph "$$$") + context "when it is the only content in document" $ + it "is removed" $ + "$$$ Here we go." `to` "" + context "when it is intermixed with other paragraphs" $ + it "is removed" $ + "First.\n\n$$$Second.\n\nThird.\n" `to` "

First.

\n

Third.

\n" + context "when it is not in plain text" $ + it "has no special effect" $ + "[$$$ link](/url) foo." `to` "

$$$ link foo.

\n" diff --git a/tests/Text/MMark/Extension/CommonSpec.hs b/tests/Text/MMark/Extension/CommonSpec.hs deleted file mode 100644 --- a/tests/Text/MMark/Extension/CommonSpec.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Text.MMark.Extension.CommonSpec (spec) where - -import Data.Default.Class -import Data.Text (Text) -import Test.Hspec -import qualified Data.Text.IO as TIO -import qualified Data.Text.Lazy as TL -import qualified Lucid as L -import qualified Text.MMark as MMark -import qualified Text.MMark.Extension.Common as Ext - -spec :: Spec -spec = parallel $ do - describe "toc" $ - it "works" $ - "data/toc.md" `withToc` "data/toc.html" - describe "punctuationPrettifier" $ do - let to = withExt (Ext.punctuationPrettifier def) - ot = withExt $ Ext.punctuationPrettifier def - { Ext.punctEnDash = False - , Ext.punctEmDash = False } - context "on plain inlines" $ do - context "when enabeled" $ do - it "replaces -- with en dash" $ - "Here we go -- at last." `to` "

Here we go – at last.

\n" - it "replaces --- with em dash" $ - "Here we go---at last." `to` "

Here we go—at last.

\n" - context "when disabled" $ do - it "does not replace -- with en dash" $ - "Here we go -- at last." `ot` "

Here we go -- at last.

\n" - it "does not replace --- with em dash" $ - "Here we go---at last." `ot` "

Here we go---at last.

\n" - context "on other inlines" $ - it "has no effect" $ - "`code -- span`" `to` "

code -- span

\n" - describe "obfuscateEmail" $ do - let to = withExt (Ext.obfuscateEmail "foo") - context "when URI has the mailto scheme" $ - it "produces the correct HTML" $ - "" `to` "

Enable JavaScript to see the email

\n" - context "when URI has some other scheme" $ - it "produces the correct HTML" $ - "" `to` "

https:example.org

\n" - context "other elements" $ - it "not affected" $ - "Something." `to` "

Something.

\n" - describe "fontAwesome" $ do - let to = withExt Ext.fontAwesome - context "when URI has the fa scheme" $ - it "produces the correct HTML" $ do - "" `to` "

fa:

\n" - "" `to` "

\n" - "" `to` "

\n" - "" `to` "

\n" - context "when URI has some other scheme" $ - it "produces the correct HTML" $ - "" `to` "

https://example.org/

\n" - context "other elements" $ - it "not affected" $ - "Something." `to` "

Something.

\n" - ----------------------------------------------------------------------------- --- Helpers - --- | Feed input into MMark parser, apply an extension, render the parsed --- document and demand that it matches the given example. - -withExt - :: MMark.Extension -- ^ MMark extension to use - -> Text -- ^ Input for the parser - -> Text -- ^ Expected output of the render - -> Expectation -withExt ext input expected = do - let Right doc = MMark.parse "" input - actual = TL.toStrict - . L.renderText - . MMark.render - . MMark.useExtension ext - $ doc - - actual `shouldBe` expected --- | Similar to 'withExt' but specialized to test the 'Ext.toc' extension --- and loads input and expected output from files. - -withToc - :: FilePath -- ^ File containing input for the parser - -> FilePath -- ^ File containing expected output of the render - -> Expectation -withToc ipath opath = do - input <- TIO.readFile ipath - expected <- TIO.readFile opath - let Right doc = MMark.parse "" input - toc = MMark.runScanner doc (Ext.tocScanner 6) - actual = TL.toStrict - . L.renderText - . MMark.render - . MMark.useExtension (Ext.toc "toc" toc) - $ doc - actual `shouldBe` expected diff --git a/tests/Text/MMark/Extension/FontAwesomeSpec.hs b/tests/Text/MMark/Extension/FontAwesomeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/FontAwesomeSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.FontAwesomeSpec (spec) where + +import Test.Hspec +import Text.MMark.Extension.FontAwesome +import Text.MMark.Extension.TestUtils + +spec :: Spec +spec = + describe "fontAwesome" $ do + let to = withExt fontAwesome + context "when URI has the fa scheme" $ + it "produces the correct HTML" $ do + "" `to` "

fa:

\n" + "" `to` "

\n" + "" `to` "

\n" + "" `to` "

\n" + context "when URI has some other scheme" $ + it "produces the correct HTML" $ + "" `to` "

https://example.org/

\n" + context "other elements" $ + it "not affected" $ + "Something." `to` "

Something.

\n" diff --git a/tests/Text/MMark/Extension/KbdSpec.hs b/tests/Text/MMark/Extension/KbdSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/KbdSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.KbdSpec (spec) where + +import Test.Hspec +import Text.MMark.Extension.Kbd +import Text.MMark.Extension.TestUtils + +spec :: Spec +spec = + describe "kbd" $ do + let to = withExt kbd + it "works" $ + "Press [Ctrl+A](kbd:)" `to` "

Press Ctrl+A

\n" diff --git a/tests/Text/MMark/Extension/LinkTargetSpec.hs b/tests/Text/MMark/Extension/LinkTargetSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/LinkTargetSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.LinkTargetSpec (spec) where + +import Test.Hspec +import Text.MMark.Extension.LinkTarget +import Text.MMark.Extension.TestUtils + +spec :: Spec +spec = + describe "linkTarget" $ do + let to = withExt linkTarget + context "when no link title provided" $ + it "has no effect" $ + "[link](/url)" `to` "

link

\n" + context "when link title does not start with a target" $ + it "has no effect" $ + "[link](/url 'something _blank')" `to` + "

link

\n" + context "when link title starts with a target" $ do + context "when there is nothing but the target in title" $ + it "works as intended, no title attribute produced" $ + "[link](/url '_blank')" `to` + "

link

\n" + context "when there is also a title" $ + it "works as intended, target is stripped from the title" $ + "[link](/url '_blank something')" `to` + "

link

\n" diff --git a/tests/Text/MMark/Extension/ObfuscateEmailSpec.hs b/tests/Text/MMark/Extension/ObfuscateEmailSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/ObfuscateEmailSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.ObfuscateEmailSpec (spec) where + +import Test.Hspec +import Text.MMark.Extension.ObfuscateEmail +import Text.MMark.Extension.TestUtils + +spec :: Spec +spec = + describe "obfuscateEmail" $ do + let to = withExt (obfuscateEmail "foo") + context "when URI has the mailto scheme" $ + it "produces the correct HTML" $ + "" `to` "

Enable JavaScript to see this email

\n" + context "when URI has some other scheme" $ + it "produces the correct HTML" $ + "" `to` "

https:example.org

\n" + context "other elements" $ + it "not affected" $ + "Something." `to` "

Something.

\n" diff --git a/tests/Text/MMark/Extension/PunctuationPrettifierSpec.hs b/tests/Text/MMark/Extension/PunctuationPrettifierSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/PunctuationPrettifierSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.PunctuationPrettifierSpec (spec) where + +import Test.Hspec +import Text.MMark.Extension.PunctuationPrettifier +import Text.MMark.Extension.TestUtils + +spec :: Spec +spec = + describe "punctuationPrettifier" $ do + let to = withExt punctuationPrettifier + context "on plain inlines" $ do + it "replaces ... with ellipsis" $ + "He forgot where he came from..." `to` "

He forgot where he came from…

\n" + it "replaces --- with em dash" $ + "Here we go---at last." `to` "

Here we go—at last.

\n" + it "replaces -- with en dash" $ + "Here we go -- at last." `to` "

Here we go – at last.

\n" + it "replaces double quotes intelligently" $ + "\"Something\"" `to` "

“Something”

\n" + it "replaces double quotes intelligently (empty)" $ + "\"\"" `to` "

“”

\n" + it "replaces single quotes intelligently" $ do + "'Something'" `to` "

‘Something’

\n" + "I'm doin' well, 'cause I care 'bout 'Big Jim'." + `to` "

I’m doin’ well, ‘cause I care ‘bout ‘Big Jim’.

\n" + it "replaces single quotes intelligently (empty)" $ + "''" `to` "

‘’

\n" + it "a tricky test 1" $ + "Something-\"foo\"." `to` "

Something-”foo”.

\n" + it "a tricky test 2" $ + "Something.--" `to` "

Something.–

\n" + context "on other inlines" $ + it "has no effect" $ + "`code -- span`" `to` "

code -- span

\n" diff --git a/tests/Text/MMark/Extension/TableOfContentsSpec.hs b/tests/Text/MMark/Extension/TableOfContentsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/TableOfContentsSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.MMark.Extension.TableOfContentsSpec (spec) where + +import Test.Hspec +import Text.MMark.Extension.TableOfContents +import qualified Data.Text.IO as TIO +import qualified Data.Text.Lazy as TL +import qualified Lucid as L +import qualified Text.MMark as MMark + +spec :: Spec +spec = + describe "toc" $ + it "works" $ do + input <- TIO.readFile "data/toc.md" + expected <- TIO.readFile "data/toc.html" + let Right doc = MMark.parse "" input + headings = MMark.runScanner doc (tocScanner (> 1)) + actual = TL.toStrict + . L.renderText + . MMark.render + . MMark.useExtension (toc "toc" headings) + $ doc + actual `shouldBe` expected diff --git a/tests/Text/MMark/Extension/TestUtils.hs b/tests/Text/MMark/Extension/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MMark/Extension/TestUtils.hs @@ -0,0 +1,26 @@ +module Text.MMark.Extension.TestUtils + ( withExt ) +where + +import Data.Text (Text) +import Test.Hspec +import qualified Data.Text.Lazy as TL +import qualified Lucid as L +import qualified Text.MMark as MMark + +-- | Feed input into MMark parser, apply an extension, render the parsed +-- document and demand that it matches the given example. + +withExt + :: MMark.Extension -- ^ MMark extension to use + -> Text -- ^ Input for the parser + -> Text -- ^ Expected output of the render + -> Expectation +withExt ext input expected = do + let Right doc = MMark.parse "" input + actual = TL.toStrict + . L.renderText + . MMark.render + . MMark.useExtension ext + $ doc + actual `shouldBe` expected