{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Exception (IOException, catch)
import Control.Monad (when)
import Data.List (intersperse, intercalate)
import Data.Monoid (mconcat)
import Options.Applicative
import qualified Text.Parsec as P
import qualified Text.Parsec.String
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.Directory (createDirectoryIfMissing, doesFileExist, getDirectoryContents, removeFile)
import System.Process (readProcess)
import Text.PrettyPrint hiding ((<>), empty)
import qualified Text.PrettyPrint as Pretty
import qualified Paths_git_checklist as V
import Data.Version (showVersion)
-- Git stuff. Find the branch we're on and the .git directory.
git :: String -> IO [String]
git args = lines <$> readProcess "git" (words args) []
`catch` \(_ :: IOException) -> do
putStrLn "Something went wrong, maybe you're not in a Git repository?"
exitFailure
getBranch, getGitDir :: IO String
getBranch = head <$> git "symbolic-ref --short HEAD"
getGitDir = head <$> git "rev-parse --show-cdup" >>= \move -> return $ move ++ ".git"
listBranches :: IO [String]
listBranches = do
root <- getGitDir
filter (`notElem` [".",".."]) <$> getDirectoryContents (root </> "checklist")
`catch` \(_ :: IOException) -> return []
-- Data structures!
data ToDo = ToDo { description :: String
, complete :: Bool
} deriving (Eq, Read, Show)
data Checklist = Checklist { branchRef :: String
, todos :: [ToDo]
} deriving (Eq,Show)
-- Loading and saving data (by cheating).
putChecklist :: Checklist -> IO ()
putChecklist checklist = do
root <- getGitDir
let listdir = root </> "checklist"
output = todos checklist
createDirectoryIfMissing False listdir
if null output
then removeFile (listdir </> branchRef checklist) `catch`
(\(_ :: IOError) -> putStrLn "Error cleaning up checklist file in .git/checklist/")
else writeFile (listdir </> branchRef checklist) (printChecklist checklist)
`catch` \(_ :: IOException) -> putStrLn "Error writing checklist file."
getChecklist :: String -> IO Checklist
getChecklist branch = do
root <- getGitDir
let path = root </> "checklist" </> branch
exists <- doesFileExist path
if exists
then do contents <- readFile path
case P.parse parseChecklist path contents of
Left err -> error $ show err
Right todolist -> return $ Checklist branch todolist
else return (Checklist branch [])
-- TODO
-- quickcheck property: roundtrip
-- parseChecklist . printChecklist (Checklist _ x) == x
parseChecklist :: P.Parsec String () [ToDo]
parseChecklist = parseTodo `P.sepEndBy` P.newline
where checkmark = P.char '[' *> P.anyChar <* P.char ']' <* P.space
remaining = P.many1 (P.noneOf "\n")
parseTodo = do done <- ('x'==) <$> checkmark
what <- remaining
return $ ToDo { description = what, complete = done }
printChecklist :: Checklist -> String
printChecklist = renderStyle noBreaks . vcat . map prettyTodo . todos
where noBreaks = style { mode = LeftMode }
upgradeFileFormat :: IO ()
upgradeFileFormat = do
branchNames <- listBranches
putStrLn $ "Processing " ++ (show (length branchNames)) ++ " files..."
mapM_ upgradeOldFormat branchNames
where
upgradeOldFormat branch = do
root <- getGitDir
let path = root </> "checklist" </> branch
exists <- doesFileExist path
if exists
then do contents <- readFile path
putChecklist $ Checklist branch $ read contents
else putStrLn $ "Failed reading branch " ++ branch
-- Operations: Adding, removing, marking done and not done.
change :: Act -> Checklist -> Checklist
change (Add desc) (Checklist b ts) = Checklist b (ToDo desc False:ts)
change (Remove n) (Checklist b ts) = let del = map snd . filter (\i -> n /= fst i)
in Checklist b (del `withNumbered` ts)
change (Done n) (Checklist b ts) = Checklist b (mark True n `withNumbered` ts)
change (Undo n) (Checklist b ts) = Checklist b (mark False n `withNumbered` ts)
withNumbered :: ([(Int,a)] -> [a]) -> [a] -> [a]
f `withNumbered` as = f $ zip [1..] as
mark :: Bool -> Int -> [(Int,ToDo)] -> [ToDo]
mark v n = map f
where f (i,t) | i == n = t { complete = v }
| otherwise = t
-- Pretty printing! Copes with up to 99 items :-)
view :: Observe -> Checklist -> Doc
view List checklist = prettyChecklist checklist
view Stats (Checklist _ []) = text "No tasks defined yet"
view Stats (Checklist _ ts) = tasksToDo <+> parens (int (length ts) <+> text "in total")
where tasksToDo = case length $ filter (not . complete) ts of
0 -> text "Nothing to do!"
1 -> text "1 task left!"
n -> int n <+> text "tasks to do"
prettyTodo :: ToDo -> Doc
prettyTodo t = brackets xmark <+> text (description t)
where xmark = if complete t then char 'x' else space
prettyChecklist :: Checklist -> Doc
prettyChecklist = vcat . zipWith rightAlign [1..] . map prettyTodo . todos
where rightAlign i doc = nest (shiftInt i) $ hcat [int i, colon, space, doc]
shiftInt n = if n < 10 then 1 else 0 -- Over 100 TODOs is silly.
-- Overall control actions
updateWith :: Act -> [Checklist] -> IO [Checklist]
updateWith a [c] = let c' = change a c
in when (c' /= c) (putChecklist c') >> return [c']
viewWith :: Observe -> [Checklist] -> Doc
viewWith o [] = Pretty.empty
viewWith o [c] = view o c
viewWith o cs = vcat $ vsep $ map (\c -> text (branchRef c) $+$ view o c) cs
where vsep = punctuate (char '\n') -- join list with blank lines
usingArgs :: Option -> IO ()
usingArgs (Option loc behaviour) = loc2checklist loc >>= operation
where
operation :: [Checklist] -> IO ()
operation = either (\o cs -> print (viewWith o cs))
(\a cs -> updateWith a cs >>= print . viewWith List)
behaviour
loc2checklist :: Location -> IO [Checklist]
loc2checklist All = listBranches >>= mapM getChecklist
loc2checklist Head = getBranch >>= getChecklist >>= \c -> return [c]
loc2checklist (Named b) = mapM getChecklist [b]
-- Define command line flags and options
data Option = Option Location (Either Observe Act) deriving Show
data Location = Head | Named String | All deriving Show
data Observe = List | Stats deriving Show
data Act = Add String | Remove Int | Done Int | Undo Int deriving Show
cli_observers :: Mod CommandFields Option
cli_observers =
command "show"
(info (Option <$> common <*> show_list)
(progDesc "Show current TODOs"))
<> command "stats"
(info (Option <$> common <*> show_stats)
(progDesc "Summary statistics of checklist"))
where
common = location True -- can have apply to many branches
show_list = pure (Left List)
show_stats = pure (Left Stats)
cli_actors :: Mod CommandFields Option
cli_actors = mconcat
[ command "add" (info (Option <$> common <*> add)
(progDesc "Add a TODO"))
, command "done" (info (Option <$> common <*> done)
(progDesc "Mark a TODO as done."))
, command "undo" (info (Option <$> common <*> undo)
(progDesc "Item needs redone!"))
, command "remove" (info (Option <$> common <*> remove)
(progDesc "Remove a TODO (can't be undone)"))
]
where add = Right . Add . unwords <$> arguments str (metavar "DESCRIPTION")
remove = Right . Remove <$> argument auto (metavar "N")
done = Right . Done <$> argument auto (metavar "N")
undo = Right . Undo <$> argument auto (metavar "N")
common = location False -- cannot apply to many branches
location :: Bool -> Parser Location
location many = nullOption (value Head <> internal)
<|> Named <$> strOption (long "branch" <> short 'b' <> metavar "BRANCH")
<|> if many then allbranches else empty
where allbranches = flag' All (long "all" <> short 'a' <> metavar "")
argParser :: ParserInfo Option
argParser = info (helper <*> version <*> cli)
(progDesc "Per-branch TODO list for Git repositories")
where blank :: Parser Option -- user enters no arguments
blank = nullOption (value (Option Head (Left List)) <> internal)
cli = blank <|> hsubparser (cli_observers <> cli_actors)
version = flip abortOption (long "version" <> short 'v' <> help "Show version")
(InfoMsg $ "git-checklist v" ++ showVersion V.version)
main :: IO ()
main = do
args <- getArgs
case args of
["--upgrade"] -> upgradeFileFormat --secret option
_ -> execParser argParser >>= usingArgs