diff options
Diffstat (limited to 'linters/lint-notes')
| -rw-r--r-- | linters/lint-notes/Main.hs | 62 | ||||
| -rw-r--r-- | linters/lint-notes/Makefile | 17 | ||||
| -rw-r--r-- | linters/lint-notes/Notes.hs | 186 | ||||
| -rw-r--r-- | linters/lint-notes/check.sh | 30 | ||||
| -rw-r--r-- | linters/lint-notes/ghc.mk | 18 | ||||
| -rw-r--r-- | linters/lint-notes/lint-notes.cabal | 21 | ||||
| -rw-r--r-- | linters/lint-notes/test | 25 |
7 files changed, 359 insertions, 0 deletions
diff --git a/linters/lint-notes/Main.hs b/linters/lint-notes/Main.hs new file mode 100644 index 0000000000..02ee3f11d4 --- /dev/null +++ b/linters/lint-notes/Main.hs @@ -0,0 +1,62 @@ +import qualified Data.Set as S +import System.Process +import System.Environment + +import Notes + +usage :: IO a +usage = do + putStrLn $ unlines + [ "usage:" + , " lint-notes <mode>" + , " lint-notes <mode> @<response-file>" + , " lint-notes <mode> <file>" + , "" + , "valid modes:" + , " dump dump all Note definitions and references" + , " defs dump all Note definitions" + , " refs dump all Note references" + , " unreferenced dump all unreferenced Note definitions" + , " broken-refs dump all references to missing Notes" + ] + fail "invalid usage" + +main :: IO () +main = do + args <- getArgs + + let printNoteDefs = putStrLn . unlines . map showNoteDef + printNoteRefs = putStrLn . unlines . map showNoteRef + printNoteRefsSugg (bad, sugg) = do + putStrLn . showNoteRef $ bad + putStrLn $ " >" ++ showNoteDef sugg + + + parseMode :: String -> Maybe (NoteDb -> IO ()) + parseMode "dump" = Just $ putStrLn . showNoteDb + parseMode "unreferenced" = Just $ printNoteDefs . S.toList . unreferencedNotes + parseMode "defs" = Just $ printNoteDefs . allNoteDefs + parseMode "refs" = Just $ printNoteRefs . allNoteRefs + parseMode "broken-refs" = Just $ printNoteRefs . map fst . brokenNoteRefs + parseMode "broken-refs-suggest" = Just $ mapM_ printNoteRefsSugg . brokenNoteRefs + parseMode _ = Nothing + + (mode, files) <- case args of + [mode, "@-"] -> do + files <- lines <$> getContents + return (parseMode mode, files) + [mode, '@':respFile] -> do + files <- lines <$> readFile respFile + return (parseMode mode, files) + [mode] -> do + let excludeList = + [ "testsuite/tests/linters/notes.stdout" + , "linters/lint-notes/test" ] + files <- lines <$> readProcess "git" ["ls-tree", "--name-only", "-r", "HEAD"] "" + return (parseMode mode, filter (`notElem` excludeList) files) + _ -> usage + + case mode of + Just run -> filesNotes files >>= run + Nothing -> return () + diff --git a/linters/lint-notes/Makefile b/linters/lint-notes/Makefile new file mode 100644 index 0000000000..71500f0147 --- /dev/null +++ b/linters/lint-notes/Makefile @@ -0,0 +1,17 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture +# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying +# +# ----------------------------------------------------------------------------- + +dir = linters/lint-notes +TOP = ../.. +include $(TOP)/mk/sub-makefile.mk + +FAST_MAKE_OPTS += stage=none diff --git a/linters/lint-notes/Notes.hs b/linters/lint-notes/Notes.hs new file mode 100644 index 0000000000..cf267d8d67 --- /dev/null +++ b/linters/lint-notes/Notes.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +module Notes where + +import Data.Either +import Data.Foldable +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import System.Directory (doesFileExist) +import Data.Array +import Data.List (sortBy) +import Data.Ord + +data SrcLoc = SrcLoc { fileName :: FilePath + , row :: !Int + , column :: !Int + } + deriving (Eq, Ord, Show) + +showSrcLoc :: SrcLoc -> String +showSrcLoc loc = + concat [fileName loc, ":", show (row loc), ":", show (column loc), ":"] + +newtype NoteName = NoteName T.Text + deriving (Eq, Ord, Show) + +showNoteName :: NoteName -> String +showNoteName (NoteName x) = "Note [" <> T.unpack x <> "]" + +data NoteDef = NoteDef { noteDefSrcLoc :: !SrcLoc + , noteDefName :: !NoteName + } + deriving (Eq, Ord, Show) + +showNoteDef :: NoteDef -> String +showNoteDef (NoteDef{noteDefSrcLoc=loc, noteDefName=name}) = + "def " <> showSrcLoc loc <> " " <> showNoteName name + +data NoteRef = NoteRef { noteRefSrcLoc :: !SrcLoc + , noteRefName :: !NoteName + } + deriving (Eq, Ord, Show) + +showNoteRef :: NoteRef -> String +showNoteRef (NoteRef{noteRefSrcLoc=loc, noteRefName=name}) = + "ref " <> showSrcLoc loc <> " " <> showNoteName name + +findNotes :: FilePath -> T.Text -> [Either NoteRef NoteDef] +findNotes fname t = + go 1 (T.lines t) + where + go :: Int -> [T.Text] -> [Either NoteRef NoteDef] + -- Note definitions: + -- We look for a "Note [" token with a "~~~" rule beneath it. + go !lineNo (l0 : l1 : ls) + | hasRule = Right (NoteDef srcLoc name) : go (lineNo+2) ls + where + (prefix, rest) = T.breakOn "Note [" l0 + startCol = T.length prefix + hasRule = T.take 3 (T.drop startCol l1) == "~~~" + srcLoc = SrcLoc fname lineNo startCol + name = NoteName $ T.takeWhile (/= ']') $ T.drop 6 rest + + -- Note references: + -- We look for a "Note [...]", strip away any beginning-of-line + -- comment symbols, and merge whitespace. + go lineNo (l0 : ls) = + [ Left (NoteRef srcLoc (NoteName name)) + | (prefix, rest) <- T.breakOnAll "Note [" l0 + , let startCol = T.length prefix + srcLoc = SrcLoc fname lineNo startCol + (name, suffix) = T.breakOn "]" (T.drop 6 rest<>" "<>T.concat (map stripBeginningOfLineComment $ take 1 ls)) + , "]" `T.isPrefixOf` suffix + ] ++ go (lineNo+1) ls + + go _lineNo [] = [] + +stripBeginningOfLineComment :: T.Text -> T.Text +stripBeginningOfLineComment = T.pack . go . T.unpack + where + -- This implements the following regular expression substitution: + -- + -- s/$ *[(\-\- )\#( \* )] */ / + + go :: String -> String + go ('#':rest) = finish rest + go ('-':'-':rest) = finish rest + go (' ':'*':rest) = finish rest + go ('/':'/':rest) = finish rest + go (' ':rest) = go rest + go xs = finish xs + + finish :: String -> String + finish = dropWhile (==' ') + +data NoteDb = NoteDb { noteRefs :: M.Map FilePath (S.Set NoteRef) + , noteDefs :: M.Map NoteName (S.Set NoteDef) + } + +instance Monoid NoteDb where + mempty = NoteDb M.empty M.empty + +instance Semigroup NoteDb where + NoteDb a b <> NoteDb c d = + NoteDb (M.unionWith (<>) a c) (M.unionWith (<>) b d) + +allNoteDefs :: NoteDb -> [NoteDef] +allNoteDefs db = + [ def + | defs <- M.elems (noteDefs db) + , def <- S.toList defs + ] + +allNoteRefs :: NoteDb -> [NoteRef] +allNoteRefs db = + [ ref + | (_fname, refs) <- M.toList (noteRefs db) + , ref <- S.toList refs + ] + +showNoteDb :: NoteDb -> String +showNoteDb db = unlines $ + map showNoteRef (allNoteRefs db) + ++ + map showNoteDef (allNoteDefs db) + +filesNotes :: [FilePath] + -> IO NoteDb +filesNotes = fmap mconcat . mapM fileNotes + +fileNotes :: FilePath -> IO NoteDb +fileNotes fname = do + is_file <- doesFileExist fname + if is_file + then do + bs <- BS.readFile fname + return $ case T.decodeUtf8' bs of + Left _ -> mempty + Right t -> + let (refs, defs) = partitionEithers (findNotes fname t) + in NoteDb + { noteRefs = M.singleton fname (S.fromList refs) + , noteDefs = M.fromList + [ (noteDefName def, S.singleton def) + | def <- defs + ] + } + else return mempty + +brokenNoteRefs :: NoteDb -> [(NoteRef, NoteDef)] +brokenNoteRefs db = + [ (ref, best_match) + | (_fname, refs) <- M.toList (noteRefs db) + , ref <- S.toList refs + , Nothing <- pure $ M.lookup (noteRefName ref) (noteDefs db) + , let best_match = bestLev (show (noteRefName ref)) (concatMap S.toList (M.elems (noteDefs db))) + ] + +bestLev :: String -> [NoteDef] -> NoteDef +bestLev x ds = head $ sortBy (comparing (\d -> lev x (show (noteDefName d)))) ds + + +lev:: (Eq a) => [a] -> [a] -> Int +lev xs ys = levMemo ! (n, m) + where levMemo = array ((0,0),(n,m)) [((i,j),lev' i j) | i <- [0..n], j <- [0..m]] + n = length xs + m = length ys + xa = listArray (1, n) xs + ya = listArray (1, m) ys + lev' 0 v = v + lev' u 0 = u + lev' u v + | xa ! u == ya ! v = levMemo ! (u-1, v-1) + | otherwise = 1 + minimum [levMemo ! (u, v-1), + levMemo ! (u-1, v), + levMemo ! (u-1, v-1)] + +unreferencedNotes :: NoteDb -> S.Set NoteDef +unreferencedNotes db = + fold $ noteDefs db `M.withoutKeys` referencedNotes + where + referencedNotes = S.fromList $ map noteRefName (allNoteRefs db) diff --git a/linters/lint-notes/check.sh b/linters/lint-notes/check.sh new file mode 100644 index 0000000000..cd87900f9b --- /dev/null +++ b/linters/lint-notes/check.sh @@ -0,0 +1,30 @@ +#!/bin/sh + +set -e + +CABAL_INSTALL="${CABAL_INSTALL:-cabal}" +GHC="${GHC:-ghc}" + +cd "$(dirname $0)" +"$CABAL_INSTALL" build -w "$GHC" +bin="$("$CABAL_INSTALL" list-bin -w "$GHC" lint-notes)" +cd "$(git rev-parse --show-toplevel)" +"$bin" broken-refs \ + | grep -v "linters/lint-notes/expected-broken-note-refs:" \ + | sed 's/:[0-9]\+:[0-9]\+:/:/' \ + > broken-note-refs + +if diff -q linters/lint-notes/expected-broken-note-refs broken-note-refs; then + printf "No unexpected broken note references" +else + printf "Found unexpected broken note references:\n\n" + diff -u linters/lint-notes/expected-broken-note-refs broken-note-refs || true + if [[ "$1" == "-a" ]]; then + cp broken-note-refs linters/lint-notes/expected-broken-note-refs + printf "\n" + printf "Accepted new broken note references." + else + exit 1 + fi +fi + diff --git a/linters/lint-notes/ghc.mk b/linters/lint-notes/ghc.mk new file mode 100644 index 0000000000..bd4e97a85f --- /dev/null +++ b/linters/lint-notes/ghc.mk @@ -0,0 +1,18 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture +# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying +# +# ----------------------------------------------------------------------------- + +linters/lint-notes_USES_CABAL = YES +linters/lint-notes_PACKAGE = lint-notes +linters/lint-notes_dist-install_PROGNAME = lint-notes +linters/lint-notes_dist-install_INSTALL = NO +linters/lint-notes_dist-install_INSTALL_INPLACE = YES +$(eval $(call build-prog,linters/lint-notes,dist-install,1)) diff --git a/linters/lint-notes/lint-notes.cabal b/linters/lint-notes/lint-notes.cabal new file mode 100644 index 0000000000..9896e74766 --- /dev/null +++ b/linters/lint-notes/lint-notes.cabal @@ -0,0 +1,21 @@ +cabal-version: 2.4 +name: lint-notes +version: 0.1.0.0 +synopsis: A tool for querying and checking GHC Notes +bug-reports: https://gitlab.haskell.org/ghc/ghc +license: BSD-3-Clause +author: Ben Gamari +maintainer: ben@smart-cactus.org +copyright: (c) 2022 Ben Gamari + +executable lint-notes + main-is: Main.hs + other-modules: Notes + build-depends: base >= 4 && < 5 , + bytestring, + containers, + directory, + text, + process, + array + default-language: Haskell2010 diff --git a/linters/lint-notes/test b/linters/lint-notes/test new file mode 100644 index 0000000000..3eb1e0466e --- /dev/null +++ b/linters/lint-notes/test @@ -0,0 +1,25 @@ +Note [Turtles] +~~~~~~~~~~~~~~~ +This is note 1. See Note [Wombats are toes]. + +/* Note [Wombats are toes] + ~~~~~~~~~~~~~~~~~~~~~~~ + This is another Note. + */ + +See Note [This is a +Note reference broken across lines]. + + // This is another Note [Broken + // across a line in a C++ comment]. + + /* + * This is another Note [Broken + * across a line in a C comment]. + */ + + -- This is another Note [Broken + -- across a line in a Haskell comment]. + + # This is another Note [Broken + # across a line in a Python comment]. |