toodles 0.1.0.14 → 0.1.0.15
raw patch · 8 files changed
+636/−586 lines, 8 filesdep −filepathdep −http-typesdep −transformers
Dependencies removed: filepath, http-types, transformers
Files
- README.md +14/−0
- app/Config.hs +40/−0
- app/Main.hs +21/−581
- app/Parse.hs +204/−0
- app/Server.hs +271/−0
- app/ToodlesApi.hs +28/−0
- app/Types.hs +51/−0
- toodles.cabal +7/−5
README.md view
@@ -77,6 +77,7 @@ - Shell / Bash - Swift - Typescript+- Vue (scripts only) - Yaml Submit a PR if you'd like a language to be added. There will eventually be@@ -103,6 +104,19 @@ $ toodles -d /path/to/your/project -p 9001 # or simply $ toodles+```+#### Running with Docker++For convenience this repository also provides a `Dockerfile` to automatically+build toodles.++```bash+# to build container run:+$ docker build -t toodles .+# afterwards you can run the following command to execute toodles for the+# directory you are currently in:+$ docker run -it -v $(pwd):/repo -p 9001:9001 toodles+ ``` ### Current Limitations
+ app/Config.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveDataTypeable,+ DataKinds,+ OverloadedStrings,+ ScopedTypeVariables,+ TypeOperators #-}++module Config where++import Paths_toodles++import Data.Text (Text)+import Data.Version (showVersion)+import System.Console.CmdArgs++data ToodlesArgs = ToodlesArgs+ { directory :: FilePath+ , assignee_search :: Maybe SearchFilter+ , limit_results :: Int+ , port :: Maybe Int+ , no_server :: Bool+ } 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"+ } &= summary ("toodles " ++ showVersion version)+ &= program "toodles"+ &= verbosity+ &= help "Manage TODO's directly from your codebase"
app/Main.hs view
@@ -1,589 +1,18 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-} --- TODO (avi|p=3|#cleanup|key=val|k3y=asdf|key=1) - break this into modules module Main where -import qualified Control.Exception as E-import Control.Monad-import Control.Monad (forM)-import Control.Monad.IO.Class-import Data.Aeson-import Data.Either-import Data.IORef-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Proxy-import Data.String.Utils-import qualified Data.Text as T-import Data.Version (showVersion)-import Data.Void-import qualified Data.Yaml as Y-import GHC.Generics-import Network.Wai.Handler.Warp+import Config import Paths_toodles-import Servant-import Servant.HTML.Blaze-import System.Console.CmdArgs-import System.Directory-import System.IO.HVFS-import qualified System.IO.Strict as SIO-import System.Path-import System.Path.NameManip-import qualified Text.Blaze.Html5 as BZ-import Text.Megaparsec-import Text.Megaparsec.Char-import qualified Text.Megaparsec.Char.Lexer as L-import Text.Printf-import Text.Read-import Text.Regex.Posix--type LineNumber = Integer--data TodoEntry- = TodoEntryHead { id :: Integer- , body :: [T.Text]- , assignee :: Maybe T.Text- , sourceFile :: FilePath- , lineNumber :: LineNumber- , priority :: Maybe Integer- , customAttributes :: [(T.Text, T.Text)]- , tags :: [T.Text]- , leadingText :: T.Text }- | TodoBodyLine T.Text- deriving (Show, Generic)--data TodoListResult = TodoListResult- { todos :: [TodoEntry]- , message :: T.Text- } deriving (Show, Generic)--newtype DeleteTodoRequest = DeleteTodoRequest- { ids :: [Integer]- } deriving (Show, Generic)--data EditTodoRequest = EditTodoRequest- { editIds :: [Integer]- , setAssignee :: Maybe T.Text- , addTags :: [T.Text]- , addKeyVals :: [(T.Text, T.Text)]- , setPriority :: Maybe Integer- } deriving (Show, Generic)--newtype ToodlesConfig = ToodlesConfig {- ignore :: [FilePath]- } deriving (Show, Generic)--instance FromJSON TodoEntry--instance ToJSON TodoEntry--instance FromJSON TodoListResult--instance ToJSON TodoListResult--instance FromJSON DeleteTodoRequest--instance ToJSON DeleteTodoRequest--instance FromJSON EditTodoRequest--instance ToJSON EditTodoRequest--instance FromJSON ToodlesConfig--type ToodlesAPI =- "todos" :> QueryFlag "recompute" :> Get '[ JSON] TodoListResult :<|>- "todos" :> "delete" :> ReqBody '[ JSON] DeleteTodoRequest :> Post '[ JSON] T.Text :<|>- "todos" :> "edit" :> ReqBody '[ JSON] EditTodoRequest :> Post '[ JSON] T.Text :<|>- "static" :> Raw :<|>- "source_file" :> Capture "id" Integer :> Get '[ HTML] BZ.Html :<|>- CaptureAll "anything-else" T.Text :> Get '[HTML] BZ.Html--server :: ToodlesState -> Server ToodlesAPI-server s =- liftIO . getFullSearchResults s :<|>- deleteTodos s :<|>- editTodos s :<|>- serveDirectoryFileServer (dataPath s) :<|>- showRawFile s :<|>- root s--data ToodlesState = ToodlesState- { results :: IORef TodoListResult,- dataPath :: FilePath- }--toodlesAPI :: Proxy ToodlesAPI-toodlesAPI = Proxy--slice :: Int -> Int -> [a] -> [a]-slice f t xs = take (t - f + 1) (drop f xs)--doUntilNull :: ([a] -> IO [a]) -> [a] -> IO ()-doUntilNull f xs = do- result <- f xs- if null result- then return ()- else doUntilNull f result--removeTodoFromCode :: MonadIO m => TodoEntry -> m ()-removeTodoFromCode = updateTodoLinesInFile (const [])---- | 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 -> [T.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--removeAndAdjust :: MonadIO io => [TodoEntry] -> io [TodoEntry]-removeAndAdjust [] = return []-removeAndAdjust (x:xs) = do- removeTodoFromCode x- forM xs $ \t ->- if (sourceFile t == sourceFile x) &&- (lineNumber t > lineNumber x)- then return $ t { lineNumber = lineNumber t - (fromIntegral . length $ body x)- }- else return t--deleteTodos :: ToodlesState -> DeleteTodoRequest -> Handler T.Text-deleteTodos (ToodlesState ref _) req = do- refVal@(TodoListResult r _) <- liftIO $ readIORef ref- let toDelete = filter (\t -> Main.id t `elem` ids req) r- liftIO $ doUntilNull removeAndAdjust toDelete- let updeatedResults =- refVal- { todos =- filter (\t -> Main.id t `notElem` map Main.id toDelete) r- }- _ <-- liftIO $ atomicModifyIORef' ref (const (updeatedResults, updeatedResults))- return "{}"--editTodos :: ToodlesState -> EditTodoRequest -> Handler T.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 = Main.id 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 -> [T.Text]-renderTodo t =- let comment =- fromJust $ lookup ("." <> getExtension (sourceFile t)) fileTypeToComment- detail =- "TODO (" <>- (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--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 :: T.Text -> [T.Text]-listIfNotNull "" = []-listIfNotNull s = [s]--root :: ToodlesState -> [T.Text] -> Handler BZ.Html-root (ToodlesState _ dPath) path =- if null path then- liftIO $ BZ.preEscapedToHtml <$> readFile (dPath ++ "/html/index.html")- else throwError $ err404 { errBody = "Not found" }--app :: ToodlesState -> Application-app s = serve toodlesAPI $ server s--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 attrs entryTags entryLeadingText) (TodoBodyLine l) =- TodoEntryHead i (b ++ [l]) a p n entryPriority attrs entryTags entryLeadingText-combineTodo _ _ = error "Can't combine todoEntry of these types"--data SourceFile = SourceFile- { fullPath :: FilePath- , sourceLines :: [T.Text]- } deriving (Show)--newtype AssigneeFilterRegex =- AssigneeFilterRegex T.Text- deriving (Show, Data, Eq)--newtype SearchFilter =- AssigneeFilter AssigneeFilterRegex- deriving (Show, Data, Eq)--data ToodlesArgs = ToodlesArgs- { directory :: FilePath- , assignee_search :: Maybe SearchFilter- , limit_results :: Int- , port :: Maybe Int- , no_server :: Bool- } deriving (Show, Data, Typeable, 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"- } &=- summary ("toodles " ++ showVersion version) &=- program "toodles" &=- verbosity &=- help "Manage TODO's directly from your codebase"--fileTypeToComment :: [(T.Text, T.Text)]-fileTypeToComment =- [ (".c", "//")- , (".cc", "//")- , (".clj", ";;")- , (".cpp", "//")- , (".cxx", "//")- , (".c++", "//")- , (".cs", "//") - , (".ex", "#")- , (".erl", "%")- , (".go", "//")- , (".h", "//")- , (".hh", "//")- , (".hpp", "//")- , (".hs", "--")- , (".hxx", "//")- , (".h++", "//")- , (".java", "//")- , (".js", "//")- , (".kt", "//")- , (".kts", "//")- , (".lua", "--")- , (".m", "//")- , (".php", "//")- , (".proto", "//")- , (".py", "#")- , (".rb", "#")- , (".rs", "//")- , (".scala", "//")- , (".sh", "#")- , (".swift", "///")- , (".ts", "//")- , (".txt", "")- , (".yaml", "#")- ]--unkownMarker :: T.Text-unkownMarker = "UNKNOWN-DELIMETER-UNKNOWN-DELIMETER-UNKNOWN-DELIMETER"--getCommentForFileType :: T.Text -> T.Text-getCommentForFileType extension =- fromMaybe unkownMarker $ lookup adjustedExtension fileTypeToComment- where- adjustedExtension =- if T.isPrefixOf "." extension- then extension- else "." <> extension--type Parser = Parsec Void T.Text--lexeme :: Parser a -> Parser a-lexeme = L.lexeme space--symbol :: T.Text -> Parser T.Text-symbol = L.symbol space--parseComment :: T.Text -> Parser TodoEntry-parseComment extension- = do- _ <- manyTill anyChar (symbol $ getCommentForFileType extension)- b <- many anyChar- return . TodoBodyLine $ T.pack b--integer :: Parser Integer-integer = lexeme $ L.signed space L.decimal--parsePriority :: Parser Integer-parsePriority = do- _ <- symbol "p="- integer--parseAssignee :: Parser String-parseAssignee = many (noneOf [')', '|', '='])---- TODO(avi|p=3|#cleanup) - fix and type this better-parseDetails ::- T.Text -> (Maybe T.Text, Maybe T.Text, [(T.Text, T.Text)], [T.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)--inParens :: Parser a -> Parser a-inParens = between (symbol "(") (symbol ")")--stringToMaybe :: T.Text -> Maybe T.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--prefixParserForFileType extension =- let comment = symbol . getCommentForFileType $ extension- orgMode =- (try $ symbol "****") <|> (try $ symbol "***") <|> (try $ symbol "**") <|>- (try $ symbol "*") <|>- (symbol "-")- in if extension == "org"- then orgMode- else comment--parseTodoEntryHead :: FilePath -> LineNumber -> Parser TodoEntry-parseTodoEntryHead path lineNum = do- entryLeadingText <- manyTill anyChar (prefixParserForFileType $ getExtension path)- _ <- symbol "TODO"- 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- otherDetails- entryTags- (T.pack entryLeadingText)--parseTodo :: FilePath -> LineNumber -> Parser TodoEntry-parseTodo path lineNum =- try (parseTodoEntryHead path lineNum) <|> parseComment (getExtension path)--getAllFiles :: ToodlesConfig -> FilePath -> IO [SourceFile]-getAllFiles config path =- E.catch- (do putStrLn $ printf "Running toodles for path: %s" path- files <- recurseDir SystemFS path- let validFiles = filter (isValidFile config) files- -- TODO(avi|p=3|#cleanup) - make sure it's a file first- 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 " ++ path ++ ": " ++ show e) >> return [])--fileHasValidExtension :: FilePath -> Bool-fileHasValidExtension path =- any (\ext -> ext `T.isSuffixOf` T.pack path) (map fst fileTypeToComment)--ignoreFile :: ToodlesConfig -> FilePath -> Bool-ignoreFile (ToodlesConfig ignoredPaths) file =- let p = T.pack file- in T.isInfixOf "node_modules" p || T.isSuffixOf "pb.go" p ||- T.isSuffixOf "_pb2.py" p ||- any (\r -> file =~ r :: Bool) ignoredPaths--getExtension :: FilePath -> T.Text-getExtension path = last $ T.splitOn "." (T.pack path)--isValidFile :: ToodlesConfig -> FilePath -> Bool-isValidFile config f =- fileHasValidExtension f && not (ignoreFile config f)--runTodoParser :: SourceFile -> [TodoEntry]-runTodoParser (SourceFile path ls) =- let parsedTodoLines =- map- (\(lineNum, lineText) -> parseMaybe (parseTodo path lineNum) lineText)- (zip [1 ..] ls)- groupedTodos = foldl foldTodoHelper ([], False) parsedTodoLines- in fst groupedTodos---- fold fn to concatenate todos that a multiple, single line comments-foldTodoHelper :: ([TodoEntry], Bool) -> Maybe TodoEntry -> ([TodoEntry], Bool)-foldTodoHelper (todoEntries :: [TodoEntry], currentlyBuildingTodoLines :: Bool) 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)--prettyFormat :: TodoEntry -> String-prettyFormat (TodoEntryHead _ l a p n entryPriority _ _ _) =- printf- "Assignee: %s\n%s%s:%d\n%s"- (fromMaybe "None" a)- (maybe "" (\x -> "Priority: " ++ show x ++ "\n") entryPriority)- p- n- (unlines $ map T.unpack l)-prettyFormat (TodoBodyLine _) = error "Invalid type for prettyFormat"--filterSearch :: Maybe SearchFilter -> (TodoEntry -> Bool)-filterSearch Nothing = const True-filterSearch (Just (AssigneeFilter (AssigneeFilterRegex query))) =- \entry -> fromMaybe "" (assignee entry) == query--limitSearch :: [TodoEntry] -> Int -> [TodoEntry]-limitSearch todoList limit =- if limit == 0- then todoList- else take limit todoList--runFullSearch :: ToodlesArgs -> IO TodoListResult-runFullSearch userArgs =- let projectRoot = directory userArgs- in do- 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- allFiles <- getAllFiles (fromRight (ToodlesConfig []) config) projectRoot- let parsedTodos = concatMap runTodoParser allFiles- filteredTodos =- filter (filterSearch (assignee_search userArgs)) parsedTodos- resultList = limitSearch filteredTodos $ limit_results userArgs- indexedResults =- map (\(i, r) -> r {Main.id = i}) $ zip [1 ..] resultList- return $ TodoListResult indexedResults ""--getFullSearchResults :: ToodlesState -> Bool -> IO TodoListResult-getFullSearchResults (ToodlesState ref _) recompute =- if recompute- then do- putStrLn "refreshing todo's"- userArgs <- cmdArgs argParser >>= setAbsolutePath- sResults <- runFullSearch userArgs- atomicModifyIORef' ref (const (sResults, sResults))- else putStrLn "cached read" >> readIORef ref--showRawFile :: ToodlesState -> Integer -> Handler BZ.Html-showRawFile (ToodlesState ref _) entryId = do- (TodoListResult r _) <- liftIO $ readIORef ref- let entry = find (\t -> Main.id t == entryId) r- liftIO $- maybe- (return "Not found")- (\e -> addAnchors <$> readFile (sourceFile e))- entry--addAnchors :: String -> BZ.Html-addAnchors s =- let codeLines = zip [1 ..] $ lines s- in BZ.preEscapedToHtml $- (unlines $- map- (\(i, l) -> printf "<pre><a name=\"line-%s\">%s</a></pre>" (show i) l)- codeLines)+import Server+import Types -setAbsolutePath :: ToodlesArgs -> IO ToodlesArgs-setAbsolutePath toodlesArgs =- let pathOrDefault =- if T.null . T.pack $ directory toodlesArgs- then "."- else directory toodlesArgs- in do absolute <- normalise_path <$> absolute_path pathOrDefault- return $ toodlesArgs {directory = absolute}+import Data.IORef (newIORef)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T (unpack)+import Network.Wai.Handler.Warp (run)+import System.Console.CmdArgs (cmdArgs)+import Text.Printf (printf) main :: IO () main = do@@ -597,3 +26,14 @@ dataDir <- (++ "/web") <$> getDataDir putStrLn $ "serving on " ++ show webPort run webPort $ app $ ToodlesState ref dataDir++prettyFormat :: TodoEntry -> String+prettyFormat (TodoEntryHead _ l a p n entryPriority _ _ _) =+ printf+ "Assignee: %s\n%s%s:%d\n%s"+ (fromMaybe "None" a)+ (maybe "" (\x -> "Priority: " ++ show x ++ "\n") entryPriority)+ p+ n+ (unlines $ map T.unpack l)+prettyFormat (TodoBodyLine _) = error "Invalid type for prettyFormat"
+ app/Parse.hs view
@@ -0,0 +1,204 @@+{-# 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)++fileTypeToComment :: [(Text, Text)]+fileTypeToComment =+ [ (".c", "//")+ , (".cc", "//")+ , (".clj", ";;")+ , (".cpp", "//")+ , (".cxx", "//")+ , (".c++", "//")+ , (".cs", "//")+ , (".ex", "#")+ , (".erl", "%")+ , (".go", "//")+ , (".h", "//")+ , (".hh", "//")+ , (".hpp", "//")+ , (".hs", "--")+ , (".hxx", "//")+ , (".h++", "//")+ , (".java", "//")+ , (".js", "//")+ , (".kt", "//")+ , (".kts", "//")+ , (".lua", "--")+ , (".m", "//")+ , (".php", "//")+ , (".proto", "//")+ , (".py", "#")+ , (".rb", "#")+ , (".rs", "//")+ , (".scala", "//")+ , (".sh", "#")+ , (".swift", "///")+ , (".ts", "//")+ , (".tsx", "//")+ , (".txt", "")+ , (".vue", "//")+ , (".yaml", "#")+ ]++runTodoParser :: SourceFile -> [TodoEntry]+runTodoParser (SourceFile path ls) =+ let parsedTodoLines =+ map+ (\(lineNum, lineText) -> parseMaybe (parseTodo 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 attrs entryTags entryLeadingText) (TodoBodyLine l) =+ TodoEntryHead i (b ++ [l]) a p n entryPriority 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 :: FilePath -> LineNumber -> Parser TodoEntry+parseTodo path lineNum = try parseTodoEntryHead+ <|> parseComment (getExtension path)++ where+ parseTodoEntryHead :: Parser TodoEntry+ parseTodoEntryHead = do+ entryLeadingText <- manyTill anyChar (prefixParserForFileType $ getExtension path)+ _ <- symbol "TODO"+ 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+ 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 view
@@ -0,0 +1,271 @@+{-# LANGUAGE DeriveAnyClass,+ DeriveGeneric,+ DataKinds,+ OverloadedStrings,+ ScopedTypeVariables,+ 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.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 GHC.Generics (Generic)+import Servant+import System.Console.CmdArgs+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++newtype ToodlesConfig = ToodlesConfig+ { ignore :: [FilePath]+ } deriving (Show, Generic, FromJSON) ++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 =+ "TODO (" <>+ (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]++-- | 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 updeatedResults =+ refVal+ { todos =+ filter (\t -> entryId t `notElem` map entryId toDelete) r+ }+ _ <- liftIO $ atomicModifyIORef' ref (const (updeatedResults, updeatedResults))+ return "{}"++ where+ doUntilNull :: ([a] -> IO [a]) -> [a] -> IO ()+ doUntilNull f xs = do+ result <- f xs+ if null result+ then return ()+ else doUntilNull f result++ removeAndAdjust :: MonadIO m => [TodoEntry] -> m [TodoEntry]+ removeAndAdjust [] = return []+ removeAndAdjust (x:xs) = do+ removeTodoFromCode x+ forM xs $ \t -> return $+ if (sourceFile t == sourceFile x) && (lineNumber t > lineNumber x)+ then t { lineNumber = lineNumber t - (fromIntegral . length $ body x)}+ else t ++ where+ removeTodoFromCode :: MonadIO m => TodoEntry -> m ()+ removeTodoFromCode = updateTodoLinesInFile (const [])++setAbsolutePath :: ToodlesArgs -> IO ToodlesArgs+setAbsolutePath toodlesArgs = do+ let pathOrDefault = if T.null . T.pack $ directory toodlesArgs+ then "."+ else directory toodlesArgs+ absolute <- normalise_path <$> absolute_path pathOrDefault+ return $ toodlesArgs {directory = absolute}++getFullSearchResults :: ToodlesState -> Bool -> IO TodoListResult+getFullSearchResults (ToodlesState ref _) recompute =+ if recompute+ then do+ putStrLn "refreshing todo's"+ userArgs <- cmdArgs argParser >>= 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+ allFiles <- getAllFiles (fromRight (ToodlesConfig []) config) projectRoot+ let parsedTodos = concatMap runTodoParser 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+ -- TODO(avi|p=3|#cleanup) - make sure it's a file first+ 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 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
+ app/Types.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveAnyClass,+ DeriveGeneric #-}++module Types where++import Data.Aeson (ToJSON, FromJSON)+import Data.IORef (IORef)+import Data.Text (Text)+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+ , customAttributes :: [(Text, Text)]+ , tags :: [Text]+ , leadingText :: Text }+ | TodoBodyLine Text+ deriving (Show, Generic, ToJSON)++data TodoListResult = TodoListResult+ { todos :: [TodoEntry]+ , message :: Text+ } deriving (Show, Generic, ToJSON)++newtype DeleteTodoRequest = DeleteTodoRequest+ { ids :: [Integer]+ } deriving (Show, Generic, FromJSON)++data EditTodoRequest = EditTodoRequest+ { editIds :: [Integer]+ , setAssignee :: Maybe Text+ , addTags :: [Text]+ , addKeyVals :: [(Text, Text)]+ , setPriority :: Maybe Integer+ } deriving (Show, Generic, FromJSON)
toodles.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: toodles-version: 0.1.0.14+version: 0.1.0.15 license: MIT copyright: 2018 Avi Press maintainer: mail@avi.press@@ -34,9 +34,14 @@ main-is: Main.hs hs-source-dirs: app other-modules:+ Config+ Parse+ Server+ ToodlesApi+ Types Paths_toodles default-language: Haskell2010- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -threaded -rtsopts -O3 -Wall -with-rtsopts=-N build-depends: MissingH >=1.4.0.1 && <1.5, aeson ==1.3.1.1,@@ -44,8 +49,6 @@ blaze-html ==0.9.1.1, cmdargs ==0.10.20, directory ==1.3.1.5,- filepath ==1.4.2,- http-types ==0.12.2, megaparsec ==6.5.0, regex-posix ==0.95.2, servant ==0.14.1,@@ -53,7 +56,6 @@ servant-server ==0.14.1, strict ==0.3.2, text ==1.2.3.1,- transformers ==0.5.5.0, wai ==3.2.1.2, warp ==3.2.25, yaml ==0.8.32