Last active
December 9, 2017 21:29
-
-
Save MichaelSnowden/fca1fad88ab2b296525408c8c2cc4e30 to your computer and use it in GitHub Desktop.
Haskell Todo list CLI
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Data.List | |
import Prelude hiding (id, pure) | |
import System.Directory | |
import System.Exit | |
import System.IO | |
import System.IO.Error | |
import System.Process | |
import Text.Read | |
data Route | |
= All | |
| Active | |
| Completed | |
deriving (Show, Read) | |
data Action | |
= Usage | |
| Add String | |
| Toggle Int | |
| Edit Int | |
String | |
| Delete Int | |
| View Route | |
| Quit | |
deriving (Show, Read) | |
data Task = Task | |
{ text :: String | |
, id :: Int | |
, completed :: Bool | |
} deriving (Show, Read) | |
data State = State | |
{ route :: Route | |
, uid :: Int | |
, tasks :: [Task] | |
} deriving (Show, Read) | |
type Effect = IO () | |
emptyState :: State | |
emptyState = State {uid = 0, route = All, tasks = []} | |
main = do | |
homeDirectory <- getHomeDirectory | |
let filePath = homeDirectory ++ "/.taskmanagerState.hs" in do | |
maybeSerializedState <- readFileMaybe filePath | |
case maybeSerializedState of | |
Nothing -> do | |
repl filePath (putStrLn $ "Failed to load \"" ++ filePath ++ "\". Will create file after first action.") emptyState | |
Just serializedState -> | |
case (readMaybe serializedState) of | |
Just state -> repl filePath noOp state | |
Nothing -> do | |
repl filePath (putStrLn $ "Failed to parse state at \"" ++ filePath ++ "\". Corrupted file?") emptyState | |
readFileMaybe :: FilePath -> IO (Maybe String) | |
readFileMaybe filePath = | |
tryIOError (readFile filePath) >>= handler | |
where handler (Right contents) = return (Just contents) | |
handler (Left _) = return Nothing | |
repl :: FilePath -> Effect -> State -> Effect | |
repl filePath effect state = do | |
system "clear" | |
effect | |
putStrLn $ "Using: " ++ filePath | |
putStrLn $ view state | |
putStr "Enter an action: " | |
line <- getLine | |
case (readMaybe line) of | |
Just action -> | |
let (updated, effect) = update action state | |
in do writeFile filePath (show updated) | |
repl filePath effect updated | |
Nothing -> do | |
repl filePath (putStrLn $ "Unrecognized action: " ++ line ++ "\n" ++ usage) state | |
usage = | |
unlines | |
[ "Usage:" | |
, "\tAdd \"Learn Haskell\" (double quotes necessary)" | |
, "\tToggle 0 (mark as complete / incomplete)" | |
, "\tEdit 0 \"Updated task name\" (double quotes necessary)" | |
, "\tDelete 0" | |
, "\tView All / Active / Completed" | |
, "\tQuit" | |
] | |
view :: State -> String | |
view state | |
| length (tasks state) == 0 = "No tasks!\n" ++ usage | |
| otherwise = | |
let filtered = (filterState state) | |
in (show (route filtered) ++ " tasks") ++ | |
"\n" ++ (intercalate "\n" $ map viewTask $ tasks filtered) | |
viewTask :: Task -> String | |
viewTask task = | |
(show $ id task) ++ | |
" " ++ | |
(text task) ++ | |
(if (completed task) | |
then " ✔" | |
else "") | |
filterState :: State -> State | |
filterState state = | |
case (route state) of | |
All -> state | |
Active -> state {tasks = filter (not . completed) (tasks state)} | |
Completed -> state {tasks = filter completed (tasks state)} | |
update :: Action -> State -> (State, Effect) | |
update action state = | |
case action of | |
Add text -> pure $ add text state | |
Toggle id' -> pure state {tasks = updateId id' toggle (tasks state)} | |
Edit id' text -> pure state {tasks = updateId id' (edit text) (tasks state)} | |
Delete id' -> pure state {tasks = deleteId id' (tasks state)} | |
View All -> pure state {route = All} | |
View Active -> pure state {route = Active} | |
View Completed -> pure state {route = Completed} | |
Usage -> (state, putStrLn usage) | |
Quit -> (state, exitSuccess) | |
noOp :: IO () | |
noOp = return () | |
pure :: State -> (State, Effect) | |
pure state = (state, noOp) | |
add :: String -> State -> State | |
add text state = | |
state | |
{ uid = (uid state) + 1 | |
, tasks = | |
(tasks state) ++ [Task {text = text, completed = False, id = (uid state)}] | |
} | |
edit :: String -> Task -> Task | |
edit text task = task {text = text} | |
toggle :: Task -> Task | |
toggle task = task {completed = (not $ completed task)} | |
updateId :: Int -> (Task -> Task) -> [Task] -> [Task] | |
updateId id' update tasks = map updateIfTarget tasks | |
where | |
updateIfTarget task | |
| (id task) == id' = update task | |
| otherwise = task | |
deleteId :: Int -> [Task] -> [Task] | |
deleteId id' tasks = filter ((/= id') . id) tasks |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment