Merge pull request #225 from serokell/Sorokin-Anton/#223-nyan-defConfigText

[#223] Use nyan-interpolation for `defConfigText`

exec/Main.hs

@@ -7,7 +7,6 @@ module Main where
 
 import Universum
 
-import Data.ByteString qualified as BS
 import Main.Utf8 (withUtf8)
 
 import Xrefcheck.CLI (Command (..), getCommand)
@@ -21,4 +20,4 @@ main = withUtf8 $ do
     DefaultCommand options ->
       defaultAction options
     DumpConfig repoType path ->
-      BS.writeFile path (defConfigText repoType)
+      writeFile path (defConfigText repoType)

package.yaml

@@ -86,7 +86,6 @@ library:
     - directory
     - dlist
     - filepath
-    - raw-strings-qq
     - fmt
     - ftp-client
     - Glob
@@ -104,7 +103,6 @@ library:
     - tagsoup
     - text
     - text-metrics
-    - th-lift-instances
     - time
     - transformers
     - universum
@@ -127,7 +125,6 @@ executables:
       - -O2
     dependencies:
       - xrefcheck
-      - bytestring
       - universum
       - with-utf8
 
@@ -144,7 +141,6 @@ tests:
       - cmark-gfm
       - firefly
       - xrefcheck
-      - bytestring
       - directory
       - http-types
       - o-clock

src/Xrefcheck/Config.hs

@@ -5,22 +5,17 @@
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Xrefcheck.Config where
+module Xrefcheck.Config
+  ( module Xrefcheck.Config
+  , defConfigText
+  ) where
 
-import Universum.Unsafe qualified as Unsafe
 
 import Universum
 
-import Control.Exception (assert)
 import Control.Lens (makeLensesWith)
 import Data.Aeson (genericParseJSON)
-import Data.ByteString qualified as BS
-import Data.Map qualified as Map
 import Data.Yaml (FromJSON (..), decodeEither', prettyPrintParseException, withText)
-import Instances.TH.Lift ()
-import Text.Interpolation.Nyan
-import Text.Regex.TDFA qualified as R
-import Text.Regex.TDFA.ByteString ()
 
 import Time (KnownRatName, Second, Time (..), unitsP)
 
@@ -28,7 +23,7 @@ import Xrefcheck.Config.Default
 import Xrefcheck.Core
 import Xrefcheck.Scan
 import Xrefcheck.Scanners.Markdown
-import Xrefcheck.Util (Field, aesonConfigOption, postfixFields, (-:))
+import Xrefcheck.Util (Field, aesonConfigOption, postfixFields)
 
 -- | Type alias for Config' with all required fields.
 type Config = Config' Identity
@@ -83,121 +78,10 @@ data ScannersConfig' f = ScannersConfig
 makeLensesWith postfixFields ''Config'
 makeLensesWith postfixFields ''NetworkingConfig'
 
--- | Picks raw config with @:PLACEHOLDER:<key>:@ and fills the specified fields
--- in it, picking a replacement suitable for the given key. Only strings and lists
--- of strings can be filled this way.
---
--- This will fail if any placeholder is left unreplaced, however extra keys in
--- the provided replacement won't cause any warnings or failures.
-fillHoles
-  :: HasCallStack
-  => [(ByteString, Either ByteString [ByteString])]
-  -> ByteString
-  -> ByteString
-fillHoles allReplacements rawConfig =
-  let holesLocs = R.getAllMatches $ holeLineRegex `R.match` rawConfig
-  in mconcat $ replaceHoles 0 holesLocs
-  where
-    showBs :: ByteString -> Text
-    showBs = show @_ @Text . decodeUtf8
-
-    holeLineRegex :: R.Regex
-    holeLineRegex = R.makeRegex ("[ -]+:PLACEHOLDER:[^:]+:" :: Text)
-
-    replacementsMap = Map.fromList allReplacements
-    getReplacement key =
-      Map.lookup key replacementsMap
-      ?: error ("Replacement for key " <> showBs key <> " is not specified")
-
-    pickConfigSubstring :: Int -> Int -> ByteString
-    pickConfigSubstring from len = BS.take len $ BS.drop from rawConfig
-
-    replaceHoles :: Int -> [(R.MatchOffset, R.MatchLength)] -> [ByteString]
-    replaceHoles processedLen [] = one $ BS.drop processedLen rawConfig
-    replaceHoles processedLen ((off, len) : locs) =
-      -- in our case matches here should not overlap
-      assert (off > processedLen) $
-        pickConfigSubstring processedLen (off - processedLen) :
-        replaceHole (pickConfigSubstring off len) ++
-        replaceHoles (off + len) locs
-
-    holeItemRegex :: R.Regex
-    holeItemRegex = R.makeRegex ("(^|:)([ ]*):PLACEHOLDER:([^:]+):" :: Text)
-
-    holeListRegex :: R.Regex
-    holeListRegex = R.makeRegex ("^([ ]*-[ ]*):PLACEHOLDER:([^:]+):" :: Text)
-
-    replaceHole :: ByteString -> [ByteString]
-    replaceHole holeLine = if
-      | Just [_wholeMatch, _beginning, leadingSpaces, key] <-
-          R.getAllTextSubmatches <$> (holeItemRegex `R.matchM` holeLine) ->
-            case getReplacement key of
-              Left replacement -> [leadingSpaces, replacement]
-              Right _ -> error $
-                [int||
-                Key #{showBs key} requires replacement with an item, \
-                but list was given"
-                |]
-
-      | Just [_wholeMatch, leadingChars, key] <-
-          R.getAllTextSubmatches <$> (holeListRegex `R.matchM` holeLine) ->
-            case getReplacement key of
-              Left _ -> error $
-                [int||
-                Key #{showBs key} requires replacement with a list, \
-                but an item was given"
-                |]
-              Right [] ->
-                ["[]"]
-              Right replacements@(_ : _) ->
-                Unsafe.init $ do
-                  replacement <- replacements
-                  [leadingChars, replacement, "\n"]
-
-      | otherwise ->
-          error $ "Unrecognized placeholder pattern " <> showBs holeLine
-
--- | Default config in textual representation.
---
--- Sometimes you cannot just use 'defConfig' because clarifying comments
--- would be lost.
-defConfigText :: Flavor -> ByteString
-defConfigText flavor =
-  flip fillHoles defConfigUnfilled
-    [
-      "flavor" -: Left (show flavor)
-
-    , "ignoreRefsFrom" -: Right $ case flavor of
-        GitHub ->
-          [ ".github/pull_request_template.md"
-          , ".github/issue_template.md"
-          , ".github/PULL_REQUEST_TEMPLATE/**/*"
-          , ".github/ISSUE_TEMPLATE/**/*"
-          ]
-        GitLab ->
-          [ ".gitlab/merge_request_templates/**/*"
-          , ".gitlab/issue_templates/**/*"
-          ]
-
-    , "ignoreLocalRefsTo" -: Right $ case flavor of
-        GitHub ->
-          [ "../../../issues"
-          , "../../../issues/*"
-          , "../../../pulls"
-          , "../../../pulls/*"
-          ]
-        GitLab ->
-          [ "../../issues"
-          , "../../issues/*"
-          , "../../merge_requests"
-          , "../../merge_requests/*"
-          ]
-    ]
-
 defConfig :: HasCallStack => Flavor -> Config
 defConfig flavor = normaliseConfigFilePaths $
   either (error . toText . prettyPrintParseException) id $
-  decodeEither' (defConfigText flavor)
+  decodeEither' $ encodeUtf8 $ defConfigText flavor
 
 -- | Override missed fields with default values.
 overrideConfig :: ConfigOptional -> Config

src/Xrefcheck/Config/Default.hs

@@ -7,11 +7,15 @@ module Xrefcheck.Config.Default where
 
 import Universum
 
-import Text.RawString.QQ
+import Text.Interpolation.Nyan
 
-defConfigUnfilled :: ByteString
-defConfigUnfilled =
-  [r|# Exclusion parameters.
+import Xrefcheck.Core
+import Xrefcheck.Util
+
+defConfigText :: Flavor -> Text
+defConfigText flavor =
+  [int|D|
+# Exclusion parameters.
 exclusions:
   # Ignore these files. References to them will fail verification,
   # and references from them will not be verified.
@@ -21,18 +25,18 @@ exclusions:
   # References from these files will not be verified.
   # List of glob patterns.
   ignoreRefsFrom:
-    - :PLACEHOLDER:ignoreRefsFrom:
+#{interpolateIndentF 4 $ interpolateBlockListF $ ignoreLocalRefsFrom}
 
   # References to these paths will not be verified.
   # List of glob patterns.
   ignoreLocalRefsTo:
-    - :PLACEHOLDER:ignoreLocalRefsTo:
+#{interpolateIndentF 4 $ interpolateBlockListF $ ignoreLocalRefsTo}
 
   # References to these URIs will not be verified.
   # List of POSIX extended regular expressions.
   ignoreExternalRefsTo:
     # Ignore localhost links by default
-    - ^(https?|ftps?)://(localhost|127\.0\.0\.1).*
+    - ^(https?|ftps?)://(localhost|127\\.0\\.0\\.1).*
 
 # Networking parameters.
 networking:
@@ -62,5 +66,33 @@ scanners:
     # Flavor of markdown, e.g. GitHub-flavor.
     #
     # This affects which anchors are generated for headers.
-    flavor: :PLACEHOLDER:flavor:
+    flavor: #s{flavor}
 |]
+  where
+    ignoreLocalRefsFrom :: NonEmpty Text
+    ignoreLocalRefsFrom = fromList $  case flavor of
+      GitHub ->
+        [ ".github/pull_request_template.md"
+        , ".github/issue_template.md"
+        , ".github/PULL_REQUEST_TEMPLATE/**/*"
+        , ".github/ISSUE_TEMPLATE/**/*"
+        ]
+      GitLab ->
+        [ ".gitlab/merge_request_templates/**/*"
+        , ".gitlab/issue_templates/**/*"
+        ]
+
+    ignoreLocalRefsTo :: NonEmpty Text
+    ignoreLocalRefsTo = fromList $  case flavor of
+      GitHub ->
+        [ "../../../issues"
+        , "../../../issues/*"
+        , "../../../pulls"
+        , "../../../pulls/*"
+        ]
+      GitLab ->
+        [ "../../issues"
+        , "../../issues/*"
+        , "../../merge_requests"
+        , "../../merge_requests/*"
+        ]

src/Xrefcheck/Core.hs

@@ -15,9 +15,9 @@ import Control.Lens (makeLenses)
 import Data.Aeson (FromJSON (..), withText)
 import Data.Char (isAlphaNum)
 import Data.Char qualified as C
-import Data.Default (Default (..))
 import Data.DList (DList)
 import Data.DList qualified as DList
+import Data.Default (Default (..))
 import Data.List qualified as L
 import Data.Reflection (Given)
 import Data.Text qualified as T

src/Xrefcheck/Scanners/Markdown.hs

@@ -25,8 +25,8 @@ import Control.Lens (_Just, makeLenses, makeLensesFor, (.=))
 import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell)
 import Data.Aeson (FromJSON (..), genericParseJSON)
 import Data.ByteString.Lazy qualified as BSL
-import Data.Default (def)
 import Data.DList qualified as DList
+import Data.Default (def)
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as LT
 import Fmt (Buildable (..), nameF)

src/Xrefcheck/Verify.hs

@@ -33,7 +33,7 @@ module Xrefcheck.Verify
 
 import Universum
 
-import Control.Concurrent.Async (async, cancel, wait, withAsync, Async, poll)
+import Control.Concurrent.Async (Async, async, cancel, poll, wait, withAsync)
 import Control.Exception (AsyncException (..), throwIO)
 import Control.Monad.Except (MonadError (..))
 import Data.ByteString qualified as BS
@@ -65,6 +65,7 @@ import Text.URI (Authority (..), ParseExceptionBs, URI (..), mkURIBs)
 import Time (RatioNat, Second, Time (..), ms, sec, threadDelay, timeout, (+:+), (-:-))
 import URI.ByteString qualified as URIBS
 
+import Control.Exception.Safe (handleAsync, handleJust)
 import Data.Bits (toIntegralSized)
 import Xrefcheck.Config
 import Xrefcheck.Core
@@ -73,7 +74,6 @@ import Xrefcheck.Progress
 import Xrefcheck.Scan
 import Xrefcheck.System
 import Xrefcheck.Util
-import Control.Exception.Safe (handleAsync, handleJust)
 
 {-# ANN module ("HLint: ignore Use uncurry" :: Text) #-}
 {-# ANN module ("HLint: ignore Use 'runExceptT' from Universum" :: Text) #-}

tests/Test/Xrefcheck/ConfigSpec.hs

@@ -10,7 +10,6 @@ import Universum
 import Control.Concurrent (forkIO, killThread)
 import Control.Exception qualified as E
 
-import Data.ByteString qualified as BS
 import Data.List (isInfixOf)
 import Data.Yaml (ParseException (..), decodeEither')
 import Network.HTTP.Types (Status (..))
@@ -38,7 +37,7 @@ test_config =
     -- The config we match against can be regenerated with
     -- stack exec xrefcheck -- dump-config -t GitHub -o tests/configs/github-config.yaml
       [ testCase "Config matches" $ do
-        config <- BS.readFile "tests/configs/github-config.yaml"
+        config <- readFile "tests/configs/github-config.yaml"
         when (config /= defConfigText GitHub) $
           assertFailure $ toString $ unwords
             [ "Config does not match the expected format."
@@ -76,7 +75,7 @@ test_config =
        ]
   , testGroup "Config parser reject input with unknown fields"
       [ testCase "throws error with useful messages" $ do
-          case decodeEither' @Config (defConfigText GitHub <> "strangeField: []") of
+          case decodeEither' @Config $ encodeUtf8 $ defConfigText GitHub <> "strangeField: []" of
             Left (AesonException str) ->
               if "unknown fields: [\"strangeField\"]" `isInfixOf` str
               then pure ()