lsp-test 0.14.0.0 → 0.14.0.1
raw patch · 17 files changed
+436/−36 lines, 17 filesdep ~basedep ~lsp-types
Dependency ranges changed: base, lsp-types
Files
- ChangeLog.md +9/−0
- LICENSE +1/−1
- lsp-test.cabal +9/−8
- src/Language/LSP/Test.hs +38/−6
- src/Language/LSP/Test/Decoding.hs +4/−13
- src/Language/LSP/Test/Exceptions.hs +3/−0
- src/Language/LSP/Test/Parsing.hs +1/−1
- src/Language/LSP/Test/Session.hs +2/−3
- test/DummyServer.hs +35/−2
- test/Test.hs +44/−2
- test/data/Error.hs +2/−0
- test/data/Format.hs +4/−0
- test/data/Rename.hs +2/−0
- test/data/documentSymbolFail/example/Main.hs +128/−0
- test/data/refactor/Main.hs +2/−0
- test/data/renameFail/Desktop/simple.hs +76/−0
- test/data/renamePass/Desktop/simple.hs +76/−0
ChangeLog.md view
@@ -1,5 +1,14 @@ # Revision history for lsp-test +## 0.14.0.1 -- 2021-07-30++* Catch IO exception when sending messages to server (#317) (@berberman)+* Improve error messages on JSON decode failures (#320) (@strager)+* Add tests for satisfyMaybe (#325) (@strager)+* Add call hierarchy support (@July541)+* pass the lspConfig at initialization time as well (@pepeiborra)+* Semantic tokens support (@michaelpj)+ ## 0.13.0.0 -- 2021-03-26 * Update for lsp-types-1.2 (@wz1000)
LICENSE view
@@ -1,4 +1,4 @@-Copyright Luke Lau 2018-2020.+Copyright Luke Lau 2018-2021. All rights reserved. Redistribution and use in source and binary forms, with or without
lsp-test.cabal view
@@ -1,16 +1,17 @@+cabal-version: 2.4 name: lsp-test-version: 0.14.0.0+version: 0.14.0.1 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against <https://microsoft.github.io/language-server-protocol/ Language Server Protocol servers>. @Language.LSP.Test@ launches your server as a subprocess and allows you to simulate a session- down to the wire. + down to the wire. To see examples of it in action, check out <https://github.com/haskell/haskell-ide-engine haskell-ide-engine>, <https://github.com/haskell/haskell-language-server haskell-language-server> and <https://github.com/digital-asset/ghcide ghcide>. homepage: https://github.com/haskell/lsp/blob/master/lsp-test/README.md-license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Luke Lau maintainer: luke_lau@icloud.com@@ -18,9 +19,9 @@ copyright: 2021 Luke Lau category: Testing build-type: Simple-cabal-version: 2.0 extra-source-files: README.md , ChangeLog.md+ , test/data/**/*.hs tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 8.10.2 source-repository head@@ -35,7 +36,7 @@ , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5- , lsp-types == 1.2.*+ , lsp-types == 1.3.* , aeson , time , aeson-pretty@@ -98,7 +99,7 @@ main-is: FuncTest.hs hs-source-dirs: func-test type: exitcode-stdio-1.0- build-depends: base <4.15+ build-depends: base <4.16 , lsp-test , lsp , data-default@@ -109,7 +110,7 @@ , async default-language: Haskell2010 -test-suite example +test-suite example main-is: Test.hs hs-source-dirs: example type: exitcode-stdio-1.0@@ -123,7 +124,7 @@ main-is: SimpleBench.hs hs-source-dirs: bench type: exitcode-stdio-1.0- build-depends: base <4.15+ build-depends: base <4.16 , lsp-test , lsp , process
src/Language/LSP/Test.hs view
@@ -40,7 +40,7 @@ , sendRequest , sendNotification , sendResponse- -- * Receving+ -- * Receiving , module Language.LSP.Test.Parsing -- * Utilities -- | Quick helper functions for common tasks.@@ -92,6 +92,12 @@ , applyEdit -- ** Code lenses , getCodeLenses+ -- ** Call hierarchy+ , prepareCallHierarchy+ , incomingCalls+ , outgoingCalls+ -- ** SemanticTokens+ , getSemanticTokens -- ** Capabilities , getRegisteredCapabilities ) where@@ -163,7 +169,7 @@ -- -- > (hinRead, hinWrite) <- createPipe -- > (houtRead, houtWrite) <- createPipe--- > +-- > -- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition -- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do -- > -- ...@@ -196,7 +202,7 @@ (Just lspTestClientInfo) (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir)- Nothing+ (lspConfig config') caps (Just TraceOff) (List <$> initialWorkspaceFolders config)@@ -398,7 +404,7 @@ regs = concatMap pred $ Map.elems dynCaps watchHits :: FileSystemWatcher -> Bool watchHits (FileSystemWatcher pattern kind) =- -- If WatchKind is exlcuded, defaults to all true as per spec+ -- If WatchKind is excluded, defaults to all true as per spec fileMatches (T.unpack pattern) && createHits (fromMaybe (WatchKind True True True) kind) fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs@@ -603,7 +609,7 @@ let supportsDocChanges = fromMaybe False $ do let mWorkspace = caps ^. LSP.workspace- C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace+ C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ _ <- mWorkspace C.WorkspaceEditClientCapabilities mDocChanges _ _ _ _ <- mEdit mDocChanges @@ -656,7 +662,7 @@ getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. -> Session ([Location] |? [LocationLink])-getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams +getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams -- | Returns the type definition(s) for the term at the specified position. getImplementations :: TextDocumentIdentifier -- ^ The document the term is in.@@ -739,6 +745,32 @@ rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId) case getResponseResult rsp of List res -> pure res++-- | Pass a param and return the response from `prepareCallHierarchy`+prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem]+prepareCallHierarchy = resolveRequestWithListResp STextDocumentPrepareCallHierarchy++incomingCalls :: CallHierarchyIncomingCallsParams -> Session [CallHierarchyIncomingCall]+incomingCalls = resolveRequestWithListResp SCallHierarchyIncomingCalls++outgoingCalls :: CallHierarchyOutgoingCallsParams -> Session [CallHierarchyOutgoingCall]+outgoingCalls = resolveRequestWithListResp SCallHierarchyOutgoingCalls++-- | Send a request and receive a response with list.+resolveRequestWithListResp :: (ResponseResult m ~ Maybe (List a))+ => SClientMethod m -> MessageParams m -> Session [a]+resolveRequestWithListResp method params = do+ rsp <- request method params+ case getResponseResult rsp of+ Nothing -> pure []+ Just (List x) -> pure x++-- | Pass a param and return the response from `prepareCallHierarchy`+getSemanticTokens :: TextDocumentIdentifier -> Session (Maybe SemanticTokens)+getSemanticTokens doc = do+ let params = SemanticTokensParams Nothing Nothing doc+ rsp <- request STextDocumentSemanticTokensFull params+ pure $ getResponseResult rsp -- | Returns a list of capabilities that the server has requested to /dynamically/ -- register during the 'Session'.
src/Language/LSP/Test/Decoding.hs view
@@ -24,16 +24,6 @@ import Data.IxMap import Data.Kind -getAllMessages :: Handle -> IO [B.ByteString]-getAllMessages h = do- done <- hIsEOF h- if done- then return []- else do- msg <- getNextMessage h-- (msg :) <$> getAllMessages h- -- | Fetches the next message bytes based on -- the Content-Length header getNextMessage :: Handle -> IO B.ByteString@@ -83,15 +73,16 @@ _ -> acc decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)-decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj+decodeFromServerMsg reqMap bytes = unP $ parse p obj where obj = fromJust $ decode bytes :: Value p = parseServerMessage $ \lid -> let (mm, newMap) = pickFromIxMap lid reqMap in case mm of Nothing -> Nothing Just m -> Just $ (m, Pair m (Const newMap))- unP (FromServerMess m msg) = (reqMap, FromServerMess m msg)- unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg)+ unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg)+ unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg)+ unP (Error e) = error e {- WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"
src/Language/LSP/Test/Exceptions.hs view
@@ -19,6 +19,7 @@ | UnexpectedResponseError SomeLspId ResponseError | UnexpectedServerTermination | IllegalInitSequenceMessage FromServerMessage+ | MessageSendError Value IOError deriving Eq instance Exception SessionException@@ -53,6 +54,8 @@ show (IllegalInitSequenceMessage msg) = "Received an illegal message between the initialize request and response:\n" ++ B.unpack (encodePretty msg)+ show (MessageSendError msg e) =+ "IO exception:\n" ++ show e ++ "\narose while trying to send message:\n" ++ B.unpack (encodePretty msg) -- | A predicate that matches on any 'SessionException' anySessionException :: SessionException -> Bool
src/Language/LSP/Test/Parsing.hs view
@@ -48,7 +48,7 @@ -- -- 'Language.LSP.Test.Session' is actually just a parser -- that operates on messages under the hood. This means that you--- can create and combine parsers to match speicifc sequences of+-- can create and combine parsers to match specific sequences of -- messages that you expect. -- -- For example, if you wanted to match either a definition or
src/Language/LSP/Test/Session.hs view
@@ -386,7 +386,6 @@ where checkIfNeedsOpened uri = do oldVFS <- vfs <$> get- ctx <- ask -- if its not open, open it unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do@@ -394,7 +393,7 @@ contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item)- liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)+ sendMessage msg modifyM $ \s -> do let (newVFS,_) = openVFS (vfs s) msg@@ -437,7 +436,7 @@ sendMessage msg = do h <- serverIn <$> ask logMsg LogClient msg- liftIO $ B.hPut h (addHeader $ encode msg)+ liftIO $ B.hPut h (addHeader $ encode msg) `catch` (throw . MessageSendError (toJSON msg)) -- | Execute a block f that will throw a 'Language.LSP.Test.Exception.Timeout' exception -- after duration seconds. This will override the global timeout
test/DummyServer.hs view
@@ -16,12 +16,13 @@ import System.FilePath import System.Process import Language.LSP.Types- +import Data.Default+ withDummyServer :: ((Handle, Handle) -> IO ()) -> IO () withDummyServer f = do (hinRead, hinWrite) <- createPipe (houtRead, houtWrite) <- createPipe- + handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar let definition = ServerDefinition { doInitialize = \env _req -> pure $ Right env@@ -185,4 +186,36 @@ Nothing Nothing resp $ Right $ InR res+ , requestHandler STextDocumentPrepareCallHierarchy $ \req resp -> do+ let RequestMessage _ _ _ params = req+ CallHierarchyPrepareParams _ pos _ = params+ Position x y = pos+ item =+ CallHierarchyItem+ "foo"+ SkMethod+ Nothing+ Nothing+ (Uri "")+ (Range (Position 2 3) (Position 4 5))+ (Range (Position 2 3) (Position 4 5))+ Nothing+ if x == 0 && y == 0+ then resp $ Right Nothing+ else resp $ Right $ Just $ List [item]+ , requestHandler SCallHierarchyIncomingCalls $ \req resp -> do+ let RequestMessage _ _ _ params = req+ CallHierarchyIncomingCallsParams _ _ item = params+ resp $ Right $ Just $+ List [CallHierarchyIncomingCall item (List [Range (Position 2 3) (Position 4 5)])]+ , requestHandler SCallHierarchyOutgoingCalls $ \req resp -> do+ let RequestMessage _ _ _ params = req+ CallHierarchyOutgoingCallsParams _ _ item = params+ resp $ Right $ Just $+ List [CallHierarchyOutgoingCall item (List [Range (Position 4 5) (Position 2 3)])]+ , requestHandler STextDocumentSemanticTokensFull $ \_req resp -> do+ let tokens = makeSemanticTokens def [SemanticTokenAbsolute 0 1 2 SttType []]+ case tokens of+ Left t -> resp $ Left $ ResponseError InternalError t Nothing+ Right tokens -> resp $ Right $ Just tokens ]
test/Test.hs view
@@ -301,14 +301,30 @@ pred _ = False void $ satisfy pred + describe "satisfyMaybe" $ do+ it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ -- Wait for window/logMessage "initialized" from the server.+ let pred (FromServerMess SWindowLogMessage _) = Just "match" :: Maybe String+ pred _ = Nothing :: Maybe String+ result <- satisfyMaybe pred+ liftIO $ result `shouldBe` "match"++ it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ let pred (FromServerMess STextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String+ pred _ = Nothing :: Maybe String+ -- We expect a window/logMessage from the server, but+ -- not a textDocument/publishDiagnostics.+ result <- satisfyMaybe pred <|> (message SWindowLogMessage *> pure "no match")+ liftIO $ result `shouldBe` "no match"+ describe "ignoreLogNotifications" $ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def { ignoreLogNotifications = True }) fullCaps "." $ do openDoc "test/data/Format.hs" "haskell"- void publishDiagnosticsNotification + void publishDiagnosticsNotification describe "dynamic capabilities" $ do- + it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do loggingNotification -- initialized log message @@ -357,6 +373,32 @@ count 0 $ loggingNotification void $ anyResponse + describe "call hierarchy" $ do+ let workPos = Position 1 0+ notWorkPos = Position 0 0+ params pos = CallHierarchyPrepareParams (TextDocumentIdentifier (Uri "")) pos Nothing+ item = CallHierarchyItem "foo" SkFunction Nothing Nothing (Uri "")+ (Range (Position 1 2) (Position 3 4))+ (Range (Position 1 2) (Position 3 4))+ Nothing+ it "prepare works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ rsp <- prepareCallHierarchy (params workPos)+ liftIO $ head rsp ^. range `shouldBe` Range (Position 2 3) (Position 4 5)+ it "prepare not works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ rsp <- prepareCallHierarchy (params notWorkPos)+ liftIO $ rsp `shouldBe` []+ it "incoming calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ [CallHierarchyIncomingCall _ (List fromRanges)] <- incomingCalls (CallHierarchyIncomingCallsParams Nothing Nothing item)+ liftIO $ head fromRanges `shouldBe` Range (Position 2 3) (Position 4 5)+ it "outgoing calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ [CallHierarchyOutgoingCall _ (List fromRanges)] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item)+ liftIO $ head fromRanges `shouldBe` Range (Position 4 5) (Position 2 3)++ describe "semantic tokens" $ do+ it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do+ let doc = TextDocumentIdentifier (Uri "")+ Just toks <- getSemanticTokens doc+ liftIO $ toks ^. xdata `shouldBe` List [0,1,2,0,0] didChangeCaps :: ClientCapabilities didChangeCaps = def { _workspace = Just workspaceCaps }
+ test/data/Error.hs view
@@ -0,0 +1,2 @@+main :: IO Int+main = return "hello"
+ test/data/Format.hs view
@@ -0,0 +1,4 @@+module Format where+foo 3 = 2+foo x = x+bar _ = 2
+ test/data/Rename.hs view
@@ -0,0 +1,2 @@+main = foo+foo = return 42
+ test/data/documentSymbolFail/example/Main.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+module Main where++import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP+import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP+import qualified LSP.Client as Client+import Data.Proxy+import qualified Data.Text.IO as T+import Control.Concurrent+import System.Process+import Control.Lens+import System.IO+import System.Exit+import System.Environment+import System.Directory+import Control.Monad++import qualified Compat++main :: IO ()+main = do+ progName <- getProgName+ args <- getArgs++ when (length args /= 1) $ do+ hPutStrLn stderr ("This program expects one argument: " ++ progName ++ " FILEPATH")+ exitFailure++ let [path] = args++ exists <- doesFileExist path+ unless exists $ do+ hPutStrLn stderr ("File does not exist: " ++ path)+ exitFailure++ file <- canonicalizePath path++ pid <- Compat.getPID++ let caps = LSP.ClientCapabilities (Just workspaceCaps) (Just textDocumentCaps) Nothing+ workspaceCaps = LSP.WorkspaceClientCapabilities+ (Just False)+ (Just (LSP.WorkspaceEditClientCapabilities (Just False)))+ (Just (LSP.DidChangeConfigurationClientCapabilities (Just False)))+ (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False)))+ (Just (LSP.SymbolClientCapabilities (Just False)))+ (Just (LSP.ExecuteClientCapabilities (Just False)))+ textDocumentCaps = LSP.TextDocumentClientCapabilities+ (Just (LSP.SynchronizationTextDocumentClientCapabilities+ (Just False)+ (Just False)+ (Just False)+ (Just False)))+ (Just (LSP.CompletionClientCapabilities+ (Just False)+ (Just (LSP.CompletionItemClientCapabilities (Just False)))))+ (Just (LSP.HoverClientCapabilities (Just False)))+ (Just (LSP.SignatureHelpClientCapabilities (Just False)))+ (Just (LSP.ReferencesClientCapabilities (Just False)))+ (Just (LSP.DocumentHighlightClientCapabilities (Just False)))+ (Just (LSP.DocumentSymbolClientCapabilities (Just False)))+ (Just (LSP.FormattingClientCapabilities (Just False)))+ (Just (LSP.RangeFormattingClientCapabilities (Just False)))+ (Just (LSP.OnTypeFormattingClientCapabilities (Just False)))+ (Just (LSP.DefinitionClientCapabilities (Just False)))+ (Just (LSP.CodeActionClientCapabilities (Just False)))+ (Just (LSP.CodeLensClientCapabilities (Just False)))+ (Just (LSP.DocumentLinkClientCapabilities (Just False)))+ (Just (LSP.RenameClientCapabilities (Just False)))+ (Just (LSP.CallHierarchyClientCapabilities (Just False)))++ initializeParams :: LSP.InitializeParams+ initializeParams = LSP.InitializeParams (Just pid) Nothing Nothing Nothing caps Nothing+++ (Just inp, Just out, _, _) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"])+ {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe}++ client <- Client.start (Client.Config inp out testNotificationMessageHandler testRequestMessageHandler)++ Client.sendClientRequest client (Proxy :: Proxy LSP.InitializeRequest) LSP.Initialize initializeParams++ Client.sendClientNotification client LSP.Initialized (Just LSP.InitializedParams)++ txt <- T.readFile file++ let uri = LSP.filePathToUri file++ Client.sendClientNotification client LSP.TextDocumentDidOpen (Just (LSP.DidOpenTextDocumentParams (LSP.TextDocumentItem uri "haskell" 1 txt)))++ Client.sendClientRequest+ client+ (Proxy :: Proxy LSP.DefinitionRequest)+ LSP.TextDocumentDefinition+ (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36)) >>= \case+ Just (Right pos) -> print pos+ _ -> putStrLn "Server couldn't give us defnition position"++ Client.sendClientRequest client (Proxy :: Proxy LSP.DocumentSymbolRequest) LSP.TextDocumentDocumentSymbol (LSP.DocumentSymbolParams (LSP.TextDocumentIdentifier uri))+ >>= \case+ Just (Right as) -> mapM_ T.putStrLn (as ^.. traverse . LSP.name)+ _ -> putStrLn "Server couldn't give us document symbol information"++ Client.sendClientRequest client (Proxy :: Proxy LSP.ShutdownRequest) LSP.Shutdown Nothing+ Client.sendClientNotification client LSP.Exit (Just LSP.ExitParams)++ Client.stop client++testRequestMessageHandler :: Client.RequestMessageHandler+testRequestMessageHandler = Client.RequestMessageHandler+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ where+ toRspId (LSP.IdInt i) = LSP.IdRspInt i+ toRspId (LSP.IdString t) = LSP.IdRspString t++ emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a+ emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing++testNotificationMessageHandler :: Client.NotificationMessageHandler+testNotificationMessageHandler = Client.NotificationMessageHandler+ (T.putStrLn . view (LSP.params . LSP.message))+ (T.putStrLn . view (LSP.params . LSP.message))+ (print . view LSP.params)+ (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message))
+ test/data/refactor/Main.hs view
@@ -0,0 +1,2 @@+main :: IO Int+main = return (42)
+ test/data/renameFail/Desktop/simple.hs view
@@ -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
+ test/data/renamePass/Desktop/simple.hs view
@@ -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