toodles 0.1.4 → 1.0.0
raw patch · 15 files changed
+1073/−709 lines, 15 filesdep +hspecdep +hspec-expectationsdep +toodles
Dependencies added: hspec, hspec-expectations, toodles
Files
- README.md +2/−15
- app/Config.hs +0/−52
- app/Main.hs +2/−2
- app/Parse.hs +0/−220
- app/Server.hs +0/−292
- app/ToodlesApi.hs +0/−28
- app/Types.hs +0/−97
- src/Config.hs +52/−0
- src/Parse.hs +368/−0
- src/Server.hs +321/−0
- src/ToodlesApi.hs +28/−0
- src/Types.hs +111/−0
- test/Spec.hs +118/−0
- toodles.cabal +70/−2
- web/html/index.html +1/−1
README.md view
@@ -59,10 +59,12 @@ - C/C++ - C#+- CSS/SASS - Elixir - Erlang - Go - Haskell+- HTML - Java - Javascript - Kotlin@@ -129,21 +131,6 @@ # directory you are currently in: $ docker run -it -v $(pwd):/repo -p 9001:9001 toodles -```--### Current Limitations--Due to the parser's current simplicity, Toodles won't see TODO's in multiline-initiated comment. For instance in javascript--```javascript-// TODO(#bug) this would be parsed--/*-- TODO(#bug) this will _not_ be picked up by toodles--*/ ``` ### Background
− app/Config.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Config- ( toodlesArgs- , ToodlesArgs(..)- , SearchFilter(..)- , AssigneeFilterRegex(..)- )- where--import Paths_toodles-import Types--import Data.Text (Text)-import Data.Version (showVersion)-import System.Console.CmdArgs--toodlesArgs :: IO ToodlesArgs-toodlesArgs = cmdArgs argParser--data ToodlesArgs = ToodlesArgs- { directory :: FilePath- , assignee_search :: Maybe SearchFilter- , limit_results :: Int- , port :: Maybe Int- , no_server :: Bool- , userFlag :: [UserFlag]- } deriving (Show, Data, Typeable, Eq)--newtype SearchFilter =- AssigneeFilter AssigneeFilterRegex- deriving (Show, Data, Eq)--newtype AssigneeFilterRegex = AssigneeFilterRegex Text- deriving (Show, Data, Eq)--argParser :: ToodlesArgs-argParser = ToodlesArgs- { directory = def &= typFile &= help "Root directory of your project"- , assignee_search = def &= help "Filter todo's by assignee"- , limit_results = def &= help "Limit number of search results"- , port = def &= help "Run server on port"- , no_server = def &= help "Output matching todos to the command line and exit"- , userFlag = def &= help "Additional flagword (e.g.: MAYBE)"- } &= summary ("toodles " ++ showVersion version)- &= program "toodles"- &= verbosity- &= help "Manage TODO's directly from your codebase"
app/Main.hs view
@@ -27,7 +27,7 @@ run webPort $ app $ ToodlesState ref dataDir prettyFormat :: TodoEntry -> String-prettyFormat (TodoEntryHead _ l a p n entryPriority f _ _ _) =+prettyFormat (TodoEntryHead _ l a p n entryPriority f _ _ _ _ _ _) = printf "Assignee: %s\n%s%s:%d\n%s - %s" (fromMaybe "None" a)@@ -36,4 +36,4 @@ n (show f) (unlines $ map T.unpack l)-prettyFormat (TodoBodyLine _) = error "Invalid type for prettyFormat"+prettyFormat a = error "Invalid type for prettyFormat: " ++ show a
− app/Parse.hs
@@ -1,220 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Parse where--import Types--import Data.List (find)-import Data.Maybe (fromJust, fromMaybe, isNothing)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Void (Void)-import Text.Megaparsec-import Text.Megaparsec.Char-import qualified Text.Megaparsec.Char.Lexer as L-import Text.Read--type Parser = Parsec Void Text--symbol :: Text -> Parser Text-symbol = L.symbol space--parseComment :: Text -> Parser TodoEntry-parseComment extension = do- _ <- manyTill anyChar (symbol $ getCommentForFileType extension)- b <- many anyChar- return . TodoBodyLine $ T.pack b--getCommentForFileType :: Text -> Text-getCommentForFileType extension =- fromMaybe unkownMarker $ lookup adjustedExtension fileTypeToComment- where- adjustedExtension =- if T.isPrefixOf "." extension- then extension- else "." <> extension--integer :: Parser Integer-integer = lexeme $ L.signed space L.decimal-- where- lexeme :: Parser a -> Parser a- lexeme = L.lexeme space--parseAssignee :: Parser String-parseAssignee = many (noneOf [')', '|', '='])---- TODO(avi|p=3|#cleanup) - fix and type this better-parseDetails :: Text -> (Maybe Text, Maybe Text, [(Text, Text)], [Text])-parseDetails toParse =- let dataTokens = T.splitOn "|" toParse- assigneeTo =- find- (\t ->- not (T.null t) &&- not (T.isInfixOf "=" t) && not (T.isPrefixOf "#" t))- dataTokens- allDetails =- map (\[a, b] -> (a, b)) $ filter (\t -> length t == 2) $- map (T.splitOn "=") dataTokens- priorityVal = snd <$> find (\t -> T.strip (fst t) == "p") allDetails- filteredDetails = filter (\t -> T.strip (fst t) /= "p") allDetails- entryTags = filter (T.isPrefixOf "#") dataTokens- in (assigneeTo, priorityVal, filteredDetails, entryTags)---- | parse "hard-coded" flags, and user-defined flags if any-parseFlag :: [UserFlag] -> Parser Flag-parseFlag us = foldr (\a b -> b <|> foo a) (try parseFlagHardcoded) us- where- foo :: UserFlag -> Parser Flag- foo (UserFlag x) = try (symbol x *> pure (UF $ UserFlag x))---- | parse flags TODO, FIXME, XXX-parseFlagHardcoded :: Parser Flag-parseFlagHardcoded =- try (symbol "TODO" *> pure TODO )- <|> try (symbol "FIXME" *> pure FIXME)- <|> (symbol "XXX" *> pure XXX )---fileTypeToComment :: [(Text, Text)]-fileTypeToComment =- [ (".c", "//")- , (".cc", "//")- , (".clj", ";;")- , (".cpp", "//")- , (".cxx", "//")- , (".c++", "//")- , (".cs", "//")- , (".ex", "#")- , (".erl", "%")- , (".go", "//")- , (".h", "//")- , (".hh", "//")- , (".hpp", "//")- , (".hs", "--")- , (".hxx", "//")- , (".h++", "//")- , (".java", "//")- , (".js", "//")- , (".jsx", "//")- , (".kt", "//")- , (".kts", "//")- , (".lua", "--")- , (".m", "//")- , (".php", "//")- , (".proto", "//")- , (".py", "#")- , (".rb", "#")- , (".rs", "//")- , (".scala", "//")- , (".sh", "#")- , (".swift", "///")- , (".ts", "//")- , (".tsx", "//")- , (".txt", "")- , (".vue", "//")- , (".yaml", "#")- ]--runTodoParser :: [UserFlag] -> SourceFile -> [TodoEntry]-runTodoParser us (SourceFile path ls) =- let parsedTodoLines =- map- (\(lineNum, lineText) -> parseMaybe (parseTodo us path lineNum) lineText)- (zip [1 ..] ls)- groupedTodos = foldl foldTodoHelper ([], False) parsedTodoLines- in fst groupedTodos-- where- -- fold fn to concatenate todos that a multiple, single line comments- foldTodoHelper :: ([TodoEntry], Bool) -> Maybe TodoEntry -> ([TodoEntry], Bool)- foldTodoHelper (todoEntries, currentlyBuildingTodoLines) maybeTodo- -- We're not on a todo line, keep going- | isNothing maybeTodo = (todoEntries, False)- -- We see the start of a new todo- | isEntryHead $ fromJust maybeTodo = (todoEntries ++ [fromJust maybeTodo], True)- -- We a body line of a todo to concatenate to the current one- | isBodyLine (fromJust maybeTodo) && currentlyBuildingTodoLines =- (init todoEntries ++ [combineTodo (last todoEntries) (fromJust maybeTodo)], True)- | otherwise = (todoEntries, False)-- where- isEntryHead :: TodoEntry -> Bool- isEntryHead TodoEntryHead {} = True- isEntryHead _ = False-- isBodyLine :: TodoEntry -> Bool- isBodyLine (TodoBodyLine _) = True- isBodyLine _ = False-- combineTodo :: TodoEntry -> TodoEntry -> TodoEntry- combineTodo (TodoEntryHead i b a p n entryPriority f attrs entryTags entryLeadingText) (TodoBodyLine l) =- TodoEntryHead i (b ++ [l]) a p n entryPriority f attrs entryTags entryLeadingText- combineTodo _ _ = error "Can't combine todoEntry of these types"--getExtension :: FilePath -> Text-getExtension path = last $ T.splitOn "." (T.pack path)--stringToMaybe :: Text -> Maybe Text-stringToMaybe t =- if T.null t- then Nothing- else Just t--fst4 :: (a, b, c, d) -> a-fst4 (x, _, _, _) = x--snd4 :: (a, b, c, d) -> b-snd4 (_, x, _, _) = x--thd4 :: (a, b, c, d) -> c-thd4 (_, _, x, _) = x--fth4 :: (a, b, c, d) -> d-fth4 (_, _, _, x) = x--unkownMarker :: Text-unkownMarker = "UNKNOWN-DELIMETER-UNKNOWN-DELIMETER-UNKNOWN-DELIMETER"--parseTodo :: [UserFlag] -> FilePath -> LineNumber -> Parser TodoEntry-parseTodo us path lineNum = try (parseTodoEntryHead us)- <|> parseComment (getExtension path)- where- parseTodoEntryHead :: [UserFlag] -> Parser TodoEntry- parseTodoEntryHead uf = do- entryLeadingText <- manyTill anyChar (prefixParserForFileType $ getExtension path)- f <- parseFlag uf- entryDetails <- optional $ try (inParens $ many (noneOf [')', '(']))- let parsedDetails = parseDetails . T.pack <$> entryDetails- entryPriority = (readMaybe . T.unpack) =<< (snd4 =<< parsedDetails)- otherDetails = maybe [] thd4 parsedDetails- entryTags = maybe [] fth4 parsedDetails- _ <- optional $ symbol "-"- _ <- optional $ symbol ":"- b <- many anyChar- return $- TodoEntryHead- 0- [T.pack b]- (stringToMaybe . T.strip $ fromMaybe "" (fst4 =<< parsedDetails))- path- lineNum- entryPriority- f- otherDetails- entryTags- (T.pack entryLeadingText)-- where- inParens :: Parser a -> Parser a- inParens = between (symbol "(") (symbol ")")-- prefixParserForFileType :: Text -> Parser Text- prefixParserForFileType "org" = try (symbol "****")- <|> try (symbol "***")- <|> try (symbol "**")- <|> try (symbol "*")- <|> symbol "-"- prefixParserForFileType extension = symbol . getCommentForFileType $ extension
− app/Server.hs
@@ -1,292 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# LANGUAGE TypeOperators #-}--module Server where--import Config-import Parse-import ToodlesApi-import Types--import qualified Control.Exception as E-import Control.Monad-import Control.Monad.IO.Class-import Data.Aeson (FromJSON)-import Data.Aeson.Types-import Data.Either-import Data.IORef-import Data.List (find, nub)-import Data.Maybe-import Data.String.Utils-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Yaml as Y-import Servant-import System.Directory-import System.IO.HVFS-import qualified System.IO.Strict as SIO-import System.Path-import System.Path.NameManip-import Text.Blaze.Html5 (Html)-import qualified Text.Blaze.Html5 as BZ-import Text.Printf-import Text.Regex.Posix--data ToodlesConfig = ToodlesConfig- { ignore :: [FilePath]- , flags :: [UserFlag]- } deriving (Show)--instance FromJSON ToodlesConfig where- parseJSON (Object o) = do- parsedIgnore <- o .:? "ignore" .!= []- parsedFlags <- o .:? "flags" .!= []- return $ ToodlesConfig parsedIgnore parsedFlags- parseJSON invalid = typeMismatch "Invalid config" invalid--app :: ToodlesState -> Application-app s = serve toodlesAPI server-- where- server :: Server ToodlesAPI- server = liftIO . getFullSearchResults s- :<|> deleteTodos s- :<|> editTodos s- :<|> serveDirectoryFileServer (dataPath s)- :<|> showRawFile s- :<|> root s--root :: ToodlesState -> [Text] -> Handler Html-root (ToodlesState _ dPath) path =- if null path then- liftIO $ BZ.preEscapedToHtml <$> readFile (dPath ++ "/html/index.html")- else throwError $ err404 { errBody = "Not found" }--showRawFile :: ToodlesState -> Integer -> Handler Html-showRawFile (ToodlesState ref _) eId = do- (TodoListResult r _) <- liftIO $ readIORef ref- let entry = find (\t -> entryId t == eId) r- liftIO $- maybe- (return "Not found")- (\e -> addAnchors <$> readFile (sourceFile e))- entry-- where- addAnchors :: String -> Html- addAnchors s =- let codeLines = zip [1::Int ..] $ lines s- in BZ.preEscapedToHtml $- (unlines $- map- (\(i, l) -> printf "<pre><a name=\"line-%s\">%s</a></pre>" (show i) l)- codeLines)--editTodos :: ToodlesState -> EditTodoRequest -> Handler Text-editTodos (ToodlesState ref _) req = do- (TodoListResult r _) <- liftIO $ readIORef ref- let editedList = map- (\t ->- if willEditTodo req t- then editTodo req t- else t)- r- editedFilteredList = filter (willEditTodo req) editedList- _ <- mapM_ recordUpdates editedFilteredList- return "{}"- where- willEditTodo :: EditTodoRequest -> TodoEntry -> Bool- willEditTodo editRequest entry = entryId entry `elem` editIds editRequest-- editTodo :: EditTodoRequest -> TodoEntry -> TodoEntry- editTodo editRequest entry =- let newAssignee = if isJust (setAssignee editRequest) && (not . T.null . fromJust $ setAssignee editRequest)- then setAssignee editRequest- else assignee entry- newPriority = if isJust (setPriority editRequest) then setPriority editRequest else priority entry in-- entry {assignee = newAssignee,- tags = tags entry ++ addTags editRequest,- priority = newPriority,- customAttributes = nub $ customAttributes entry ++ addKeyVals editRequest}-- recordUpdates :: MonadIO m => TodoEntry -> m ()- recordUpdates t = void $ updateTodoLinesInFile renderTodo t--renderTodo :: TodoEntry -> [Text]-renderTodo t =- let comment =- fromJust $ lookup ("." <> getExtension (sourceFile t)) fileTypeToComment- detail =- renderFlag (flag t) <> " (" <>- (T.pack $- Data.String.Utils.join- "|"- (map T.unpack $ [fromMaybe "" $ assignee t] ++- listIfNotNull (fmap (T.pack . maybe "" ((\n -> "p=" ++ n) . show)) priority t) ++- tags t ++- map (\a -> fst a <> "=" <> snd a) (customAttributes t))) <>- ") "- fullNoComments = mapHead (\l -> detail <> "- " <> l) $ body t- commented = map (\l -> comment <> " " <> l) fullNoComments in- mapHead (\l -> leadingText t <> l) $- mapInit (\l -> foldl (<>) "" [" " | _ <- [1..(T.length $ leadingText t)]] <> l) commented-- where- mapHead :: (a -> a) -> [a] -> [a]- mapHead f (x:xs) = f x : xs- mapHead _ xs = xs-- mapInit :: (a -> a) -> [a] -> [a]- mapInit f (x:xs) = [x] ++ map f xs- mapInit _ x = x-- listIfNotNull :: Text -> [Text]- listIfNotNull "" = []- listIfNotNull s = [s]-- renderFlag :: Flag -> Text- renderFlag TODO = "TODO"- renderFlag FIXME = "FIXME"- renderFlag XXX = "XXX"- renderFlag (UF (UserFlag x)) = x---- | Given a function to emit new lines for a given todo, write that update in--- place of the current todo lines-updateTodoLinesInFile :: MonadIO m => (TodoEntry -> [Text]) -> TodoEntry -> m ()-updateTodoLinesInFile f todo = do- let startIndex = lineNumber todo - 1- newLines = map T.unpack $ f todo- fileLines <- liftIO $ lines <$> SIO.readFile (sourceFile todo)- let updatedLines =- slice 0 (fromIntegral $ startIndex - 1) fileLines ++ newLines ++- (slice- (fromIntegral startIndex + length (body todo))- (length fileLines - 1)- fileLines)- liftIO $ writeFile (sourceFile todo) $ unlines updatedLines-- where- slice :: Int -> Int -> [a] -> [a]- slice a b xs = take (b - a + 1) (drop a xs)--deleteTodos :: ToodlesState -> DeleteTodoRequest -> Handler Text-deleteTodos (ToodlesState ref _) req = do- refVal@(TodoListResult r _) <- liftIO $ readIORef ref- let toDelete = filter (\t -> entryId t `elem` ids req) r- liftIO $ doUntilNull removeAndAdjust toDelete- let remainingResults = filter (\t -> entryId t `notElem` map entryId toDelete) r- updatedResults <- return $ foldl (flip adjustLinesAfterDeletionOf) remainingResults toDelete- let remainingResultsRef = refVal { todos = updatedResults }- _ <- liftIO $ atomicModifyIORef' ref (const (remainingResultsRef, remainingResultsRef))- return "{}"-- where-- doUntilNull :: ([a] -> IO [a]) -> [a] -> IO ()- doUntilNull f xs = do- result <- f xs- if null result- then return ()- else doUntilNull f result-- -- If we delete an entry, we need to decrement the line-numbers for the- -- other entries that come later in the file- adjustLinesAfterDeletionOf :: TodoEntry -> [TodoEntry] -> [TodoEntry]- adjustLinesAfterDeletionOf deleted =- map (\remaining ->- if (sourceFile remaining == sourceFile deleted) && (lineNumber remaining > lineNumber deleted)- then remaining { lineNumber = lineNumber remaining - (fromIntegral . length $ body deleted)}- else remaining)-- removeAndAdjust :: MonadIO m => [TodoEntry] -> m [TodoEntry]- removeAndAdjust [] = return []- removeAndAdjust (x:xs) = do- removeTodoFromCode x- return $ adjustLinesAfterDeletionOf x xs-- where- removeTodoFromCode :: MonadIO m => TodoEntry -> m ()- removeTodoFromCode = updateTodoLinesInFile (const [])--setAbsolutePath :: ToodlesArgs -> IO ToodlesArgs-setAbsolutePath args = do- let pathOrDefault = if T.null . T.pack $ directory args- then "."- else directory args- absolute <- normalise_path <$> absolute_path pathOrDefault- return $ args {directory = absolute}--getFullSearchResults :: ToodlesState -> Bool -> IO TodoListResult-getFullSearchResults (ToodlesState ref _) recompute =- if recompute- then do- putStrLn "refreshing todo's"- userArgs <- toodlesArgs >>= setAbsolutePath- sResults <- runFullSearch userArgs- atomicModifyIORef' ref (const (sResults, sResults))- else putStrLn "cached read" >> readIORef ref--runFullSearch :: ToodlesArgs -> IO TodoListResult-runFullSearch userArgs = do- let projectRoot = directory userArgs- configExists <- doesFileExist $ projectRoot ++ "/.toodles.yaml"- config <- if configExists- then Y.decodeFileEither (projectRoot ++ "/.toodles.yaml")- else return . Right $ ToodlesConfig [] []- when (isLeft config)- $ putStrLn $ "[WARNING] Invalid .toodles.yaml: " ++ show config- let config' = fromRight (ToodlesConfig [] []) config- allFiles <- getAllFiles config' projectRoot- let parsedTodos = concatMap (runTodoParser $ userFlag userArgs ++ flags config') allFiles- filteredTodos = filter (filterSearch (assignee_search userArgs)) parsedTodos- resultList = limitSearch filteredTodos $ limit_results userArgs- indexedResults = map (\(i, r) -> r {entryId = i}) $ zip [1 ..] resultList- return $ TodoListResult indexedResults ""-- where- filterSearch :: Maybe SearchFilter -> TodoEntry -> Bool- filterSearch Nothing _ = True- filterSearch (Just (AssigneeFilter (AssigneeFilterRegex query))) entry = fromMaybe "" (assignee entry) == query-- limitSearch :: [TodoEntry] -> Int -> [TodoEntry]- limitSearch todoList 0 = todoList- limitSearch todoList n = take n todoList--getAllFiles :: ToodlesConfig -> FilePath -> IO [SourceFile]-getAllFiles (ToodlesConfig ignoredPaths _) basePath =- E.catch- (do putStrLn $ printf "Running toodles for path: %s" basePath- files <- recurseDir SystemFS basePath- let validFiles = filter isValidFile files- mapM- (\f ->- SourceFile f . (map T.pack . lines) <$>- E.catch- (SIO.readFile f)- (\(e :: E.IOException) -> print e >> return ""))- validFiles)- (\(e :: E.IOException) ->- putStrLn ("Error reading " ++ basePath ++ ": " ++ show e) >> return [])-- where-- isValidFile :: FilePath -> Bool- isValidFile path = fileHasValidExtension && not ignoreFile-- where-- fileHasValidExtension :: Bool- fileHasValidExtension = any (\ext -> ext `T.isSuffixOf` T.pack path) (map fst fileTypeToComment)-- ignoreFile :: Bool- ignoreFile =- let p = T.pack path- in T.isInfixOf "node_modules" p || T.isSuffixOf "pb.go" p ||- T.isSuffixOf "_pb2.py" p ||- any (\r -> path =~ r :: Bool) ignoredPaths
− app/ToodlesApi.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE DataKinds,- ScopedTypeVariables,- TypeOperators #-}--module ToodlesApi where--import Types--import Data.Proxy (Proxy)-import Data.Text (Text)-import Servant-import Servant.HTML.Blaze (HTML)-import Text.Blaze.Html5 (Html)--type ToodlesAPI = "todos" :> QueryFlag "recompute" :> Get '[JSON] TodoListResult-- :<|> "todos" :> "delete" :> ReqBody '[JSON] DeleteTodoRequest :> Post '[JSON] Text-- :<|> "todos" :> "edit" :> ReqBody '[JSON] EditTodoRequest :> Post '[JSON] Text-- :<|> "static" :> Raw-- :<|> "source_file" :> Capture "id" Integer :> Get '[HTML] Html-- :<|> CaptureAll "anything-else" Text :> Get '[HTML] Html--toodlesAPI :: Proxy ToodlesAPI-toodlesAPI = Proxy
− app/Types.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--module Types where--import Data.Aeson (FromJSON, ToJSON, Value (String), parseJSON,- toJSON)-import Data.Aeson.Types (typeMismatch)-import Data.Data-import Data.IORef (IORef)-import Data.String (IsString)-import Data.Text (Text)-import qualified Data.Text as T (unpack)-import GHC.Generics (Generic)--data SourceFile = SourceFile- { fullPath :: FilePath- , sourceLines :: [Text]- } deriving (Show)--type LineNumber = Integer--data ToodlesState = ToodlesState- { results :: IORef TodoListResult,- dataPath :: FilePath- }--data TodoEntry- = TodoEntryHead { entryId :: Integer- , body :: [Text]- , assignee :: Maybe Text- , sourceFile :: FilePath- , lineNumber :: LineNumber- , priority :: Maybe Integer- , flag :: Flag- , customAttributes :: [(Text, Text)]- , tags :: [Text]- , leadingText :: Text }- | TodoBodyLine Text- deriving (Show, Generic)-instance ToJSON TodoEntry--data TodoListResult = TodoListResult- { todos :: [TodoEntry]- , message :: Text- } deriving (Show, Generic)-instance ToJSON TodoListResult--newtype DeleteTodoRequest = DeleteTodoRequest- { ids :: [Integer]- } deriving (Show, Generic)-instance FromJSON DeleteTodoRequest--data EditTodoRequest = EditTodoRequest- { editIds :: [Integer]- , setAssignee :: Maybe Text- , addTags :: [Text]- , addKeyVals :: [(Text, Text)]- , setPriority :: Maybe Integer- } deriving (Show, Generic)-instance FromJSON EditTodoRequest--data Flag = TODO | FIXME | XXX | UF UserFlag- deriving (Generic)--newtype UserFlag = UserFlag Text- deriving (Show, Eq, IsString, Data, Generic)--instance Show Flag where- show TODO = "TODO"- show FIXME = "FIXME"- show XXX = "XXX"- show (UF (UserFlag x)) = T.unpack x--instance ToJSON Flag where- toJSON TODO = Data.Aeson.String "TODO"- toJSON FIXME = Data.Aeson.String "FIXME"- toJSON XXX = Data.Aeson.String "XXX"- toJSON (UF (UserFlag x)) = Data.Aeson.String x--instance FromJSON Flag where- parseJSON (Data.Aeson.String x) =- case x of- "TODO" -> pure TODO- "FIXME" -> pure FIXME- "XXX" -> pure XXX- _ -> pure $ UF $ UserFlag x- parseJSON invalid = typeMismatch "UserFlag" invalid--instance ToJSON UserFlag where- toJSON (UserFlag x) = Data.Aeson.String x--instance FromJSON UserFlag where- parseJSON (Data.Aeson.String x) = pure $ UserFlag x- parseJSON invalid = typeMismatch "UserFlag" invalid
+ src/Config.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Config+ ( toodlesArgs+ , ToodlesArgs(..)+ , SearchFilter(..)+ , AssigneeFilterRegex(..)+ )+ where++import Paths_toodles+import Types++import Data.Text (Text)+import Data.Version (showVersion)+import System.Console.CmdArgs++toodlesArgs :: IO ToodlesArgs+toodlesArgs = cmdArgs argParser++data ToodlesArgs = ToodlesArgs+ { directory :: FilePath+ , assignee_search :: Maybe SearchFilter+ , limit_results :: Int+ , port :: Maybe Int+ , no_server :: Bool+ , userFlag :: [UserFlag]+ } deriving (Show, Data, Typeable, Eq)++newtype SearchFilter =+ AssigneeFilter AssigneeFilterRegex+ deriving (Show, Data, Eq)++newtype AssigneeFilterRegex = AssigneeFilterRegex Text+ deriving (Show, Data, Eq)++argParser :: ToodlesArgs+argParser = ToodlesArgs+ { directory = def &= typFile &= help "Root directory of your project"+ , assignee_search = def &= help "Filter todo's by assignee"+ , limit_results = def &= help "Limit number of search results"+ , port = def &= help "Run server on port"+ , no_server = def &= help "Output matching todos to the command line and exit"+ , userFlag = def &= help "Additional flagword (e.g.: MAYBE)"+ } &= summary ("toodles " ++ showVersion version)+ &= program "toodles"+ &= verbosity+ &= help "Manage TODO's directly from your codebase"
+ src/Parse.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Parse where++import Types+++import Data.Functor+import Data.List (find)+import Data.Maybe (fromJust, fromMaybe, isJust,+ isNothing)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void (Void)+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import Text.Printf+import Text.Read++type Parser = Parsec Void Text++symbol :: Text -> Parser Text+symbol = L.symbol space++parseComment :: TodoParserState -> Text -> Parser TodoEntry+parseComment state fileExtension =+ if state == ParseStateMultiLineComment+ then do+ let closingParser = symbol $ getMultiClosingForFileType fileExtension+ lineWithClosing <- optional . try $ manyTill anyChar closingParser+ lineWithOutClosing <- optional $ many anyChar+ return $ TodoBodyLine (T.pack (fromMaybe (fromJust lineWithOutClosing) lineWithOutClosing)) False (isJust lineWithClosing)+ else do+ single <- optional . try $ manyTill anyChar (symbol $ getCommentForFileType fileExtension)+ multi <-+ if isJust single+ then return Nothing+ else+ optional . try $ manyTill anyChar (symbol $ getMultiOpeningForFileType fileExtension)+ if isJust single || isJust multi+ then do+ b <- many anyChar+ return $ TodoBodyLine (T.pack b) (isJust multi) (getMultiClosingForFileType fileExtension `T.isInfixOf` T.pack b)+ else+ fail "No open comment marker found"++getCommentForFileType :: Text -> Text+getCommentForFileType fileExtension =+ getCommentForFileTypeWithDefault singleCommentStart fileExtension++getMultiClosingForFileType :: Text -> Text+getMultiClosingForFileType fileExtension =+ getCommentForFileTypeWithDefault multiLineClose fileExtension++getMultiOpeningForFileType :: Text -> Text+getMultiOpeningForFileType fileExtension =+ getCommentForFileTypeWithDefault multiLineOpen fileExtension++getCommentForFileTypeWithDefault :: (FileTypeDetails -> Maybe Text) -> Text -> Text+getCommentForFileTypeWithDefault getter fileExtension =+ fromMaybe unkownMarker (getter =<< find (\a -> extension a == adjustedExtension) fileTypeToComment)+ where+ adjustedExtension =+ if T.isPrefixOf "." fileExtension+ then fileExtension+ else "." <> fileExtension++integer :: Parser Integer+integer = lexeme $ L.signed space L.decimal++ where+ lexeme :: Parser a -> Parser a+ lexeme = L.lexeme space++parseAssignee :: Parser String+parseAssignee = many (noneOf [')', '|', '='])++-- TODO(avi|p=3|#cleanup) - fix and type this better+parseDetails :: Text -> (Maybe Text, Maybe Text, [(Text, Text)], [Text])+parseDetails toParse =+ let dataTokens = T.splitOn "|" toParse+ assigneeTo =+ find+ (\t ->+ not (T.null t) &&+ not (T.isInfixOf "=" t) && not (T.isPrefixOf "#" t))+ dataTokens+ allDetails =+ map (\[a, b] -> (a, b)) $ filter (\t -> length t == 2) $+ map (T.splitOn "=") dataTokens+ priorityVal = snd <$> find (\t -> T.strip (fst t) == "p") allDetails+ filteredDetails = filter (\t -> T.strip (fst t) /= "p") allDetails+ entryTags = filter (T.isPrefixOf "#") dataTokens+ in (assigneeTo, priorityVal, filteredDetails, entryTags)++-- | parse "hard-coded" flags, and user-defined flags if any+parseFlag :: [UserFlag] -> Parser Flag+parseFlag = foldr (\a b -> b <|> foo a) (try parseFlagHardcoded)+ where+ foo :: UserFlag -> Parser Flag+ foo (UserFlag x) = try (symbol x $> (UF $ UserFlag x))++-- | parse flags TODO, FIXME, XXX+parseFlagHardcoded :: Parser Flag+parseFlagHardcoded =+ try (symbol "TODO" $> TODO )+ <|> try (symbol "FIXME" $> FIXME)+ <|> (symbol "XXX" $> XXX )++newtype MultineCommentEnclosing = MultineCommentEnclosing (Text, Text)++data FileTypeDetails = FileTypeDetails+ { extension :: Text+ , singleCommentStart :: Maybe Text+ , multilineEnclosing :: Maybe MultineCommentEnclosing+ }++multiLineClose :: FileTypeDetails -> Maybe Text+multiLineClose (FileTypeDetails _ _ (Just (MultineCommentEnclosing (_, b)))) = Just b+multiLineClose _ = Nothing++multiLineOpen :: FileTypeDetails -> Maybe Text+multiLineOpen (FileTypeDetails _ _ (Just (MultineCommentEnclosing (a, _)))) = Just a+multiLineOpen _ = Nothing++enclosing :: (Text, Text) -> Maybe MultineCommentEnclosing+enclosing = Just . MultineCommentEnclosing++slashStar :: Maybe MultineCommentEnclosing+slashStar = enclosing ("/*", "*/")++fileTypeToComment :: [FileTypeDetails]+fileTypeToComment =+ [ FileTypeDetails ".c" (Just "//") slashStar+ , FileTypeDetails ".cc" (Just "//") slashStar+ , FileTypeDetails ".clj" (Just ";;") Nothing+ , FileTypeDetails ".cpp" (Just "//") slashStar+ , FileTypeDetails ".cxx" (Just "//") slashStar+ , FileTypeDetails ".c++" (Just "//") slashStar+ , FileTypeDetails ".cs" (Just "//") slashStar+ , FileTypeDetails ".css" Nothing slashStar+ , FileTypeDetails ".ex" (Just "#") Nothing+ , FileTypeDetails ".erl" (Just "%") Nothing+ , FileTypeDetails ".go" (Just "//") slashStar+ , FileTypeDetails ".h" (Just "//") slashStar+ , FileTypeDetails ".hh" (Just "//") slashStar+ , FileTypeDetails ".hpp" (Just "//") slashStar+ , FileTypeDetails ".hs" (Just "--") (enclosing ("{-", "-}"))+ , FileTypeDetails ".html" Nothing (enclosing ("<!--", "-->"))+ , FileTypeDetails ".hxx" (Just "//") slashStar+ , FileTypeDetails ".h++" (Just "//") slashStar+ , FileTypeDetails ".java" (Just "//") slashStar+ , FileTypeDetails ".js" (Just "//") slashStar+ , FileTypeDetails ".jsx" (Just "//") slashStar+ , FileTypeDetails ".kt" (Just "//") slashStar+ , FileTypeDetails ".kts" (Just "//") slashStar+ , FileTypeDetails ".lua" (Just "--") (enclosing ("--[[", "]]"))+ , FileTypeDetails ".m" (Just "//") slashStar+ , FileTypeDetails ".php" (Just "//") slashStar+ , FileTypeDetails ".proto" (Just "//") slashStar+ , FileTypeDetails ".py" (Just "#") (enclosing ("\"\"\"", "\"\"\""))+ , FileTypeDetails ".rb" (Just "#") (enclosing ("=begin", "=end"))+ , FileTypeDetails ".rs" (Just "//") slashStar+ , FileTypeDetails ".scss" Nothing slashStar+ , FileTypeDetails ".scala" (Just "//") slashStar+ , FileTypeDetails ".sh" (Just "#") slashStar+ , FileTypeDetails ".swift" (Just "///") slashStar+ , FileTypeDetails ".ts" (Just "//") slashStar+ , FileTypeDetails ".tsx" (Just "//") slashStar+ , FileTypeDetails ".txt" (Just "") Nothing+ , FileTypeDetails ".vue" (Just "//") slashStar+ , FileTypeDetails ".yaml" (Just "#") Nothing+ ]++singleLineCommentForExtension :: Text -> Maybe Text+singleLineCommentForExtension fileExtension =+ find (\f -> extension f == fileExtension) fileTypeToComment >>= singleCommentStart++multiLineOpenCommentForExtension :: Text -> Maybe Text+multiLineOpenCommentForExtension fileExtension =+ find (\f -> extension f == fileExtension) fileTypeToComment >>=+ multilineEnclosing >>=+ (\(MultineCommentEnclosing a) -> return $ fst a)++-- Higher order function returning our folder.+fileParseFoldFn ::+ -- partial fn params+ [UserFlag]+ -> FilePath+ -- returns a fold function of:+ -> (TodoParserState, [Maybe TodoEntry])+ -> (Integer, Text)+ -> (TodoParserState, [Maybe TodoEntry])+fileParseFoldFn userFlags file (currentLineState, pastList) (lineNum, line) =+ let parsedLine = parseMaybe (parseTodo currentLineState userFlags file lineNum) line+ newState = nextState currentLineState parsedLine in+ (newState, pastList ++ [parsedLine])++nextState :: TodoParserState -> Maybe TodoEntry -> TodoParserState+nextState _ Nothing = ParseStateUnknown+nextState _ (Just (TodoBodyLine _ _ True)) = ParseStateUnknown+nextState _ (Just (TodoBodyLine _ True False)) = ParseStateMultiLineComment+nextState s (Just (TodoBodyLine _ False False)) = s+nextState _ (Just (TodoEntryHead _ _ _ _ _ _ _ _ _ _ _ True False)) = ParseStateMultiLineComment+nextState _ (Just (TodoEntryHead _ _ _ _ _ _ _ _ _ _ MultiLine _ False)) = ParseStateMultiLineComment+nextState _ (Just TodoEntryHead {}) = ParseStateUnknown+nextState a b = error ("No next state for " ++ show a ++ " " ++ show b)++runTodoParser :: [UserFlag] -> SourceFile -> [TodoEntry]+runTodoParser us (SourceFile path ls) =+ let parsedTodoLines =+ foldl+ (fileParseFoldFn+ us+ path)+ (ParseStateUnknown, [])+ (zip [1 ..] ls)+ groupedTodos = foldl foldTodoHelper ([], False) (snd parsedTodoLines)+ in fst groupedTodos++ where+ -- fold fn to concatenate todos that a multiple, single line comments+ foldTodoHelper :: ([TodoEntry], Bool) -> Maybe TodoEntry -> ([TodoEntry], Bool)+ foldTodoHelper (todoEntries, currentlyBuildingTodoLines) maybeTodo+ -- We're not on a todo line, keep going+ | isNothing maybeTodo = (todoEntries, False)+ -- We see the start of a new todo+ | isEntryHead $ fromJust maybeTodo = (todoEntries ++ [fromJust maybeTodo], True)+ -- We a body line of a todo to concatenate to the current one+ | isBodyLine (fromJust maybeTodo) && currentlyBuildingTodoLines =+ (init todoEntries ++ [combineTodo (last todoEntries) (fromJust maybeTodo)], True)+ | otherwise = (todoEntries, False)++ where+ isEntryHead :: TodoEntry -> Bool+ isEntryHead TodoEntryHead {} = True+ isEntryHead _ = False++ isBodyLine :: TodoEntry -> Bool+ isBodyLine TodoBodyLine {} = True+ isBodyLine _ = False++ combineTodo :: TodoEntry -> TodoEntry -> TodoEntry+ combineTodo (TodoEntryHead i b a p n entryPriority f attrs entryTags entryLeadingText t isOpened _) (TodoBodyLine l _ isClosed) =+ TodoEntryHead i (b ++ [l]) a p n entryPriority f attrs entryTags entryLeadingText t isOpened isClosed+ combineTodo (TodoBodyLine l isOpened _) (TodoEntryHead i b a p n entryPriority f attrs entryTags entryLeadingText t _ isClosed) =+ TodoEntryHead i (l : b) a p n entryPriority f attrs entryTags entryLeadingText t isOpened isClosed+ combineTodo (TodoBodyLine l isOpened _) (TodoBodyLine r _ isClosed) =+ TodoBodyLineCombined (l : [r]) isOpened isClosed+ combineTodo (TodoBodyLineCombined l isOpened _) (TodoBodyLine r _ isClosed) =+ TodoBodyLineCombined (l ++ [r]) isOpened isClosed+ combineTodo (TodoBodyLineCombined l isOpened _) (TodoEntryHead i b a p n entryPriority f attrs entryTags entryLeadingText t _ isClosed) =+ TodoEntryHead i (l ++ b) a p n entryPriority f attrs entryTags entryLeadingText t isOpened isClosed+ combineTodo _ _ = error "Can't combine todoEntry of these types"++getExtension :: FilePath -> Text+getExtension path = last $ T.splitOn "." (T.pack path)++stringToMaybe :: Text -> Maybe Text+stringToMaybe t =+ if T.null t+ then Nothing+ else Just t++fst4 :: (a, b, c, d) -> a+fst4 (x, _, _, _) = x++snd4 :: (a, b, c, d) -> b+snd4 (_, x, _, _) = x++thd4 :: (a, b, c, d) -> c+thd4 (_, _, x, _) = x++fth4 :: (a, b, c, d) -> d+fth4 (_, _, _, x) = x++unkownMarker :: Text+unkownMarker = "UNKNOWN-DELIMETER-UNKNOWN-DELIMETER-UNKNOWN-DELIMETER"++data TodoParserState+ = ParseStateUnknown+ | ParseStateSource+ | ParseStateSingleComment+ | ParseStateMultiLineComment deriving (Eq, Show)++data LeadingTextKind = SingleLT | MultiLT | NonOpenedComment deriving (Eq, Show)++takeShorter :: String -> String -> String+takeShorter singleLeadingText multiLeadingText+ | length singleLeadingText == length multiLeadingText = ""+ | null singleLeadingText = multiLeadingText+ | null multiLeadingText = singleLeadingText+ | length singleLeadingText > length multiLeadingText = multiLeadingText+ | length singleLeadingText < length multiLeadingText = singleLeadingText+ | otherwise = ""++parseTodo :: TodoParserState -> [UserFlag] -> FilePath -> LineNumber -> Parser TodoEntry+parseTodo state us path lineNum = try (parseTodoEntryHead us)+ <|> parseComment state (getExtension path)+ where+ parseTodoEntryHead :: [UserFlag] -> Parser TodoEntry+ parseTodoEntryHead uf =+ if state == ParseStateMultiLineComment+ then do+ leadingTextMulti <- optional (try $ many spaceChar)+ parseEntryHead NonOpenedComment (fromMaybe "" leadingTextMulti)+ else do+ entryLeadingTextSingle <- optional (try (manyTill anyChar (lookAhead . prefixParserForFileType $ getExtension path)))+ entryLeadingTextMulti <-+ if isNothing entryLeadingTextSingle+ then+ optional (manyTill anyChar (lookAhead . multiPrefixParserForFileType $ getExtension path))+ else+ return Nothing++ commentOpenSingle <- optional . try $ prefixParserForFileType $ getExtension path+ commentOpenMulti <- optional . try $ multiPrefixParserForFileType $ getExtension path+ let leadingTextKind = case (commentOpenSingle, commentOpenMulti) of+ (Just _, Nothing) -> SingleLT+ (Nothing, Just _) -> MultiLT+ (Nothing, Nothing) -> NonOpenedComment+ err -> error . printf "Error: unexpected value in leading text pattern match: %s. Please report this bug https://github.com/aviaviavi/toodles" $ show err++ -- select the shorter leading text, and update leadingTextKind enum accordingly+ matchingLeadingText = takeShorter (fromMaybe "" entryLeadingTextSingle) (fromMaybe "" entryLeadingTextMulti)++ parseEntryHead leadingTextKind matchingLeadingText++ where++ parseEntryHead leadingTextCharsKind leadingTextChars = do+ f <- parseFlag uf+ entryDetails <- optional $ try (inParens $ many (noneOf [')', '(']))+ let parsedDetails = parseDetails . T.pack <$> entryDetails+ entryPriority = (readMaybe . T.unpack) =<< (snd4 =<< parsedDetails)+ otherDetails = maybe [] thd4 parsedDetails+ entryTags = maybe [] fth4 parsedDetails+ _ <- optional $ symbol "-"+ _ <- optional $ symbol ":"+ let closingParser = symbol $ getMultiClosingForFileType (getExtension path)+ lineWithClosing <- optional . try $ manyTill anyChar closingParser+ lineWithOutClosing <- optional $ many anyChar+ return $+ TodoEntryHead+ 0+ [T.pack (fromMaybe (fromJust lineWithOutClosing) lineWithClosing)]+ (stringToMaybe . T.strip $ fromMaybe "" (fst4 =<< parsedDetails))+ path+ lineNum+ entryPriority+ f+ otherDetails+ entryTags+ (T.pack leadingTextChars)+ (if leadingTextCharsKind == SingleLT then SingleLine else MultiLine)+ (leadingTextCharsKind == MultiLT)+ (isJust lineWithClosing)++ inParens :: Parser a -> Parser a+ inParens = between (symbol "(") (symbol ")")++ prefixParserForFileType :: Text -> Parser Text+ prefixParserForFileType fileExtension = symbol . getCommentForFileType $ fileExtension++ multiPrefixParserForFileType :: Text -> Parser Text+ multiPrefixParserForFileType fileExtension = symbol . getMultiOpeningForFileType $ fileExtension
+ src/Server.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# LANGUAGE TypeOperators #-}++module Server where++import Config+import Parse+import ToodlesApi+import Types++import qualified Control.Exception as E+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson (FromJSON)+import Data.Aeson.Types+import Data.Either+import Data.IORef+import Data.List (find, nub)+import Data.Maybe+import Data.String.Utils+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Yaml as Y+import Servant+import System.Directory+import System.IO.HVFS+import qualified System.IO.Strict as SIO+import System.Path+import System.Path.NameManip+import Text.Blaze.Html5 (Html)+import qualified Text.Blaze.Html5 as BZ+import Text.Printf+import Text.Regex.Posix++data ToodlesConfig = ToodlesConfig+ { ignore :: [FilePath]+ , flags :: [UserFlag]+ } deriving (Show)++instance FromJSON ToodlesConfig where+ parseJSON (Object o) = do+ parsedIgnore <- o .:? "ignore" .!= []+ parsedFlags <- o .:? "flags" .!= []+ return $ ToodlesConfig parsedIgnore parsedFlags+ parseJSON invalid = typeMismatch "Invalid config" invalid++app :: ToodlesState -> Application+app s = serve toodlesAPI server++ where+ server :: Server ToodlesAPI+ server = liftIO . getFullSearchResults s+ :<|> deleteTodos s+ :<|> editTodos s+ :<|> serveDirectoryFileServer (dataPath s)+ :<|> showRawFile s+ :<|> root s++root :: ToodlesState -> [Text] -> Handler Html+root (ToodlesState _ dPath) path =+ if null path then+ liftIO $ BZ.preEscapedToHtml <$> readFile (dPath ++ "/html/index.html")+ else throwError $ err404 { errBody = "Not found" }++showRawFile :: ToodlesState -> Integer -> Handler Html+showRawFile (ToodlesState ref _) eId = do+ (TodoListResult r _) <- liftIO $ readIORef ref+ let entry = find (\t -> entryId t == eId) r+ liftIO $+ maybe+ (return "Not found")+ (\e -> addAnchors <$> readFile (sourceFile e))+ entry++ where+ addAnchors :: String -> Html+ addAnchors s =+ let codeLines = zip [1::Int ..] $ lines s+ in BZ.preEscapedToHtml+ (unlines $+ map+ (\(i, l) -> printf "<pre><a name=\"line-%s\">%s</a></pre>" (show i) l)+ codeLines)++editTodos :: ToodlesState -> EditTodoRequest -> Handler Text+editTodos (ToodlesState ref _) req = do+ (TodoListResult r _) <- liftIO $ readIORef ref+ let editedList =+ map+ (\t ->+ if willEditTodo req t+ then editTodo req t+ else t)+ r+ editedFilteredList = filter (willEditTodo req) editedList+ _ <- mapM_ recordUpdates editedFilteredList+ return "{}"+ where+ willEditTodo :: EditTodoRequest -> TodoEntry -> Bool+ willEditTodo editRequest entry = entryId entry `elem` editIds editRequest++ editTodo :: EditTodoRequest -> TodoEntry -> TodoEntry+ editTodo editRequest entry =+ let newAssignee =+ if isJust (setAssignee editRequest) &&+ (not . T.null . fromJust $ setAssignee editRequest)+ then setAssignee editRequest+ else assignee entry+ newPriority =+ if isJust (setPriority editRequest)+ then setPriority editRequest+ else priority entry+ in entry+ { assignee = newAssignee+ , tags = tags entry ++ addTags editRequest+ , priority = newPriority+ , customAttributes =+ nub $ customAttributes entry ++ addKeyVals editRequest+ }++ recordUpdates :: MonadIO m => TodoEntry -> m ()+ recordUpdates t = void $ updateTodoLinesInFile renderTodo t++renderTodo :: TodoEntry -> [Text]+renderTodo t =+ let ext = "." <> getExtension (sourceFile t)+ comment =+ if commentType t == SingleLine+ then fromJust $ singleLineCommentForExtension ext+ else fromJust $ multiLineOpenCommentForExtension ext+ detail =+ renderFlag (flag t) <> " (" <>+ T.pack (+ Data.String.Utils.join+ "|"+ (map T.unpack $+ [fromMaybe "" $ assignee t] +++ listIfNotNull+ (fmap (T.pack . maybe "" ((\n -> "p=" ++ n) . show)) priority t) +++ tags t ++ map (\a -> fst a <> "=" <> snd a) (customAttributes t))) <>+ ") "+ fullNoComments = mapHead (\l -> detail <> "- " <> l) $ body t+ commentFn =+ if commentType t == SingleLine+ then (\l -> comment <> " " <> l)+ else id+ commented = map commentFn fullNoComments+ in mapLast+ (\line ->+ if entryHeadClosed t+ then line <> " " <> getMultiClosingForFileType ext+ else line) .+ mapHead (\l -> if entryHeadOpened t then leadingText t <> getMultiOpeningForFileType ext <> " " <> l else leadingText t <> l) .+ mapInit+ (\l -> foldl (<>) "" [" " | _ <- [1 .. (T.length $ leadingText t)]] <> l) $+ commented+ where+ listIfNotNull :: Text -> [Text]+ listIfNotNull "" = []+ listIfNotNull s = [s]++ renderFlag :: Flag -> Text+ renderFlag TODO = "TODO"+ renderFlag FIXME = "FIXME"+ renderFlag XXX = "XXX"+ renderFlag (UF (UserFlag x)) = x++-- | Given a function to emit new lines for a given todo, write that update in+-- place of the current todo lines+updateTodoLinesInFile :: MonadIO m => (TodoEntry -> [Text]) -> TodoEntry -> m ()+updateTodoLinesInFile f todo = do+ let startIndex = lineNumber todo - 1+ newLines = map T.unpack $ f todo+ fileLines <- liftIO $ lines <$> SIO.readFile (sourceFile todo)+ let updatedLines =+ slice 0 (fromIntegral $ startIndex - 1) fileLines ++ newLines +++ slice+ (fromIntegral startIndex + length (body todo))+ (length fileLines - 1)+ fileLines+ liftIO $ writeFile (sourceFile todo) $ unlines updatedLines++ where+ slice :: Int -> Int -> [a] -> [a]+ slice a b xs = take (b - a + 1) (drop a xs)++deleteTodos :: ToodlesState -> DeleteTodoRequest -> Handler Text+deleteTodos (ToodlesState ref _) req = do+ refVal@(TodoListResult r _) <- liftIO $ readIORef ref+ let toDelete = filter (\t -> entryId t `elem` ids req) r+ liftIO $ doUntilNull removeAndAdjust toDelete+ let remainingResults = filter (\t -> entryId t `notElem` map entryId toDelete) r+ let updatedResults = foldl (flip adjustLinesAfterDeletionOf) remainingResults toDelete+ let remainingResultsRef = refVal { todos = updatedResults }+ _ <- liftIO $ atomicModifyIORef' ref (const (remainingResultsRef, remainingResultsRef))+ return "{}"++ where++ doUntilNull :: ([a] -> IO [a]) -> [a] -> IO ()+ doUntilNull f xs = do+ result <- f xs+ if null result+ then return ()+ else doUntilNull f result++ -- If we delete an entry, we need to decrement the line-numbers for the+ -- other entries that come later in the file+ adjustLinesAfterDeletionOf :: TodoEntry -> [TodoEntry] -> [TodoEntry]+ adjustLinesAfterDeletionOf deleted =+ map (\remaining ->+ if (sourceFile remaining == sourceFile deleted) && (lineNumber remaining > lineNumber deleted)+ then remaining { lineNumber = lineNumber remaining - (fromIntegral . length $ body deleted)}+ else remaining)++ removeAndAdjust :: MonadIO m => [TodoEntry] -> m [TodoEntry]+ removeAndAdjust [] = return []+ removeAndAdjust (x:xs) = do+ removeTodoFromCode x+ return $ adjustLinesAfterDeletionOf x xs++ where+ removeTodoFromCode :: MonadIO m => TodoEntry -> m ()+ removeTodoFromCode t =+ let opening = [getMultiOpeningForFileType $ getExtension (sourceFile t) | entryHeadOpened t]+ closing = [getMultiClosingForFileType $ getExtension (sourceFile t) | entryHeadClosed t]+ finalList = if length opening /= length closing then opening ++ closing else [] in+ updateTodoLinesInFile (const finalList) t++setAbsolutePath :: ToodlesArgs -> IO ToodlesArgs+setAbsolutePath args = do+ let pathOrDefault = if T.null . T.pack $ directory args+ then "."+ else directory args+ absolute <- normalise_path <$> absolute_path pathOrDefault+ return $ args {directory = absolute}++getFullSearchResults :: ToodlesState -> Bool -> IO TodoListResult+getFullSearchResults (ToodlesState ref _) recompute =+ if recompute+ then do+ putStrLn "refreshing todo's"+ userArgs <- toodlesArgs >>= setAbsolutePath+ sResults <- runFullSearch userArgs+ atomicModifyIORef' ref (const (sResults, sResults))+ else putStrLn "cached read" >> readIORef ref++runFullSearch :: ToodlesArgs -> IO TodoListResult+runFullSearch userArgs = do+ let projectRoot = directory userArgs+ configExists <- doesFileExist $ projectRoot ++ "/.toodles.yaml"+ config <- if configExists+ then Y.decodeFileEither (projectRoot ++ "/.toodles.yaml")+ else return . Right $ ToodlesConfig [] []+ when (isLeft config)+ $ putStrLn $ "[WARNING] Invalid .toodles.yaml: " ++ show config+ let config' = fromRight (ToodlesConfig [] []) config+ allFiles <- getAllFiles config' projectRoot+ let parsedTodos = concatMap (runTodoParser $ userFlag userArgs ++ flags config') allFiles+ filteredTodos = filter (filterSearch (assignee_search userArgs)) parsedTodos+ resultList = limitSearch filteredTodos $ limit_results userArgs+ indexedResults = map (\(i, r) -> r {entryId = i}) $ zip [1 ..] resultList+ return $ TodoListResult indexedResults ""++ where+ filterSearch :: Maybe SearchFilter -> TodoEntry -> Bool+ filterSearch Nothing _ = True+ filterSearch (Just (AssigneeFilter (AssigneeFilterRegex query))) entry = fromMaybe "" (assignee entry) == query++ limitSearch :: [TodoEntry] -> Int -> [TodoEntry]+ limitSearch todoList 0 = todoList+ limitSearch todoList n = take n todoList++getAllFiles :: ToodlesConfig -> FilePath -> IO [SourceFile]+getAllFiles (ToodlesConfig ignoredPaths _) basePath =+ E.catch+ (do putStrLn $ printf "Running toodles for path: %s" basePath+ files <- recurseDir SystemFS basePath+ let validFiles = filter isValidFile files+ mapM+ (\f ->+ SourceFile f . (map T.pack . lines) <$>+ E.catch+ (SIO.readFile f)+ (\(e :: E.IOException) -> print e >> return ""))+ validFiles)+ (\(e :: E.IOException) ->+ putStrLn ("Error reading " ++ basePath ++ ": " ++ show e) >> return [])++ where++ isValidFile :: FilePath -> Bool+ isValidFile path = fileHasValidExtension && not ignoreFile++ where++ fileHasValidExtension :: Bool+ fileHasValidExtension = any (\ext -> ext `T.isSuffixOf` T.pack path) (map extension fileTypeToComment)++ ignoreFile :: Bool+ ignoreFile =+ let p = T.pack path+ in T.isInfixOf "node_modules" p || T.isSuffixOf "pb.go" p ||+ T.isSuffixOf "_pb2.py" p ||+ any (\r -> path =~ r :: Bool) ignoredPaths++mapHead :: (a -> a) -> [a] -> [a]+mapHead f (x:xs) = f x : xs+mapHead _ xs = xs++mapInit :: (a -> a) -> [a] -> [a]+mapInit f (x:xs) = x : map f xs+mapInit _ x = x++mapLast :: (a -> a) -> [a] -> [a]+mapLast f xs+ | null xs = []+ | otherwise = init xs ++ [f $ last xs]
+ src/ToodlesApi.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds,+ ScopedTypeVariables,+ TypeOperators #-}++module ToodlesApi where++import Types++import Data.Proxy (Proxy)+import Data.Text (Text)+import Servant+import Servant.HTML.Blaze (HTML)+import Text.Blaze.Html5 (Html)++type ToodlesAPI = "todos" :> QueryFlag "recompute" :> Get '[JSON] TodoListResult++ :<|> "todos" :> "delete" :> ReqBody '[JSON] DeleteTodoRequest :> Post '[JSON] Text++ :<|> "todos" :> "edit" :> ReqBody '[JSON] EditTodoRequest :> Post '[JSON] Text++ :<|> "static" :> Raw++ :<|> "source_file" :> Capture "id" Integer :> Get '[HTML] Html++ :<|> CaptureAll "anything-else" Text :> Get '[HTML] Html++toodlesAPI :: Proxy ToodlesAPI+toodlesAPI = Proxy
+ src/Types.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Types where++import Data.Aeson (FromJSON, ToJSON, Value (String), parseJSON,+ toJSON)+import Data.Aeson.Types (typeMismatch)+import Data.Data+import Data.IORef (IORef)+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as T (unpack)+import GHC.Generics (Generic)++data SourceFile = SourceFile+ { fullPath :: FilePath+ , sourceLines :: [Text]+ } deriving (Show)++type LineNumber = Integer++data ToodlesState = ToodlesState+ { results :: IORef TodoListResult,+ dataPath :: FilePath+ }++data CommentType = SingleLine | MultiLine deriving (Show, Eq, Generic)+instance ToJSON CommentType++data TodoEntry+ = TodoEntryHead { entryId :: Integer+ , body :: [Text]+ , assignee :: Maybe Text+ , sourceFile :: FilePath+ , lineNumber :: LineNumber+ , priority :: Maybe Integer+ , flag :: Flag+ , customAttributes :: [(Text, Text)]+ , tags :: [Text]+ , leadingText :: Text+ , commentType :: CommentType+ , entryHeadOpened :: Bool+ , entryHeadClosed :: Bool+ }+ | TodoBodyLine+ Text -- the body+ Bool -- has opening tag+ Bool -- has closing tag+ | TodoBodyLineCombined+ [Text] -- the body+ Bool -- has opening tag+ Bool -- has closing tag+ deriving (Show, Generic)+instance ToJSON TodoEntry++data TodoListResult = TodoListResult+ { todos :: [TodoEntry]+ , message :: Text+ } deriving (Show, Generic)+instance ToJSON TodoListResult++newtype DeleteTodoRequest = DeleteTodoRequest+ { ids :: [Integer]+ } deriving (Show, Generic)+instance FromJSON DeleteTodoRequest++data EditTodoRequest = EditTodoRequest+ { editIds :: [Integer]+ , setAssignee :: Maybe Text+ , addTags :: [Text]+ , addKeyVals :: [(Text, Text)]+ , setPriority :: Maybe Integer+ } deriving (Show, Generic)+instance FromJSON EditTodoRequest++data Flag = TODO | FIXME | XXX | UF UserFlag+ deriving (Generic)++newtype UserFlag = UserFlag Text+ deriving (Show, Eq, IsString, Data, Generic)++instance Show Flag where+ show TODO = "TODO"+ show FIXME = "FIXME"+ show XXX = "XXX"+ show (UF (UserFlag x)) = T.unpack x++instance ToJSON Flag where+ toJSON TODO = Data.Aeson.String "TODO"+ toJSON FIXME = Data.Aeson.String "FIXME"+ toJSON XXX = Data.Aeson.String "XXX"+ toJSON (UF (UserFlag x)) = Data.Aeson.String x++instance FromJSON Flag where+ parseJSON (Data.Aeson.String x) =+ case x of+ "TODO" -> pure TODO+ "FIXME" -> pure FIXME+ "XXX" -> pure XXX+ _ -> pure $ UF $ UserFlag x+ parseJSON invalid = typeMismatch "UserFlag" invalid++instance ToJSON UserFlag where+ toJSON (UserFlag x) = Data.Aeson.String x++instance FromJSON UserFlag where+ parseJSON (Data.Aeson.String x) = pure $ UserFlag x+ parseJSON invalid = typeMismatch "UserFlag" invalid
+ test/Spec.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Parse+import Types++import Data.Either+import qualified Data.Text as T+import Test.Hspec+import Text.Megaparsec++bodyText (TodoBodyLine a _ _) = a+bodyText t = T.unlines (body t)++hasClosing (TodoBodyLine _ _ a) = a+hasClosing t = entryHeadClosed t++hasOpening (TodoBodyLine _ t _) = t+hasOpening t = entryHeadOpened t++defaultBodyLine = TodoBodyLine "default bad" False False++main :: IO ()+main = hspec $+ describe "Toodles" $ do+ let unknownStateParser = parse (parseTodo ParseStateUnknown [] "hello.hs" 10 ) ""+ multiLineStateParser = parse (parseTodo ParseStateMultiLineComment [] "hello.hs" 10 ) ""+ singleHaskellParser = parse (parseComment ParseStateSingleComment ".hs") ""+ multiHaskellParser = parse (parseComment ParseStateMultiLineComment ".hs") ""++ it "parses single line comments" $ do+ let haskellSingleComment = " -- a plain comment"+ singleParsed = singleHaskellParser haskellSingleComment+ singleParsed `shouldSatisfy` isRight+ bodyText (fromRight defaultBodyLine singleParsed) `shouldSatisfy` (`T.isInfixOf` "a plain comment")++ it "parses lines of multiline comments" $ do+ let haskellMultiComment = "a plain comment"+ multiParsed = multiHaskellParser haskellMultiComment+ multiParsed `shouldSatisfy` isRight+ let result = fromRight defaultBodyLine multiParsed+ hasClosing result `shouldBe` False++ let multiParsedWithClosing = multiHaskellParser (haskellMultiComment <> " -} ")+ multiParsedWithClosing `shouldSatisfy` isRight+ let result2 = fromRight defaultBodyLine multiParsedWithClosing+ bodyText result2 `shouldSatisfy` ((`T.isInfixOf` "a plain comment"))+ hasClosing result2 `shouldBe` True++ it "parses multiline comment closings" $ do+ let haskellMultiClose = "-}"+ let multiCloseParsed = multiHaskellParser haskellMultiClose+ multiCloseParsed `shouldSatisfy` isRight+ let result3 = fromRight defaultBodyLine multiCloseParsed+ hasClosing result3 `shouldBe` True+ hasOpening result3 `shouldBe` False++ it "parses multiline comment opens" $ do+ let emptyMultiOpen = " {- "+ emptyOpen = unknownStateParser emptyMultiOpen+ emptyOpen `shouldSatisfy` isRight+ let result5 = fromRight defaultBodyLine emptyOpen+ hasOpening result5 `shouldBe` True+ hasClosing result5 `shouldBe` False++ it "parses empty lines as multiline comments " $ do+ let emptyMulti = ""+ emptyMultiParsed = multiLineStateParser emptyMulti+ emptyMultiParsed `shouldSatisfy` isRight+ let result6 = fromRight defaultBodyLine emptyMultiParsed+ hasOpening result6 `shouldBe` False+ hasClosing result6 `shouldBe` False++ it "parses single TODOs" $ do+ let haskellSingleTodo = " -- TODO(avi|p=1|#tag|key=val) some stuff we need to fix"+ singleParsed = unknownStateParser haskellSingleTodo+ singleParsed `shouldSatisfy` isRight+ bodyText (fromRight defaultBodyLine singleParsed) `shouldBe` "some stuff we need to fix\n"++ it "parses a multiline TODO fully enclosed on one line" $ do+ let haskellEnclosedTodo = " {- TODO(avi|p=1|#tag|key=val) some stuff we need to fix -} "+ multiParsed = unknownStateParser haskellEnclosedTodo+ multiParsed `shouldSatisfy` isRight+ let result2 = fromRight defaultBodyLine multiParsed+ bodyText result2 `shouldBe` "some stuff we need to fix \n"+ hasClosing result2 `shouldBe` True+ hasOpening result2 `shouldBe` True++ it "parses mutline TODO's on an opening line" $ do+ let haskellMultiOpenTodo = " {- TODO(avi|p=1|#tag|key=val) some stuff we need to fix"+ multiOpenParsed = unknownStateParser haskellMultiOpenTodo+ multiOpenParsed `shouldSatisfy` isRight+ let result3 = fromRight defaultBodyLine multiOpenParsed+ bodyText result3 `shouldBe` "some stuff we need to fix\n"+ hasClosing result3 `shouldBe` False+ hasOpening result3 `shouldBe` True++ it "parses mutline TODO's on a closing line" $ do+ let haskellMultiCloseTodo = " TODO(avi|p=1|#tag|key=val) some stuff we need to fix -}"+ unknownStateParser haskellMultiCloseTodo `shouldSatisfy` isLeft++ let mutliCloseParsed = multiLineStateParser haskellMultiCloseTodo+ mutliCloseParsed `shouldSatisfy` isRight+ let result4 = fromRight defaultBodyLine mutliCloseParsed+ bodyText result4 `shouldBe` "some stuff we need to fix \n"+ hasClosing result4 `shouldBe` True+ hasOpening result4 `shouldBe` False++ it "parses bare TODO's in the middle of an opening line" $ do+ let haskellBareMultiTodo = " TODO(avi|p=1|#tag|key=val) some stuff we need to fix"+ bareMultiParsed = multiLineStateParser haskellBareMultiTodo+ bareMultiParsed `shouldSatisfy` isRight+ let result7 = fromRight defaultBodyLine bareMultiParsed+ hasOpening result7 `shouldBe` False+ hasClosing result7 `shouldBe` False+ bodyText result7 `shouldBe` "some stuff we need to fix\n"+
toodles.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: toodles-version: 0.1.4+version: 1.0.0 license: MIT license-file: LICENSE copyright: 2018 Avi Press@@ -31,9 +31,41 @@ type: git location: https://github.com/aviaviavi/toodles +library+ exposed-modules:+ Parse+ Types+ Config+ ToodlesApi+ Server+ hs-source-dirs: src+ other-modules:+ Paths_toodles+ default-language: Haskell2010+ ghc-options: -Wall -Wcompat+ build-depends:+ MissingH >=1.4.0.1 && <1.5,+ aeson ==1.3.1.1,+ base >=4.0 && <5,+ blaze-html ==0.9.1.1,+ cmdargs ==0.10.20,+ directory ==1.3.1.5,+ hspec >=2.4.4 && <2.6,+ hspec-expectations >=0.8.2 && <0.9,+ megaparsec ==6.5.0,+ regex-posix ==0.95.2,+ servant ==0.14.1,+ servant-blaze ==0.8,+ servant-server ==0.14.1,+ strict ==0.3.2,+ text ==1.2.3.1,+ wai ==3.2.1.2,+ warp ==3.2.25,+ yaml ==0.8.32+ executable toodles main-is: Main.hs- hs-source-dirs: app+ hs-source-dirs: app src other-modules: Config Parse@@ -51,6 +83,8 @@ blaze-html ==0.9.1.1, cmdargs ==0.10.20, directory ==1.3.1.5,+ hspec >=2.4.4 && <2.6,+ hspec-expectations >=0.8.2 && <0.9, megaparsec ==6.5.0, regex-posix ==0.95.2, servant ==0.14.1,@@ -58,6 +92,40 @@ servant-server ==0.14.1, strict ==0.3.2, text ==1.2.3.1,+ wai ==3.2.1.2,+ warp ==3.2.25,+ yaml ==0.8.32++test-suite toodles-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test src+ other-modules:+ Config+ Parse+ Server+ ToodlesApi+ Types+ Paths_toodles+ default-language: Haskell2010+ ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N -w+ build-depends:+ MissingH >=1.4.0.1 && <1.5,+ aeson ==1.3.1.1,+ base >=4.0 && <5,+ blaze-html ==0.9.1.1,+ cmdargs ==0.10.20,+ directory ==1.3.1.5,+ hspec >=2.4.4 && <2.6,+ hspec-expectations >=0.8.2 && <0.9,+ megaparsec ==6.5.0,+ regex-posix ==0.95.2,+ servant ==0.14.1,+ servant-blaze ==0.8,+ servant-server ==0.14.1,+ strict ==0.3.2,+ text ==1.2.3.1,+ toodles -any, wai ==3.2.1.2, warp ==3.2.25, yaml ==0.8.32
web/html/index.html view
@@ -39,7 +39,7 @@ </div> <div class="navbar-item deselect-all" v-on:click="deselectAll" v-show="todos.length && todos.every(t => t.selected)"> <span class="icon">- <i class="fa fa-square"></i> + <i class="fa fa-square"></i> </span> <span>Deselect All</span> </div>