Start work on swapping out files

[lsp-test.git] / test / files / simple.hs

diff --git a/test/files/simple.hs b/test/files/simple.hs
new file mode 100644 (file)
index 0000000..f58bbd0
--- /dev/null
+++ b/test/files/simple.hs
@@ -0,0 +1,76 @@
+module Main where
+
+main :: IO ()
+main = do
+  let initialList = []
+  interactWithUser initialList
+
+type Item = String
+type Items = [Item]
+
+data Command = Quit
+             | DisplayItems
+             | AddItem String
+             | RemoveItem Int
+             | Help
+
+type Error = String
+
+parseCommand :: String -> Either Error Command
+parseCommand line = case words line of
+  ["quit"] -> Right Quit
+  ["items"] -> Right DisplayItems
+  "add" : item -> Right $ AddItem $ unwords item
+  "remove" : i -> Right $ RemoveItem $ read $ unwords i
+  ["help"] -> Right Help
+  _ -> Left "Unknown command"
+
+addItem :: Item -> Items -> Items
+addItem = (:)
+
+displayItems :: Items -> String
+displayItems = unlines . map ("- " ++)
+
+removeItem :: Int -> Items -> Either Error Items
+removeItem i items
+  | i < 0 || i >= length items = Left "Out of range"
+  | otherwise = Right result
+  where (front, back) = splitAt (i + 1) items
+        result = init front ++ back
+
+interactWithUser :: Items -> IO ()
+interactWithUser items = do
+  line <- getLine
+  case parseCommand line of
+    Right DisplayItems -> do
+      putStrLn $ displayItems items
+      interactWithUser items
+
+    Right (AddItem item) -> do
+      let newItems = addItem item items
+      putStrLn "Added"
+      interactWithUser newItems
+
+    Right (RemoveItem i) ->
+      case removeItem i items of
+        Right newItems -> do
+          putStrLn $ "Removed " ++ items !! i
+          interactWithUser newItems
+        Left err -> do
+          putStrLn err
+          interactWithUser items
+
+
+    Right Quit -> return ()
+
+    Right Help -> do
+      putStrLn "Commands:"
+      putStrLn "help"
+      putStrLn "items"
+      putStrLn "add"
+      putStrLn "quit"
+      interactWithUser items
+
+    Left err -> do
+      putStrLn $ "Error: " ++ err
+      interactWithUser items