{-# LANGUAGE PatternSynonyms #-}
module Xrefcheck.Core where
import Control.DeepSeq (NFData)
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 (Show, Generic)
instance Buildable Position where
build (Position pos) = case pos of
Nothing -> ""
Just p -> style Faint $ "at src:" <> build p
data Reference = Reference
{ rName :: Text
, rLink :: Text
, rAnchor :: Maybe Text
, rPos :: Position
} deriving (Show, Generic)
data AnchorType
= HeaderAnchor Int
| HandAnchor
| BiblioAnchor
deriving (Show, Eq, Generic)
data Anchor = Anchor
{ aType :: AnchorType
, aName :: Text
, aPos :: Position
} deriving (Show, Generic)
data FileInfo = FileInfo
{ _fiReferences :: [Reference]
, _fiAnchors :: [Anchor]
} deriving (Show, Generic)
makeLenses ''FileInfo
instance Default FileInfo where
def = FileInfo [] []
newtype RepoInfo = RepoInfo (Map FilePath FileInfo)
deriving (Show)
finaliseFileInfo :: FileInfo -> FileInfo
finaliseFileInfo = execState $ do
fiReferences %= reverse
fiAnchors %= reverse
instance NFData Position
instance NFData Reference
instance NFData AnchorType
instance NFData Anchor
instance NFData FileInfo
instance Buildable Reference where
build Reference{..} =
nameF ("reference " +| paren (build loc) |+ " " +| rPos |+ "") $
blockListF
[ "text: " <> show rName
, "link: " <> build rLink
, "anchor: " <> build (rAnchor ?: style Faint "-")
]
where
loc = locationType rLink
instance Buildable AnchorType where
build = style Faint . \case
HeaderAnchor l -> color Green ("header " <> toRoman l)
HandAnchor -> color Yellow "hand made"
BiblioAnchor -> color Cyan "biblio"
instance Buildable Anchor where
build (Anchor t a p) = a |+ " (" +| t |+ ") " +| p |+ ""
instance Buildable FileInfo where
build FileInfo{..} =
blockListF
[ nameF "references" $ blockListF _fiReferences
, nameF "anchors" $ blockListF _fiAnchors
]
instance Buildable RepoInfo where
build (RepoInfo m) =
blockListF' "⮚" buildFileReport (M.toList m)
where
buildFileReport (name, info) = mconcat
[ color Cyan $ fromString name <> ":\n"
, build info
, "\n"
]
pattern PathSep :: Char
pattern PathSep <- (isPathSeparator -> True)
data LocationType
= LocalLoc
| RelativeLoc
| AbsoluteLoc
| ExternalLoc
| OtherLoc
deriving (Show)
instance Buildable LocationType where
build = \case
LocalLoc -> color Green "local"
RelativeLoc -> color Yellow "relative"
AbsoluteLoc -> color Blue "absolute"
ExternalLoc -> color Red "external"
OtherLoc -> ""
isExternal :: LocationType -> Bool
isExternal = \case
ExternalLoc -> True
_ -> False
isLocal :: LocationType -> Bool
isLocal = \case
LocalLoc -> True
RelativeLoc -> True
AbsoluteLoc -> True
ExternalLoc -> False
OtherLoc -> False
locationType :: Text -> LocationType
locationType location = case toString location of
[] -> LocalLoc
PathSep : _ -> AbsoluteLoc
'.' : PathSep : _ -> RelativeLoc
'.' : '.' : PathSep : _ -> RelativeLoc
_ | hasUrlProtocol -> ExternalLoc
| hasProtocol -> OtherLoc
| otherwise -> RelativeLoc
where
hasUrlProtocol = "://" `T.isInfixOf` T.take 10 location
hasProtocol = ":" `T.isInfixOf` T.take 10 location
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
headerToAnchor :: Text -> Text
headerToAnchor 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 == '-')
where
joinSyms sym = T.intercalate sym . filter (not . null) . T.splitOn sym
tmp = "\0"
stripAnchorDupNo :: Text -> Maybe Text
stripAnchorDupNo t = do
let strippedNo = T.dropWhileEnd C.isNumber t
guard (length strippedNo < length t)
T.stripSuffix "-" strippedNo
canonizeLocalRef :: Text -> Text
canonizeLocalRef ref =
case T.stripPrefix localPrefix ref of
Nothing -> ref
Just r -> canonizeLocalRef r
where
localPrefix = toText ['.', pathSeparator]
data VerifyProgress = VerifyProgress
{ vrLocal :: !(Progress Int)
, vrExternal :: !(Progress Int)
} deriving (Show)
initVerifyProgress :: [Reference] -> VerifyProgress
initVerifyProgress references =
VerifyProgress
{ vrLocal = initProgress (length localRefs)
, vrExternal = initProgress (length extRefs)
}
where
(extRefs, localRefs) =
L.partition isExternal $
map (locationType . rLink) references
showAnalyseProgress :: VerifyMode -> VerifyProgress -> Text
showAnalyseProgress mode VerifyProgress{..} = mconcat . mconcat $
[ [ "Verifying " ]
, [ showProgress "local" 10 White vrLocal <> " "
| shouldCheckLocal mode ]
, [ showProgress "external" 15 Yellow vrExternal
| shouldCheckExternal mode ]
]
reprintAnalyseProgress :: Rewrite -> VerifyMode -> VerifyProgress -> IO ()
reprintAnalyseProgress rw mode p = putTextRewrite rw (showAnalyseProgress mode p)