mmark-ext-0.0.1.2: Text/MMark/Extension/Common.hs
-- |
-- Module : Text.MMark.Extension.Common
-- Copyright : © 2017–2018 Mark Karpov
-- License : BSD 3 clause
--
-- Maintainer : Mark Karpov <markkarpov92@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- Commonly useful extensions for MMark markdown processor.
--
-- We suggest using a qualified import, like this:
--
-- > import qualified Text.MMark.Extension.Common as Ext
--
-- Here is an example that uses several extensions from this module at the
-- same time, it should give you an idea where to start:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > module Main (main) where
-- >
-- > import Data.Default.Class
-- > import qualified Data.Text.IO as T
-- > import qualified Data.Text.Lazy.IO as TL
-- > import qualified Lucid as L
-- > import qualified Text.MMark as MMark
-- > import qualified Text.MMark.Extension.Common as Ext
-- >
-- > main :: IO ()
-- > main = do
-- > let input = "input.md"
-- > txt <- T.readFile input
-- > case MMark.parse input txt of
-- > Left errs -> putStrLn (MMark.parseErrorsPretty txt errs)
-- > Right r ->
-- > let toc = MMark.runScanner r (Ext.tocScanner 4)
-- > in TL.writeFile "output.html"
-- > . L.renderText
-- > . MMark.render
-- > . MMark.useExtensions
-- > [ Ext.toc "toc" toc
-- > , Ext.punctuationPrettifier def
-- > , Ext.obfuscateEmail "protected-email"
-- > , Ext.fontAwesome ]
-- > $ 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 )
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:
--
-- > <a class="protected-email"
-- > data-email="something@example.org"
-- > href="javascript:void(0)">Enable JavaScript to see the email</a>
--
-- 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:
--
-- > <fa:user>
--
-- This @user@ identifier is the name of icon you want to insert. You can
-- also control the size of the icon like this:
--
-- > <fa:user/fw> -- fixed width
-- > <fa:user/lg> -- large
-- > <fa:user/2x>
-- > <fa:user/3x>
-- > <fa:user/4x>
-- > <fa:user/5x>
--
-- 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 <http://fontawesome.io/examples/>:
--
-- > <fa:quote-left/3x/pull-left/border>
--
-- See also: <http://fontawesome.io>.
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