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

{-# LANGUAGE PatternSynonyms #-}

-- | Various primitives.

module Xrefcheck.Core where

import Control.Lens (makeLenses, (%=))
import Data.Char (isAlphaNum)
import qualified Data.Char as C
import Data.Default (Default (..))
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Text as T
import Fmt (Buildable (..), blockListF, blockListF', nameF, (+|), (|+))
import System.Console.Pretty (Color (..), Style (..), color, style)
import System.FilePath (isPathSeparator, pathSeparator)
import Text.Numeral.Roman (toRoman)

import Xrefcheck.Progress
import Xrefcheck.Util

-----------------------------------------------------------
-- Types
-----------------------------------------------------------

-- | 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 (Maybe Text)
    deriving (Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
(Int -> Position -> ShowS)
-> (Position -> String) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show, (forall x. Position -> Rep Position x)
-> (forall x. Rep Position x -> Position) -> Generic Position
forall x. Rep Position x -> Position
forall x. Position -> Rep Position x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Position x -> Position
$cfrom :: forall x. Position -> Rep Position x
Generic)

instance Buildable Position where
    build :: Position -> Builder
build (Position Maybe Text
pos) = case Maybe Text
pos of
        Maybe Text
Nothing -> Builder
""
        Just Text
p  -> Style -> Builder -> Builder
forall a. Pretty a => Style -> a -> a
style Style
Faint (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
"at src:" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
p

-- | Full info about a reference.
data Reference = Reference
    { Reference -> Text
rName   :: Text
      -- ^ Text displayed as reference.
    , Reference -> Text
rLink   :: Text
      -- ^ File or site reference points to.
    , Reference -> Maybe Text
rAnchor :: Maybe Text
      -- ^ Section or custom anchor tag.
    , Reference -> Position
rPos    :: Position
    } deriving (Int -> Reference -> ShowS
[Reference] -> ShowS
Reference -> String
(Int -> Reference -> ShowS)
-> (Reference -> String)
-> ([Reference] -> ShowS)
-> Show Reference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reference] -> ShowS
$cshowList :: [Reference] -> ShowS
show :: Reference -> String
$cshow :: Reference -> String
showsPrec :: Int -> Reference -> ShowS
$cshowsPrec :: Int -> Reference -> ShowS
Show, (forall x. Reference -> Rep Reference x)
-> (forall x. Rep Reference x -> Reference) -> Generic Reference
forall x. Rep Reference x -> Reference
forall x. Reference -> Rep Reference x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Reference x -> Reference
$cfrom :: forall x. Reference -> Rep Reference x
Generic)

-- | 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 (Int -> AnchorType -> ShowS
[AnchorType] -> ShowS
AnchorType -> String
(Int -> AnchorType -> ShowS)
-> (AnchorType -> String)
-> ([AnchorType] -> ShowS)
-> Show AnchorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnchorType] -> ShowS
$cshowList :: [AnchorType] -> ShowS
show :: AnchorType -> String
$cshow :: AnchorType -> String
showsPrec :: Int -> AnchorType -> ShowS
$cshowsPrec :: Int -> AnchorType -> ShowS
Show, AnchorType -> AnchorType -> Bool
(AnchorType -> AnchorType -> Bool)
-> (AnchorType -> AnchorType -> Bool) -> Eq AnchorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnchorType -> AnchorType -> Bool
$c/= :: AnchorType -> AnchorType -> Bool
== :: AnchorType -> AnchorType -> Bool
$c== :: AnchorType -> AnchorType -> Bool
Eq, (forall x. AnchorType -> Rep AnchorType x)
-> (forall x. Rep AnchorType x -> AnchorType) -> Generic AnchorType
forall x. Rep AnchorType x -> AnchorType
forall x. AnchorType -> Rep AnchorType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AnchorType x -> AnchorType
$cfrom :: forall x. AnchorType -> Rep AnchorType x
Generic)

-- | A referable anchor.
data Anchor = Anchor
    { Anchor -> AnchorType
aType :: AnchorType
    , Anchor -> Text
aName :: Text
    , Anchor -> Position
aPos  :: Position
    } deriving (Int -> Anchor -> ShowS
[Anchor] -> ShowS
Anchor -> String
(Int -> Anchor -> ShowS)
-> (Anchor -> String) -> ([Anchor] -> ShowS) -> Show Anchor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Anchor] -> ShowS
$cshowList :: [Anchor] -> ShowS
show :: Anchor -> String
$cshow :: Anchor -> String
showsPrec :: Int -> Anchor -> ShowS
$cshowsPrec :: Int -> Anchor -> ShowS
Show, (forall x. Anchor -> Rep Anchor x)
-> (forall x. Rep Anchor x -> Anchor) -> Generic Anchor
forall x. Rep Anchor x -> Anchor
forall x. Anchor -> Rep Anchor x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Anchor x -> Anchor
$cfrom :: forall x. Anchor -> Rep Anchor x
Generic)

-- | All information regarding a single file we care about.
data FileInfo = FileInfo
    { FileInfo -> [Reference]
_fiReferences :: [Reference]
    , FileInfo -> [Anchor]
_fiAnchors    :: [Anchor]
    } deriving (Int -> FileInfo -> ShowS
[FileInfo] -> ShowS
FileInfo -> String
(Int -> FileInfo -> ShowS)
-> (FileInfo -> String) -> ([FileInfo] -> ShowS) -> Show FileInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileInfo] -> ShowS
$cshowList :: [FileInfo] -> ShowS
show :: FileInfo -> String
$cshow :: FileInfo -> String
showsPrec :: Int -> FileInfo -> ShowS
$cshowsPrec :: Int -> FileInfo -> ShowS
Show, (forall x. FileInfo -> Rep FileInfo x)
-> (forall x. Rep FileInfo x -> FileInfo) -> Generic FileInfo
forall x. Rep FileInfo x -> FileInfo
forall x. FileInfo -> Rep FileInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileInfo x -> FileInfo
$cfrom :: forall x. FileInfo -> Rep FileInfo x
Generic)
makeLenses ''FileInfo

instance Default FileInfo where
    def :: FileInfo
def = [Reference] -> [Anchor] -> FileInfo
FileInfo [] []

newtype RepoInfo = RepoInfo (Map FilePath FileInfo)
    deriving (Int -> RepoInfo -> ShowS
[RepoInfo] -> ShowS
RepoInfo -> String
(Int -> RepoInfo -> ShowS)
-> (RepoInfo -> String) -> ([RepoInfo] -> ShowS) -> Show RepoInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RepoInfo] -> ShowS
$cshowList :: [RepoInfo] -> ShowS
show :: RepoInfo -> String
$cshow :: RepoInfo -> String
showsPrec :: Int -> RepoInfo -> ShowS
$cshowsPrec :: Int -> RepoInfo -> ShowS
Show)

finaliseFileInfo :: FileInfo -> FileInfo
finaliseFileInfo :: FileInfo -> FileInfo
finaliseFileInfo = State FileInfo () -> FileInfo -> FileInfo
forall s a. State s a -> s -> s
execState (State FileInfo () -> FileInfo -> FileInfo)
-> State FileInfo () -> FileInfo -> FileInfo
forall a b. (a -> b) -> a -> b
$ do
    ([Reference] -> Identity [Reference])
-> FileInfo -> Identity FileInfo
Lens' FileInfo [Reference]
fiReferences (([Reference] -> Identity [Reference])
 -> FileInfo -> Identity FileInfo)
-> ([Reference] -> [Reference]) -> State FileInfo ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [Reference] -> [Reference]
forall a. [a] -> [a]
reverse
    ([Anchor] -> Identity [Anchor]) -> FileInfo -> Identity FileInfo
Lens' FileInfo [Anchor]
fiAnchors (([Anchor] -> Identity [Anchor]) -> FileInfo -> Identity FileInfo)
-> ([Anchor] -> [Anchor]) -> State FileInfo ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [Anchor] -> [Anchor]
forall a. [a] -> [a]
reverse

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

instance NFData Position
instance NFData Reference
instance NFData AnchorType
instance NFData Anchor
instance NFData FileInfo

instance Buildable Reference where
    build :: Reference -> Builder
build Reference{Maybe Text
Text
Position
rPos :: Position
rAnchor :: Maybe Text
rLink :: Text
rName :: Text
rPos :: Reference -> Position
rAnchor :: Reference -> Maybe Text
rLink :: Reference -> Text
rName :: Reference -> Text
..} =
        Builder -> Builder -> Builder
nameF (Builder
"reference " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Builder -> Builder
paren (LocationType -> Builder
forall p. Buildable p => p -> Builder
build LocationType
loc) Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Position
rPos Position -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"") (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
            [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF
            [ Builder
"text: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall b a. (Show a, IsString b) => a -> b
show Text
rName
            , Builder
"link: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
rLink
            , Builder
"anchor: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build (Maybe Text
rAnchor Maybe Text -> Text -> Text
forall a. Maybe a -> a -> a
?: Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Faint Text
"-")
            ]
      where
        loc :: LocationType
loc = Text -> LocationType
locationType Text
rLink

instance Buildable AnchorType where
    build :: AnchorType -> Builder
build = Style -> Builder -> Builder
forall a. Pretty a => Style -> a -> a
style Style
Faint (Builder -> Builder)
-> (AnchorType -> Builder) -> AnchorType -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        HeaderAnchor Int
l -> Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Green (Builder
"header " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall s n. (IsString s, Monoid s, Ord n, Num n) => n -> s
toRoman Int
l)
        AnchorType
HandAnchor -> Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Yellow Builder
"hand made"
        AnchorType
BiblioAnchor -> Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Cyan Builder
"biblio"

instance Buildable Anchor where
    build :: Anchor -> Builder
build (Anchor AnchorType
t Text
a Position
p) = Text
a Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" (" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| AnchorType
t AnchorType -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
") " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Position
p Position -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""

instance Buildable FileInfo where
    build :: FileInfo -> Builder
build FileInfo{[Anchor]
[Reference]
_fiAnchors :: [Anchor]
_fiReferences :: [Reference]
_fiAnchors :: FileInfo -> [Anchor]
_fiReferences :: FileInfo -> [Reference]
..} =
        [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF
        [ Builder -> Builder -> Builder
nameF Builder
"references" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Reference] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF [Reference]
_fiReferences
        , Builder -> Builder -> Builder
nameF Builder
"anchors" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [Anchor] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF [Anchor]
_fiAnchors
        ]

instance Buildable RepoInfo where
    build :: RepoInfo -> Builder
build (RepoInfo Map String FileInfo
m) =
        Text
-> ((String, FileInfo) -> Builder)
-> [(String, FileInfo)]
-> Builder
forall (f :: * -> *) a.
Foldable f =>
Text -> (a -> Builder) -> f a -> Builder
blockListF' Text
"⮚" (String, FileInfo) -> Builder
forall p. Buildable p => (String, p) -> Builder
buildFileReport (Map String FileInfo -> [(String, FileInfo)]
forall k a. Map k a -> [(k, a)]
M.toList Map String FileInfo
m)
      where
        buildFileReport :: (String, p) -> Builder
buildFileReport (String
name, p
info) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Cyan (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Builder
forall a. IsString a => String -> a
fromString String
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":\n"
            , p -> Builder
forall p. Buildable p => p -> Builder
build p
info
            , Builder
"\n"
            ]

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

pattern PathSep :: Char
pattern $mPathSep :: forall r. Char -> (Void# -> r) -> (Void# -> r) -> r
PathSep <- (isPathSeparator -> True)

-- | Type of reference.
data LocationType
    = LocalLoc
      -- ^ Reference on this file
    | RelativeLoc
      -- ^ Reference to a file relative to given one
    | AbsoluteLoc
      -- ^ Reference to a file relative to the root
    | ExternalLoc
      -- ^ Reference to a file at outer site
    | OtherLoc
      -- ^ Entry not to be processed (e.g. "mailto:e-mail")
    deriving (Int -> LocationType -> ShowS
[LocationType] -> ShowS
LocationType -> String
(Int -> LocationType -> ShowS)
-> (LocationType -> String)
-> ([LocationType] -> ShowS)
-> Show LocationType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LocationType] -> ShowS
$cshowList :: [LocationType] -> ShowS
show :: LocationType -> String
$cshow :: LocationType -> String
showsPrec :: Int -> LocationType -> ShowS
$cshowsPrec :: Int -> LocationType -> ShowS
Show)

instance Buildable LocationType where
    build :: LocationType -> Builder
build = \case
        LocationType
LocalLoc -> Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Green Builder
"local"
        LocationType
RelativeLoc -> Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Yellow Builder
"relative"
        LocationType
AbsoluteLoc -> Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Blue Builder
"absolute"
        LocationType
ExternalLoc -> Color -> Builder -> Builder
forall a. Pretty a => Color -> a -> a
color Color
Red Builder
"external"
        LocationType
OtherLoc -> Builder
""

-- | Whether this is a link to external resource.
isExternal :: LocationType -> Bool
isExternal :: LocationType -> Bool
isExternal = \case
    LocationType
ExternalLoc -> Bool
True
    LocationType
_ -> Bool
False

-- | Whether this is a link to repo-local resource.
isLocal :: LocationType -> Bool
isLocal :: LocationType -> Bool
isLocal = \case
    LocationType
LocalLoc -> Bool
True
    LocationType
RelativeLoc -> Bool
True
    LocationType
AbsoluteLoc -> Bool
True
    LocationType
ExternalLoc -> Bool
False
    LocationType
OtherLoc -> Bool
False

-- | Get type of reference.
locationType :: Text -> LocationType
locationType :: Text -> LocationType
locationType Text
location = case Text -> String
forall a. ToString a => a -> String
toString Text
location of
    []                      -> LocationType
LocalLoc
    Char
PathSep : String
_             -> LocationType
AbsoluteLoc
    Char
'.' : Char
PathSep : String
_       -> LocationType
RelativeLoc
    Char
'.' : Char
'.' : Char
PathSep : String
_ -> LocationType
RelativeLoc
    String
_ | Bool
hasUrlProtocol      -> LocationType
ExternalLoc
      | Bool
hasProtocol         -> LocationType
OtherLoc
      | Bool
otherwise           -> LocationType
RelativeLoc
  where
    hasUrlProtocol :: Bool
hasUrlProtocol = Text
"://" Text -> Text -> Bool
`T.isInfixOf` Int -> Text -> Text
T.take Int
10 Text
location
    hasProtocol :: Bool
hasProtocol = Text
":" Text -> Text -> Bool
`T.isInfixOf` Int -> Text -> Text
T.take Int
10 Text
location

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

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

shouldCheckExternal :: VerifyMode -> Bool
shouldCheckExternal :: VerifyMode -> Bool
shouldCheckExternal = \case
    VerifyMode
LocalOnlyMode -> Bool
False
    VerifyMode
ExternalOnlyMode -> Bool
True
    VerifyMode
FullMode -> Bool
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 :: Text -> Text
headerToAnchor :: Text -> Text
headerToAnchor Text
t = Text
t
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text
T.toLower
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace Text
"+" Text
tmp
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace Text
" " Text
tmp
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text
joinSyms Text
tmp
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace (Text
tmp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-") Text
"-"
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace (Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tmp) Text
"-"
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace Text
tmp Text
"-"
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> Text -> Text
T.filter (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
  where
    joinSyms :: Text -> Text -> Text
joinSyms Text
sym = Text -> [Text] -> Text
T.intercalate Text
sym ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
forall t. Container t => t -> Bool
null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
sym
    tmp :: Text
tmp = Text
"\0"

-- | 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 :: Text -> Maybe Text
stripAnchorDupNo Text
t = do
    let strippedNo :: Text
strippedNo = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
C.isNumber Text
t
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Int
forall t. Container t => t -> Int
length Text
strippedNo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Text -> Int
forall t. Container t => t -> Int
length Text
t)
    Text -> Text -> Maybe Text
T.stripSuffix Text
"-" Text
strippedNo

-- | Strip './' prefix from local references.
canonizeLocalRef :: Text -> Text
canonizeLocalRef :: Text -> Text
canonizeLocalRef Text
ref =
    case Text -> Text -> Maybe Text
T.stripPrefix Text
localPrefix Text
ref of
      Maybe Text
Nothing -> Text
ref
      Just Text
r  -> Text -> Text
canonizeLocalRef Text
r
  where
    localPrefix :: Text
localPrefix = String -> Text
forall a. ToText a => a -> Text
toText [Char
'.', Char
pathSeparator]

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

data VerifyProgress = VerifyProgress
    { VerifyProgress -> Progress Int
vrLocal    :: !(Progress Int)
    , VerifyProgress -> Progress Int
vrExternal :: !(Progress Int)
    } deriving (Int -> VerifyProgress -> ShowS
[VerifyProgress] -> ShowS
VerifyProgress -> String
(Int -> VerifyProgress -> ShowS)
-> (VerifyProgress -> String)
-> ([VerifyProgress] -> ShowS)
-> Show VerifyProgress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerifyProgress] -> ShowS
$cshowList :: [VerifyProgress] -> ShowS
show :: VerifyProgress -> String
$cshow :: VerifyProgress -> String
showsPrec :: Int -> VerifyProgress -> ShowS
$cshowsPrec :: Int -> VerifyProgress -> ShowS
Show)

initVerifyProgress :: [Reference] -> VerifyProgress
initVerifyProgress :: [Reference] -> VerifyProgress
initVerifyProgress [Reference]
references =
    VerifyProgress :: Progress Int -> Progress Int -> VerifyProgress
VerifyProgress
    { vrLocal :: Progress Int
vrLocal = Int -> Progress Int
forall a. Num a => a -> Progress a
initProgress ([LocationType] -> Int
forall t. Container t => t -> Int
length [LocationType]
localRefs)
    , vrExternal :: Progress Int
vrExternal = Int -> Progress Int
forall a. Num a => a -> Progress a
initProgress ([LocationType] -> Int
forall t. Container t => t -> Int
length [LocationType]
extRefs)
    }
  where
    ([LocationType]
extRefs, [LocationType]
localRefs) =
        (LocationType -> Bool)
-> [LocationType] -> ([LocationType], [LocationType])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition LocationType -> Bool
isExternal ([LocationType] -> ([LocationType], [LocationType]))
-> [LocationType] -> ([LocationType], [LocationType])
forall a b. (a -> b) -> a -> b
$
        (Reference -> LocationType) -> [Reference] -> [LocationType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> LocationType
locationType (Text -> LocationType)
-> (Reference -> Text) -> Reference -> LocationType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Text
rLink) [Reference]
references

showAnalyseProgress :: VerifyMode -> VerifyProgress -> Text
showAnalyseProgress :: VerifyMode -> VerifyProgress -> Text
showAnalyseProgress VerifyMode
mode VerifyProgress{Progress Int
vrExternal :: Progress Int
vrLocal :: Progress Int
vrExternal :: VerifyProgress -> Progress Int
vrLocal :: VerifyProgress -> Progress Int
..} = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat ([[Text]] -> Text) -> [[Text]] -> Text
forall a b. (a -> b) -> a -> b
$
    [ [ Text
"Verifying " ]
    , [ Text -> Int -> Color -> Progress Int -> Text
showProgress Text
"local" Int
10 Color
White Progress Int
vrLocal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
      | VerifyMode -> Bool
shouldCheckLocal VerifyMode
mode ]
    , [ Text -> Int -> Color -> Progress Int -> Text
showProgress Text
"external" Int
15 Color
Yellow Progress Int
vrExternal
      | VerifyMode -> Bool
shouldCheckExternal VerifyMode
mode ]
    ]

reprintAnalyseProgress :: Rewrite -> VerifyMode -> VerifyProgress -> IO ()
reprintAnalyseProgress :: Rewrite -> VerifyMode -> VerifyProgress -> IO ()
reprintAnalyseProgress Rewrite
rw VerifyMode
mode VerifyProgress
p = Rewrite -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Rewrite -> Text -> m ()
putTextRewrite Rewrite
rw (VerifyMode -> VerifyProgress -> Text
showAnalyseProgress VerifyMode
mode VerifyProgress
p)