mmark-ext 0.2.1.5 → 0.3.0.0

raw patch · 46 files changed

+2914/−503 lines, 46 filesdep +bytestringdep +containersdep +directorydep ~basedep ~mmarkdep ~skylightingsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, containers, directory, filepath, megaparsec

Dependency ranges changed: base, mmark, skylighting

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• README.md +2/−2
• Setup.hs +0/−6
• Text/MMark/Extension/Comment.hs +6/−6
• Text/MMark/Extension/Common.hs +35/−17
• Text/MMark/Extension/Emoji.hs +317/−0
• Text/MMark/Extension/FontAwesome.hs +0/−62
• Text/MMark/Extension/Footnotes.hs +166/−36
• Text/MMark/Extension/GhcSyntaxHighlighter.hs +47/−15
• Text/MMark/Extension/Heading.hs +102/−0
• Text/MMark/Extension/Icons.hs +190/−0
• Text/MMark/Extension/Image.hs +188/−0
• Text/MMark/Extension/Internal.hs +98/−0
• Text/MMark/Extension/Kbd.hs +6/−6
• Text/MMark/Extension/LineHighlight.hs +72/−0
• Text/MMark/Extension/Link.hs +180/−0
• Text/MMark/Extension/LinkTarget.hs +0/−47
• Text/MMark/Extension/MathJax.hs +8/−8
• Text/MMark/Extension/Mermaid.hs +79/−0
• Text/MMark/Extension/Metadata.hs +101/−0
• Text/MMark/Extension/ObfuscateEmail.hs +0/−65
• Text/MMark/Extension/Permalinks.hs +83/−0
• Text/MMark/Extension/PunctuationPrettifier.hs +7/−7
• Text/MMark/Extension/Skylighting.hs +19/−11
• Text/MMark/Extension/TableOfContents.hs +41/−31
• mmark-ext.cabal +49/−25
• tests/Text/MMark/Extension/CommentSpec.hs +9/−9
• tests/Text/MMark/Extension/EmojiSpec.hs +61/−0
• tests/Text/MMark/Extension/FontAwesomeSpec.hs +0/−24
• tests/Text/MMark/Extension/FootnotesSpec.hs +62/−20
• tests/Text/MMark/Extension/GhcSyntaxHighlighterSpec.hs +40/−4
• tests/Text/MMark/Extension/HeadingSpec.hs +73/−0
• tests/Text/MMark/Extension/IconsSpec.hs +65/−0
• tests/Text/MMark/Extension/ImageSpec.hs +242/−0
• tests/Text/MMark/Extension/LineHighlightSpec.hs +78/−0
• tests/Text/MMark/Extension/LinkSpec.hs +132/−0
• tests/Text/MMark/Extension/LinkTargetSpec.hs +0/−28
• tests/Text/MMark/Extension/MathJaxSpec.hs +16/−16
• tests/Text/MMark/Extension/MermaidSpec.hs +37/−0
• tests/Text/MMark/Extension/MetadataSpec.hs +29/−0
• tests/Text/MMark/Extension/ObfuscateEmailSpec.hs +0/−21
• tests/Text/MMark/Extension/PermalinksSpec.hs +47/−0
• tests/Text/MMark/Extension/PunctuationPrettifierSpec.hs +4/−4
• tests/Text/MMark/Extension/SkylightingSpec.hs +41/−6
• tests/Text/MMark/Extension/TableOfContentsSpec.hs +42/−13
• tests/Text/MMark/Extension/TestUtils.hs +118/−14

@@ -1,3 +1,25 @@+## MMark Ext 0.3.0.0++* The package now requires `mmark-0.1` or later.++* Added the following modules:++    * `Text.MMark.Extension.Emoji`+    * `Text.MMark.Extension.Heading`+    * `Text.MMark.Extension.Icons`+    * `Text.MMark.Extension.Image`+    * `Text.MMark.Extension.LineHighlight`+    * `Text.MMark.Extension.Link`+    * `Text.MMark.Extension.Mermaid`+    * `Text.MMark.Extension.Metadata`+    * `Text.MMark.Extension.Permalinks`++* Removed the following modules:++    * `Text.MMark.Extension.FontAwesome`+    * `Text.MMark.Extension.LinkTarget`+    * `Text.MMark.Extension.ObfuscateEmail`+ ## MMark Ext 0.2.1.5  * The test suite now passes with `modern-uri-0.3.4.4`.

@@ -4,7 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/mmark-ext.svg?style=flat)](https://hackage.haskell.org/package/mmark-ext) [![Stackage Nightly](http://stackage.org/package/mmark-ext/badge/nightly)](http://stackage.org/nightly/package/mmark-ext) [![Stackage LTS](http://stackage.org/package/mmark-ext/badge/lts)](http://stackage.org/lts/package/mmark-ext)-![CI](https://github.com/mmark-md/mmark-ext/workflows/CI/badge.svg?branch=master)+[![CI](https://github.com/mmark-md/mmark-ext/actions/workflows/ci.yaml/badge.svg)](https://github.com/mmark-md/mmark-ext/actions/workflows/ci.yaml)  Commonly useful extensions for the [MMark](https://hackage.haskell.org/package/mmark) markdown processor.@@ -20,4 +20,4 @@  Copyright © 2017–present Mark Karpov -Distributed under BSD 3 clause license.+Distributed under the BSD 3-clause license.

@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain

@@ -17,21 +17,21 @@ import Control.Monad import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text)-import qualified Data.Text as T-import Text.MMark.Extension (Block (..), Extension, Inline (..))-import qualified Text.MMark.Extension as Ext+import Data.Text qualified as T+import Text.MMark.Render (Block (..), Inline (..), RenderExtension)+import Text.MMark.Render qualified as Ext  -- | This extension removes top-level paragraphs starting with the given -- sequence of non-markup characters. commentParagraph ::   -- | Sequence of characters that starts a comment   Text ->-  Extension+  RenderExtension commentParagraph commentPrefix = Ext.blockRender $ \old block ->   case block of-    p@(Paragraph (ois, _)) ->+    p@(Paragraph _ (ois, _)) ->       case Ext.getOis ois of-        (Plain txt :| _) ->+        (Plain _ txt :| _) ->           unless (commentPrefix `T.isPrefixOf` txt) $             old p         _ -> old p

@@ -14,12 +14,13 @@ -- > 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:+-- same time; it should give you an idea where to start: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > module Main (main) where -- >+-- > import           Control.Monad               ((>=>)) -- > import qualified Data.Text.IO                as T -- > import qualified Data.Text.Lazy.IO           as TL -- > import qualified Lucid                       as L@@ -33,25 +34,36 @@ -- >   txt <- T.readFile input -- >   case MMark.parse input txt of -- >     Left bundle -> putStrLn (M.errorBundlePretty bundle)--- >     Right r ->--- >       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--- >               , Ext.skylighting ]--- >           $ r+-- >     Right r -> do+-- >       let toc = MMark.runScanner (Ext.tocScanner (> 1)) r+-- >           fns = MMark.runScanner Ext.footnoteScanner r+-- >           trans = Ext.toc "toc" toc >=> Ext.punctuationPrettifier+-- >           renderExts = Ext.skylighting <> Ext.footnotes+-- >       case MMark.runCheck (Ext.validateFootnotes fns) r of+-- >         Left errs -> putStrLn (M.errorBundlePretty errs)+-- >         Right () -> return ()+-- >       case MMark.runTrans trans r of+-- >         Left errs -> putStrLn (M.errorBundlePretty errs)+-- >         Right r' ->+-- >           TL.writeFile "output.html"+-- >             . L.renderText+-- >             . MMark.render renderExts+-- >             $ r' module Text.MMark.Extension.Common   ( module Text.MMark.Extension.Comment,-    module Text.MMark.Extension.FontAwesome,+    module Text.MMark.Extension.Emoji,     module Text.MMark.Extension.Footnotes,     module Text.MMark.Extension.GhcSyntaxHighlighter,+    module Text.MMark.Extension.Heading,+    module Text.MMark.Extension.Icons,+    module Text.MMark.Extension.Image,     module Text.MMark.Extension.Kbd,-    module Text.MMark.Extension.LinkTarget,+    module Text.MMark.Extension.LineHighlight,+    module Text.MMark.Extension.Link,     module Text.MMark.Extension.MathJax,-    module Text.MMark.Extension.ObfuscateEmail,+    module Text.MMark.Extension.Mermaid,+    module Text.MMark.Extension.Metadata,+    module Text.MMark.Extension.Permalinks,     module Text.MMark.Extension.PunctuationPrettifier,     module Text.MMark.Extension.Skylighting,     module Text.MMark.Extension.TableOfContents,@@ -59,13 +71,19 @@ where  import Text.MMark.Extension.Comment-import Text.MMark.Extension.FontAwesome+import Text.MMark.Extension.Emoji import Text.MMark.Extension.Footnotes import Text.MMark.Extension.GhcSyntaxHighlighter+import Text.MMark.Extension.Heading+import Text.MMark.Extension.Icons+import Text.MMark.Extension.Image import Text.MMark.Extension.Kbd-import Text.MMark.Extension.LinkTarget+import Text.MMark.Extension.LineHighlight+import Text.MMark.Extension.Link import Text.MMark.Extension.MathJax-import Text.MMark.Extension.ObfuscateEmail+import Text.MMark.Extension.Mermaid+import Text.MMark.Extension.Metadata+import Text.MMark.Extension.Permalinks import Text.MMark.Extension.PunctuationPrettifier import Text.MMark.Extension.Skylighting import Text.MMark.Extension.TableOfContents

@@ -0,0 +1,317 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Text.MMark.Extension.Emoji+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Replace @:shortcode:@ with the emoji it names.+--+-- @since 0.3.0.0+module Text.MMark.Extension.Emoji+  ( emoji,+    emojiWith,+    defaultEmoji,+  )+where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Text (Text)+import Data.Text qualified as T+import Text.MMark.Trans (Bni, Inline (..), Trans)+import Text.MMark.Trans qualified as Trans++-- | Replace every @:shortcode:@ of 'defaultEmoji' with the emoji it names,+-- and report every @:shortcode:@ that is not one of them. A name that is+-- not recognized is far more likely to be a typo than something the writer+-- meant to keep.+emoji :: Bni -> Trans Bni+emoji = emojiWith defaultEmoji++-- | Like 'emoji', but you supply the table.+emojiWith :: Map Text Text -> Bni -> Trans Bni+emojiWith table = Trans.bottomUpInlines $ \case+  Plain spn txt -> Plain spn <$> replace spn txt+  other -> return other+  where+    replace spn = fmap T.concat . mapM (piece spn) . chunks+    piece spn = \case+      Left t -> return t+      Right name -> case M.lookup name table of+        Just e -> return e+        Nothing -> do+          Trans.report spn ("there is no emoji called \"" <> name <> "\"")+          return (":" <> name <> ":")++-- | Split text into literal pieces and the shortcodes between them. A+-- shortcode is a run of letters, digits, @_@, @+@, and @-@ between colons.+chunks :: Text -> [Either Text Text]+chunks t =+  case T.breakOn ":" t of+    (before, rest)+      | T.null rest -> [Left before | not (T.null before)]+      | otherwise ->+          let (name, rest') = T.breakOn ":" (T.drop 1 rest)+           in if T.null rest' || T.null name || not (T.all nameChar name)+                then case chunks (T.drop 1 rest) of+                  cs -> Left (before <> ":") : cs+                else Left before : Right name : chunks (T.drop 1 rest')+  where+    nameChar c = c `elem` ("_+-" :: String) || c `elem` ['a' .. 'z'] || c `elem` ['0' .. '9']++-- | The table 'emoji' uses: a couple of hundred of the shortcodes that come+-- up most often, grouped below by what they are about. The names are the+-- familiar ones, so @:tada:@, @:+1:@, and @:warning:@ mean what you expect.+defaultEmoji :: Map Text Text+defaultEmoji =+  M.fromList+    [ -- Faces and emotions+      ("smile", "\128578"),+      ("grin", "\128512"),+      ("grinning", "\128512"),+      ("laughing", "\128514"),+      ("joy", "\128514"),+      ("sweat_smile", "\128517"),+      ("rofl", "\129315"),+      ("wink", "\128521"),+      ("blush", "\128522"),+      ("heart_eyes", "\128525"),+      ("star_struck", "\129321"),+      ("sunglasses", "\128526"),+      ("smirk", "\128527"),+      ("stuck_out_tongue", "\128539"),+      ("nerd_face", "\129299"),+      ("thinking", "\129300"),+      ("zipper_mouth_face", "\129296"),+      ("face_with_monocle", "\129488"),+      ("neutral_face", "\128528"),+      ("confused", "\128533"),+      ("upside_down_face", "\128579"),+      ("worried", "\128543"),+      ("cry", "\128546"),+      ("sob", "\128557"),+      ("tired_face", "\128555"),+      ("scream", "\128561"),+      ("angry", "\128544"),+      ("rage", "\128545"),+      ("sleeping", "\128564"),+      ("yawning_face", "\129393"),+      ("exploding_head", "\129327"),+      ("partying_face", "\129395"),+      ("shrug", "\129335"),+      ("facepalm", "\129318"),+      -- Hands+      ("thumbsup", "\128077"),+      ("thumbsdown", "\128078"),+      ("+1", "\128077"),+      ("-1", "\128078"),+      ("ok_hand", "\128076"),+      ("v", "\9996\65039"),+      ("point_up", "\9757\65039"),+      ("point_right", "\128073"),+      ("point_left", "\128072"),+      ("wave", "\128075"),+      ("clap", "\128079"),+      ("raised_hands", "\128588"),+      ("pray", "\128591"),+      ("handshake", "\129309"),+      ("muscle", "\128170"),+      ("writing_hand", "\9997\65039"),+      ("eyes", "\128064"),+      -- Hearts+      ("heart", "\10084\65039"),+      ("broken_heart", "\128148"),+      ("sparkling_heart", "\128150"),+      ("blue_heart", "\128153"),+      ("green_heart", "\128154"),+      ("yellow_heart", "\128155"),+      ("orange_heart", "\129505"),+      ("purple_heart", "\128156"),+      ("black_heart", "\128420"),+      -- Nature and weather+      ("sunny", "\9728\65039"),+      ("crescent_moon", "\127769"),+      ("star", "\11088"),+      ("sparkles", "\10024"),+      ("cloud", "\9729\65039"),+      ("zap", "\9889"),+      ("snowflake", "\10052\65039"),+      ("rainbow", "\127752"),+      ("droplet", "\128167"),+      ("ocean", "\127754"),+      ("earth_americas", "\127758"),+      ("mountain", "\9968\65039"),+      ("seedling", "\127793"),+      ("herb", "\127807"),+      ("four_leaf_clover", "\127808"),+      ("maple_leaf", "\127809"),+      ("cactus", "\127797"),+      ("palm_tree", "\127796"),+      ("fire", "\128293"),+      -- Animals+      ("snail", "\128012"),+      ("turtle", "\128034"),+      ("rabbit", "\128007"),+      ("cat", "\128049"),+      ("dog", "\128054"),+      ("mouse", "\128045"),+      ("horse", "\128052"),+      ("pig", "\128055"),+      ("bear", "\128059"),+      ("panda_face", "\128060"),+      ("fox_face", "\129418"),+      ("monkey", "\128018"),+      ("elephant", "\128024"),+      ("camel", "\128043"),+      ("unicorn", "\129412"),+      ("dragon", "\128009"),+      ("snake", "\128013"),+      ("bird", "\128038"),+      ("owl", "\129417"),+      ("penguin", "\128039"),+      ("fish", "\128031"),+      ("whale", "\128051"),+      ("octopus", "\128025"),+      ("crab", "\129408"),+      ("bug", "\128027"),+      ("bee", "\128029"),+      ("ant", "\128028"),+      ("butterfly", "\129419"),+      -- Food and drink+      ("coffee", "\9749"),+      ("tea", "\127861"),+      ("beer", "\127866"),+      ("wine_glass", "\127863"),+      ("cocktail", "\127864"),+      ("champagne", "\127870"),+      ("clinking_glasses", "\129346"),+      ("pizza", "\127829"),+      ("hamburger", "\127828"),+      ("taco", "\127790"),+      ("sushi", "\127843"),+      ("popcorn", "\127871"),+      ("cake", "\127856"),+      ("birthday", "\127874"),+      ("cookie", "\127850"),+      ("doughnut", "\127849"),+      ("ice_cream", "\127848"),+      ("chocolate_bar", "\127851"),+      ("apple", "\127822"),+      ("banana", "\127820"),+      ("avocado", "\129361"),+      -- Tools and objects+      ("bulb", "\128161"),+      ("wrench", "\128295"),+      ("hammer", "\128296"),+      ("hammer_and_wrench", "\128736\65039"),+      ("nut_and_bolt", "\128297"),+      ("gear", "\9881\65039"),+      ("toolbox", "\129520"),+      ("microscope", "\128300"),+      ("telescope", "\128301"),+      ("mag", "\128269"),+      ("computer", "\128187"),+      ("keyboard", "\9000\65039"),+      ("floppy_disk", "\128190"),+      ("package", "\128230"),+      ("battery", "\128267"),+      ("electric_plug", "\128268"),+      ("camera", "\128247"),+      ("movie_camera", "\127909"),+      ("tv", "\128250"),+      ("bell", "\128276"),+      ("mega", "\128227"),+      ("loudspeaker", "\128226"),+      ("speech_balloon", "\128172"),+      ("thought_balloon", "\128173"),+      ("envelope", "\9993\65039"),+      ("inbox_tray", "\128229"),+      ("outbox_tray", "\128228"),+      ("flashlight", "\128294"),+      ("candle", "\128367\65039"),+      ("broom", "\129529"),+      ("wastebasket", "\128465\65039"),+      ("crystal_ball", "\128302"),+      ("gem", "\128142"),+      ("crown", "\128081"),+      ("trophy", "\127942"),+      ("dart", "\127919"),+      ("game_die", "\127922"),+      ("art", "\127912"),+      ("musical_note", "\127925"),+      ("rocket", "\128640"),+      ("airplane", "\9992\65039"),+      ("hourglass", "\8987"),+      ("alarm_clock", "\9200"),+      ("stopwatch", "\9201\65039"),+      ("calendar", "\128197"),+      ("balance_scale", "\9878\65039"),+      ("chart_with_upwards_trend", "\128200"),+      ("bar_chart", "\128202"),+      -- Paper and files+      ("book", "\128214"),+      ("books", "\128218"),+      ("memo", "\128221"),+      ("pencil2", "\9999\65039"),+      ("scroll", "\128220"),+      ("page_facing_up", "\128196"),+      ("newspaper", "\128240"),+      ("clipboard", "\128203"),+      ("file_folder", "\128193"),+      ("open_file_folder", "\128194"),+      ("paperclip", "\128206"),+      ("pushpin", "\128204"),+      ("bookmark", "\128278"),+      ("label", "\127991\65039"),+      ("link", "\128279"),+      ("lock", "\128274"),+      ("unlock", "\128275"),+      ("closed_lock_with_key", "\128272"),+      ("key", "\128273"),+      ("shield", "\128737\65039"),+      -- Marks and signs+      ("white_check_mark", "\9989"),+      ("heavy_check_mark", "\10004\65039"),+      ("ballot_box_with_check", "\9745\65039"),+      ("x", "\10060"),+      ("question", "\10067"),+      ("exclamation", "\10071"),+      ("warning", "\9888\65039"),+      ("boom", "\128165"),+      ("100", "\128175"),+      ("tada", "\127881"),+      ("checkered_flag", "\127937"),+      ("triangular_flag_on_post", "\128681"),+      ("construction", "\128679"),+      ("rotating_light", "\128680"),+      ("no_entry", "\9940"),+      ("recycle", "\9851\65039"),+      ("infinity", "\9854\65039"),+      ("heavy_plus_sign", "\10133"),+      ("heavy_minus_sign", "\10134"),+      ("arrow_right", "\10145\65039"),+      ("arrow_left", "\11013\65039"),+      ("arrow_up", "\11014\65039"),+      ("arrow_down", "\11015\65039"),+      ("arrows_counterclockwise", "\128260"),+      ("red_circle", "\128308"),+      ("large_blue_circle", "\128309"),+      ("green_circle", "\128994"),+      ("yellow_circle", "\128993"),+      ("orange_circle", "\128992"),+      ("purple_circle", "\128995"),+      ("white_circle", "\9898"),+      ("black_circle", "\9899"),+      -- Other+      ("ghost", "\128123"),+      ("alien", "\128125"),+      ("robot", "\129302"),+      ("skull", "\128128"),+      ("zzz", "\128164")+    ]

@@ -1,62 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}---- |--- Module      :  Text.MMark.Extension.FontAwesome--- Copyright   :  © 2017–present Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Turn links into Font Awesome icons.-module Text.MMark.Extension.FontAwesome-  ( fontAwesome,-  )-where--import qualified Data.Text as T-import Lens.Micro ((^.))-import Lucid-import Text.MMark.Extension (Extension, Inline (..))-import qualified Text.MMark.Extension as Ext-import qualified Text.URI as URI-import Text.URI.Lens (uriPath)-import Text.URI.QQ (scheme)---- | Insert @span@s with font awesome icons using autolinks like this:------ > <fa:user>------ This @user@ identifier is the name of the 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 that go after the name of the 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 _ 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

@@ -1,5 +1,7 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}  -- | -- Module      :  Text.MMark.Extension.Footnotes@@ -14,24 +16,40 @@ -- -- @since 0.1.1.0 module Text.MMark.Extension.Footnotes-  ( footnotes,+  ( -- * Rendering+    footnotes,++    -- * Validation+    Footnotes,+    footnoteScanner,+    validateFootnotes,   ) where +import Control.Foldl qualified as L import Control.Monad import Data.Char (isDigit)+import Data.List (sort) import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T import Lens.Micro ((^.)) import Lucid-import Text.MMark.Extension (Block (..), Extension, Inline (..), getOis)-import qualified Text.MMark.Extension as Ext-import qualified Text.URI as URI+import Text.MMark qualified as MMark+import Text.MMark.Render (RenderExtension, getOis)+import Text.MMark.Render qualified as Render+import Text.MMark.Trans (Block (..), Bni, Inline (..), Span (..), Trans)+import Text.MMark.Trans qualified as Trans+import Text.URI qualified as URI import Text.URI.Lens (uriPath) import Text.URI.QQ (scheme) +----------------------------------------------------------------------------+-- Rendering+ -- | The extension performs two transformations: -- --     * It turns links with URIs with @footnote@ scheme and single path@@ -42,46 +60,35 @@ -- > Here goes some text [1](footnote:1). -- > -- > > footnotes--- >--- >   1. Here we have the footnote.+-- > >+-- > > 1. Here we have the footnote. ----- The extension is not fully safe though in the sense that we can't check--- that a footnote reference refers to an existing footnote and that--- footnotes have the corresponding references, or that they are present in--- the document in the right order.-footnotes :: Extension+-- This extension only renders footnotes, it does not check that they make+-- sense. Pair it with 'validateFootnotes', which does.+footnotes :: RenderExtension footnotes = footnoteRefs <> footnoteSection  -- | Create footnote references.-footnoteRefs :: Extension-footnoteRefs = Ext.inlineRender $ \old inline ->+footnoteRefs :: RenderExtension+footnoteRefs = Render.inlineRender $ \old inline ->   case inline of-    l@(Link _ uri _) ->-      if URI.uriScheme uri == Just [scheme|footnote|]-        then case uri ^. uriPath of-          [x'] ->-            let x = URI.unRText x'-             in if T.all isDigit x-                  then-                    a_-                      [ fragmentHref (footnoteId x),-                        id_ (referenceId x)-                      ]-                      $ sup_ (toHtml x)-                  else old l-          _ -> old l-        else old l+    l@(Link _ _ uri _) ->+      case footnoteRef uri of+        Just n ->+          let x = renderIx n+           in a_ [fragmentHref (footnoteId x), id_ (referenceId x)] $+                sup_ (toHtml x)+        Nothing -> old l     other -> old other  -- | Create a footnote section.-footnoteSection :: Extension-footnoteSection = Ext.blockRender $ \old block ->+footnoteSection :: RenderExtension+footnoteSection = Render.blockRender $ \old block ->   case block of-    b@(Blockquote [Paragraph (pOis, _), OrderedList i items]) ->-      if getOis pOis == Plain "footnotes" :| []+    b@(Blockquote _ [Paragraph _ (pOis, _), OrderedList _ i items]) ->+      if Render.asPlainText (getOis pOis) == footnoteLabel         then do           let startIndex = [start_ (renderIx i) | i /= 1]-              renderIx = T.pack . show           ol_ startIndex $ do             newline             forM_ (NE.zip (NE.iterate (+ 1) i) items) $ \(j, x) -> do@@ -97,8 +104,131 @@   where     newline = "\n" +----------------------------------------------------------------------------+-- Validation++-- | The footnotes of a document as collected by 'footnoteScanner'.+data Footnotes = Footnotes+  { -- | Span of every footnote section that was found, in order+    fnSections :: [Span],+    -- | Span of every footnote, by the number it is given+    fnDefined :: Map Word Span,+    -- | Span of every reference, by the number it refers to+    fnReferenced :: Map Word [Span],+    -- | Span of every reference we could not make sense of+    fnMalformed :: [Span]+  }++instance Semigroup Footnotes where+  x <> y =+    Footnotes+      { fnSections = fnSections x <> fnSections y,+        fnDefined = fnDefined x <> fnDefined y,+        fnReferenced = M.unionWith (<>) (fnReferenced x) (fnReferenced y),+        fnMalformed = fnMalformed x <> fnMalformed y+      }++instance Monoid Footnotes where+  mempty = Footnotes [] M.empty M.empty []++-- | Collect the footnotes of a document and the references to them, so that+-- 'validateFootnotes' can check that the two agree.+footnoteScanner :: L.Fold Bni Footnotes+footnoteScanner = MMark.scanner mempty $ \acc block ->+  acc <> scanSection block <> foldMap scanInlines block++-- | A check that reports every footnote that does not make sense. Every+-- problem is reported where it can be seen: a reference that leads nowhere+-- at the reference, a footnote that nothing refers to at the footnote.+--+-- > let fns = MMark.runScanner footnoteScanner doc+-- > case MMark.runCheck (validateFootnotes fns) doc of+-- >   Left errs -> putStrLn (errorBundlePretty errs)+-- >   Right () -> …+validateFootnotes :: Footnotes -> Trans ()+validateFootnotes Footnotes {..} = do+  forM_ (drop 1 fnSections) $ \spn ->+    Trans.report spn "there is more than one footnote section"+  forM_ fnMalformed $ \spn ->+    Trans.report+      spn+      "a footnote reference must have a single number as its path"+  forM_ (M.toAscList fnReferenced) $ \(n, spns) ->+    if M.member n fnDefined+      then forM_ (drop 1 (sort spns)) $ \spn ->+        Trans.report+          spn+          ( "footnote "+              <> renderIx n+              <> " is referred to more than once, which would give the"+              <> " references the same id"+          )+      else forM_ spns $ \spn ->+        Trans.report spn ("there is no footnote " <> renderIx n)+  forM_ (M.toAscList fnDefined) $ \(n, spn) ->+    unless (M.member n fnReferenced) $+      Trans.report spn ("nothing refers to footnote " <> renderIx n)++-- | Collect a footnote section, if this block is one.+scanSection :: Bni -> Footnotes+scanSection = \case+  Blockquote spn [Paragraph _ pInlines, OrderedList _ i items]+    | Trans.asPlainText pInlines == footnoteLabel ->+        mempty+          { fnSections = [spn],+            fnDefined = M.fromList (zip [i ..] (itemSpan <$> NE.toList items))+          }+  _ -> mempty+  where+    itemSpan = \case+      [] -> Span 0 0+      xs -> foldr1 Trans.spanUnion (Trans.blockSpan <$> xs)++-- | Collect the footnote references of a collection of inlines.+scanInlines :: NonEmpty Inline -> Footnotes+scanInlines = foldMap go+  where+    go = \case+      l@(Link spn inner uri _)+        | URI.uriScheme uri == Just [scheme|footnote|] ->+            case footnoteRef uri of+              Just n -> mempty {fnReferenced = M.singleton n [spn]}+              Nothing -> mempty {fnMalformed = [Trans.inlineSpan l]}+        | otherwise -> foldMap go inner+      Emphasis _ xs -> foldMap go xs+      Strong _ xs -> foldMap go xs+      Strikeout _ xs -> foldMap go xs+      Subscript _ xs -> foldMap go xs+      Superscript _ xs -> foldMap go xs+      Image _ xs _ _ -> foldMap go xs+      _ -> mempty++----------------------------------------------------------------------------+-- Helpers++-- | The number a footnote URI refers to, if it is a well-formed footnote+-- reference.+footnoteRef :: URI.URI -> Maybe Word+footnoteRef uri =+  if URI.uriScheme uri == Just [scheme|footnote|]+    then case uri ^. uriPath of+      [x'] ->+        let x = URI.unRText x'+         in if not (T.null x) && T.all isDigit x+              then Just (read (T.unpack x))+              else Nothing+      _ -> Nothing+    else Nothing++-- | The label that marks a block quote as the footnote section.+footnoteLabel :: Text+footnoteLabel = "footnotes"++renderIx :: Word -> Text+renderIx = T.pack . show+ fragmentHref :: Text -> Attribute-fragmentHref = href_ . URI.render . Ext.headerFragment+fragmentHref = href_ . URI.render . Render.headerFragment  footnoteId :: Text -> Text footnoteId x = "fn" <> x

@@ -18,12 +18,14 @@   ) where +import Control.Monad (forM_) import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T import GHC.SyntaxHighlighter import Lucid-import Text.MMark.Extension (Block (..), Extension)-import qualified Text.MMark.Extension as Ext+import Text.MMark.Extension.Internal (infoStringParts, withLineHighlight)+import Text.MMark.Render (Block (..), RenderExtension)+import Text.MMark.Render qualified as Ext  -- | Use the @ghc-syntax-highlighter@ package to highlight Haskell code. The -- extension is applied only to code blocks with the info string@@ -49,26 +51,56 @@ -- To use with 'Text.MMark.Extension.Skylighting.skylighting' the extension -- should be applied /after/ the -- 'Text.MMark.Extension.Skylighting.skylighting' extension so it can--- overwrite its logic for code block with @\"haskell\"@ info string. So--- place it on the left hand side of @('<>')@ or above+-- overwrite its logic for a code block with the @\"haskell\"@ info string.+-- So place it on the left hand side of @('<>')@ or above -- 'Text.MMark.Extension.Skylighting.skylighting' in the list passed to -- 'Text.MMark.useExtensions'.-ghcSyntaxHighlighter :: Extension+--+-- The info string may end with a line specification, as in @haskell {2,4-6}@+-- (see 'Text.MMark.Extension.LineHighlight.lineHighlight'). It does not stop+-- the block from being recognized as Haskell, and the lines it names are+-- given the class @\"highlighted-line\"@ around the tokens of the line.+ghcSyntaxHighlighter :: RenderExtension ghcSyntaxHighlighter = Ext.blockRender $ \old block ->   case block of-    cb@(CodeBlock (Just "haskell") txt) ->-      case tokenizeHaskell txt of-        Nothing -> old cb-        Just toks -> do-          div_ [class_ "source-code"]-            . pre_-            . code_ [class_ "language-haskell"]-            $ mapM_ tokenToHtml toks-          newline+    cb@(CodeBlock _ (Just infoString) txt)+      | (Just "haskell", highlighted) <- infoStringParts infoString ->+          case tokenizeHaskell txt of+            Nothing -> old cb+            Just toks -> do+              div_ [class_ "source-code"]+                . pre_+                . code_ [class_ "language-haskell"]+                $ if null highlighted+                  then mapM_ tokenToHtml toks+                  else forM_ (zip [1 ..] (tokenLines toks)) $ \(n, l) ->+                    withLineHighlight highlighted n $ do+                      mapM_ tokenToHtml l+                      newline+              newline     other -> old other   where     newline :: Html ()     newline = "\n"++-- | Split a token stream into the tokens of each line.+tokenLines :: [(Token, Text)] -> [[(Token, Text)]]+tokenLines = dropFinalEmpty . go []+  where+    dropFinalEmpty ls = case ls of+      (_ : _) | null (last ls) -> init ls+      _ -> ls+    go acc [] = [reverse acc]+    go acc ((tt, txt) : rest) =+      case T.splitOn "\n" txt of+        [] -> go acc rest+        [only] -> go (push tt only acc) rest+        (first : more) ->+          reverse (push tt first acc)+            : fmap (\m -> push tt m []) (init more)+              <> go (push tt (last more) []) rest+    -- an empty piece is not a token, it is where a newline was+    push tt t acc = if T.null t then acc else (tt, t) : acc  -- | Render a single 'Token'. tokenToHtml :: (Token, Text) -> Html ()

@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Text.MMark.Extension.Heading+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Checks on the headings of a document, which a parser cannot make on its+-- own because they concern the document as a whole: the outline the+-- headings form, and the ids they are given.+--+-- Scan the document first, then check what the scan collected:+--+-- > let hs = MMark.runScanner headingScanner doc+-- > MMark.runCheck (checkHeadings hs) doc+--+-- @since 0.3.0.0+module Text.MMark.Extension.Heading+  ( Headings,+    headingScanner,+    checkHeadings,+    headingProblems,+  )+where++import Control.Foldl qualified as L+import Data.List (sortOn)+import Data.Map.Strict qualified as M+import Data.Text (Text)+import Data.Text qualified as T+import Text.MMark qualified as MMark+import Text.MMark.Trans (Block (..), Bni, Span, Trans)+import Text.MMark.Trans qualified as Trans++-- | The headings of a document as collected by 'headingScanner'.+newtype Headings = Headings [(Span, Int, Text)]++instance Semigroup Headings where+  Headings x <> Headings y = Headings (x <> y)++instance Monoid Headings where+  mempty = Headings []++-- | Collect the headings of a document in the order they appear, with the+-- id each of them is given.+headingScanner :: L.Fold Bni Headings+headingScanner = MMark.scanner mempty $ \acc block ->+  acc <> heading block+  where+    heading b = case b of+      Heading1 spn x -> one spn 1 x+      Heading2 spn x -> one spn 2 x+      Heading3 spn x -> one spn 3 x+      Heading4 spn x -> one spn 4 x+      Heading5 spn x -> one spn 5 x+      Heading6 spn x -> one spn 6 x+      _ -> mempty+    one spn n x = Headings [(spn, n, Trans.headerId x)]++-- | A check that reports the problems 'headingProblems' finds.+checkHeadings :: Headings -> Trans ()+checkHeadings = mapM_ (uncurry Trans.report) . headingProblems++-- | The problems with the headings of a document:+--+--     * a heading that skips a level, such as a level 3 heading that+--       follows a level 1 one, which leaves a hole in the outline that+--       assistive technology relies on;+--     * a second level 1 heading, since a document has one title;+--     * two headings that MMark gives the same id, in which case every+--       link to one of them leads to the first.+headingProblems :: Headings -> [(Span, Text)]+headingProblems (Headings hs) =+  sortOn fst (skips <> extraTitles <> collisions)+  where+    skips =+      [ (spn, skipMessage prev n)+      | ((_, prev, _), (spn, n, _)) <- zip hs (drop 1 hs),+        n > prev + 1+      ]+    skipMessage prev n =+      "this heading is of level "+        <> tshow n+        <> ", but the one before it is of level "+        <> tshow prev+        <> ", so the outline of the document skips a level"+    extraTitles =+      [ (spn, "there is more than one level 1 heading in this document")+      | (spn, _, _) <- drop 1 [h | h@(_, 1, _) <- hs]+      ]+    collisions =+      [ (spn, "another heading is already given the id \"" <> i <> "\"")+      | (spn, _, i) <- hs,+        M.lookup i firstWithId /= Just spn+      ]+    firstWithId = M.fromListWith (\_ old -> old) [(i, spn) | (spn, _, i) <- hs]+    tshow :: Int -> Text+    tshow = T.pack . show

@@ -0,0 +1,190 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++-- |+-- Module      :  Text.MMark.Extension.Icons+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Put an icon in a document by naming it: @\<icon:github\>@.+--+-- The icons are yours. You give 'icons' a table that says what each name+-- draws, and the SVG it finds there goes into the page:+--+-- > myIcons :: Map Text (Html ())+-- > myIcons = toHtmlRaw <$> M.fromList+-- >   [ ("github", "<svg viewBox=\"0 0 24 24\">…</svg>")+-- >   , ("envelope", "<svg viewBox=\"0 0 24 24\">…</svg>")+-- >   ]+--+-- Nothing else about the icons is this extension's business, so any SVG+-- will do, whoever drew it. The sets people usually take them from, with+-- the licence each one puts on its artwork:+--+--     * Font Awesome Free (CC BY 4.0), the largest of them+--     * Lucide (ISC) and Feather (MIT), which it forked from, both drawn as+--       strokes on a 24×24 grid+--     * Bootstrap Icons (MIT), Heroicons (MIT), Tabler Icons (MIT), and+--       Phosphor (MIT)+--     * Octicons (MIT), the ones GitHub uses+--     * Material Symbols (Apache 2.0)+--     * Simple Icons (CC0), for the logos of companies and projects, which+--       the general-purpose sets mostly do not carry+--+-- Or draw your own, export one from a design tool, or build it with the+-- Lucid combinators instead of pasting the markup: the table holds+-- @'Html' ()@, so it does not care where the SVG came from.+--+-- This package ships no icons of its own, because bundling artwork would+-- put someone else's licence and attribution on top of its own. Whichever+-- set you take from, check what its licence asks of you; the CC BY ones+-- want to be credited somewhere in your page.+--+-- @since 0.3.0.0+module Text.MMark.Extension.Icons+  ( -- * Rendering+    icons,+    iconsWith,++    -- * Checking+    checkIcons,+    checkIconsWith,+  )+where++import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Text (Text)+import Data.Text qualified as T+import Lucid+import Lucid.Base (makeAttribute)+import Text.MMark.Extension.Internal (inlinesOf)+import Text.MMark.Render (Inline (..), RenderExtension)+import Text.MMark.Render qualified as Render+import Text.MMark.Trans (Bni, Trans)+import Text.MMark.Trans qualified as Trans+import Text.URI (RText, RTextLabel (..), URI)+import Text.URI qualified as URI+import Text.URI.QQ (scheme)++-- | Put the SVG of an icon in place of every link with the @icon@ scheme+-- that names one:+--+-- > <icon:github>+--+-- becomes, given an @icon-github@ table entry:+--+-- > <span class="icon icon-github" aria-hidden="true">…the SVG…</span>+--+-- An icon written as an autolink is decorative: it is hidden from a screen+-- reader, which is what you want next to text that already says what the+-- link is. Give the link text instead to label it:+--+-- > [GitHub](icon:github)+--+-- > <span class="icon icon-github" role="img" aria-label="GitHub">…the SVG…</span>+--+-- Path components after the name become classes too, so an icon can be+-- given a size or a position by a style sheet of yours:+--+-- > <icon:github/lg>+--+-- > <span class="icon icon-github icon-lg" aria-hidden="true">…the SVG…</span>+--+-- A link that names an icon you do not have is left as it is, so that it is+-- visible in the output rather than missing from it. 'checkIcons' turns it+-- into an error instead.+icons ::+  -- | The icons you have, by name+  Map Text (Html ()) ->+  RenderExtension+icons = iconsWith [scheme|icon|] "icon"++-- | Like 'icons', but you choose the scheme that marks an icon and the+-- prefix of the classes. Documents written for the @fontAwesome@ extension+-- keep working with+--+-- > iconsWith [scheme|fa|] "icon" myIcons+iconsWith ::+  -- | Scheme that marks a link as an icon+  RText 'Scheme ->+  -- | Prefix of the classes to give the icon+  Text ->+  -- | The icons you have, by name+  Map Text (Html ()) ->+  RenderExtension+iconsWith scm prefix table = Render.inlineRender $ \old inline ->+  case inline of+    Link _ inner uri _+      | hasScheme scm uri,+        Just (name, mods) <- iconPath uri,+        Just svg <- M.lookup name table ->+          span_ (class_ (classes name mods) : how inner uri) svg+    other -> old other+  where+    classes name mods = T.unwords (prefix : fmap dashed (name : mods))+    dashed x = prefix <> "-" <> x+    -- An autolink is a link whose text is its own URI, and it is the way to+    -- ask for an icon that says nothing.+    how inner uri =+      let label = Render.asPlainText inner+       in if label == URI.render uri+            then [makeAttribute "aria-hidden" "true"]+            else [makeAttribute "role" "img", makeAttribute "aria-label" label]++-- | Report every link with the @icon@ scheme that does not name one of the+-- icons you have. 'icons' cannot do this itself: it runs while the document+-- is rendered, and by then there is nothing left to report against.+--+-- > MMark.runTrans (checkIcons myIcons) doc+--+-- Only the names matter here, so the table you render with will do.+checkIcons ::+  -- | The icons you have, by name+  Map Text a ->+  Bni ->+  Trans Bni+checkIcons = checkIconsWith [scheme|icon|]++-- | Like 'checkIcons', but you choose the scheme, as in 'iconsWith'.+checkIconsWith ::+  -- | Scheme that marks a link as an icon+  RText 'Scheme ->+  -- | The icons you have, by name+  Map Text a ->+  Bni ->+  Trans Bni+checkIconsWith scm table block = do+  mapM_ check (iconLinks block)+  return block+  where+    iconLinks = foldMap ofInline . inlinesOf+    ofInline = \case+      Link spn _ uri _ | hasScheme scm uri -> [(spn, uri)]+      _ -> []+    check (spn, uri) = case iconPath uri of+      Nothing -> Trans.report spn "this link names no icon"+      Just (name, _)+        | M.member name table -> return ()+        | otherwise ->+            Trans.report spn ("there is no icon called \"" <> name <> "\"")++----------------------------------------------------------------------------+-- Helpers++-- | Whether a URI is written in the given scheme.+hasScheme :: RText 'Scheme -> URI -> Bool+hasScheme scm uri = URI.uriScheme uri == Just scm++-- | The icon a URI names and the modifiers that follow it.+iconPath :: URI -> Maybe (Text, [Text])+iconPath uri = case URI.uriPath uri of+  Just (_, name :| mods) -> Just (URI.unRText name, URI.unRText <$> mods)+  Nothing -> Nothing

@@ -0,0 +1,188 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Text.MMark.Extension.Image+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Tell the browser how large an image is before it has been fetched, let it+-- decide when to fetch it, and say when an image describes itself to nobody.+--+-- An @\<img\>@ without @width@ and @height@ makes the page move under the+-- reader while the image loads, which is the layout shift every measure of+-- page quality penalizes.+--+-- 'lazyImages' and 'checkAltText' need nothing but the document. The width+-- and height have to be measured first, which 'imageScanner',+-- 'imageSizeOf', and 'imageDimensions' do between them.+--+-- @since 0.3.0.0+module Text.MMark.Extension.Image+  ( lazyImages,+    checkAltText,+    imageScanner,+    imageDimensions,+    imageSizeOf,+  )+where++import Control.Exception (IOException, try)+import Control.Foldl qualified as L+import Data.Bits (shiftL, (.|.))+import Data.ByteString qualified as B+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Text qualified as T+import Data.Word (Word8)+import Lucid+import Lucid.Base (makeAttribute)+import System.IO (IOMode (..), withBinaryFile)+import Text.MMark qualified as MMark+import Text.MMark.Extension.Internal (inlinesOf)+import Text.MMark.Render (Bni, Inline (..), RenderExtension, Span)+import Text.MMark.Render qualified as Render+import Text.MMark.Trans (Trans)+import Text.MMark.Trans qualified as Trans+import Text.URI (URI)++-- | Give every image @loading=\"lazy\"@ and @decoding=\"async\"@, so that+-- an image far down the page does not hold up the ones the reader can see.+lazyImages :: RenderExtension+lazyImages = Render.inlineRender $ \old inline ->+  case inline of+    i@Image {} ->+      with+        (old i)+        [ makeAttribute "loading" "lazy",+          makeAttribute "decoding" "async"+        ]+    other -> old other++-- | Report every image whose description is empty. A reader who cannot see+-- the image is told nothing about it, and a search engine cannot index it.+--+-- Note that MMark renders such an image as @\<img alt src=\"…\"\>@ without+-- complaining, so nothing else in the pipeline will tell you.+checkAltText :: Bni -> Trans Bni+checkAltText block = do+  mapM_ check (inlinesOf block)+  return block+  where+    check = \case+      Image spn desc _ _+        | Trans.asPlainText desc == "" ->+            Trans.report spn "this image has no description for the alt attribute"+      _ -> return ()++-- | Collect the URI of every image of a document, by the span of the image+-- it belongs to.+--+-- > let imgs = MMark.runScanner imageScanner doc+-- > sizes <- traverse (imageSizeOf . toPath) imgs+-- > TL.putStr (renderText (MMark.render (imageDimensions sizes) doc))+imageScanner :: L.Fold Bni (Map Span URI)+imageScanner = MMark.scanner M.empty $ \acc block ->+  foldr insert acc (inlinesOf block)+  where+    insert = \case+      Image spn _ uri _ -> M.insert spn uri+      _ -> id++-- | Give each image the width and height it was measured to have. An image+-- with no measurement, or one that could not be measured, is left alone.+imageDimensions :: Map Span (Maybe (Int, Int)) -> RenderExtension+imageDimensions sizes = Render.inlineRender $ \old inline ->+  case inline of+    i@(Image spn _ _ _) ->+      case M.lookup spn sizes of+        Just (Just (w, h)) ->+          with (old i) [width_ (tshow w), height_ (tshow h)]+        _ -> old i+    other -> old other+  where+    tshow = T.pack . show++-- | Measure a PNG, GIF, or JPEG file without decoding it, by reading the+-- header that states its size. Anything else gives 'Nothing'.+imageSizeOf :: FilePath -> IO (Maybe (Int, Int))+imageSizeOf path = do+  r <- try (withBinaryFile path ReadMode (`B.hGet` headerLimit))+  return $ case r of+    Left (_ :: IOException) -> Nothing+    Right bs -> sizeOfPng bs `orElse` sizeOfGif bs `orElse` sizeOfJpeg bs+  where+    orElse (Just x) _ = Just x+    orElse Nothing y = y++-- | How much of a file 'imageSizeOf' reads looking for the header that+-- states its size.+headerLimit :: Int+headerLimit = 256 * 1024++-- | @IHDR@ holds the size in the first two big-endian words of its data.+sizeOfPng :: B.ByteString -> Maybe (Int, Int)+sizeOfPng bs+  | B.take 8 bs == B.pack [137, 80, 78, 71, 13, 10, 26, 10],+    B.length bs >= 24 =+      Just (be32 (B.drop 16 bs), be32 (B.drop 20 bs))+  | otherwise = Nothing++-- | The logical screen descriptor holds the size in little-endian shorts.+sizeOfGif :: B.ByteString -> Maybe (Int, Int)+sizeOfGif bs+  | B.take 3 bs == "GIF",+    B.length bs >= 10 =+      Just (le16 (B.drop 6 bs), le16 (B.drop 8 bs))+  | otherwise = Nothing++-- | Walk the segments of a JPEG until one of the frame headers, which+-- carries the size after a byte of precision.+sizeOfJpeg :: B.ByteString -> Maybe (Int, Int)+sizeOfJpeg bs+  | B.take 2 bs == B.pack [0xFF, 0xD8] = go (B.drop 2 bs)+  | otherwise = Nothing+  where+    go s = do+      (marker, rest) <- segment s+      if isFrame marker+        then+          if B.length rest >= 7+            then Just (be16 (B.drop 5 rest), be16 (B.drop 3 rest))+            else Nothing+        else+          if isStandalone marker+            then if marker == 0xD9 then Nothing else go rest+            else+              if B.length rest >= 2+                then go (B.drop (be16 rest) rest)+                else Nothing+    segment s =+      let s' = B.dropWhile (== 0xFF) s+       in if B.null s' then Nothing else Just (B.head s', B.drop 1 s')+    -- SOF0 through SOF15, less the four markers that are not frames+    isFrame m =+      m >= 0xC0 && m <= 0xCF && m /= 0xC4 && m /= 0xC8 && m /= 0xCC++-- | Whether a JPEG marker carries no payload, in which case the two bytes+-- that follow it are not a length: TEM, the eight restart markers, SOI, and+-- EOI.+isStandalone :: Word8 -> Bool+isStandalone m = m == 0x01 || (m >= 0xD0 && m <= 0xD9)++be32 :: B.ByteString -> Int+be32 b =+  (fromIntegral (B.index b 0) `shiftL` 24)+    .|. (fromIntegral (B.index b 1) `shiftL` 16)+    .|. (fromIntegral (B.index b 2) `shiftL` 8)+    .|. fromIntegral (B.index b 3)++be16 :: B.ByteString -> Int+be16 b = (fromIntegral (B.index b 0) `shiftL` 8) .|. fromIntegral (B.index b 1)++le16 :: B.ByteString -> Int+le16 b = (fromIntegral (B.index b 1) `shiftL` 8) .|. fromIntegral (B.index b 0)

@@ -0,0 +1,98 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Text.MMark.Extension.Internal+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Helpers shared by the extensions of this package.+module Text.MMark.Extension.Internal+  ( inlinesOf,+    lineSpec,+    infoStringParts,+    withLineHighlight,+  )+where++import Data.Char (isDigit)+import Data.List.NonEmpty qualified as NE+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Lucid+import Text.MMark.Trans (Bni, Inline (..))++-- | Every inline of a block, including the ones nested inside other+-- inlines and inside the blocks the block contains.+inlinesOf :: Bni -> [Inline]+inlinesOf = foldMap (concatMap go . NE.toList)+  where+    go i =+      i : case i of+        Emphasis _ xs -> nested xs+        Strong _ xs -> nested xs+        Strikeout _ xs -> nested xs+        Subscript _ xs -> nested xs+        Superscript _ xs -> nested xs+        Link _ xs _ _ -> nested xs+        Image _ xs _ _ -> nested xs+        _ -> []+    nested = concatMap go . NE.toList++-- | Split the info string of a code block into the language it names and+-- the lines it points at, as in @haskell {2,4-6}@.+--+-- Gives 'Nothing' when there is no line specification, so that a code block+-- written the usual way is left to whatever renders it.+lineSpec :: Text -> Maybe (Maybe Text, [Int])+lineSpec info = do+  let (before, rest) = T.breakOn "{" info+  spec <- T.stripSuffix "}" =<< T.stripPrefix "{" rest+  ns <- traverse range (T.splitOn "," (T.filter (/= ' ') spec))+  return (language before, concat ns)+  where+    range t = case T.splitOn "-" t of+      [a] -> (: []) <$> number a+      [a, b] -> do+        x <- number a+        y <- number b+        if x <= y then Just [x .. y] else Nothing+      _ -> Nothing+    number t =+      if not (T.null t) && T.all isDigit t+        then Just (read (T.unpack t))+        else Nothing++-- | Like 'lineSpec', but for an info string that need not carry a line+-- specification at all: one that does not simply points at no lines.+--+-- Every extension that renders a code block goes through this, so that a+-- language followed by a line specification is still recognized as that+-- language. Without it @haskell {2}@ looks like the name of a language+-- nobody has, and the block loses its syntax highlighting.+infoStringParts :: Text -> (Maybe Text, [Int])+infoStringParts info = fromMaybe (language info, []) (lineSpec info)++-- | Wrap the rendering of one line of a code block when the line is among+-- the ones pointed at.+withLineHighlight ::+  -- | The lines pointed at+  [Int] ->+  -- | The line being rendered, counting from one+  Int ->+  Html () ->+  Html ()+withLineHighlight ns n+  | n `elem` ns = span_ [class_ "highlighted-line"]+  | otherwise = id++-- | The language an info string names, if it names one.+language :: Text -> Maybe Text+language t =+  let l = T.strip t+   in if T.null l then Nothing else Just l

@@ -16,9 +16,9 @@ where  import Lucid-import Text.MMark.Extension (Extension, Inline (..))-import qualified Text.MMark.Extension as Ext-import qualified Text.URI as URI+import Text.MMark.Render (Inline (..), RenderExtension)+import Text.MMark.Render qualified as Ext+import Text.URI qualified as URI import Text.URI.QQ (scheme)  -- | Introduce @kbd@ tags by wrapping content in links with @kbd@ scheme.@@ -30,13 +30,13 @@ -- > [kbd]: kbd: -- -- The use of reference-style links seems more aesthetically pleasant to me,--- but you can of course do somethnig like this instead:+-- but you can of course do something like this instead: -- -- > To enable that mode press [Ctrl+A](kbd:).-kbd :: Extension+kbd :: RenderExtension kbd = Ext.inlineRender $ \old inline ->   case inline of-    l@(Link inner uri _) ->+    l@(Link _ inner uri _) ->       if URI.uriScheme uri == Just [scheme|kbd|]         then kbd_ (mapM_ old inner)         else old l

@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Text.MMark.Extension.LineHighlight+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Point at the lines of a code block that the prose is about.+--+-- Write the lines to point at after the language in the info string:+--+-- > ```haskell {2,4-6}+-- > …+-- > ```+--+-- 'Text.MMark.Extension.Skylighting.skylighting' and+-- 'Text.MMark.Extension.GhcSyntaxHighlighter.ghcSyntaxHighlighter' read the+-- same specification and point at the lines themselves, around the tokens+-- they have coloured. Put either of them before this extension and it takes+-- the blocks whose language it knows; this one renders the rest, without+-- colouring but with the lines still pointed at.+--+-- @since 0.3.0.0+module Text.MMark.Extension.LineHighlight+  ( lineHighlight,+    parseLineSpec,+  )+where++import Data.Text (Text)+import Data.Text qualified as T+import Lucid+import Text.MMark.Extension.Internal (lineSpec, withLineHighlight)+import Text.MMark.Render (Block (..), RenderExtension)+import Text.MMark.Render qualified as Render++-- | Render a code block whose info string ends with a line specification,+-- giving the lines it names the class @\"highlighted-line\"@.+--+-- The language, if there is one, still becomes the @language-@ class of the+-- @\<code\>@ element, so this composes with a style sheet written for the+-- usual output.+lineHighlight :: RenderExtension+lineHighlight = Render.blockRender $ \old block ->+  case block of+    b@(CodeBlock _ (Just info) txt) ->+      case parseLineSpec info of+        Nothing -> old b+        Just (lang, ns) -> do+          pre_+            $ code_ (langAttr lang)+            $ mapM_ (line ns) (zip [1 :: Int ..] (T.lines txt))+          "\n"+    other -> old other+  where+    langAttr = \case+      Just l | not (T.null l) -> [class_ ("language-" <> l)]+      _ -> []+    line ns (n, t) = withLineHighlight ns n (toHtml (t <> "\n"))++-- | Split an info string into the language and the lines to point at.+-- Gives 'Nothing' when there is no line specification, so that an ordinary+-- code block is left to whatever renders it.+--+-- > parseLineSpec "haskell {2,4-6}" == Just (Just "haskell", [2,4,5,6])+parseLineSpec :: Text -> Maybe (Maybe Text, [Int])+parseLineSpec = lineSpec

@@ -0,0 +1,180 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module      :  Text.MMark.Extension.Link+-- Copyright   :  © 2018–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Say where a link opens, and find the links that lead nowhere.+--+-- 'linkTarget' is the only render extension here; the rest are checks. The+-- three checks cost increasingly more, so they are separate: checking+-- fragments needs nothing but the document, checking local files needs the+-- file system, and checking the rest needs whatever you are willing to do+-- to find out.+--+-- @since 0.3.0.0+module Text.MMark.Extension.Link+  ( linkTarget,+    headerIdScanner,+    checkFragments,+    checkLocalFiles,+    checkExternal,+  )+where++import Control.Foldl qualified as L+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (asum)+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as S+import Data.Text qualified as T+import Lucid+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath ((</>))+import Text.MMark qualified as MMark+import Text.MMark.Extension.Internal (inlinesOf)+import Text.MMark.Render (RenderExtension)+import Text.MMark.Render qualified as Render+import Text.MMark.Trans (Block (..), Bni, Inline (..), Trans, TransT)+import Text.MMark.Trans qualified as Trans+import Text.URI (URI (..))+import Text.URI qualified as URI++-- | When the title of a link starts with the word @\"_blank\"@,+-- @\"_self\"@, @\"_parent\"@, or @\"_top\"@, it's stripped from the title (as+-- well as all whitespace after it) and added as the value of the @target@+-- attribute of the resulting link.+--+-- For example:+--+-- > This [link](/url '_blank My title') opens in new tab.+--+-- A link that opens in a new browsing context also gets+-- @rel=\"noopener noreferrer\"@. Without it the page that is opened can+-- reach back to the page that opened it through @window.opener@, and the+-- referrer is disclosed to it.+linkTarget :: RenderExtension+linkTarget = Render.inlineRender $ \old inline ->+  case inline of+    l@(Link spn 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'+          -- Only a new browsing context can reach back through+          -- window.opener, so the other targets do not need protecting.+          relAttrs =+            [rel_ "noopener noreferrer" | prefix == "_blank"]+      return $+        with (old (Link spn txt url mtitle)) (target_ prefix : relAttrs)+    other -> old other++-- | Collect the ids MMark gives to the headings of a document, so that+-- 'checkFragments' can tell whether a link into the document leads+-- anywhere.+headerIdScanner :: L.Fold Bni (Set T.Text)+headerIdScanner = MMark.scanner S.empty $ \acc block ->+  case block of+    Heading1 _ x -> add x acc+    Heading2 _ x -> add x acc+    Heading3 _ x -> add x acc+    Heading4 _ x -> add x acc+    Heading5 _ x -> add x acc+    Heading6 _ x -> add x acc+    _ -> acc+  where+    add x = S.insert (Trans.headerId x)++-- | Report every link of the form @#section@ whose fragment no heading of+-- the document defines.+--+-- > let ids = MMark.runScanner headerIdScanner doc+-- > MMark.runTrans (checkFragments ids) doc+checkFragments :: Set T.Text -> Bni -> Trans Bni+checkFragments ids block = do+  mapM_ check (links block)+  return block+  where+    check (spn, uri) = case internalFragment uri of+      Just f+        | not (f `S.member` ids) ->+            Trans.report+              spn+              ("no heading of this document has the id \"" <> f <> "\"")+      _ -> return ()++-- | Report every link to a path that does not exist, relative to the given+-- directory. Links with a scheme or an authority are left to+-- 'checkExternal'.+checkLocalFiles :: FilePath -> Bni -> TransT IO Bni+checkLocalFiles base block = do+  mapM_ check (links block)+  return block+  where+    check (spn, uri) = case localPath uri of+      Nothing -> return ()+      Just p -> do+        let path = base </> T.unpack p+        there <- liftIO $ (||) <$> doesFileExist path <*> doesDirectoryExist path+        if there+          then return ()+          else Trans.report spn ("there is nothing at " <> T.pack path)++-- | Report every link the given action says is unreachable. The action is+-- yours to write, so that this package needs no HTTP client of its own and+-- so that you can cache, rate limit, or skip whatever you like.+--+-- > checkExternal (\uri -> (== 200) . statusCode <$> headRequest uri)+checkExternal :: (URI -> IO Bool) -> Bni -> TransT IO Bni+checkExternal reachable block = do+  mapM_ check (links block)+  return block+  where+    check (spn, uri) =+      case (URI.uriScheme uri, localPath uri, internalFragment uri) of+        (Nothing, _, _) -> return ()+        (_, Just _, _) -> return ()+        (_, _, Just _) -> return ()+        _ -> do+          ok <- liftIO (reachable uri)+          if ok+            then return ()+            else Trans.report spn ("cannot reach " <> URI.render uri)++----------------------------------------------------------------------------+-- Helpers++-- | The links and images of a block, with the span to report against.+links :: Bni -> [(Trans.Span, URI)]+links = foldMap ofInline . inlinesOf+  where+    ofInline = \case+      Link spn _ uri _ -> [(spn, uri)]+      Image spn _ uri _ -> [(spn, uri)]+      _ -> []++-- | The fragment of a URI that points into the document it appears in.+internalFragment :: URI -> Maybe T.Text+internalFragment uri =+  case (uriScheme uri, uriAuthority uri, uriPath uri, uriFragment uri) of+    (Nothing, Left False, Nothing, Just f) -> Just (URI.unRText f)+    _ -> Nothing++-- | The path of a URI that points at a file next to the document.+localPath :: URI -> Maybe T.Text+localPath uri =+  case (uriScheme uri, uriAuthority uri, uriPath uri) of+    (Nothing, Left False, Just (_, ps)) ->+      Just (T.intercalate "/" (URI.unRText <$> foldr (:) [] ps))+    _ -> Nothing

@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}---- |--- Module      :  Text.MMark.Extension.LinkTarget--- Copyright   :  © 2018–present Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Specify the @target@ attribute of links in link titles. This allows us--- to, e.g. make a link open in a new tab.-module Text.MMark.Extension.LinkTarget-  ( linkTarget,-  )-where--import Data.Foldable (asum)-import Data.Maybe (fromMaybe)-import qualified Data.Text as T-import Lucid-import Text.MMark.Extension (Extension, Inline (..))-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

@@ -19,10 +19,10 @@  import Control.Monad import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T import Lucid-import Text.MMark.Extension (Block (..), Extension, Inline (..))-import qualified Text.MMark.Extension as Ext+import Text.MMark.Render (Block (..), Inline (..), RenderExtension)+import Text.MMark.Render qualified as Ext  -- | The extension allows us to transform inline code spans into MathJax -- inline spans and code blocks with the info string @\"mathjax\"@@@ -37,16 +37,16 @@ mathJax ::   -- | Starting\/ending character in MathJax inline spans   Maybe Char ->-  Extension+  RenderExtension mathJax mch = mathJaxSpan mch <> mathJaxBlock  -- | Turn code spans that start and end with a given character into MathJax -- inline spans. If 'Nothing' is provided instead of a char, apply the -- transformation to all code spans.-mathJaxSpan :: Maybe Char -> Extension+mathJaxSpan :: Maybe Char -> RenderExtension mathJaxSpan mch = Ext.inlineRender $ \old inline ->   case inline of-    s@(CodeSpan txt) ->+    s@(CodeSpan _ txt) ->       case mch of         Nothing -> spn txt         Just ch ->@@ -62,10 +62,10 @@  -- | Turn code blocks with info string @\"mathjax\"@ into MathJax display -- spans.-mathJaxBlock :: Extension+mathJaxBlock :: RenderExtension mathJaxBlock = Ext.blockRender $ \old block ->   case block of-    b@(CodeBlock mlabel txt) ->+    b@(CodeBlock _ mlabel txt) ->       if mlabel == Just "mathjax"         then do           p_ . forM_ (T.lines txt) $ \x ->

@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Text.MMark.Extension.Mermaid+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Turn code blocks with the @mermaid@ info string into diagrams, either in+-- the browser or ahead of time.+--+-- @since 0.3.0.0+module Text.MMark.Extension.Mermaid+  ( -- * In the browser+    mermaid,++    -- * Ahead of time+    mermaidScanner,+    mermaidSvg,+  )+where++import Control.Foldl qualified as L+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Text (Text)+import Lucid+import Text.MMark qualified as MMark+import Text.MMark.Render (Block (..), Bni, RenderExtension, Span)+import Text.MMark.Render qualified as Render++-- | Render a @mermaid@ code block as @\<pre class=\"mermaid\"\>@, which is+-- what the mermaid script in the page looks for.+mermaid :: RenderExtension+mermaid = Render.blockRender $ \old block ->+  case block of+    b@(CodeBlock _ mlabel txt) ->+      if mlabel == Just label+        then pre_ [class_ label] (toHtml txt) >> "\n"+        else old b+    other -> old other++-- | Collect the source of every @mermaid@ code block, by the span of the+-- block it came from.+--+-- Hand the result to whatever turns a diagram into an SVG, then give the+-- SVGs to 'mermaidSvg':+--+-- > srcs <- pure (MMark.runScanner mermaidScanner doc)+-- > svgs <- traverse mermaidCli srcs+-- > TL.putStr (renderText (MMark.render (mermaidSvg svgs) doc))+--+-- The span is the key because it is what tells two diagrams apart, even+-- two that contain exactly the same source.+mermaidScanner :: L.Fold Bni (Map Span Text)+mermaidScanner = MMark.scanner M.empty $ \acc block ->+  case block of+    CodeBlock spn (Just l) txt | l == label -> M.insert spn txt acc+    _ -> acc++-- | Put the given SVG in place of the @mermaid@ code block it was made+-- from. A block with no SVG is left as it is, so that a diagram that could+-- not be rendered is still visible as its source.+mermaidSvg :: Map Span Text -> RenderExtension+mermaidSvg svgs = Render.blockRender $ \old block ->+  case block of+    b@(CodeBlock spn (Just l) _)+      | l == label ->+          case M.lookup spn svgs of+            Just svg -> figure_ [class_ label] (toHtmlRaw svg) >> "\n"+            Nothing -> old b+    other -> old other++label :: Text+label = "mermaid"

@@ -0,0 +1,101 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module      :  Text.MMark.Extension.Metadata+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- What a blog wants to know about a post: how long it is, how long it+-- takes to read, and what to put on the card that appears when it is+-- shared.+--+-- @since 0.3.0.0+module Text.MMark.Extension.Metadata+  ( Metadata (..),+    metadataScanner,+    readingTime,+  )+where++import Control.Foldl qualified as L+import Data.Text (Text)+import Data.Text qualified as T+import Text.MMark qualified as MMark+import Text.MMark.Extension.Internal (inlinesOf)+import Text.MMark.Trans (Block (..), Bni, Inline (..))+import Text.MMark.Trans qualified as Trans+import Text.URI (URI)++-- | What 'metadataScanner' finds out about a document.+data Metadata = Metadata+  { -- | Number of words in the prose of the document+    metaWords :: !Int,+    -- | Text of the first paragraph, for the description of a card+    metaLead :: Maybe Text,+    -- | URI of the first image, for the picture on a card+    metaImage :: Maybe URI,+    -- | Text of the first level 1 heading, for the title+    metaTitle :: Maybe Text+  }+  deriving (Eq, Show)++instance Semigroup Metadata where+  x <> y =+    Metadata+      { metaWords = metaWords x + metaWords y,+        metaLead = firstOf metaLead,+        metaImage = firstOf metaImage,+        metaTitle = firstOf metaTitle+      }+    where+      firstOf f = maybe (f y) Just (f x)++instance Monoid Metadata where+  mempty = Metadata 0 Nothing Nothing Nothing++-- | Scan a document for its 'Metadata'.+--+-- > let meta = MMark.runScanner metadataScanner doc+-- > putStrLn (show (readingTime 200 meta) <> " minute read")+metadataScanner :: L.Fold Bni Metadata+metadataScanner = MMark.scanner mempty $ \acc block ->+  acc <> ofBlock block+  where+    ofBlock block =+      mempty+        { metaWords = wordsIn block,+          metaLead = leadOf block,+          metaImage = imageOf block,+          metaTitle = titleOf block+        }+    wordsIn = length . T.words . T.unwords . fmap plainOf . inlinesOf+    plainOf = \case+      Plain _ t -> t+      CodeSpan _ t -> t+      _ -> ""+    leadOf = \case+      Paragraph _ xs -> Just (Trans.asPlainText xs)+      _ -> Nothing+    titleOf = \case+      Heading1 _ xs -> Just (Trans.asPlainText xs)+      _ -> Nothing+    imageOf block = case [uri | Image _ _ uri _ <- inlinesOf block] of+      (uri : _) -> Just uri+      [] -> Nothing++-- | How many minutes the document takes to read at the given number of+-- words per minute, rounded up, and never less than one.+readingTime ::+  -- | Words per minute, 200 to 250 for most readers+  Int ->+  -- | Collected metadata+  Metadata ->+  Int+readingTime wpm Metadata {..} =+  max 1 ((metaWords + wpm - 1) `div` wpm)

@@ -1,65 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}---- |--- Module      :  Text.MMark.Extension.ObfuscateEmail--- Copyright   :  © 2018–present Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Obfuscate email addresses.-module Text.MMark.Extension.ObfuscateEmail-  ( obfuscateEmail,-  )-where--import Data.List.NonEmpty (NonEmpty (..))-import Data.Text (Text)-import qualified Data.Text as T-import Lucid-import Text.MMark.Extension (Extension, Inline (..))-import qualified Text.MMark.Extension as Ext-import qualified Text.URI as URI-import Text.URI.QQ (scheme, uri)---- | This extension makes email addresses in autolinks be rendered as--- something like this:------ > <a class="protected-email"--- >    data-email="something@example.org"--- >    href="javascript:void(0)">Enable JavaScript to see this 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 ::-  -- | Name of class to assign to the links, e.g. @\"protected-email\"@-  Text ->-  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"-                    (T.drop 7 (URI.render email))-                ]-        else old l-    other -> old other

@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      :  Text.MMark.Extension.Permalinks+-- Copyright   :  © 2026–present Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Give every heading a link to itself, so that a reader can get a URL that+-- points at the section they are looking at.+--+-- @since 0.3.0.0+module Text.MMark.Extension.Permalinks+  ( permalinks,+    permalinksWith,+  )+where++import Data.Text (Text)+import Lucid+import Lucid.Base (makeAttribute)+import Text.MMark.Render (Block (..), Ois, RenderExtension, getOis)+import Text.MMark.Render qualified as Render+import Text.URI qualified as URI++-- | Append to every heading a link to the id MMark gives that heading. The+-- link is labelled @\"#\"@ and given the class @\"permalink\"@, so that a+-- style sheet can show it only when the heading is hovered.+permalinks :: RenderExtension+permalinks = permalinksWith (const True) "permalink" Nothing "#"++-- | Like 'permalinks', but you choose which headings get a link, the class+-- it is given, what a screen reader makes of it, and what the reader sees.+--+-- The last of these is @'Html' ()@, so the link can be labelled with an+-- icon rather than a character:+--+-- > permalinksWith (\n -> n >= 2 && n <= 4) "anchor" Nothing linkIcon+--+-- A link nothing is to be said about is hidden from a screen reader, and+-- taken out of the order the keyboard walks: a link that is announced to+-- nobody is of no use to someone who has landed on it. Say what it is+-- instead to keep it in:+--+-- > permalinksWith (const True) "anchor" (Just "Link to this section") "#"+permalinksWith ::+  -- | Whether to give a heading of this level (1–6) a link+  (Int -> Bool) ->+  -- | Class to give the link+  Text ->+  -- | What a screen reader should say, if anything+  Maybe Text ->+  -- | What the reader sees+  Html () ->+  RenderExtension+permalinksWith p klass spoken shown = Render.blockRender $ \old block ->+  case block of+    Heading1 spn x | p 1 -> old (Heading1 spn (anchor x))+    Heading2 spn x | p 2 -> old (Heading2 spn (anchor x))+    Heading3 spn x | p 3 -> old (Heading3 spn (anchor x))+    Heading4 spn x | p 4 -> old (Heading4 spn (anchor x))+    Heading5 spn x | p 5 -> old (Heading5 spn (anchor x))+    Heading6 spn x | p 6 -> old (Heading6 spn (anchor x))+    other -> old other+  where+    anchor (ois, html) = (ois, html <> link ois)+    link :: Ois -> Html ()+    link ois =+      a_+        ( href_ (URI.render (Render.headerFragment (Render.headerId (getOis ois))))+            : class_ klass+            : how+        )+        shown+    how = case spoken of+      Just t -> [makeAttribute "aria-label" t]+      Nothing ->+        [ makeAttribute "aria-hidden" "true",+          makeAttribute "tabindex" "-1"+        ]

@@ -18,9 +18,9 @@  import Data.Char (isSpace) import Data.Text (Text)-import qualified Data.Text as T-import Text.MMark.Extension (Extension, Inline (..))-import qualified Text.MMark.Extension as Ext+import Data.Text qualified as T+import Text.MMark.Trans (Bni, Inline (..), Trans)+import Text.MMark.Trans qualified as Trans  -- | Prettify punctuation (only affects plain text in inlines): --@@ -32,10 +32,10 @@ --     * 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+punctuationPrettifier :: Bni -> Trans Bni+punctuationPrettifier = Trans.bottomUpInlines $ \case+  Plain spn txt -> return (Plain spn (T.unfoldr gen (True, txt)))+  other -> return other  gen ::   -- | Whether the previous character was a space and remaining input

@@ -18,12 +18,13 @@  import Control.Monad import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T import Lucid import Skylighting (Token, TokenType (..))-import qualified Skylighting as S-import Text.MMark.Extension (Block (..), Extension)-import qualified Text.MMark.Extension as Ext+import Skylighting qualified as S+import Text.MMark.Extension.Internal (infoStringParts, withLineHighlight)+import Text.MMark.Render (Block (..), RenderExtension)+import Text.MMark.Render qualified as Ext  -- | Use the @skylighting@ package to render code blocks with info strings -- that result in a successful lookup from 'S.defaultSyntaxMap'.@@ -61,16 +62,22 @@ --     * 'VariableTok'       = @\"va\"@ --     * 'VerbatimStringTok' = @\"vs\"@ --     * 'WarningTok'        = @\"wa\"@-skylighting :: Extension+--+-- The info string may end with a line specification, as in @haskell {2,4-6}@+-- (see 'Text.MMark.Extension.LineHighlight.lineHighlight'). It does not stop+-- the language from being recognized, and the lines it names are given the+-- class @\"highlighted-line\"@ around the tokens of the line.+skylighting :: RenderExtension skylighting = Ext.blockRender $ \old block ->   case block of-    cb@(CodeBlock (Just infoString') txt) ->+    cb@(CodeBlock _ (Just infoString') txt) ->       let tokenizerConfig =             S.TokenizerConfig               { S.syntaxMap = S.defaultSyntaxMap,                 S.traceOutput = False               }-          infoString = T.replace "-" " " infoString'+          (lang, highlighted) = infoStringParts infoString'+          infoString = maybe "" (T.replace "-" " ") lang        in case S.lookupSyntax infoString S.defaultSyntaxMap of             Nothing -> old cb             Just syntax ->@@ -80,10 +87,11 @@                   div_ [class_ "source-code"]                     . pre_                     . code_ [class_ ("language-" <> infoString)]-                    . forM_ ls-                    $ \l -> do-                      mapM_ tokenToHtml l-                      newline+                    . forM_ (zip [1 ..] ls)+                    $ \(n, l) ->+                      withLineHighlight highlighted n $ do+                        mapM_ tokenToHtml l+                        newline                   newline     other -> old other   where

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}  -- | -- Module      :  Text.MMark.Extension.TableOfContents@@ -9,8 +10,8 @@ -- Stability   :  experimental -- Portability :  portable ----- Place this markup in markdown document where you want table of contents--- to be inserted:+-- Place this markup in a markdown document where you want a table of+-- contents to be inserted: -- -- > ```toc -- > ```@@ -24,32 +25,33 @@   ) where -import qualified Control.Foldl as L+import Control.Foldl qualified as L import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Maybe (maybeToList) import Data.Text (Text)-import Text.MMark.Extension (Block (..), Bni, Extension, Inline (..))-import qualified Text.MMark.Extension as Ext+import Text.MMark qualified as MMark+import Text.MMark.Trans (Block (..), Bni, Inline (..), Span, Trans)+import Text.MMark.Trans qualified as Trans --- | An opaque type representing table of contents produced by the+-- | An opaque type representing a 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+-- | The scanner builds a table of contents 'Toc' that can then be passed to -- 'toc' to obtain an extension that renders the table of contents in HTML. tocScanner ::   -- | Whether to include a header of this level (1–6)   (Int -> Bool) ->   L.Fold Bni Toc-tocScanner p = fmap (Toc . ($ [])) . Ext.scanner id $ \xs block ->+tocScanner p = fmap (Toc . ($ [])) . MMark.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+    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 =@@ -59,31 +61,39 @@  -- | Create an extension that replaces a certain code block with the -- previously constructed table of contents.+--+-- A document that asks for a table of contents but has no headings to put+-- in one is reported at the code block that asks, because there is nothing+-- to put in its place and leaving the block alone would render the marker+-- into the page as an empty code block. toc ::   -- | Label of the code block to replace by the table of contents   Text ->   -- | Previously generated by 'tocScanner'   Toc ->-  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+  Bni ->+  Trans Bni+toc label (Toc xs) = Trans.bottomUpBlocks $ \case+  old@(CodeBlock spn mlabel _)+    | mlabel == pure label ->+        case NE.nonEmpty xs of+          Nothing -> do+            Trans.report+              spn+              "there are no headings to put in the table of contents"+            return old+          Just ns -> return (renderToc spn ns)+  other -> return other --- | Construct 'Bni' for a table of contents from given collection of+-- | Construct 'Bni' for a table of contents from a given collection of -- headers. This is a non-public helper.-renderToc :: NonEmpty (Int, NonEmpty Inline) -> Bni-renderToc = UnorderedList . NE.unfoldr f+renderToc :: Span -> NonEmpty (Int, NonEmpty Inline) -> Bni+renderToc spn = UnorderedList spn . 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),+          url = Trans.headerFragment (Trans.headerId x)+       in ( Naked spn (Link spn x url Nothing :| [])+              : maybeToList (renderToc spn <$> NE.nonEmpty sitems),             NE.nonEmpty fitems           )

@@ -1,11 +1,11 @@ cabal-version:   2.4 name:            mmark-ext-version:         0.2.1.5+version:         0.3.0.0 license:         BSD-3-Clause license-file:    LICENSE.md maintainer:      Mark Karpov <markkarpov92@gmail.com> author:          Mark Karpov <markkarpov92@gmail.com>-tested-with:     ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.1+tested-with:     ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.1 homepage:        https://github.com/mmark-md/mmark-ext bug-reports:     https://github.com/mmark-md/mmark-ext/issues synopsis:        Commonly useful extensions for the MMark markdown processor@@ -35,34 +35,45 @@ library     exposed-modules:         Text.MMark.Extension.Common+        Text.MMark.Extension.Emoji+        Text.MMark.Extension.Heading+        Text.MMark.Extension.Icons+        Text.MMark.Extension.Image+        Text.MMark.Extension.LineHighlight+        Text.MMark.Extension.Link+        Text.MMark.Extension.Mermaid+        Text.MMark.Extension.Metadata+        Text.MMark.Extension.Permalinks         Text.MMark.Extension.Comment-        Text.MMark.Extension.FontAwesome         Text.MMark.Extension.Footnotes         Text.MMark.Extension.GhcSyntaxHighlighter         Text.MMark.Extension.Kbd-        Text.MMark.Extension.LinkTarget         Text.MMark.Extension.MathJax-        Text.MMark.Extension.ObfuscateEmail         Text.MMark.Extension.PunctuationPrettifier         Text.MMark.Extension.Skylighting         Text.MMark.Extension.TableOfContents -    default-language: Haskell2010+    other-modules:    Text.MMark.Extension.Internal+    default-language: GHC2021     build-depends:-        base >=4.13 && <5.0,+        base >=4.16 && <5,+        bytestring >=0.10 && <0.13,+        containers >=0.5 && <0.9,+        directory >=1.2 && <1.4,+        filepath >=1.4 && <1.6,         foldl >=1.2 && <1.5,         ghc-syntax-highlighter >=0.0.1 && <0.1,-        lucid >=2.9.13 && <3.0,-        microlens >=0.4 && <0.5,-        mmark >=0.0.4 && <=0.1,+        lucid >=2.9.13 && <3,+        microlens >=0.4 && <0.6,+        mmark >=0.1 && <0.2,         modern-uri >=0.3.4.4 && <0.4,-        skylighting >=0.7.6 && <0.13,-        text >=0.2 && <1.3+        skylighting >=0.7.6 && <0.15,+        text >=0.2 && <2.2      if flag(dev)         ghc-options:-            -O0 -Wall -Werror -Wcompat -Wincomplete-record-updates-            -Wincomplete-uni-patterns -Wnoncanonical-monad-instances+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages -haddock -Winvalid-haddock      else         ghc-options: -O2 -Wall@@ -74,30 +85,43 @@     hs-source-dirs:     tests     other-modules:         Text.MMark.Extension.CommentSpec-        Text.MMark.Extension.FontAwesomeSpec+        Text.MMark.Extension.EmojiSpec+        Text.MMark.Extension.HeadingSpec+        Text.MMark.Extension.IconsSpec+        Text.MMark.Extension.ImageSpec+        Text.MMark.Extension.LineHighlightSpec+        Text.MMark.Extension.LinkSpec+        Text.MMark.Extension.MermaidSpec+        Text.MMark.Extension.MetadataSpec+        Text.MMark.Extension.PermalinksSpec         Text.MMark.Extension.FootnotesSpec         Text.MMark.Extension.GhcSyntaxHighlighterSpec         Text.MMark.Extension.KbdSpec-        Text.MMark.Extension.LinkTargetSpec         Text.MMark.Extension.MathJaxSpec-        Text.MMark.Extension.ObfuscateEmailSpec         Text.MMark.Extension.PunctuationPrettifierSpec         Text.MMark.Extension.SkylightingSpec         Text.MMark.Extension.TableOfContentsSpec         Text.MMark.Extension.TestUtils -    default-language:   Haskell2010+    default-language:   GHC2021     build-depends:-        base >=4.13 && <5.0,-        hspec >=2.0 && <3.0,-        lucid >=2.9.13 && <3.0,-        mmark >=0.0.4 && <=0.1,+        base >=4.16 && <5,+        bytestring >=0.10 && <0.13,+        containers >=0.5 && <0.9,+        directory >=1.2 && <1.4,+        filepath >=1.4 && <1.6,+        hspec >=2 && <3,+        lucid >=2.9.13 && <3,+        megaparsec >=8 && <10,+        mmark >=0.1 && <0.2,         mmark-ext,-        skylighting >=0.7.6 && <0.13,-        text >=0.2 && <1.3+        modern-uri >=0.3.4.4 && <0.4,+        text >=0.2 && <2.2      if flag(dev)-        ghc-options: -O0 -Wall -Werror+        ghc-options:+            -Wall -Werror -Wredundant-constraints -Wpartial-fields+            -Wunused-packages -haddock -Winvalid-haddock      else         ghc-options: -O2 -Wall

@@ -10,12 +10,12 @@ 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` "<p>First.</p>\n<p>Third.</p>\n"-    context "when it is not in plain text" $-      it "has no special effect" $-        "[$$$ link](/url) foo." `to` "<p><a href=\"/url\">$$$ link</a> foo.</p>\n"+    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` "<p>First.</p>\n<p>Third.</p>\n"+    context "when it is not in plain text"+      $ it "has no special effect"+      $ "[$$$ link](/url) foo." `to` "<p><a href=\"/url\">$$$ link</a> foo.</p>\n"

@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.EmojiSpec (spec) where++import Data.Map.Strict qualified as M+import Test.Hspec+import Text.MMark.Extension.Emoji+import Text.MMark.Extension.TestUtils++spec :: Spec+spec = do+  emojiSpec+  emojiWithSpec++emojiSpec :: Spec+emojiSpec = describe "emoji" $ do+  it "replaces a shortcode it knows" $+    withTrans emoji "Hi :smile: there" "<p>Hi \128578 there</p>\n"+  it "replaces several in one go" $+    withTrans emoji ":fire: :rocket:" "<p>\128293 \128640</p>\n"+  it "replaces one that is more than one code point" $+    withTrans emoji ":warning:" "<p>\9888\65039</p>\n"+  it "replaces a shortcode that is an alias of another" $+    withTrans emoji ":joy: :laughing:" "<p>\128514 \128514</p>\n"+  it "replaces one whose name is not letters" $+    withTrans emoji ":+1: :100:" "<p>\128077 \128175</p>\n"+  it "reports a shortcode it does not know" $+    transErrors emoji "Hi :nosuch: there"+      `shouldReturn` ["1:1: there is no emoji called \"nosuch\""]+  it "leaves a lone colon alone" $+    withTrans emoji "at 12:30 sharp" "<p>at 12:30 sharp</p>\n"+  it "leaves text with no colons alone" $+    withTrans emoji "nothing here" "<p>nothing here</p>\n"+  it "leaves a shortcode in a code span alone" $+    withTrans emoji "`:smile:`" "<p><code>:smile:</code></p>\n"+  it "replaces a shortcode nested in other markup" $+    withTrans emoji "**:fire:**" "<p><strong>\128293</strong></p>\n"+  it "reports every unknown shortcode, not just the first" $+    transErrors emoji ":nosuch: and :neither:"+      `shouldReturn` [ "1:1: there is no emoji called \"nosuch\"",+                       "1:1: there is no emoji called \"neither\""+                     ]++emojiWithSpec :: Spec+emojiWithSpec = describe "emojiWith" $ do+  it "uses the table it is given" $+    withTrans (emojiWith table) "look :cat:" "<p>look \128049</p>\n"+  it "reports a shortcode the table does not have" $+    transErrors (emojiWith table) ":smile:"+      `shouldReturn` ["1:1: there is no emoji called \"smile\""]+  it "reports nothing for a table that has everything" $+    transErrors (emojiWith table) ":cat: :dog:" `shouldReturn` []+  it "reports every unknown shortcode of a paragraph" $+    transErrors (emojiWith table) ":nope: and :also:"+      `shouldReturn` [ "1:1: there is no emoji called \"nope\"",+                       "1:1: there is no emoji called \"also\""+                     ]+  it "replaces nothing when the table is empty" $+    withTrans (emojiWith mempty) "no colons here" "<p>no colons here</p>\n"+  where+    table = M.fromList [("cat", "\128049"), ("dog", "\128054")]

@@ -1,24 +0,0 @@-{-# 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-        "<fa:>" `to` "<p><a href=\"fa:\">fa:</a></p>\n"-        "<fa:user>" `to` "<p><span class=\"fa fa-user\"></span></p>\n"-        "<fa:user/lg>" `to` "<p><span class=\"fa fa-user fa-lg\"></span></p>\n"-        "<fa:quote-left/3x/pull-left/border>" `to` "<p><span class=\"fa fa-quote-left fa-3x fa-pull-left fa-border\"></span></p>\n"-    context "when URI has some other scheme" $-      it "produces the correct HTML" $-        "<https://example.org>" `to` "<p><a href=\"https://example.org\">https://example.org</a></p>\n"-    context "other elements" $-      it "not affected" $-        "Something." `to` "<p>Something.</p>\n"

@@ -2,7 +2,9 @@  module Text.MMark.Extension.FootnotesSpec (spec) where +import Data.Text (Text) import Test.Hspec+import Text.MMark qualified as MMark import Text.MMark.Extension.Footnotes import Text.MMark.Extension.TestUtils @@ -10,23 +12,63 @@ spec =   describe "footnotes" $ do     let to = withExt footnotes-    context "when link has no scheme" $-      it "has no effect" $-        "Link [link](1)."-          `to` "<p>Link <a href=\"1\">link</a>.</p>\n"-    context "when link has not \"footnote\" scheme" $-      it "has no effect" $-        "Link [link](https:1)"-          `to` "<p>Link <a href=\"https:1\">link</a></p>\n"-    context "when link has \"footnote\" scheme" $-      it "transforms the link correctly" $-        "Link [link](footnote:1)"-          `to` "<p>Link <a href=\"#fn1\" id=\"fnref1\"><sup>1</sup></a></p>\n"-    context "when block quotes are not formatted correctly" $-      it "has no effect" $-        "> blah"-          `to` "<blockquote>\n<p>blah</p>\n</blockquote>\n"-    context "when block quotes are formatted correctly" $-      it "transforms them into footnotes" $-        "> footnotes\n\n  1. Something.\n"-          `to` "<ol>\n<li id=\"fn1\">\nSomething.\n<a href=\"#fnref1\">↩</a></li>\n</ol>\n"+    context "when link has no scheme"+      $ it "has no effect"+      $ "Link [link](1)."+        `to` "<p>Link <a href=\"1\">link</a>.</p>\n"+    context "when link has not \"footnote\" scheme"+      $ it "has no effect"+      $ "Link [link](https:1)"+        `to` "<p>Link <a href=\"https:1\">link</a></p>\n"+    context "when link has \"footnote\" scheme"+      $ it "transforms the link correctly"+      $ "Link [link](footnote:1)"+        `to` "<p>Link <a href=\"#fn1\" id=\"fnref1\"><sup>1</sup></a></p>\n"+    context "when block quotes are not formatted correctly"+      $ it "has no effect"+      $ "> blah"+        `to` "<blockquote>\n<p>blah</p>\n</blockquote>\n"+    context "when block quotes are formatted correctly"+      $ it "transforms them into footnotes"+      $ "> footnotes\n>\n> 1. Something.\n"+        `to` "<ol>\n<li id=\"fn1\">\nSomething.\n<a href=\"#fnref1\">↩</a></li>\n</ol>\n"+    context "validation" $ do+      it "accepts a document whose footnotes all line up" $+        check "Text [1](footnote:1).\n\n> footnotes\n>\n> 1. The note.\n"+          `shouldReturn` []+      it "reports a reference to a footnote that does not exist" $+        check "Text [2](footnote:2).\n\n> footnotes\n>\n> 1. The note.\n"+          `shouldReturn` ["1:6: there is no footnote 2", "5:6: nothing refers to footnote 1"]+      it "reports a footnote nothing refers to" $+        check "Text.\n\n> footnotes\n>\n> 1. Orphan.\n"+          `shouldReturn` ["5:6: nothing refers to footnote 1"]+      it "reports a footnote that is referred to more than once" $+        check "A [1](footnote:1) and B [1](footnote:1).\n\n> footnotes\n>\n> 1. N.\n"+          `shouldReturn` [ "1:25: footnote 1 is referred to more than once, which would give the references the same id"+                         ]+      it "reports a reference whose path is not a number" $+        check "Text [x](footnote:abc).\n\n> footnotes\n>\n> 1. N.\n"+          `shouldReturn` [ "1:6: a footnote reference must have a single number as its path",+                           "5:6: nothing refers to footnote 1"+                         ]+      it "reaches references nested inside other inlines" $+        check "T [1](footnote:1) *and [2](footnote:2)*.\n\n> footnotes\n>\n> 1. A.\n> 2. B.\n"+          `shouldReturn` []+      it "reports every problem exactly once" $+        check "[9](footnote:9)\n\nSome text.\n\nMore text.\n"+          `shouldReturn` ["1:1: there is no footnote 9"]+      -- The footnotes of the second section are the same numbers as those+      -- of the first, so they are not counted twice; the document is+      -- already reported as having more than one section.+      it "reports a second footnote section" $+        check "> footnotes\n>\n> 1. A.\n\n> footnotes\n>\n> 1. B.\n"+          `shouldReturn` [ "3:6: nothing refers to footnote 1",+                           "5:1: there is more than one footnote section"+                         ]++-- | Validate the footnotes of a document, returning one @line:col: message@+-- string per reported problem.+check :: Text -> IO [Text]+check input = do+  Right doc <- pure (MMark.parse "" input)+  checkErrors (validateFootnotes (MMark.runScanner footnoteScanner doc)) input

@@ -2,6 +2,7 @@  module Text.MMark.Extension.GhcSyntaxHighlighterSpec (spec) where +import Data.Text qualified as T import Test.Hspec import Text.MMark.Extension.GhcSyntaxHighlighter import Text.MMark.Extension.TestUtils@@ -10,7 +11,42 @@ spec =   describe "ghcSyntaxHighlighter" $ do     let to = withExt ghcSyntaxHighlighter-    context "with info string is \"haskell\"" $-      it "renders it correctly" $-        "```haskell\nmain :: IO ()\nmain = return ()\n```\n"-          `to` "<div class=\"source-code\"><pre><code class=\"language-haskell\"><span class=\"va\">main</span><span> </span><span class=\"sy\">::</span><span> </span><span class=\"cr\">IO</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span><span>\n</span><span class=\"va\">main</span><span> </span><span class=\"sy\">=</span><span> </span><span class=\"va\">return</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span><span>\n</span></code></pre></div>\n"+    context "with info string is \"haskell\""+      $ it "renders it correctly"+      $ "```haskell\nmain :: IO ()\nmain = return ()\n```\n"+        `to` "<div class=\"source-code\"><pre><code class=\"language-haskell\"><span class=\"va\">main</span><span> </span><span class=\"sy\">::</span><span> </span><span class=\"cr\">IO</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span><span>\n</span><span class=\"va\">main</span><span> </span><span class=\"sy\">=</span><span> </span><span class=\"va\">return</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span><span>\n</span></code></pre></div>\n"+    context "when the info string ends with a line specification" $ do+      it "still recognizes the language, and points at the line" $+        "```haskell {2}\nmain :: IO ()\nmain = return ()\n```\n"+          `to` T.concat+            [ "<div class=\"source-code\"><pre><code class=\"language-haskell\">",+              "<span class=\"va\">main</span><span> </span><span class=\"sy\">::</span><span> </span><span class=\"cr\">IO</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span>\n",+              "<span class=\"highlighted-line\">",+              "<span class=\"va\">main</span><span> </span><span class=\"sy\">=</span><span> </span><span class=\"va\">return</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span>\n",+              "</span>",+              "</code></pre></div>\n"+            ]+      it "does not take a specification that names no line for one" $+        -- there is no such thing as pointing at nothing, so this is a+        -- malformed info string and the whole of it names the language+        "```haskell {}\nmain :: IO ()\nmain = return ()\n```\n"+          `to` "<pre><code class=\"language-haskell\">main :: IO ()\nmain = return ()\n</code></pre>\n"+      it "counts the lines the way Data.Text.lines does" $+        -- a trailing newline ends the last line, it does not start another,+        -- so there is no line 3 here to point at+        "```haskell {3}\nmain :: IO ()\nmain = return ()\n```\n"+          `to` "<div class=\"source-code\"><pre><code class=\"language-haskell\"><span class=\"va\">main</span><span> </span><span class=\"sy\">::</span><span> </span><span class=\"cr\">IO</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span>\n<span class=\"va\">main</span><span> </span><span class=\"sy\">=</span><span> </span><span class=\"va\">return</span><span> </span><span class=\"sy\">(</span><span class=\"sy\">)</span>\n</code></pre></div>\n"+      it "cuts a token that runs across lines at the newline" $+        -- the comment is one token spanning two lines; pointing at the+        -- second of them must not swallow the first+        "```haskell {2}\nx = 1\n{- a\nb -}\n```\n"+          `to` T.concat+            [ "<div class=\"source-code\"><pre><code class=\"language-haskell\">",+              "<span class=\"va\">x</span><span> </span><span class=\"sy\">=</span><span> </span><span class=\"it\">1</span>\n",+              "<span class=\"highlighted-line\"><span class=\"co\">{- a</span>\n</span>",+              "<span class=\"co\">b -}</span>\n",+              "</code></pre></div>\n"+            ]+      it "leaves a block of another language alone" $+        "```rust {1}\nfn main() {}\n```\n"+          `to` "<pre><code class=\"language-rust\">fn main() {}\n</code></pre>\n"

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.HeadingSpec (spec) where++import Data.Text (Text)+import Data.Text qualified as T+import Test.Hspec+import Text.MMark qualified as MMark+import Text.MMark.Extension.Heading+import Text.MMark.Extension.TestUtils++spec :: Spec+spec = do+  describe "checkHeadings" $ do+    it "reports a heading that skips a level" $+      headingErrors "# A\n\n### B"+        `shouldReturn` [ "3:1: this heading is of level 3, but the one before it is of level 1, so the outline of the document skips a level"+                       ]+    it "reports a second level 1 heading" $+      headingErrors "# A\n\n# B"+        `shouldReturn` ["3:1: there is more than one level 1 heading in this document"]+    it "reports two headings that get the same id" $+      headingErrors "# A\n\n## A"+        `shouldReturn` ["3:1: another heading is already given the id \"a\""]+    it "accepts a well formed outline" $+      headingErrors "# A\n\n## B\n\n### C\n\n## D" `shouldReturn` []+    it "reports each problem exactly once" $+      headingErrors "# A\n\nSome text.\n\nMore text.\n\n### B"+        `shouldReturn` [ "7:1: this heading is of level 3, but the one before it is of level 1, so the outline of the document skips a level"+                       ]++  describe "headingProblems" $ do+    it "finds nothing in a document with no headings" $+      problems "just some text" `shouldBe` []+    it "finds nothing in a well formed outline" $+      problems "# A\n\n## B\n\n### C\n\n## D" `shouldBe` []+    it "accepts an outline that comes back up several levels at once" $+      problems "# A\n\n## B\n\n### C\n\n## D\n\n# E" `shouldBe` ["title"]+    it "accepts a document that starts below level 1" $+      problems "## A\n\n### B" `shouldBe` []+    it "names the level a heading skips to and from" $+      problems "## A\n\n##### B" `shouldBe` ["skip"]+    it "finds a problem of each kind at once" $+      problems "# A\n\n### B\n\n# A" `shouldBe` ["skip", "title", "collision"]+    it "reports the problems in the order they appear" $+      problems "# A\n\n# B\n\n### C"+        `shouldBe` ["title", "skip"]+    it "finds a collision between headings of different levels" $+      problems "# Same\n\n## Same" `shouldBe` ["collision"]+    it "reports every heading after the first that shares an id" $+      problems "## A\n\n## A\n\n## A" `shouldBe` ["collision", "collision"]+    it "sees headings inside a block quote as part of the outline" $+      problems "# A\n\n> ### B" `shouldBe` []++-- | Scan a document for its headings and check them.+headingErrors :: Text -> IO [Text]+headingErrors input = do+  Right doc <- pure (MMark.parse "" input)+  checkErrors (checkHeadings (MMark.runScanner headingScanner doc)) input++-- | The problems of a document, each named by its kind so that a test does+-- not have to repeat the whole message.+problems :: Text -> [Text]+problems input = kindOf . snd <$> headingProblems (scan input)+  where+    scan t = case MMark.parse "" t of+      Left _ -> error "the test input does not parse"+      Right doc -> MMark.runScanner headingScanner doc+    kindOf msg+      | "skips a level" `T.isSuffixOf` msg = "skip"+      | "more than one level 1" `T.isInfixOf` msg = "title"+      | "already given the id" `T.isInfixOf` msg = "collision"+      | otherwise = msg

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Text.MMark.Extension.IconsSpec (spec) where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Text (Text)+import Lucid+import Test.Hspec+import Text.MMark.Extension.Icons+import Text.MMark.Extension.TestUtils+import Text.URI.QQ (scheme)++spec :: Spec+spec = do+  describe "icons" $ do+    let to = withExt (icons table)+    it "puts the SVG of an autolink in place of it" $+      "<icon:github>"+        `to` "<p><span class=\"icon icon-github\" aria-hidden=\"true\"><svg id=\"gh\"></svg></span></p>\n"+    it "labels an icon that has link text" $+      "[GitHub](icon:github)"+        `to` "<p><span class=\"icon icon-github\" role=\"img\" aria-label=\"GitHub\"><svg id=\"gh\"></svg></span></p>\n"+    it "turns the rest of the path into classes" $+      "<icon:github/lg/pull-left>"+        `to` "<p><span class=\"icon icon-github icon-lg icon-pull-left\" aria-hidden=\"true\"><svg id=\"gh\"></svg></span></p>\n"+    it "leaves an icon it does not have as a link" $+      "<icon:nosuch>" `to` "<p><a href=\"icon:nosuch\">icon:nosuch</a></p>\n"+    it "leaves a link with no icon name alone" $+      "<icon:>" `to` "<p><a href=\"icon:\">icon:</a></p>\n"+    it "leaves a link of another scheme alone" $+      "<https://example.org>"+        `to` "<p><a href=\"https://example.org\">https://example.org</a></p>\n"+    it "leaves other inlines alone" $+      "Something." `to` "<p>Something.</p>\n"+  describe "iconsWith" $ do+    let to = withExt (iconsWith [scheme|fa|] "fa" table)+    it "uses the scheme and the prefix it is given" $+      "<fa:github>"+        `to` "<p><span class=\"fa fa-github\" aria-hidden=\"true\"><svg id=\"gh\"></svg></span></p>\n"+    it "leaves the scheme it replaces alone" $+      "<icon:github>" `to` "<p><a href=\"icon:github\">icon:github</a></p>\n"+  describe "checkIcons" $ do+    it "reports an icon it does not have" $+      transErrors (checkIcons table) "See <icon:nosuch> there"+        `shouldReturn` ["1:5: there is no icon called \"nosuch\""]+    it "reports a link that names no icon" $+      transErrors (checkIcons table) "See <icon:> there"+        `shouldReturn` ["1:5: this link names no icon"]+    it "says nothing about an icon it has" $+      transErrors (checkIcons table) "See <icon:github/lg> there"+        `shouldReturn` []+    it "says nothing about a link of another scheme" $+      transErrors (checkIcons table) "See <https://example.org> there"+        `shouldReturn` []+  describe "checkIconsWith"+    $ it "uses the scheme it is given"+    $ transErrors (checkIconsWith [scheme|fa|] table) "See <fa:nosuch> there"+      `shouldReturn` ["1:5: there is no icon called \"nosuch\""]++-- | An icon table with something recognizable in it. Raw SVG is how an icon+-- usually arrives, so that is what the table holds here.+table :: Map Text (Html ())+table = toHtmlRaw <$> M.fromList [("github", "<svg id=\"gh\"></svg>" :: Text)]

@@ -0,0 +1,242 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.ImageSpec (spec) where++import Data.Bits (shiftR, (.&.))+import Data.ByteString (ByteString)+import Data.ByteString qualified as B+import Data.ByteString.Char8 qualified as B8+import Data.Map.Strict qualified as M+import Data.Text (Text)+import Data.Word (Word8)+import System.FilePath ((</>))+import Test.Hspec+import Text.MMark qualified as MMark+import Text.MMark.Extension.Image+import Text.MMark.Extension.TestUtils+import Text.MMark.Trans (Span)+import Text.URI qualified as URI++spec :: Spec+spec = do+  describe "checkAltText" $ do+    it "reports an image with no description" $+      transErrors checkAltText "![](/a.png)"+        `shouldReturn` ["1:1: this image has no description for the alt attribute"]+    it "accepts an image with a description" $+      transErrors checkAltText "![a cat](/a.png)" `shouldReturn` []+    it "reports an image nested in a link" $+      transErrors checkAltText "[![](/a.png)](/x)"+        `shouldReturn` ["1:2: this image has no description for the alt attribute"]+    it "finds an image inside a block quote" $+      transErrors checkAltText "> ![](/a.png)"+        `shouldReturn` ["1:3: this image has no description for the alt attribute"]+    it "reports every undescribed image, once each" $+      transErrors checkAltText "![](/a.png) ![b](/b.png) ![](/c.png)"+        `shouldReturn` [ "1:1: this image has no description for the alt attribute",+                         "1:26: this image has no description for the alt attribute"+                       ]++  describe "lazyImages" $ do+    it "adds the loading and decoding attributes" $+      withExt+        lazyImages+        "![a cat](/a.png)"+        "<p><img loading=\"lazy\" decoding=\"async\" alt=\"a cat\" src=\"/a.png\"></p>\n"+    it "leaves other inlines alone" $+      withExt lazyImages "[a link](/x)" "<p><a href=\"/x\">a link</a></p>\n"++  describe "imageScanner" $ do+    it "collects the URI of an image" $+      scanned "![a cat](/a.png)" `shouldBe` ["/a.png"]+    it "collects every image of a document" $+      scanned "![a](/a.png)\n\n![b](/b.png)" `shouldBe` ["/a.png", "/b.png"]+    it "collects an image nested in a link and in a quote" $+      scanned "[![a](/a.png)](/x)\n\n> ![b](/b.png)"+        `shouldBe` ["/a.png", "/b.png"]+    it "keeps two images with the same URI apart" $+      length (M.toList (scan "![a](/a.png) ![a](/a.png)")) `shouldBe` 2+    it "collects nothing from a document with no images" $+      scanned "just some text" `shouldBe` []++  describe "imageDimensions" $ do+    it "gives an image the size it was measured to have" $+      withSizes+        (Just (640, 480))+        "![a cat](/a.png)"+        "<p><img width=\"640\" height=\"480\" alt=\"a cat\" src=\"/a.png\"></p>\n"+    it "leaves an image that could not be measured alone" $+      withSizes+        Nothing+        "![a cat](/a.png)"+        "<p><img alt=\"a cat\" src=\"/a.png\"></p>\n"+    it "leaves an image with no measurement at all alone" $+      withExt+        (imageDimensions M.empty)+        "![a cat](/a.png)"+        "<p><img alt=\"a cat\" src=\"/a.png\"></p>\n"+    it "composes with lazyImages" $+      withSizesUsing+        (lazyImages <>)+        (Just (7, 3))+        "![a cat](/a.png)"+        "<p><img loading=\"lazy\" decoding=\"async\" width=\"7\" height=\"3\" alt=\"a cat\" src=\"/a.png\"></p>\n"++  describe "imageSizeOf" $ do+    it "measures a PNG" $+      measuring (pngBytes 7 3) `shouldReturn` Just (7, 3)+    it "measures a PNG larger than a byte in each direction" $+      measuring (pngBytes 1920 1080) `shouldReturn` Just (1920, 1080)+    it "measures a GIF" $+      measuring (gifBytes 11 5) `shouldReturn` Just (11, 5)+    it "measures a GIF larger than a byte in each direction" $+      measuring (gifBytes 800 600) `shouldReturn` Just (800, 600)+    it "measures a JPEG" $+      measuring (jpegBytes [] 13 9) `shouldReturn` Just (13, 9)+    it "measures a JPEG behind a segment it does not care about" $+      measuring (jpegBytes [app0, comment 40] 320 240)+        `shouldReturn` Just (320, 240)+    it "measures a JPEG behind a marker that carries no payload" $+      -- 0xD8 is SOI, whose two following bytes are not a length; a walk+      -- that reads them as one lands in the middle of nothing.+      measuring (jpegBytes [app0, standalone 0xD8, comment 8] 64 48)+        `shouldReturn` Just (64, 48)+    it "measures a JPEG whose frame is not the baseline one" $+      -- SOF2, the progressive frame header+      measuring (jpegBytesWith 0xC2 [app0] 21 12) `shouldReturn` Just (21, 12)+    it "does not mistake a huffman table for a frame" $+      -- 0xC4 is in the SOF range by number but is not a frame+      measuring (jpegBytes [tableNotAFrame] 30 20) `shouldReturn` Just (30, 20)+    it "gives up on a JPEG that ends before its frame" $+      measuring (B.pack [0xFF, 0xD8] <> app0) `shouldReturn` Nothing+    it "gives up on a JPEG whose segment lengths are nonsense" $+      -- a segment that claims to be no bytes long, then one that claims to+      -- run past the end of the file+      measuring+        ( B.pack [0xFF, 0xD8, 0xFF, 0xE0, 0x00, 0x00]+            <> B.replicate 8 0x20+            <> B.pack [0xFF, 0xC0]+            <> be16 11+            <> B.pack [8]+            <> be16 99+            <> be16 99+            <> B.pack [1, 1, 0x11, 0]+        )+        `shouldReturn` Nothing+    it "gives up on a file that is not an image" $+      measuring (B8.pack "just some text, not an image at all")+        `shouldReturn` Nothing+    it "gives up on an empty file" $+      measuring B.empty `shouldReturn` Nothing+    it "gives up on a truncated PNG" $+      measuring (B.take 20 (pngBytes 7 3)) `shouldReturn` Nothing+    it "gives up on a truncated GIF" $+      measuring (B.take 8 (gifBytes 11 5)) `shouldReturn` Nothing+    it "gives up on a file that is not there instead of throwing" $+      withTempDir (\dir -> imageSizeOf (dir </> "nope.png"))+        `shouldReturn` Nothing+    it "gives up on a directory instead of throwing" $+      withTempDir imageSizeOf `shouldReturn` Nothing++----------------------------------------------------------------------------+-- Helpers++-- | Scan a document and return the URI of every image it has, in order.+scanned :: Text -> [Text]+scanned = fmap URI.render . M.elems . scan++scan :: Text -> M.Map Span URI.URI+scan input = case MMark.parse "" input of+  Left _ -> error "the test input does not parse"+  Right doc -> MMark.runScanner imageScanner doc++-- | Render a document with every image measured as the given size.+withSizes :: Maybe (Int, Int) -> Text -> Text -> Expectation+withSizes = withSizesUsing id++withSizesUsing ::+  -- | What else to render with+  (MMark.RenderExtension -> MMark.RenderExtension) ->+  -- | The size every image is measured to have+  Maybe (Int, Int) ->+  -- | Input for the parser+  Text ->+  -- | Expected output of the render+  Text ->+  Expectation+withSizesUsing f size input expected =+  withExt (f (imageDimensions (size <$ scan input))) input expected++-- | The bytes of a PNG of the given size: the signature and the @IHDR@+-- chunk, which is all that states the size.+pngBytes :: Int -> Int -> ByteString+pngBytes w h =+  B.pack [137, 80, 78, 71, 13, 10, 26, 10]+    <> be32 13+    <> B8.pack "IHDR"+    <> be32 w+    <> be32 h+    <> B.pack [8, 2, 0, 0, 0]++-- | The bytes of a GIF of the given size: the signature and the logical+-- screen descriptor.+gifBytes :: Int -> Int -> ByteString+gifBytes w h = B8.pack "GIF89a" <> le16 w <> le16 h <> B.pack [0, 0, 0]++-- | The bytes of a JPEG of the given size: @SOI@, the given segments, then+-- a baseline frame header.+jpegBytes :: [ByteString] -> Int -> Int -> ByteString+jpegBytes = jpegBytesWith 0xC0++-- | Like 'jpegBytes', but you choose which frame header states the size.+jpegBytesWith :: Word8 -> [ByteString] -> Int -> Int -> ByteString+jpegBytesWith marker leading w h =+  B.pack [0xFF, 0xD8] <> B.concat leading <> sof <> B.pack [0xFF, 0xD9]+  where+    sof =+      B.pack [0xFF, marker]+        <> be16 11+        <> B.pack [8]+        <> be16 h+        <> be16 w+        <> B.pack [1, 1, 0x11, 0]++-- | A @JFIF@ header, the segment that usually comes first.+app0 :: ByteString+app0 =+  B.pack [0xFF, 0xE0]+    <> be16 16+    <> B8.pack "JFIF\NUL"+    <> B.pack [1, 1, 0, 0, 1, 0, 1, 0, 0]++-- | A comment segment carrying the given number of bytes of padding.+comment :: Int -> ByteString+comment n = B.pack [0xFF, 0xFE] <> be16 (n + 2) <> B.replicate n 0x20++-- | A marker that carries no payload at all.+standalone :: Word8 -> ByteString+standalone m = B.pack [0xFF, m]++-- | A huffman table, which sits in the range the frame headers occupy but+-- is not one of them.+tableNotAFrame :: ByteString+tableNotAFrame = B.pack [0xFF, 0xC4] <> be16 6 <> B.replicate 4 0++-- | Write the given bytes to a file and measure it.+measuring :: ByteString -> IO (Maybe (Int, Int))+measuring bs = withTempDir $ \dir -> do+  let path = dir </> "image"+  B.writeFile path bs+  imageSizeOf path++be32 :: Int -> ByteString+be32 n = B.pack (fmap (byte n) [24, 16, 8, 0])++be16 :: Int -> ByteString+be16 n = B.pack (fmap (byte n) [8, 0])++le16 :: Int -> ByteString+le16 n = B.pack (fmap (byte n) [0, 8])++byte :: Int -> Int -> Word8+byte n s = fromIntegral ((n `shiftR` s) .&. 0xFF)

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.LineHighlightSpec (spec) where++import Data.Text qualified as T+import Test.Hspec+import Text.MMark.Extension.LineHighlight+import Text.MMark.Extension.TestUtils++spec :: Spec+spec = do+  describe "parseLineSpec" $ do+    it "reads a single line" $+      parseLineSpec "haskell {2}" `shouldBe` Just (Just "haskell", [2])+    it "reads a range" $+      parseLineSpec "haskell {4-6}" `shouldBe` Just (Just "haskell", [4, 5, 6])+    it "reads a mixture" $+      parseLineSpec "haskell {2,4-6}" `shouldBe` Just (Just "haskell", [2, 4, 5, 6])+    it "works without a language" $+      parseLineSpec "{1}" `shouldBe` Just (Nothing, [1])+    it "gives nothing when there is no specification" $+      parseLineSpec "haskell" `shouldBe` Nothing+    it "gives nothing when the specification makes no sense" $ do+      parseLineSpec "haskell {x}" `shouldBe` Nothing+      parseLineSpec "haskell {6-4}" `shouldBe` Nothing+  describe "lineHighlight" $ do+    it "points at the line it is told to" $+      withExt+        lineHighlight+        "```haskell {2}\none\ntwo\n```"+        "<pre><code class=\"language-haskell\">one\n<span class=\"highlighted-line\">two\n</span></code></pre>\n"+    it "leaves a code block with no specification alone" $+      withExt+        lineHighlight+        "```haskell\none\n```"+        "<pre><code class=\"language-haskell\">one\n</code></pre>\n"+    it "renders a block of real code, pointing where it is told" $+      withExt+        lineHighlight+        ( T.unlines+            [ "```haskell {2,4-6}",+              "module Main (main) where",+              "",+              "import Data.List (sort & \"x\")",+              "main :: IO ()",+              "main = print (sort [3,1,2] <> [])",+              "-- done",+              "```"+            ]+        )+        ( T.concat+            [ "<pre><code class=\"language-haskell\">",+              "module Main (main) where\n",+              "<span class=\"highlighted-line\">\n</span>",+              "import Data.List (sort &amp; &quot;x&quot;)\n",+              "<span class=\"highlighted-line\">main :: IO ()\n</span>",+              "<span class=\"highlighted-line\">main = print (sort [3,1,2] &lt;&gt; [])\n</span>",+              "<span class=\"highlighted-line\">-- done\n</span>",+              "</code></pre>\n"+            ]+        )+    it "gives a block with no language no class to be styled by" $+      withExt+        lineHighlight+        "``` {1,3}\na\nb\nc\n```"+        ( T.concat+            [ "<pre><code>",+              "<span class=\"highlighted-line\">a\n</span>",+              "b\n",+              "<span class=\"highlighted-line\">c\n</span>",+              "</code></pre>\n"+            ]+        )+    it "ignores a line the block does not have" $+      withExt+        lineHighlight+        "```haskell {2,9}\na\nb\nc\n```"+        "<pre><code class=\"language-haskell\">a\n<span class=\"highlighted-line\">b\n</span>c\n</code></pre>\n"

@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.LinkSpec (spec) where++import Data.ByteString qualified as B+import Data.IORef+import Data.Text (Text)+import Data.Text qualified as T+import System.Directory (createDirectory)+import System.FilePath ((</>))+import Test.Hspec+import Text.MMark qualified as MMark+import Text.MMark.Extension.Link+import Text.MMark.Extension.TestUtils+import Text.URI (URI)+import Text.URI qualified as URI++spec :: Spec+spec = do+  describe "linkTarget" $ do+    let to = withExt linkTarget+    context "when no link title provided"+      $ it "has no effect"+      $ "[link](/url)" `to` "<p><a href=\"/url\">link</a></p>\n"+    context "when link title does not start with a target"+      $ it "has no effect"+      $ "[link](/url 'something _blank')"+        `to` "<p><a href=\"/url\" title=\"something _blank\">link</a></p>\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` "<p><a target=\"_blank\" rel=\"noopener noreferrer\" href=\"/url\">link</a></p>\n"+      context "when there is also a title"+        $ it "works as intended, target is stripped from the title"+        $ "[link](/url '_blank something')"+          `to` "<p><a target=\"_blank\" rel=\"noopener noreferrer\" href=\"/url\" title=\"something\">link</a></p>\n"+      context "when the target is not a new browsing context"+        $ it "does not add a rel attribute"+        $ "[link](/url '_self something')"+          `to` "<p><a target=\"_self\" href=\"/url\" title=\"something\">link</a></p>\n"+  describe "checkFragments" $ do+    it "accepts a link to a heading that exists" $+      fragmentErrors "# Real\n\n[go](#real)" `shouldReturn` []+    it "reports a link to a heading that does not" $+      fragmentErrors "# Real\n\n[go](#nope)"+        `shouldReturn` ["3:1: no heading of this document has the id \"nope\""]+    it "leaves a link with a scheme alone" $+      fragmentErrors "[go](https://example.org#nope)" `shouldReturn` []+    it "reports every bad fragment, once each" $+      fragmentErrors "# R\n\n[a](#x) and [b](#y)"+        `shouldReturn` [ "3:1: no heading of this document has the id \"x\"",+                         "3:13: no heading of this document has the id \"y\""+                       ]++  describe "checkLocalFiles" $ do+    it "accepts a link to a file that is there" $+      localErrors "[go](there.txt)" `shouldReturn` []+    it "reports a link to a file that is not" $+      localErrors "[go](nope.txt)"+        `shouldReturn` ["1:1: there is nothing at ./nope.txt"]+    it "accepts a link to a directory" $+      localErrors "[go](sub)" `shouldReturn` []+    it "accepts a link to a file in a subdirectory" $+      localErrors "[go](sub/deep.txt)" `shouldReturn` []+    it "ignores the fragment of a link to a file that is there" $+      localErrors "[go](there.txt#part)" `shouldReturn` []+    it "leaves a link with a scheme to checkExternal" $+      localErrors "[go](https://example.org/nope.txt)" `shouldReturn` []+    it "leaves a link that is only a fragment alone" $+      localErrors "[go](#part)" `shouldReturn` []+    it "checks images too" $+      localErrors "![x](nope.png)"+        `shouldReturn` ["1:1: there is nothing at ./nope.png"]+    it "reports every missing file, once each" $+      localErrors "[a](nope.txt) and [b](gone.txt)"+        `shouldReturn` [ "1:1: there is nothing at ./nope.txt",+                         "1:19: there is nothing at ./gone.txt"+                       ]++  describe "checkExternal" $ do+    it "accepts a link the action says is reachable" $+      externalErrors (const (pure True)) "[go](https://example.org)"+        `shouldReturn` []+    it "reports a link the action says is not" $+      externalErrors (const (pure False)) "[go](https://example.org)"+        `shouldReturn` ["1:1: cannot reach https://example.org"]+    it "hands the action the URI of the link" $ do+      seen <- asked (const True) "[go](https://example.org/a)"+      seen `shouldBe` ["https://example.org/a"]+    it "does not ask about a link with no scheme" $+      asked (const True) "[go](nope.txt)" `shouldReturn` []+    it "does not ask about a link that is only a fragment" $+      asked (const True) "[go](#part)" `shouldReturn` []+    it "asks about every external link, once each" $+      asked (const True) "[a](https://a.example) [b](https://b.example)"+        `shouldReturn` ["https://a.example", "https://b.example"]+    it "checks images too" $+      externalErrors (const (pure False)) "![x](https://example.org/a.png)"+        `shouldReturn` ["1:1: cannot reach https://example.org/a.png"]++-- | Scan a document for its header ids and check its fragments.+fragmentErrors :: Text -> IO [Text]+fragmentErrors input = do+  Right doc <- pure (MMark.parse "" input)+  transErrors (checkFragments (MMark.runScanner headerIdScanner doc)) input++-- | Check the local links of a document against a directory holding+-- @there.txt@ and @sub\/deep.txt@.+localErrors :: Text -> IO [Text]+localErrors input = withTempDir $ \dir -> do+  B.writeFile (dir </> "there.txt") ""+  createDirectory (dir </> "sub")+  B.writeFile (dir </> "sub" </> "deep.txt") ""+  errs <- transErrorsM (checkLocalFiles dir) input+  -- the messages name the base directory, which is a different one every+  -- run, so put something back that a test can be written against+  return (T.replace (T.pack dir) "." <$> errs)++-- | Check the external links of a document with the given action.+externalErrors :: (URI -> IO Bool) -> Text -> IO [Text]+externalErrors reachable = transErrorsM (checkExternal reachable)++-- | The URIs 'checkExternal' asked the action about, in order.+asked :: (URI -> Bool) -> Text -> IO [Text]+asked answer input = do+  ref <- newIORef []+  _ <-+    externalErrors+      (\uri -> modifyIORef' ref (URI.render uri :) >> pure (answer uri))+      input+  reverse <$> readIORef ref

@@ -1,28 +0,0 @@-{-# 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` "<p><a href=\"/url\">link</a></p>\n"-    context "when link title does not start with a target" $-      it "has no effect" $-        "[link](/url 'something _blank')"-          `to` "<p><a href=\"/url\" title=\"something _blank\">link</a></p>\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` "<p><a target=\"_blank\" href=\"/url\">link</a></p>\n"-      context "when there is also a title" $-        it "works as intended, target is stripped from the title" $-          "[link](/url '_blank something')"-            `to` "<p><a target=\"_blank\" href=\"/url\" title=\"something\">link</a></p>\n"

@@ -11,10 +11,10 @@   describe "mathJax" $ do     let to = withExt (mathJax Nothing)         to' = withExt (mathJax (Just '$'))-    context "when span char is not specified" $-      it "transforms all code spans correctly" $-        "I've got `foo`."-          `to` "<p>I&#39;ve got <span class=\"math inline\">\\(foo\\)</span>.</p>\n"+    context "when span char is not specified"+      $ it "transforms all code spans correctly"+      $ "I've got `foo`."+        `to` "<p>I&#39;ve got <span class=\"math inline\">\\(foo\\)</span>.</p>\n"     context "when span char is specified" $ do       it "does not affect mismatching code spans" $         "I've got `foo`."@@ -22,16 +22,16 @@       it "transforms matching code spans correctly" $         "I've got `$foo$`."           `to'` "<p>I&#39;ve got <span class=\"math inline\">\\(foo\\)</span>.</p>\n"-    context "when code block is not labelled with \"mathjax\"" $-      it "does not affect it" $-        "```\nfoo\n```\n"-          `to` "<pre><code>foo\n</code></pre>\n"+    context "when code block is not labelled with \"mathjax\""+      $ it "does not affect it"+      $ "```\nfoo\n```\n"+        `to` "<pre><code>foo\n</code></pre>\n"     context "when code block is labelled with \"mathjax\"" $ do-      context "when code block contains a single line" $-        it "renders it correctly" $-          "```mathjax\nfoo\n```\n"-            `to` "<p><span class=\"math display\">\\[foo\\]</span></p>\n"-      context "when code block contains multiple lines" $-        it "renders it correctly" $-          "```mathjax\nfoo\nbar\n```\n"-            `to` "<p><span class=\"math display\">\\[foo\\]</span><span class=\"math display\">\\[bar\\]</span></p>\n"+      context "when code block contains a single line"+        $ it "renders it correctly"+        $ "```mathjax\nfoo\n```\n"+          `to` "<p><span class=\"math display\">\\[foo\\]</span></p>\n"+      context "when code block contains multiple lines"+        $ it "renders it correctly"+        $ "```mathjax\nfoo\nbar\n```\n"+          `to` "<p><span class=\"math display\">\\[foo\\]</span><span class=\"math display\">\\[bar\\]</span></p>\n"

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.MermaidSpec (spec) where++import Data.Map.Strict qualified as M+import Data.Text.Lazy qualified as TL+import Lucid qualified as L+import Test.Hspec+import Text.MMark qualified as MMark+import Text.MMark.Extension.Mermaid+import Text.MMark.Extension.TestUtils++spec :: Spec+spec = do+  describe "mermaid" $ do+    it "renders a mermaid block for the browser" $+      withExt+        mermaid+        "```mermaid\ngraph TD;\n```"+        "<pre class=\"mermaid\">graph TD;\n</pre>\n"+    it "leaves another code block alone" $+      withExt+        mermaid+        "```haskell\nmain\n```"+        "<pre><code class=\"language-haskell\">main\n</code></pre>\n"+  describe "mermaidScanner and mermaidSvg" $ do+    it "puts the rendered diagram in place of the block" $ do+      Right doc <- pure (MMark.parse "" "```mermaid\ngraph TD;\n```")+      let svgs = M.map (const "<svg/>") (MMark.runScanner mermaidScanner doc)+      render (mermaidSvg svgs) doc+        `shouldBe` "<figure class=\"mermaid\"><svg/></figure>\n"+    it "leaves a block with no diagram as its source" $ do+      Right doc <- pure (MMark.parse "" "```mermaid\ngraph TD;\n```")+      render (mermaidSvg M.empty) doc+        `shouldBe` "<pre><code class=\"language-mermaid\">graph TD;\n</code></pre>\n"+  where+    render e = TL.toStrict . L.renderText . MMark.render e

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.MetadataSpec (spec) where++import Test.Hspec+import Text.MMark qualified as MMark+import Text.MMark.Extension.Metadata+import Text.URI qualified as URI++spec :: Spec+spec = describe "metadataScanner" $ do+  it "finds the title, the lead, and the first image" $ do+    m <- scan "# Title\n\nThe lead here.\n\n![pic](/p.png)\n\nMore."+    metaTitle m `shouldBe` Just "Title"+    metaLead m `shouldBe` Just "The lead here."+    fmap URI.render (metaImage m) `shouldBe` Just "/p.png"+  it "counts words" $ do+    m <- scan "one two three four five"+    metaWords m `shouldBe` 5+  it "rounds the reading time up and never gives zero" $ do+    m <- scan "one two"+    readingTime 200 m `shouldBe` 1+  it "keeps the first of each thing" $ do+    m <- scan "# One\n\n# Two"+    metaTitle m `shouldBe` Just "One"+  where+    scan input = do+      Right doc <- pure (MMark.parse "" input)+      pure (MMark.runScanner metadataScanner doc)

@@ -1,21 +0,0 @@-{-# 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" $-        "<mailto:me@example.org>" `to` "<p><a class=\"foo\" data-email=\"me@example.org\" href=\"javascript:void%280%29\">Enable JavaScript to see this email</a></p>\n"-    context "when URI has some other scheme" $-      it "produces the correct HTML" $-        "<https:example.org>" `to` "<p><a href=\"https:example.org\">https:example.org</a></p>\n"-    context "other elements" $-      it "not affected" $-        "Something." `to` "<p>Something.</p>\n"

@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Extension.PermalinksSpec (spec) where++import Lucid+import Test.Hspec+import Text.MMark.Extension.Permalinks+import Text.MMark.Extension.TestUtils++spec :: Spec+spec = do+  describe "permalinks" $ do+    it "adds a link to the heading id" $+      withExt+        permalinks+        "# Title"+        "<h1 id=\"title\">Title<a href=\"#title\" class=\"permalink\" aria-hidden=\"true\" tabindex=\"-1\">#</a></h1>\n"+    it "works for every level" $+      withExt+        permalinks+        "###### Deep"+        "<h6 id=\"deep\">Deep<a href=\"#deep\" class=\"permalink\" aria-hidden=\"true\" tabindex=\"-1\">#</a></h6>\n"+    it "leaves other blocks alone" $+      withExt permalinks "Just text." "<p>Just text.</p>\n"+  describe "permalinksWith" $ do+    it "can be given another class and label" $+      withExt+        (permalinksWith (const True) "anchor" Nothing "\182")+        "# T"+        "<h1 id=\"t\">T<a href=\"#t\" class=\"anchor\" aria-hidden=\"true\" tabindex=\"-1\">\182</a></h1>\n"+    it "labels the link with the markup it is given" $+      withExt+        (permalinksWith (const True) "anchor" Nothing (toHtmlRaw ("<svg id=\"a\"></svg>" :: String)))+        "# T"+        "<h1 id=\"t\">T<a href=\"#t\" class=\"anchor\" aria-hidden=\"true\" tabindex=\"-1\"><svg id=\"a\"></svg></a></h1>\n"+    it "keeps a link a screen reader is told about" $+      withExt+        (permalinksWith (const True) "anchor" (Just "Link to this section") "#")+        "# T"+        "<h1 id=\"t\">T<a href=\"#t\" class=\"anchor\" aria-label=\"Link to this section\">#</a></h1>\n"+    it "gives a link only to the levels it is told to" $ do+      withExt (permalinksWith (\n -> n >= 2 && n <= 4) "anchor" Nothing "#") "# T" "<h1 id=\"t\">T</h1>\n"+      withExt+        (permalinksWith (\n -> n >= 2 && n <= 4) "anchor" Nothing "#")+        "## T"+        "<h2 id=\"t\">T<a href=\"#t\" class=\"anchor\" aria-hidden=\"true\" tabindex=\"-1\">#</a></h2>\n"+      withExt (permalinksWith (\n -> n >= 2 && n <= 4) "anchor" Nothing "#") "##### T" "<h5 id=\"t\">T</h5>\n"

@@ -9,7 +9,7 @@ spec :: Spec spec =   describe "punctuationPrettifier" $ do-    let to = withExt punctuationPrettifier+    let to = withTrans punctuationPrettifier     context "on plain inlines" $ do       it "replaces ... with ellipsis" $         "He forgot where he came from..." `to` "<p>He forgot where he came from…</p>\n"@@ -31,6 +31,6 @@         "Something-\"foo\"." `to` "<p>Something-”foo”.</p>\n"       it "a tricky test 2" $         "Something.--" `to` "<p>Something.–</p>\n"-    context "on other inlines" $-      it "has no effect" $-        "`code -- span`" `to` "<p><code>code -- span</code></p>\n"+    context "on other inlines"+      $ it "has no effect"+      $ "`code -- span`" `to` "<p><code>code -- span</code></p>\n"

@@ -2,6 +2,7 @@  module Text.MMark.Extension.SkylightingSpec (spec) where +import Data.Text qualified as T import Test.Hspec import Text.MMark.Extension.Skylighting import Text.MMark.Extension.TestUtils@@ -10,11 +11,45 @@ spec =   describe "skylighting" $ do     let to = withExt skylighting-    context "when info string does not result in a successful lookup" $-      it "has no effect" $-        "```foo\nmain :: IO ()\nmain = return ()\n```\n"+    context "when info string does not result in a successful lookup"+      $ it "has no effect"+      $ "```foo\nmain :: IO ()\nmain = return ()\n```\n"+        `to` "<pre><code class=\"language-foo\">main :: IO ()\nmain = return ()\n</code></pre>\n"+    context "with info string results in a successful lookup"+      $ it "renders it correctly"+      $ "```haskell\nmain :: IO ()\nmain = return ()\n```\n"+        `to` "<div class=\"source-code\"><pre><code class=\"language-haskell\"><span class=\"ot\">main ::</span><span> </span><span class=\"dt\">IO</span><span> ()</span>\n<span>main </span><span class=\"ot\">=</span><span> </span><span class=\"fu\">return</span><span> ()</span>\n</code></pre></div>\n"+    context "when the info string ends with a line specification" $ do+      it "still recognizes the language, and points at the line" $+        "```haskell {2}\nmain :: IO ()\nmain = return ()\n```\n"+          `to` T.concat+            [ "<div class=\"source-code\"><pre><code class=\"language-haskell\">",+              "<span class=\"ot\">main ::</span><span> </span><span class=\"dt\">IO</span><span> ()</span>\n",+              "<span class=\"highlighted-line\">",+              "<span>main </span><span class=\"ot\">=</span><span> </span><span class=\"fu\">return</span><span> ()</span>\n",+              "</span>",+              "</code></pre></div>\n"+            ]+      it "points at every line a range names" $+        "```haskell {1-2}\nmain :: IO ()\nmain = return ()\n```\n"+          `to` T.concat+            [ "<div class=\"source-code\"><pre><code class=\"language-haskell\">",+              "<span class=\"highlighted-line\">",+              "<span class=\"ot\">main ::</span><span> </span><span class=\"dt\">IO</span><span> ()</span>\n",+              "</span>",+              "<span class=\"highlighted-line\">",+              "<span>main </span><span class=\"ot\">=</span><span> </span><span class=\"fu\">return</span><span> ()</span>\n",+              "</span>",+              "</code></pre></div>\n"+            ]+      it "does not take a specification that names no line for one" $+        -- there is no such thing as pointing at nothing, so this is a+        -- malformed info string and the whole of it names the language+        "```haskell {}\nmain :: IO ()\nmain = return ()\n```\n"+          `to` "<pre><code class=\"language-haskell\">main :: IO ()\nmain = return ()\n</code></pre>\n"+      it "leaves a block alone when the language is still not one it knows" $+        "```foo {1}\nmain :: IO ()\nmain = return ()\n```\n"           `to` "<pre><code class=\"language-foo\">main :: IO ()\nmain = return ()\n</code></pre>\n"-    context "with info string results in a successful lookup" $-      it "renders it correctly" $-        "```haskell\nmain :: IO ()\nmain = return ()\n```\n"+      it "ignores a line the block does not have" $+        "```haskell {9}\nmain :: IO ()\nmain = return ()\n```\n"           `to` "<div class=\"source-code\"><pre><code class=\"language-haskell\"><span class=\"ot\">main ::</span><span> </span><span class=\"dt\">IO</span><span> ()</span>\n<span>main </span><span class=\"ot\">=</span><span> </span><span class=\"fu\">return</span><span> ()</span>\n</code></pre></div>\n"

@@ -2,25 +2,54 @@  module Text.MMark.Extension.TableOfContentsSpec (spec) where -import qualified Data.Text.IO as TIO-import qualified Data.Text.Lazy as TL-import qualified Lucid as L+import Data.Text (Text)+import Data.Text.IO qualified as TIO+import Data.Text.Lazy qualified as TL+import Lucid qualified as L import Test.Hspec-import qualified Text.MMark as MMark+import Text.MMark qualified as MMark import Text.MMark.Extension.TableOfContents+import Text.MMark.Extension.TestUtils (summarize)+import Text.Megaparsec (errorBundlePretty)  spec :: Spec spec =-  describe "toc" $+  describe "toc" $ do     it "works" $ do       input <- TIO.readFile "data/toc.md"       expected <- TIO.readFile "data/toc.html"       Right doc <- pure (MMark.parse "" input)-      let headings = MMark.runScanner doc (tocScanner (> 1))-          actual =-            TL.toStrict-              . L.renderText-              . MMark.render-              . MMark.useExtension (toc "toc" headings)-              $ doc-      actual `shouldBe` expected+      let headings = MMark.runScanner (tocScanner (> 1)) doc+      case MMark.runTrans (toc "toc" headings) doc of+        Left errs -> expectationFailure (errorBundlePretty errs)+        Right doc' ->+          (TL.toStrict . L.renderText . MMark.render mempty) doc'+            `shouldBe` expected+    it "leaves a code block with another label alone" $+      withToc (> 0) "toc" "# A\n\n```haskell\nx = 1\n```\n"+        `shouldBe` Right "<h1 id=\"a\">A</h1>\n<pre><code class=\"language-haskell\">x = 1\n</code></pre>\n"+    it "uses the label it is given" $+      withToc (> 0) "contents" "# A\n\n```contents\n```\n"+        `shouldBe` Right "<h1 id=\"a\">A</h1>\n<ul>\n<li>\n<a href=\"#a\">A</a>\n</li>\n</ul>\n"+    it "reports a table of contents with nothing to put in it" $+      withToc (> 1) "toc" "# A\n\n```toc\n```\n"+        `shouldBe` Left ["3:1: there are no headings to put in the table of contents"]+    it "reports a table of contents in a document with no headings at all" $+      withToc (> 0) "toc" "Some text.\n\n```toc\n```\n"+        `shouldBe` Left ["3:1: there are no headings to put in the table of contents"]+    it "says nothing about a document that asks for no table of contents" $+      withToc (> 1) "toc" "# A\n\nSome text.\n"+        `shouldBe` Right "<h1 id=\"a\">A</h1>\n<p>Some text.</p>\n"++-- | Build a table of contents out of the headings the predicate admits and+-- put it where the given label asks, giving either the problems reported or+-- the rendered document.+withToc :: (Int -> Bool) -> Text -> Text -> Either [Text] Text+withToc p label input =+  case MMark.parse "" input of+    Left _ -> error "the test input does not parse"+    Right doc ->+      case MMark.runTrans (toc label (MMark.runScanner (tocScanner p) doc)) doc of+        Left errs -> Left (summarize (errorBundlePretty errs))+        Right doc' ->+          Right (TL.toStrict (L.renderText (MMark.render mempty doc')))

@@ -1,19 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+ module Text.MMark.Extension.TestUtils   ( withExt,+    withTrans,+    transErrors,+    transErrorsM,+    checkErrors,+    summarize,+    withTempDir,   ) where +import Control.Exception (bracket)+import Data.Char (isDigit) import Data.Text (Text)-import qualified Data.Text.Lazy as TL-import qualified Lucid as L+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Lucid qualified as L+import System.Directory+  ( createDirectory,+    getTemporaryDirectory,+    removeDirectoryRecursive,+    removeFile,+  )+import System.IO (hClose, openTempFile) import Test.Hspec-import qualified Text.MMark as MMark+import Text.MMark qualified as MMark+import Text.MMark.Trans (Bni, Trans, TransT)+import Text.Megaparsec (errorBundlePretty) --- | Feed input into MMark parser, apply an extension, render the parsed--- document and demand that it matches the given example.+-- | Feed input into MMark parser, apply a render extension, render the+-- parsed document and demand that it matches the given example. withExt ::-  -- | MMark extension to use-  MMark.Extension ->+  -- | Render extension to use+  MMark.RenderExtension ->   -- | Input for the parser   Text ->   -- | Expected output of the render@@ -21,10 +41,94 @@   Expectation withExt ext input expected = do   Right doc <- pure (MMark.parse "" input)-  let actual =-        TL.toStrict-          . L.renderText-          . MMark.render-          . MMark.useExtension ext-          $ doc-  actual `shouldBe` expected+  render mempty doc `shouldBe` expected+  where+    render e = TL.toStrict . L.renderText . MMark.render (e <> ext)++-- | Like 'withExt', but applies a transformation instead.+withTrans ::+  -- | Transformation to apply+  (Bni -> Trans Bni) ->+  -- | Input for the parser+  Text ->+  -- | Expected output of the render+  Text ->+  Expectation+withTrans f input expected = do+  Right doc <- pure (MMark.parse "" input)+  case MMark.runTrans f doc of+    Left errs -> expectationFailure (errorBundlePretty errs)+    Right doc' ->+      (TL.toStrict . L.renderText . MMark.render mempty) doc'+        `shouldBe` expected++-- | Apply a transformation that is expected to report problems and return+-- one @line:col: message@ string per problem.+transErrors ::+  -- | Transformation to apply+  (Bni -> Trans Bni) ->+  -- | Input for the parser+  Text ->+  IO [Text]+transErrors f input = do+  Right doc <- pure (MMark.parse "" input)+  pure $ case MMark.runTrans f doc of+    Right _ -> []+    Left errs -> summarize (errorBundlePretty errs)++-- | Like 'transErrors', but for a transformation that needs 'IO'.+transErrorsM ::+  -- | Transformation to apply+  (Bni -> TransT IO Bni) ->+  -- | Input for the parser+  Text ->+  IO [Text]+transErrorsM f input = do+  Right doc <- pure (MMark.parse "" input)+  r <- MMark.runTransM f doc+  pure $ case r of+    Right _ -> []+    Left errs -> summarize (errorBundlePretty errs)++-- | Reduce a rendered error bundle to one @line:col: message@ string per+-- error, dropping the source excerpt megaparsec prints in between.+summarize :: String -> [Text]+summarize = go Nothing . fmap T.strip . T.lines . T.pack+  where+    go _ [] = []+    go cur (l : ls)+      | T.null l = go cur ls+      | isPos l = go (Just l) ls+      | "|" `T.isInfixOf` l = go cur ls+      | otherwise = case cur of+          Just p -> (p <> " " <> l) : go Nothing ls+          Nothing -> go Nothing ls+    isPos t = ":" `T.isSuffixOf` t && T.all (\c -> isDigit c || c == ':') t++-- | Run a check that is expected to report problems and return one+-- @line:col: message@ string per problem.+checkErrors ::+  -- | Check to run+  Trans a ->+  -- | Input for the parser+  Text ->+  IO [Text]+checkErrors c input = do+  Right doc <- pure (MMark.parse "" input)+  pure $ case MMark.runCheck c doc of+    Right _ -> []+    Left errs -> summarize (errorBundlePretty errs)++-- | Run an action in a fresh empty directory, which is removed afterwards.+withTempDir :: (FilePath -> IO a) -> IO a+withTempDir = bracket acquire removeDirectoryRecursive+  where+    -- 'openTempFile' is the only way base offers to get a name nothing else+    -- has taken, so take one and swap the file for a directory.+    acquire = do+      tmp <- getTemporaryDirectory+      (path, h) <- openTempFile tmp "mmark-ext-test"+      hClose h+      removeFile path+      createDirectory path+      return path