test/recordings/renamePass/Desktop/simple.hs

   1 module Main where
   2
   3 main :: IO ()
   4 main = do
   5   let initialList = []
   6   interactWithUser initialList
   7
   8 type Item = String
   9 type Items = [Item]
  10
  11 data Command = Quit
  12              | DisplayItems
  13              | AddItem String
  14              | RemoveItem Int
  15              | Help
  16
  17 type Error = String
  18
  19 parseCommand :: String -> Either Error Command
  20 parseCommand line = case words line of
  21   ["quit"] -> Right Quit
  22   ["items"] -> Right DisplayItems
  23   "add" : item -> Right $ AddItem $ unwords item
  24   "remove" : i -> Right $ RemoveItem $ read $ unwords i
  25   ["help"] -> Right Help
  26   _ -> Left "Unknown command"
  27
  28 addItem :: Item -> Items -> Items
  29 addItem = (:)
  30
  31 displayItems :: Items -> String
  32 displayItems = unlines . map ("- " ++)
  33
  34 removeItem :: Int -> Items -> Either Error Items
  35 removeItem i items
  36   | i < 0 || i >= length items = Left "Out of range"
  37   | otherwise = Right result
  38   where (front, back) = splitAt (i + 1) items
  39         result = init front ++ back
  40
  41 interactWithUser :: Items -> IO ()
  42 interactWithUser items = do
  43   line <- getLine
  44   case parseCommand line of
  45     Right DisplayItems -> do
  46       putStrLn $ displayItems items
  47       interactWithUser items
  48
  49     Right (AddItem item) -> do
  50       let newItems = addItem item items
  51       putStrLn "Added"
  52       interactWithUser newItems
  53
  54     Right (RemoveItem i) ->
  55       case removeItem i items of
  56         Right newItems -> do
  57           putStrLn $ "Removed " ++ items !! i
  58           interactWithUser newItems
  59         Left err -> do
  60           putStrLn err
  61           interactWithUser items
  62
  63
  64     Right Quit -> return ()
  65
  66     Right Help -> do
  67       putStrLn "Commands:"
  68       putStrLn "help"
  69       putStrLn "items"
  70       putStrLn "add"
  71       putStrLn "quit"
  72       interactWithUser items
  73
  74     Left err -> do
  75       putStrLn $ "Error: " ++ err
  76       interactWithUser items