diff options
| -rw-r--r-- | anissue.cabal | 4 | ||||
| -rw-r--r-- | app/Issue.hs | 77 | ||||
| -rw-r--r-- | app/Main.hs | 94 | ||||
| -rw-r--r-- | app/TreeGrepper/FileType.hs | 76 | ||||
| -rw-r--r-- | app/TreeGrepper/Match.hs | 28 | ||||
| -rw-r--r-- | app/TreeGrepper/Result.hs | 15 |
6 files changed, 229 insertions, 65 deletions
diff --git a/anissue.cabal b/anissue.cabal index a5b4e3a..e15a069 100644 --- a/anissue.cabal +++ b/anissue.cabal @@ -66,7 +66,10 @@ executable anissue -- Modules included in this executable, other than Main. other-modules: + Issue + TreeGrepper.FileType TreeGrepper.Match + TreeGrepper.Result -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -77,6 +80,7 @@ executable anissue bytestring, filepath, optparse-applicative, + text, typed-process -- Directories containing source files. diff --git a/app/Issue.hs b/app/Issue.hs new file mode 100644 index 0000000..02de257 --- /dev/null +++ b/app/Issue.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Issue (Issue (..), fromMatch) where + +import Data.List (find) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import TreeGrepper.FileType qualified as G +import TreeGrepper.Match (Match (..)) +import TreeGrepper.Match qualified as G +import TreeGrepper.Result (Result (..)) +import TreeGrepper.Result qualified as G + +data Issue = Issue + { title :: Text, + description :: Text, + start :: G.Position, + end :: G.Position + } + +fromMatch :: G.Result -> G.Match -> Maybe Issue +fromMatch result match = + if T.isPrefixOf marker (T.unlines (take 1 lns)) + then + Just + Issue + { title = stripMarker (T.strip (T.unlines title)), + description = T.strip (T.unlines description), + start = match.start, + end = match.end + } + else Nothing + where + text = stripComments result.file_type match.text + lns = T.lines text + title = takeWhile (not . isEmpty) lns + description = drop (length title + 1) lns + isEmpty = T.null . T.strip + +marker :: Text +marker = "TODO" + +stripMarker :: Text -> Text +stripMarker text = maybe text T.stripStart (T.stripPrefix marker text) + +stripComments :: G.FileType -> Text -> Text +stripComments fileType text = + maybe + (stripLineComments (G.info fileType).lineStart text) + ( \(blockInfo, blockStart) -> + stripBlockComment blockStart blockInfo.blockEnd text + ) + $ do + blockInfo <- (G.info fileType).block + (,) blockInfo <$> find (`T.isPrefixOf` text) blockInfo.blockStart + +stripLineComments :: Text -> Text -> Text +stripLineComments lineStart text = + onLines + ( \line -> + fromMaybe line . fmap T.stripStart $ + T.stripPrefix lineStart line + ) + text + where + onLines f = T.unlines . map f . T.lines + +stripBlockComment :: Text -> Text -> Text -> Text +stripBlockComment blockStart blockEnd text = + T.strip + . (fromMaybe text . T.stripSuffix blockEnd) + . (fromMaybe text . T.stripPrefix blockStart) + $ text diff --git a/app/Main.hs b/app/Main.hs index 50ac0fd..ed059e5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -50,22 +50,21 @@ module Main where import Control.Exception (Exception, catch, throw) import Data.Aeson qualified as A -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy qualified as LB import Data.ByteString.Lazy.Char8 qualified as LB8 -import Data.List as L +import Data.Maybe (catMaybes) import Data.Maybe qualified as Maybe -import Data.Ord as O import Data.String qualified as String -import GHC.Generics (Generic) +import Data.Text.IO qualified as T +import Issue (Issue (..)) +import Issue qualified as I import Options.Applicative ((<**>)) import Options.Applicative qualified as O import System.Exit (ExitCode (ExitFailure), exitWith) import System.FilePath as F import System.IO (hPutStrLn, stderr) import System.Process.Typed qualified as P -import TreeGrepper.Match (Match (..), Position (..)) -import TreeGrepper.Match qualified as TM +import TreeGrepper.Match qualified as G +import TreeGrepper.Result qualified as G data Options = Options { optCommand :: Command @@ -108,25 +107,24 @@ main = do (\filename -> catch (fmap Just (getIssues filename)) (forgetGetIssuesExceptions)) files ) - ( \(InvalidTreeGrepperResult error) -> + ( \(InvalidTreeGrepperResult e) -> do - hPutStrLn stderr error + hPutStrLn stderr e exitWith (ExitFailure 1) ) - let issuesWithMarker = issues - issuesWithTags = issuesWithMarker - issuesFilteredByTags = issuesWithTags case options of List -> mapM_ listMatches $ concat issues Show -> mapM_ showMatches $ concat issues -showMatches :: TreeGrepperResult -> IO () -showMatches treeGrepperResult = - mapM_ (putStrLn . (.text)) $ treeGrepperResult.matches +showMatches :: Issue -> IO () +showMatches issue = do + T.putStrLn issue.title + T.putStrLn "" + T.putStrLn issue.description -listMatches :: TreeGrepperResult -> IO () -listMatches treeGrepperResult = - mapM_ (putStrLn . unlines . take 1 . lines . (.text)) $ treeGrepperResult.matches +listMatches :: Issue -> IO () +listMatches issue = + T.putStrLn issue.title data UnknownFileExtension = UnknownFileExtension { extension :: String @@ -142,22 +140,10 @@ data InvalidTreeGrepperResult = InvalidTreeGrepperResult instance Exception InvalidTreeGrepperResult -forgetGetIssuesExceptions :: UnknownFileExtension -> IO (Maybe _) -forgetGetIssuesExceptions _ = - pure Nothing +forgetGetIssuesExceptions :: UnknownFileExtension -> IO (Maybe a) +forgetGetIssuesExceptions _ = pure Nothing -data Issue = Issue {} - -data TreeGrepperResult = TreeGrepperResult - { file :: String, - file_type :: String, - matches :: [Match] - } - deriving (Show, Generic) - -instance A.FromJSON TreeGrepperResult - -getIssues :: String -> IO [TreeGrepperResult] +getIssues :: String -> IO [Issue] getIssues filename = let extension = F.takeExtension filename treeGrepperLanguage = @@ -180,27 +166,29 @@ getIssues filename = _ -> throw (UnknownFileExtension extension) decode raw = case A.eitherDecode raw of - Left error -> - throw (InvalidTreeGrepperResult error) - Right treeGrepperResult -> - treeGrepperResult - in fmap (map fixTreeGrepper) $ - fmap (decode . snd) $ - P.readProcessStdout - ( String.fromString - ( "tree-grepper --query '" - ++ treeGrepperLanguage - ++ "' '" - ++ treeGrepperQuery - ++ "' --format json '" - ++ filename - ++ "'" - ) - ) - -fixTreeGrepper :: TreeGrepperResult -> TreeGrepperResult + Left e -> throw (InvalidTreeGrepperResult e) + Right treeGrepperResult -> treeGrepperResult + in catMaybes + . map (uncurry I.fromMatch) + . concatMap (\result -> map ((,) result) result.matches) + . map fixTreeGrepper + . decode + . snd + <$> P.readProcessStdout + ( String.fromString + ( "tree-grepper --query '" + ++ treeGrepperLanguage + ++ "' '" + ++ treeGrepperQuery + ++ "' --format json '" + ++ filename + ++ "'" + ) + ) + +fixTreeGrepper :: G.Result -> G.Result fixTreeGrepper treeGrepperResult = - treeGrepperResult {matches = TM.merge treeGrepperResult.matches} + treeGrepperResult {G.matches = G.merge treeGrepperResult.matches} getFiles :: IO [String] getFiles = diff --git a/app/TreeGrepper/FileType.hs b/app/TreeGrepper/FileType.hs new file mode 100644 index 0000000..843eaf1 --- /dev/null +++ b/app/TreeGrepper/FileType.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module TreeGrepper.FileType + ( FileType (..), + all, + Info (..), + BlockInfo (..), + info, + ) +where + +import Data.Aeson (FromJSON (parseJSON)) +import Data.Text (Text) +import Prelude hiding (all) + +data FileType + = Elm + | Haskell + | Nix + | Shell + deriving (Show) + +instance FromJSON FileType where + parseJSON v = + parseJSON v >>= \case + "elm" -> pure Elm + "haskell" -> pure Haskell + "nix" -> pure Nix + "sh" -> pure Shell + fileType -> fail ("parsing file_type failed, got " ++ fileType) + +all :: [FileType] +all = + [ Elm, + Haskell, + Nix, + Shell + ] + +data Info = Info + { exts :: [String], + lineStart :: Text, + block :: Maybe BlockInfo + } + +data BlockInfo = BlockInfo + { blockStart :: [Text], + blockEnd :: Text + } + +info :: FileType -> Info +info Elm = + Info + { exts = [".elm"], + lineStart = "--", + block = Just BlockInfo {blockStart = ["{-|", "{-"], blockEnd = "-}"} + } +info Haskell = + Info + { exts = [".hs"], + lineStart = "--", + block = Just BlockInfo {blockStart = ["{-"], blockEnd = "-}"} + } +info Nix = + Info + { exts = [".nix"], + lineStart = "#", + block = Just BlockInfo {blockStart = ["/*"], blockEnd = "*/"} + } +info Shell = + Info + { exts = [".sh"], + lineStart = "#", + block = Nothing + } diff --git a/app/TreeGrepper/Match.hs b/app/TreeGrepper/Match.hs index f882a3c..7b8cde8 100644 --- a/app/TreeGrepper/Match.hs +++ b/app/TreeGrepper/Match.hs @@ -10,13 +10,17 @@ where import Data.Aeson (FromJSON) import Data.Function (on) import Data.List (sortBy) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as N import Data.Ord (comparing) +import Data.Text (Text) +import Data.Text qualified as T import GHC.Generics (Generic) data Match = Match { kind :: String, name :: String, - text :: String, + text :: Text, start :: Position, end :: Position } @@ -39,11 +43,11 @@ instance FromJSON Position merge :: [Match] -> [Match] merge matches = map mergeGroup - . groupBy (\a b -> a.end.row + 1 == b.start.row) + . chainsBy (\a b -> a.end.row + 1 == b.start.row) $ sortBy (comparing (.start)) matches -mergeGroup :: [Match] -> Match -mergeGroup (m : ms) = +mergeGroup :: NonEmpty Match -> Match +mergeGroup (m :| ms) = m { text = text, start = start, @@ -51,16 +55,16 @@ mergeGroup (m : ms) = } where mss = m : ms - text = unlines $ map (.text) mss + text = T.unlines $ map (.text) mss start = minimum $ map (.start) mss end = maximum $ map (.end) mss {- A version of `Data.List.groupBy` that uses the last added group-member for comparison with new candidates for the group. `Data.List.groupBy` uses the initial member for all subsequent comparisons. -} -groupBy :: (a -> a -> Bool) -> [a] -> [[a]] -groupBy p xs = reverse . map reverse $ go [] p xs +chainsBy :: (a -> a -> Bool) -> [a] -> [NonEmpty a] +chainsBy p = reverse . map N.reverse . go [] where - go rs _ [] = rs - go [] p (x : xs) = go [[x]] p xs - go (ass@((a : as) : rs)) p (x : xs) - | p a x = go ((x : a : as) : rs) p xs - | otherwise = go ([x] : ass) p xs + go rs [] = rs + go [] (x : xs) = go [N.singleton x] xs + go (ass@((a :| as) : rs)) (x : xs) + | p a x = go ((x :| a : as) : rs) xs + | otherwise = go (N.singleton x : ass) xs diff --git a/app/TreeGrepper/Result.hs b/app/TreeGrepper/Result.hs new file mode 100644 index 0000000..856871a --- /dev/null +++ b/app/TreeGrepper/Result.hs @@ -0,0 +1,15 @@ +module TreeGrepper.Result (Result (..)) where + +import Data.Aeson (FromJSON) +import GHC.Generics (Generic) +import TreeGrepper.FileType (FileType) +import TreeGrepper.Match (Match) + +data Result = Result + { file :: String, + file_type :: FileType, + matches :: [Match] + } + deriving (Show, Generic) + +instance FromJSON Result |