Merge pull request #41 from damiencourousse/flags

add support for Flags

.toodles.yaml

@@ -4,3 +4,6 @@
 ignore:
 - test.js
 - stack-work
+
+flags:
+- MAYBE

app/Config.hs

@@ -1,23 +1,34 @@
-{-# LANGUAGE DeriveDataTypeable,
-             DataKinds,
-             OverloadedStrings,
-             ScopedTypeVariables,
-             TypeOperators #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveDataTypeable  #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
 
-module Config where
+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 =
@@ -34,6 +45,7 @@ argParser = ToodlesArgs
           , 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

app/Main.hs

@@ -11,15 +11,14 @@ 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
-  userArgs <- cmdArgs argParser >>= setAbsolutePath
+  userArgs <- toodlesArgs >>= setAbsolutePath
   sResults <- runFullSearch userArgs
   case userArgs of
-    (ToodlesArgs _ _ _ _ True) -> mapM_ (putStrLn . prettyFormat) $ todos sResults
+    (ToodlesArgs _ _ _ _ True _) -> mapM_ (putStrLn . prettyFormat) $ todos sResults
     _ -> do
           let webPort = fromMaybe 9001 $ port userArgs
           ref <- newIORef sResults
@@ -28,12 +27,13 @@ main = do
           run webPort $ app $ ToodlesState ref dataDir
 
 prettyFormat :: TodoEntry -> String
-prettyFormat (TodoEntryHead _ l a p n entryPriority _ _ _) =
+prettyFormat (TodoEntryHead _ l a p n entryPriority f _ _ _) =
   printf
-    "Assignee: %s\n%s%s:%d\n%s"
+    "Assignee: %s\n%s%s:%d\n%s - %s"
     (fromMaybe "None" a)
     (maybe "" (\x -> "Priority: " ++ show x ++ "\n") entryPriority)
     p
     n
+    (show f)
     (unlines $ map T.unpack l)
 prettyFormat (TodoBodyLine _) = error "Invalid type for prettyFormat"

app/Parse.hs

@@ -63,6 +63,21 @@ parseDetails toParse =
       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", "//")
@@ -102,16 +117,16 @@ fileTypeToComment =
   , (".yaml", "#")
   ]
 
-runTodoParser :: SourceFile -> [TodoEntry]
-runTodoParser (SourceFile path ls) =
+runTodoParser :: [UserFlag] -> SourceFile -> [TodoEntry]
+runTodoParser us (SourceFile path ls) =
   let parsedTodoLines =
         map
-          (\(lineNum, lineText) -> parseMaybe (parseTodo path lineNum) lineText)
+          (\(lineNum, lineText) -> parseMaybe (parseTodo us path lineNum) lineText)
           (zip [1 ..] ls)
       groupedTodos = foldl foldTodoHelper ([], False) parsedTodoLines
   in fst groupedTodos
 
-    where
+  where
     -- fold fn to concatenate todos that a multiple, single line comments
     foldTodoHelper :: ([TodoEntry], Bool) -> Maybe TodoEntry -> ([TodoEntry], Bool)
     foldTodoHelper (todoEntries, currentlyBuildingTodoLines) maybeTodo
@@ -124,7 +139,7 @@ runTodoParser (SourceFile path ls) =
             (init todoEntries ++ [combineTodo (last todoEntries) (fromJust maybeTodo)], True)
         | otherwise = (todoEntries, False)
 
-            where
+          where
             isEntryHead :: TodoEntry -> Bool
             isEntryHead TodoEntryHead {} = True
             isEntryHead _                = False
@@ -134,8 +149,8 @@ runTodoParser (SourceFile path ls) =
             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 (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
@@ -162,15 +177,14 @@ 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
+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)
-        _ <- symbol "TODO"
+        f <- parseFlag uf
         entryDetails <- optional $ try (inParens $ many (noneOf [')', '(']))
         let parsedDetails = parseDetails . T.pack <$> entryDetails
             entryPriority = (readMaybe . T.unpack) =<< (snd4 =<< parsedDetails)
@@ -187,6 +201,7 @@ parseTodo path lineNum = try parseTodoEntryHead
             path
             lineNum
             entryPriority
+            f
             otherDetails
             entryTags
             (T.pack entryLeadingText)

app/Server.hs

@@ -26,7 +26,6 @@ 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
@@ -37,8 +36,9 @@ import qualified Text.Blaze.Html5       as BZ
 import           Text.Printf
 import           Text.Regex.Posix
 
-newtype ToodlesConfig = ToodlesConfig
+data ToodlesConfig = ToodlesConfig
   { ignore :: [FilePath]
+  , flags  :: [UserFlag]
   } deriving (Show, Generic, FromJSON)
 
 app :: ToodlesState -> Application
@@ -115,7 +115,7 @@ renderTodo t =
   let comment =
         fromJust $ lookup ("." <> getExtension (sourceFile t)) fileTypeToComment
       detail =
-        "TODO (" <>
+        renderFlag (flag t) <> " (" <>
         (T.pack $
          Data.String.Utils.join
            "|"
@@ -129,7 +129,7 @@ renderTodo t =
       mapHead (\l -> leadingText t <> l) $
         mapInit (\l -> foldl (<>) "" [" " | _ <- [1..(T.length $ leadingText t)]] <> l) commented
 
-    where
+  where
     mapHead :: (a -> a) -> [a] -> [a]
     mapHead f (x:xs) = f x : xs
     mapHead _ xs     = xs
@@ -142,6 +142,12 @@ renderTodo t =
     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 ()
@@ -201,19 +207,19 @@ deleteTodos (ToodlesState ref _) req = do
         removeTodoFromCode = updateTodoLinesInFile (const [])
 
 setAbsolutePath :: ToodlesArgs -> IO ToodlesArgs
-setAbsolutePath toodlesArgs = do
-    let pathOrDefault = if T.null . T.pack $ directory toodlesArgs
+setAbsolutePath args = do
+    let pathOrDefault = if T.null . T.pack $ directory args
                             then "."
-                            else directory toodlesArgs
+                            else directory args
     absolute <- normalise_path <$> absolute_path pathOrDefault
-    return $ toodlesArgs {directory = absolute}
+    return $ args {directory = absolute}
 
 getFullSearchResults :: ToodlesState -> Bool -> IO TodoListResult
 getFullSearchResults (ToodlesState ref _) recompute =
   if recompute
     then do
       putStrLn "refreshing todo's"
-      userArgs <- cmdArgs argParser >>= setAbsolutePath
+      userArgs <- toodlesArgs >>= setAbsolutePath
       sResults <- runFullSearch userArgs
       atomicModifyIORef' ref (const (sResults, sResults))
     else putStrLn "cached read" >> readIORef ref
@@ -224,11 +230,12 @@ runFullSearch userArgs = do
     configExists <- doesFileExist $ projectRoot ++ "/.toodles.yaml"
     config <- if configExists
         then Y.decodeFileEither (projectRoot ++ "/.toodles.yaml")
-        else return . Right $ ToodlesConfig []
+        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
+    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
@@ -244,7 +251,7 @@ runFullSearch userArgs = do
     limitSearch todoList n = take n todoList
 
 getAllFiles :: ToodlesConfig -> FilePath -> IO [SourceFile]
-getAllFiles (ToodlesConfig ignoredPaths) basePath =
+getAllFiles (ToodlesConfig ignoredPaths _) basePath =
   E.catch
     (do putStrLn $ printf "Running toodles for path: %s" basePath
         files <- recurseDir SystemFS basePath

app/Types.hs

@@ -1,12 +1,19 @@
-{-# LANGUAGE DeriveAnyClass,
-             DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
 
 module Types where
 
-import Data.Aeson             (ToJSON, FromJSON)
-import Data.IORef             (IORef)
-import Data.Text              (Text)
-import GHC.Generics           (Generic)
+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
@@ -27,25 +34,64 @@ data TodoEntry
                   , sourceFile       :: FilePath
                   , lineNumber       :: LineNumber
                   , priority         :: Maybe Integer
+                  , flag             :: Flag
                   , customAttributes :: [(Text, Text)]
                   , tags             :: [Text]
                   , leadingText      :: Text }
   | TodoBodyLine Text
-  deriving (Show, Generic, ToJSON)
+  deriving (Show, Generic)
+instance ToJSON TodoEntry
 
 data TodoListResult = TodoListResult
   { todos   :: [TodoEntry]
   , message :: Text
-  } deriving (Show, Generic, ToJSON)
+  } deriving (Show, Generic)
+instance ToJSON TodoListResult
 
 newtype DeleteTodoRequest = DeleteTodoRequest
   { ids :: [Integer]
-  } deriving (Show, Generic, FromJSON)
+  } 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, FromJSON)
+  } 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

package.yaml

@@ -26,7 +26,10 @@ description:
     your TODO\'s with an easy to use web application. When you make changes via
     toodles, the edits will be applied directly the TODO entries in your code.
     When you\'re done, commit and push your changes to share them with your team!
-
+
+ghc-options:
+  - -Wall
+  - -Wcompat
 
 dependencies:
 - base >= 4.0 && < 5