From 4adb99e683b81df9d572c05db06e6fb688fb007a Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Wed, 4 Oct 2023 10:01:50 +0200
Subject: bring issue extraction on-par with shell script
---
anissue.cabal | 4 ++
app/Issue.hs | 77 +++++++++++++++++++++++++++++++++++++
app/Main.hs | 94 ++++++++++++++++++++-------------------------
app/TreeGrepper/FileType.hs | 76 ++++++++++++++++++++++++++++++++++++
app/TreeGrepper/Match.hs | 28 ++++++++------
app/TreeGrepper/Result.hs | 15 ++++++++
6 files changed, 229 insertions(+), 65 deletions(-)
create mode 100644 app/Issue.hs
create mode 100644 app/TreeGrepper/FileType.hs
create mode 100644 app/TreeGrepper/Result.hs
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
--
cgit v1.2.3