[#55] Account for Markdown flavor type

Problem: it turned out that GitHub and GitLab render anchors for headers
differently.

Solution: make it possible to specify flavor in config, adjust
headers conversion respectively. Added some fixes for GitHub as well.

Flavor field is mandatory, so this change is breaking, but I
think it's a worthy thing since otherwise other subtle bugs are
possible, it should be good if users specify the flavor as soon
as possible.

Author: Martoon-00

exec/Main.hs

@@ -19,9 +19,9 @@ import Xrefcheck.Scanners
 import Xrefcheck.System
 import Xrefcheck.Verify
 
-formats :: FormatsSupport
-formats = specificFormatsSupport
-    [ markdownSupport
+formats :: ScannersConfig -> FormatsSupport
+formats ScannersConfig{..} = specificFormatsSupport
+    [ markdownSupport scMarkdown
     ]
 
 defaultAction :: Options -> IO ()
@@ -45,7 +45,7 @@ defaultAction Options{..} = do
 
     repoInfo <- allowRewrite showProgressBar $ \rw -> do
         let fullConfig = addTraversalOptions (cTraversal config) oTraversalOptions
-        gatherRepoInfo rw formats fullConfig root
+        gatherRepoInfo rw (formats $ cScanners config) fullConfig root
 
     when oVerbose $
         fmtLn $ "=== Repository data ===\n\n" <> indentF 2 (build repoInfo)

src-files/def-config.yaml

@@ -56,3 +56,12 @@ verification:
   # It is an optional parameter, so it can be omitted.
   ignoreRefs:
     []
+
+# Parameters of scanners for various file types.
+scanners:
+
+  markdown:
+    # Flavor of markdown, e.g. GitHub-flavor.
+    #
+    # This affects which anchors are generated for headers.
+    flavor: GitHub

src/Xrefcheck/CLI.hs

@@ -19,14 +19,14 @@ module Xrefcheck.CLI
 
 import qualified Data.List as L
 import Data.Version (showVersion)
-import Options.Applicative (Parser, ReadM, command, eitherReader, execParser, flag', footerDoc, fullDesc,
-                            help, helper, hsubparser, info, infoOption, long, metavar, option, progDesc,
-                            short, strOption, switch, value)
+import Options.Applicative
+  (Parser, ReadM, command, eitherReader, execParser, flag', footerDoc, fullDesc, help, helper,
+  hsubparser, info, infoOption, long, metavar, option, progDesc, short, strOption, switch, value)
 import Options.Applicative.Help.Pretty (Doc, displayS, fill, fillSep, indent, renderPretty, text)
 
 import Paths_xrefcheck (version)
-import Xrefcheck.Config
 import Xrefcheck.Core
+import Xrefcheck.Scan
 
 modeReadM :: ReadM VerifyMode
 modeReadM = eitherReader $ \s ->

src/Xrefcheck/Config.hs

@@ -14,25 +14,22 @@ import Instances.TH.Lift ()
 import Text.Regex.TDFA (CompOption (..), ExecOption (..), Regex)
 import Text.Regex.TDFA.Text (compile)
 
-import Data.FileEmbed (embedFile)
 -- FIXME: Use </> from System.FilePath
 -- </> from Posix is used only because we cross-compile to Windows and \ doesn't work on Linux
+import Data.FileEmbed (embedFile)
 import System.FilePath.Posix ((</>))
 import Time (KnownRatName, Second, Time, unitsP)
 
+import Xrefcheck.Scan
+import Xrefcheck.Scanners.Markdown
 import Xrefcheck.System (RelGlobPattern)
 import Xrefcheck.Util (aesonConfigOption, postfixFields)
 
 -- | Overall config.
 data Config = Config
     { cTraversal    :: TraversalConfig
     , cVerification :: VerifyConfig
-    }
-
--- | Config of repositry traversal.
-data TraversalConfig = TraversalConfig
-    { tcIgnored   :: [FilePath]
-      -- ^ Files and folders, files in which we completely ignore.
+    , cScanners     :: ScannersConfig
     }
 
 -- | Config of verification.
@@ -47,6 +44,11 @@ data VerifyConfig = VerifyConfig
       -- ^ Regular expressions that match external references we should not verify.
     }
 
+-- | Configs for all the supported scanners.
+data ScannersConfig = ScannersConfig
+    { scMarkdown :: MarkdownConfig
+    }
+
 makeLensesWith postfixFields ''Config
 makeLensesWith postfixFields ''VerifyConfig
 
@@ -72,7 +74,7 @@ defConfig =
 -----------------------------------------------------------
 
 deriveFromJSON aesonConfigOption ''Config
-deriveFromJSON aesonConfigOption ''TraversalConfig
+deriveFromJSON aesonConfigOption ''ScannersConfig
 deriveFromJSON aesonConfigOption ''VerifyConfig
 
 instance KnownRatName unit => FromJSON (Time unit) where

src/Xrefcheck/Core.hs

@@ -10,6 +10,7 @@
 module Xrefcheck.Core where
 
 import Control.Lens (makeLenses, (%=))
+import Data.Aeson (FromJSON (..), withText)
 import Data.Char (isAlphaNum)
 import qualified Data.Char as C
 import Data.Default (Default (..))
@@ -28,6 +29,22 @@ import Xrefcheck.Util
 -- Types
 -----------------------------------------------------------
 
+-- | Markdown flavor.
+--
+-- Unfortunatelly, CMark renderers used on different sites slightly differ,
+-- we have to account for that.
+data Flavor
+  = GitHub
+  | GitLab
+  deriving (Show)
+
+instance FromJSON Flavor where
+  parseJSON = withText "flavor" $ \txt ->
+    case T.toLower txt of
+      "github" -> pure GitHub
+      "gitlab" -> pure GitLab
+      _ -> fail $ "Unknown flavor " <> show txt
+
 -- | Description of element position in source file.
 -- We keep this in text because scanners for different formats use different
 -- representation of this thing, and it actually appears in reports only.
@@ -210,19 +227,33 @@ shouldCheckExternal = \case
 
 -- | Convert section header name to an anchor refering it.
 -- Conversion rules: https://docs.gitlab.com/ee/user/markdown.html#header-ids-and-links
-headerToAnchor :: Text -> Text
-headerToAnchor t = t
+headerToAnchor :: Flavor -> Text -> Text
+headerToAnchor flavor = \t -> t
     & T.toLower
-    & T.replace "+" tmp
-    & T.replace " " tmp
-    & joinSyms tmp
-    & T.replace (tmp <> "-") "-"
-    & T.replace ("-" <> tmp) "-"
-    & T.replace tmp "-"
-    & T.filter (\c -> isAlphaNum c || c == '_' || c == '-')
+    & mergeSpecialSymbols
   where
-    joinSyms sym = T.intercalate sym . filter (not . null) . T.splitOn sym
-    tmp = "\0"
+    joinSubsequentChars sym = toText . go . toString
+      where
+      go = \case
+        (c1 : c2 : s)
+          | c1 == c2 && c1 == sym -> go (c1 : s)
+        (c : s) -> c : go s
+        [] -> []
+
+    mergeSpecialSymbols = case flavor of
+      GitLab -> \t -> t
+        & T.replace " " "-"
+        & T.filter (\c -> isAlphaNum c || c == '_' || c == '-')
+        & joinSubsequentChars '-'
+      GitHub ->
+        -- GitHub case is tricky, it can produce many hythens in a row, e.g.
+        -- "A - B" -> "a---b"
+        let tmp = '\0'; tmpT = T.singleton tmp
+        in \t -> t
+        & T.replace " " tmpT
+        & joinSubsequentChars tmp
+        & T.replace tmpT "-"
+        & T.filter (\c -> isAlphaNum c || c == '_' || c == '-')
 
 -- | When there are several anchors with the same name, github automatically attaches
 -- "-<number>" suffixes to duplications to make them referable unambiguously.

src/Xrefcheck/Scan.hs

@@ -6,7 +6,8 @@
 -- | Generalised repo scanner and analyser.
 
 module Xrefcheck.Scan
-    ( Extension
+    ( TraversalConfig (..)
+    , Extension
     , ScanAction
     , FormatsSupport
     , RepoInfo (..)
@@ -15,16 +16,24 @@ module Xrefcheck.Scan
     , specificFormatsSupport
     ) where
 
+import Data.Aeson.TH (deriveFromJSON)
 import qualified Data.Foldable as F
 import qualified Data.Map as M
 import GHC.Err (errorWithoutStackTrace)
 import qualified System.Directory.Tree as Tree
 import System.FilePath (takeDirectory, takeExtension, (</>))
 
-import Xrefcheck.Config
 import Xrefcheck.Core
 import Xrefcheck.Progress
-import Xrefcheck.Util ()
+import Xrefcheck.Util (aesonConfigOption)
+
+-- | Config of repositry traversal.
+data TraversalConfig = TraversalConfig
+    { tcIgnored   :: [FilePath]
+      -- ^ Files and folders, files in which we completely ignore.
+    }
+
+deriveFromJSON aesonConfigOption ''TraversalConfig
 
 -- | File extension, dot included.
 type Extension = String

src/Xrefcheck/Scanners/Markdown.hs

@@ -8,14 +8,17 @@
 -- | Markdown documents markdownScanner.
 
 module Xrefcheck.Scanners.Markdown
-    ( markdownScanner
+    ( MarkdownConfig (..)
+    , defGithubMdConfig
+    , markdownScanner
     , markdownSupport
     , parseFileInfo
     ) where
 
 import CMarkGFM (Node (..), NodeType (..), PosInfo (..), commonmarkToNode)
 import Control.Lens ((%=))
 import Control.Monad.Trans.Except (Except, runExcept, throwE)
+import Data.Aeson.TH (deriveFromJSON)
 import qualified Data.ByteString.Lazy as BSL
 import Data.Char (isSpace)
 import Data.Default (Default (..))
@@ -25,6 +28,18 @@ import Fmt (Buildable (..), blockListF, nameF, (+|), (|+))
 
 import Xrefcheck.Core
 import Xrefcheck.Scan
+import Xrefcheck.Util
+
+data MarkdownConfig = MarkdownConfig
+  { mcFlavor :: Flavor
+  }
+
+deriveFromJSON aesonConfigOption ''MarkdownConfig
+
+defGithubMdConfig :: MarkdownConfig
+defGithubMdConfig = MarkdownConfig
+  { mcFlavor = GitHub
+  }
 
 instance Buildable Node where
     build (Node _mpos ty subs) = nameF (show ty) $ blockListF subs
@@ -57,8 +72,8 @@ data IgnoreMode
     | File
     deriving Eq
 
-nodeExtractInfo :: Node -> Except Text FileInfo
-nodeExtractInfo (Node _ _ docNodes) =
+nodeExtractInfo :: MarkdownConfig -> Node -> Except Text FileInfo
+nodeExtractInfo config (Node _ _ docNodes) =
     if checkIgnoreFile docNodes
     then return def
     else finaliseFileInfo <$> extractionResult
@@ -90,7 +105,8 @@ nodeExtractInfo (Node _ _ docNodes) =
                     HTML_BLOCK _ -> processHtmlNode node pos nodes toIgnore
                     HEADING lvl -> do
                         let aType = HeaderAnchor lvl
-                        let aName = headerToAnchor $ nodeExtractText node
+                        let aName = headerToAnchor (mcFlavor config) $
+                                    nodeExtractText node
                         let aPos = toPosition pos
                         fiAnchors %= (Anchor{..} :)
                         loop nodes toIgnore
@@ -230,17 +246,17 @@ nodeExtractInfo (Node _ _ docNodes) =
                     (loop nodes . pure) $ getIgnoreMode node
                 Nothing -> loop nodes toIgnore
 
-parseFileInfo :: LT.Text -> Either Text FileInfo
-parseFileInfo input = runExcept $ nodeExtractInfo $
+parseFileInfo :: MarkdownConfig -> LT.Text -> Either Text FileInfo
+parseFileInfo config input = runExcept $ nodeExtractInfo config $
     commonmarkToNode [] [] $ toStrict input
 
-markdownScanner :: ScanAction
-markdownScanner path = do
-    errOrInfo <- parseFileInfo . decodeUtf8 <$> BSL.readFile path
+markdownScanner :: MarkdownConfig -> ScanAction
+markdownScanner config path = do
+    errOrInfo <- parseFileInfo config . decodeUtf8 <$> BSL.readFile path
     case errOrInfo of
         Left errTxt -> do
             die $ "Error when scanning " <> path <> ": " <> T.unpack errTxt
         Right fileInfo -> return fileInfo
 
-markdownSupport :: ([Extension], ScanAction)
-markdownSupport = ([".md"], markdownScanner)
+markdownSupport :: MarkdownConfig -> ([Extension], ScanAction)
+markdownSupport config = ([".md"], markdownScanner config)