diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -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 . @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 , and . 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 diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- a/src/Language/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -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'. diff --git a/src/Language/LSP/Test/Decoding.hs b/src/Language/LSP/Test/Decoding.hs --- a/src/Language/LSP/Test/Decoding.hs +++ b/src/Language/LSP/Test/Decoding.hs @@ -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" diff --git a/src/Language/LSP/Test/Exceptions.hs b/src/Language/LSP/Test/Exceptions.hs --- a/src/Language/LSP/Test/Exceptions.hs +++ b/src/Language/LSP/Test/Exceptions.hs @@ -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 diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -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 diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- a/src/Language/LSP/Test/Session.hs +++ b/src/Language/LSP/Test/Session.hs @@ -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 diff --git a/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -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 ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 } diff --git a/test/data/Error.hs b/test/data/Error.hs new file mode 100644 --- /dev/null +++ b/test/data/Error.hs @@ -0,0 +1,2 @@ +main :: IO Int +main = return "hello" diff --git a/test/data/Format.hs b/test/data/Format.hs new file mode 100644 --- /dev/null +++ b/test/data/Format.hs @@ -0,0 +1,4 @@ +module Format where +foo 3 = 2 +foo x = x +bar _ = 2 diff --git a/test/data/Rename.hs b/test/data/Rename.hs new file mode 100644 --- /dev/null +++ b/test/data/Rename.hs @@ -0,0 +1,2 @@ +main = foo +foo = return 42 diff --git a/test/data/documentSymbolFail/example/Main.hs b/test/data/documentSymbolFail/example/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/documentSymbolFail/example/Main.hs @@ -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)) diff --git a/test/data/refactor/Main.hs b/test/data/refactor/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/refactor/Main.hs @@ -0,0 +1,2 @@ +main :: IO Int +main = return (42) diff --git a/test/data/renameFail/Desktop/simple.hs b/test/data/renameFail/Desktop/simple.hs new file mode 100644 --- /dev/null +++ b/test/data/renameFail/Desktop/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 diff --git a/test/data/renamePass/Desktop/simple.hs b/test/data/renamePass/Desktop/simple.hs new file mode 100644 --- /dev/null +++ b/test/data/renamePass/Desktop/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