{-# LANGUAGE PatternSynonyms #-}
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
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
data Reference = Reference
{ Reference -> Text
rName :: Text
, Reference -> Text
rLink :: Text
, Reference -> Maybe Text
rAnchor :: Maybe Text
, 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)
data AnchorType
= Int
| HandAnchor
| BiblioAnchor
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)
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)
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
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"
]
pattern PathSep :: Char
pattern $mPathSep :: forall r. Char -> (Void# -> r) -> (Void# -> r) -> r
PathSep <- (isPathSeparator -> True)
data LocationType
= LocalLoc
| RelativeLoc
| AbsoluteLoc
| ExternalLoc
| OtherLoc
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
""
isExternal :: LocationType -> Bool
isExternal :: LocationType -> Bool
isExternal = \case
LocationType
ExternalLoc -> Bool
True
LocationType
_ -> Bool
False
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
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
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
headerToAnchor :: Text -> Text
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"
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
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]
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)