bring issue extraction on-par with shell script

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