Haskell練習用TodoList. 覚えている範囲のスキルのみを使って作成. 実際にはもっと綺麗にできるはず.

todolist.hs

import System.IO
import System.Directory
import qualified Data.Map as M
import Data.List.Split

-- リストのリストを結合し、一つのリストにする
flatten :: [[a]] -> [a]
flatten [] = []
flatten (x:xs) = x ++ flatten xs

-- ユーザがシステムに対して要求するコマンドの型
data Command = Display | Append | Remove | Invalid | Exit deriving(Show, Eq)

-- 入力された文字列をコマンドに変換するときのread関数もどき
-- 早めにCommandをRead型クラスのインスタンスにしたほうがよい
readCommand :: String -> Command
readCommand "d" = Display
readCommand "a" = Append
readCommand "r" = Remove
readCommand "e" = Exit
readCommand _ = Invalid

-- Todo 1件あたりの型
type Title = String
type Detail = String
data Todo = Todo Title Detail deriving(Show, Eq)
fromString :: String -> Todo
fromString str = Todo title detail
  where splited = splitOn "," str
        title = head splited
        detail = unwords . tail $ splited

-- Todoを複数件まとめて取り扱うための型
type TodoNumber = Integer
type TodoList = M.Map TodoNumber Todo
fromList :: [String] -> TodoList
fromList strs = M.fromList $ zip [1..] todolist
  where todolist = map fromString strs

-- 指定されたファイルからTodoリストを読み込む
-- 存在しなかった場合は空のTodoリストを返却する
readTodo :: String -> IO TodoList
readTodo fileName = do
    has <- doesFileExist fileName
    if has then
      readTodoFromFile fileName
    else
      return . fromList $ []
  where readTodoFromFile fileName = do
        contents <- readFile fileName
        return . fromList $ lines contents

-- TodoListを指定されたファイル名で永続化する
writeTodo :: TodoList -> String -> IO ()
writeTodo list fileName = do
    removeFile fileName
    let writeList = M.foldr (\(Todo title detail) acc -> flatten [title, ",", detail] : acc) [] list
    writeFile fileName $ unlines writeList
    return ()

-- Todo一件を文字列化する
toStringTodo :: Todo -> String
toStringTodo (Todo title detail) = title ++ " :: " ++ detail

-- TodoListの中のTodoをナンバー付きで文字列化する
toStringTodoList :: TodoList -> [String]
toStringTodoList = M.foldrWithKey (\key val acc -> toStringRecord key val : acc) []
  where toStringRecord num todo = flatten [show num, " - ", toStringTodo todo]

-- 与えられたTodoListの中身をすべて表示する
printTodoList :: TodoList -> IO ()
printTodoList ts = sequence_ . map putStrLn $ toStringTodoList ts

-- 指定された番号のTodoListを削除する
removeTodoList :: TodoNumber -> TodoList -> TodoList
removeTodoList n = M.filterWithKey (\k v -> k /= n)

-- TodoをTodoListに追加する
addTodoList :: Todo -> TodoList -> TodoList
addTodoList t l = M.insert nextNumber t l
  where nextNumber = succ $ M.foldlWithKey (\acc k v -> max acc k) 0 l

-- ユーザから入力されたコマンド
type Arguments = [String]

-- ユーザから入力された文字列をパースし、コマンドと引数にする
parseCommand :: String -> (Command, Arguments)
parseCommand "" = (Invalid, [])
parseCommand raw = let ws = words raw in (readCommand $ head ws, tail ws)

-- コマンドを実行し、アプリケーションを続行するかを返却する関数
executeCommand :: TodoList -> Command -> Arguments -> IO (TodoList, Bool)
executeCommand ls cmd args
    | cmd == Append = if argsNum < 2 then
                          executeCommand ls Invalid []
                      else do
                          let (title, detail) = forAppendArgs args
                              l = addTodoList (Todo title detail) ls
                          executeCommand l Display []
    | cmd == Remove = if argsNum < 1 then
                          executeCommand ls Invalid []
                      else do
                          let removeNumber = forRemoveArg args
                              l = removeTodoList removeNumber ls
                          executeCommand l Display []
    | cmd == Display = printTodoList ls >> return (ls, True)
    | cmd == Invalid = putStrLn "Invalid command" >> return (ls, True)
    | cmd == Exit = return (ls, False)
  where argsNum = length args
        forAppendArgs as = (head as, unwords $ tail as)
        forRemoveArg as = read $ head as :: TodoNumber

-- ユーザからの入力を受け取り、処理を行うIOアクション
repl :: String -> TodoList -> IO TodoList
repl fileName ls = do
    putStr $ "Please Input Command(" ++ fileName ++ ") > "
    c <- getLine
    let (cmd, args) = parseCommand c
    (l, doContinue) <- executeCommand ls cmd args
    if doContinue then repl fileName l else return l

-- Todoリストアプリケーションのエントリポイント
-- ユーザからのファイル名指定のみをここでは行い、あとは他のところへ回している
main :: IO ()
main = do
    putStr "Please Input FileName > "
    fileName <- getLine
    list <- readTodo fileName
    l <- repl fileName list
    writeTodo l fileName
    putStrLn "bye"