Core.hs

{- SPDX-FileCopyrightText: 2018-2020 Serokell <https://serokell.io>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

{-# LANGUAGE PatternSynonyms #-}

-- | Various primitives.

module Xrefcheck.Core where

import Universum hiding ((^..))

import Control.Lens (folded, makeLenses, makePrisms, to, united, (^..))
import Data.Aeson (FromJSON (..), withText)
import Data.Char (isAlphaNum)
import Data.Char qualified as C
import Data.DList (DList)
import Data.DList qualified as DList
import Data.Map qualified as M
import Data.Reflection (Given)
import Data.Text qualified as T
import Fmt (Buildable (..), Builder)
import System.FilePath.Posix (isPathSeparator)
import Text.Interpolation.Nyan
import Time (Second, Time)

import Xrefcheck.Progress
import Xrefcheck.System
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 stock (Show, Enum, Bounded)

allFlavors :: [Flavor]
allFlavors = [minBound .. maxBound]

-- | Whether anchors are case-sensitive for a given Markdown flavour or not.
caseInsensitiveAnchors :: Flavor -> Bool
caseInsensitiveAnchors GitHub = True
caseInsensitiveAnchors GitLab = False

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.
newtype Position = Position Text
  deriving stock (Show, Eq, Generic)

instance Buildable Position where
  build (Position pos) = build pos

-- | Full info about a reference.
data Reference = Reference
  { rName :: Text
    -- ^ Text displayed as reference.
  , rPos :: Position
    -- ^ Position in source file.
  , rInfo :: ReferenceInfo
    -- ^ More info about the reference.
  } deriving stock (Show, Generic)

-- | Info about the reference.
data ReferenceInfo
  = RIExternal ExternalLink
  | RIFile ReferenceInfoFile
  deriving stock (Show, Generic)

data ReferenceInfoFile = ReferenceInfoFile
  { rifAnchor :: Maybe Text
    -- ^ Section or custom anchor tag.
  , rifLink :: FileLink
    -- ^ More info about the link.
  } deriving stock (Show, Generic)

data ExternalLink
  = ELUrl Text
    -- ^ Reference to a file at outer site, e.g @[d](http://www.google.com/doodles)@.
  | ELOther Text
    -- ^ Entry not to be processed, e.g. @mailto:e-mail@.
  deriving stock (Show, Generic)

data FileLink
  = FLAbsolute RelPosixLink
    -- ^ Reference to a file or directory relative to the repository root.
  | FLRelative RelPosixLink
    -- ^ Reference to a file or directory relative to the given one.
  | FLLocal
    -- ^ Reference to this file.
  deriving stock (Show, Generic)

makePrisms ''ReferenceInfo
makePrisms ''ExternalLink

pattern PathSep :: Char
pattern PathSep <- (isPathSeparator -> True)

-- | Compute the 'ReferenceInfo' corresponding to a given link.
referenceInfo :: Text -> ReferenceInfo
referenceInfo url
  | hasUrlProtocol = RIExternal $ ELUrl url
  | hasProtocol = RIExternal $ ELOther url
  | null link = RIFile $ ReferenceInfoFile anchor FLLocal
  | otherwise = case T.uncons link of
      Just (PathSep, path) ->
        RIFile $ ReferenceInfoFile anchor $ FLAbsolute $ RelPosixLink path
      _ ->
        RIFile $ ReferenceInfoFile anchor $ FLRelative $ RelPosixLink link
  where
    hasUrlProtocol = "://" `T.isInfixOf` T.take 10 url
    hasProtocol = ":" `T.isInfixOf` T.take 10 url
    (link, anchor) = case T.splitOn "#" url of
      [t] -> (t, Nothing)
      t : ts -> (t, Just $ T.intercalate "#" ts)
      [] -> (url, Nothing)

-- | Context of anchor.
data AnchorType
  = HeaderAnchor Int
    -- ^ Every section header is usually an anchor
  | HandAnchor
    -- ^ They can be set up manually
  | BiblioAnchor
    -- ^ Id of entry in bibliography
  deriving stock (Show, Eq, Generic)

-- | A referable anchor.
data Anchor = Anchor
  { aType :: AnchorType
  , aName :: Text
  , aPos  :: Position
  } deriving stock (Show, Eq, Generic)

data FileInfoDiff = FileInfoDiff
  { _fidReferences :: DList Reference
  , _fidAnchors    :: DList Anchor
  }
makeLenses ''FileInfoDiff

diffToFileInfo :: FileInfoDiff -> FileInfo
diffToFileInfo (FileInfoDiff refs anchors) =
    FileInfo (DList.toList refs) (DList.toList anchors)

instance Semigroup FileInfoDiff where
  FileInfoDiff a b <> FileInfoDiff c d = FileInfoDiff (a <> c) (b <> d)

instance Monoid FileInfoDiff where
  mempty = FileInfoDiff mempty mempty

-- | All information regarding a single file we care about.
data FileInfo = FileInfo
  { _fiReferences :: [Reference]
  , _fiAnchors    :: [Anchor]
  } deriving stock (Show, Generic)
makeLenses ''FileInfo

data ScanPolicy
  = OnlyTracked
  -- ^ Scan and treat as existing only files tracked by Git.
  -- Warn when there are scannable files not added to Git yet.
  | IncludeUntracked
  -- ^ Also scan and treat as existing
  -- files that were neither tracked nor ignored by Git.
  deriving stock (Show, Eq)

data FileStatus
  = Scanned FileInfo
  | NotScannable
  -- ^ Files that are not supported by our scanners.
  | NotAddedToGit
  -- ^ We are not scanning files that are not added to git
  -- unless --include-untracked CLI option was enabled, but we're
  -- gathering information about them to improve reports.
  deriving stock (Show)

data DirectoryStatus
  = TrackedDirectory
  | UntrackedDirectory
  deriving stock (Show)

-- | All tracked files and directories.
data RepoInfo = RepoInfo
  { riFiles :: Map CanonicalRelPosixLink (RelPosixLink, FileStatus)
    -- ^ Files from the repo with `FileInfo` attached to files that we've scanned.
  , riDirectories :: Map CanonicalRelPosixLink (RelPosixLink, DirectoryStatus)
    -- ^ Directories containing those files.
  }

-- Search for a file in the repository.
lookupFile :: CanonicalRelPosixLink -> RepoInfo -> Maybe FileStatus
lookupFile path RepoInfo{..} =
  snd <$> M.lookup path riFiles

-- Search for a directory in the repository.
lookupDirectory :: CanonicalRelPosixLink -> RepoInfo -> Maybe DirectoryStatus
lookupDirectory path RepoInfo{..} =
  snd <$> M.lookup path riDirectories

-----------------------------------------------------------
-- Instances
-----------------------------------------------------------

instance NFData ReferenceInfo
instance NFData Anchor
instance NFData AnchorType
instance NFData ExternalLink
instance NFData FileInfo
instance NFData FileLink
instance NFData Position
instance NFData Reference
instance NFData ReferenceInfoFile

instance Given ColorMode => Buildable Reference where
  build Reference{..} =
    case rInfo of
      RIFile ReferenceInfoFile{..} ->
        case rifLink of
          FLLocal ->
            [int||
            reference #{paren $ colorIfNeeded Green "file-local"} at #{rPos}:
              - text: #s{rName}
              - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"}
            |]
          FLRelative link ->
            [int||
            reference #{paren $ colorIfNeeded Yellow "relative"} at #{rPos}:
              - text: #s{rName}
              - link: #{link}
              - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"}
            |]
          FLAbsolute link ->
            [int||
            reference #{paren $ colorIfNeeded Yellow "absolute"} at #{rPos}:
              - text: #s{rName}
              - link: /#{link}
              - anchor: #{rifAnchor ?: styleIfNeeded Faint "-"}
            |]
      RIExternal (ELUrl url) ->
        [int||
        reference #{paren $ colorIfNeeded Red "external"} at #{rPos}:
          - text: #s{rName}
          - link: #{url}
        |]
      RIExternal (ELOther url) ->
        [int||
        reference (other) at #{rPos}:
          - text: #s{rName}
          - link: #{url}
        |]

instance Given ColorMode => Buildable AnchorType where
  build = styleIfNeeded Faint . \case
    HeaderAnchor l -> colorIfNeeded Green ("header " <> headerLevelToRoman l)
    HandAnchor -> colorIfNeeded Yellow "handmade"
    BiblioAnchor -> colorIfNeeded Cyan "biblio"
    where
      headerLevelToRoman = \case
        1 -> "I"
        2 -> "II"
        3 -> "III"
        4 -> "IV"
        5 -> "V"
        6 -> "VI"
        n -> error "Bad header level: " <> show n

instance Given ColorMode => Buildable Anchor where
  build Anchor{..} =
    [int||
    #{aName} (#{aType}) at #{aPos}
    |]

instance Given ColorMode => Buildable FileInfo where
  build FileInfo{..} =
    [int||
    - references:
    #{ interpolateIndentF 4 $ maybe "none" interpolateBlockListF (nonEmpty _fiReferences) }
    - anchors:
    #{ interpolateIndentF 4 $ maybe "none" interpolateBlockListF (nonEmpty _fiAnchors) }
    |]

instance Given ColorMode => Buildable RepoInfo where
  build RepoInfo{..}
    | Just scanned <- nonEmpty [(name, info) | (_, (name, Scanned info)) <- toPairs riFiles]
    = interpolateUnlinesF $ buildFileReport <$> scanned
    where
      buildFileReport :: (RelPosixLink, FileInfo) -> Builder
      buildFileReport (name, info) =
        [int||
        #{ colorIfNeeded Cyan name }:
        #{ interpolateIndentF 2 $ build info }
        |]
  build _ = "No scannable files found."

-----------------------------------------------------------
-- Analysing
-----------------------------------------------------------

-- | Which parts of verification do we perform.
data VerifyMode
  = LocalOnlyMode
  | ExternalOnlyMode
  | FullMode

shouldCheckLocal :: VerifyMode -> Bool
shouldCheckLocal = \case
  LocalOnlyMode -> True
  ExternalOnlyMode -> False
  FullMode -> True

shouldCheckExternal :: VerifyMode -> Bool
shouldCheckExternal = \case
  LocalOnlyMode -> False
  ExternalOnlyMode -> True
  FullMode -> True

-- | Convert section header name to an anchor refering it.
-- Conversion rules: https://docs.gitlab.com/ee/user/markdown.html#header-ids-and-links
headerToAnchor :: Flavor -> Text -> Text
headerToAnchor flavor = \t -> t
  & T.toLower
  & mergeSpecialSymbols
  where
    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.
-- For instance, if there are two headers called "description", they would gain
-- "description" and "description-1" anchors correspondingly.
--
-- This function strips this suffix and returns the original anchor in case when
-- suffix is present.
stripAnchorDupNo :: Text -> Maybe Text
stripAnchorDupNo t = do
  let strippedNo = T.dropWhileEnd C.isNumber t
  guard (length strippedNo < length t)
  T.stripSuffix "-" strippedNo

-----------------------------------------------------------
-- Visualisation
-----------------------------------------------------------

data VerifyProgress = VerifyProgress
  { vrLocal    :: !(Progress Int ())
  , vrExternal :: !(Progress Int Text)
  } deriving stock (Show)

initVerifyProgress :: [Reference] -> VerifyProgress
initVerifyProgress references = VerifyProgress
  { vrLocal = initProgressWitnessed $
      references ^.. folded . to rInfo . (_RIFile . united <> _RIExternal . _ELOther . united)
  , vrExternal = initProgressWitnessed . ordNub $
      references ^.. folded . to rInfo . _RIExternal . _ELUrl
  }

showAnalyseProgress :: Given ColorMode => VerifyMode -> Time Second -> VerifyProgress -> Text
showAnalyseProgress mode posixTime VerifyProgress{..} =
  mconcat . mconcat $
    [ [ "Verifying " ]
    , [ showProgress "local" 10 White posixTime vrLocal <> " "
      | shouldCheckLocal mode ]
    , [ showProgress "external" 15 Yellow posixTime vrExternal
      | shouldCheckExternal mode ]
    ]

reprintAnalyseProgress :: Given ColorMode =>
  Rewrite -> VerifyMode -> Time Second -> VerifyProgress -> IO ()
reprintAnalyseProgress rw mode posixTime p = putTextRewrite rw $
  showAnalyseProgress mode posixTime p