{-# LANGUAGE TypeInType #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}

import DummyServer
import           Test.Hspec
import           Data.Aeson
import           Data.Default
import qualified Data.HashMap.Strict as HM
import           Data.Either
import           Data.Maybe
import qualified Data.Text as T
import           Data.Type.Equality
import           Control.Applicative.Combinators
import           Control.Concurrent
import           Control.Monad.IO.Class
import           Control.Monad
import           Control.Lens hiding (List, Iso)
import           Language.LSP.Test
import           Language.LSP.Types
import           Language.LSP.Types.Lens hiding
  (capabilities, message, rename, applyEdit)
import qualified Language.LSP.Types.Lens as LSP
import           Language.LSP.Types.Capabilities as LSP
import           System.Directory
import           System.FilePath
import           System.Timeout


{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
{-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}


main = hspec $ around withDummyServer $ do
  describe "Session" $ do
    it "fails a test" $ \(hin, hout) ->
      let session = runSessionWithHandles hin hout def fullCaps "." $ do
                      openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
                      anyRequest
        in session `shouldThrow` anySessionException
    it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      rsp <- initializeResponse
      liftIO $ rsp ^. result `shouldSatisfy` isRight

    it "runSessionWithConfig" $ \(hin, hout) ->
      runSessionWithHandles hin hout def didChangeCaps "." $ return ()

    describe "withTimeout" $ do
      it "times out" $ \(hin, hout) ->
        let sesh = runSessionWithHandles hin hout def fullCaps "." $ do
                    openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
                    -- won't receive a request - will timeout
                    -- incoming logging requests shouldn't increase the
                    -- timeout
                    withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit)
          -- wait just a bit longer than 5 seconds so we have time
          -- to open the document
          in timeout 6000000 sesh `shouldThrow` anySessionException

      it "doesn't time out" $ \(hin, hout) ->
        let sesh = runSessionWithHandles hin hout def fullCaps "." $ do
                    openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
                    withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification
          in void $ timeout 6000000 sesh

      it "further timeout messages are ignored" $ \(hin, hout) ->
        runSessionWithHandles hin hout def fullCaps "." $ do
          doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
          -- shouldn't timeout
          withTimeout 3 $ getDocumentSymbols doc
          -- longer than the original timeout
          liftIO $ threadDelay (5 * 10^6)
          -- shouldn't throw an exception
          getDocumentSymbols doc
          return ()

      it "overrides global message timeout" $ \(hin, hout) ->
        let sesh =
              runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do
                doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
                -- shouldn't time out in here since we are overriding it
                withTimeout 10 $ liftIO $ threadDelay 7000000
                getDocumentSymbols doc
                return True
        in sesh `shouldReturn` True

      it "unoverrides global message timeout" $ \(hin, hout) ->
        let sesh =
              runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do
                doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
                -- shouldn't time out in here since we are overriding it
                withTimeout 10 $ liftIO $ threadDelay 7000000
                getDocumentSymbols doc
                -- should now timeout
                skipManyTill anyMessage (message SWorkspaceApplyEdit)
            isTimeout (Timeout _) = True
            isTimeout _ = False
        in sesh `shouldThrow` isTimeout


    describe "SessionException" $ do
      it "throw on time out" $ \(hin, hout) ->
        let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do
                skipMany loggingNotification
                _ <- message SWorkspaceApplyEdit
                return ()
        in sesh `shouldThrow` anySessionException

      it "don't throw when no time out" $ \(hin, hout) ->
        runSessionWithHandles hin hout (def {messageTimeout = 5}) fullCaps "." $ do
          loggingNotification
          liftIO $ threadDelay $ 6 * 1000000
          _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
          return ()

      describe "UnexpectedMessageException" $ do
        it "throws when there's an unexpected message" $ \(hin, hout) ->
          let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True
              selector _ = False
            in runSessionWithHandles hin hout def fullCaps "." publishDiagnosticsNotification `shouldThrow` selector
        it "provides the correct types that were expected and received" $ \(hin, hout) ->
          let selector (UnexpectedMessage "Response for: STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True
              selector _ = False
              sesh = do
                doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
                sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
                skipMany anyNotification
                response STextDocumentRename -- the wrong type
            in runSessionWithHandles hin hout def fullCaps "." sesh
              `shouldThrow` selector

  describe "text document VFS" $ do
    it "sends back didChange notifications (documentChanges)" $ \(hin, hout) ->
      runSessionWithHandles hin hout def fullCaps "." $ do
        doc <- openDoc "test/data/refactor/Main.hs" "haskell"
        VersionedTextDocumentIdentifier _ beforeVersion <- getVersionedDoc doc

        let args = toJSON (VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion)
            reqParams = ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [args]))

        request_ SWorkspaceExecuteCommand reqParams

        editReq <- message SWorkspaceApplyEdit
        liftIO $ do
          let Just (List [InL(TextDocumentEdit vdoc (List [InL edit_]))]) =
                editReq ^. params . edit . documentChanges
          vdoc `shouldBe` VersionedTextDocumentIdentifier  (doc ^. uri) beforeVersion
          edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"

        change <- customNotification "custom/textDocument/didChange"
        let NotMess (NotificationMessage _ _ (c::Value)) = change
            Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c
            VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc

        contents <- documentContents doc

        liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
        VersionedTextDocumentIdentifier _ afterVersion <- getVersionedDoc doc
        liftIO $ afterVersion `shouldNotBe` beforeVersion

        liftIO $ reportedVersion `shouldNotBe` beforeVersion

    it "sends back didChange notifications" $ \(hin, hout) ->
      runSessionWithHandles hin hout def fullCaps "." $ do
        doc <- openDoc "test/data/refactor/Main.hs" "haskell"

        let args = toJSON (doc ^. uri)
            reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
        request_ SWorkspaceExecuteCommand reqParams

        editReq <- message SWorkspaceApplyEdit
        liftIO $ do
          let (Just cs) = editReq ^. params . edit . changes
              [(u, List es)] = HM.toList cs
          u `shouldBe` doc ^. uri
          es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"]
        contents <- documentContents doc
        liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"

  describe "getDocumentEdit" $
    it "automatically consumes applyedit requests" $ \(hin, hout) ->
      runSessionWithHandles hin hout def fullCaps "." $ do
        doc <- openDoc "test/data/refactor/Main.hs" "haskell"

        let args = toJSON (doc ^. uri)
            reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
        request_ SWorkspaceExecuteCommand reqParams
        contents <- getDocumentEdit doc
        liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"

  describe "getCodeActions" $
    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      doc <- openDoc "test/data/refactor/Main.hs" "haskell"
      waitForDiagnostics
      [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2))
      actions <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
      liftIO $ action ^. title `shouldBe` "Delete this"
      liftIO $ actions `shouldSatisfy` null

  describe "getAllCodeActions" $
    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      doc <- openDoc "test/data/refactor/Main.hs" "haskell"
      _ <- waitForDiagnostics
      actions <- getAllCodeActions doc
      liftIO $ do
        let [InR action] = actions
        action ^. title `shouldBe` "Delete this"
        action ^. command . _Just . command  `shouldBe` "deleteThis"

  describe "getDocumentSymbols" $
    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"

      skipMany loggingNotification

      Left (mainSymbol:_) <- getDocumentSymbols doc

      liftIO $ do
        mainSymbol ^. name `shouldBe` "foo"
        mainSymbol ^. kind `shouldBe` SkObject
        mainSymbol ^. range `shouldBe` mkRange 0 0 3 6

  describe "applyEdit" $ do
    it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def docChangesCaps "." $ do
      doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
      VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
      let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
      VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit
      liftIO $ newVersion `shouldBe` oldVersion + 1
    it "changes the document contents" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
      let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo"
      applyEdit doc edit
      contents <- documentContents doc
      liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"

  describe "getCompletions" $
    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"

      comps <- getCompletions doc (Position 5 5)
      let item = head comps
      liftIO $ item ^. label `shouldBe` "foo"

  -- describe "getReferences" $
  --   it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
  --     doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
  --     let pos = Position 40 3 -- interactWithUser
  --         uri = doc ^. LSP.uri
  --     refs <- getReferences doc pos True
  --     liftIO $ refs `shouldContain` map (Location uri) [
  --         mkRange 41 0 41 16
  --       , mkRange 75 6 75 22
  --       , mkRange 71 6 71 22
  --       ]

  -- describe "getDefinitions" $
  --   it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
  --     doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
  --     let pos = Position 49 25 -- addItem
  --     defs <- getDefinitions doc pos
  --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]

  -- describe "getTypeDefinitions" $
  --   it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
  --     doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
  --     let pos = Position 20 23  -- Quit value
  --     defs <- getTypeDefinitions doc pos
  --     liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)]  -- Type definition

  describe "waitForDiagnosticsSource" $
    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      openDoc "test/data/Error.hs" "haskell"
      [diag] <- waitForDiagnosticsSource "dummy-server"
      liftIO $ do
        diag ^. severity `shouldBe` Just DsWarning
        diag ^. source `shouldBe` Just "dummy-server"

  -- describe "rename" $ do
  --   it "works" $ \(hin, hout) -> pendingWith "HaRe not in hie-bios yet"
  --   it "works on javascript" $
  --     runSessionWithHandles hin hout "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
  --       doc <- openDoc "test.js" "javascript"
  --       rename doc (Position 2 11) "bar"
  --       documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack

  describe "getHover" $
    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
      hover <- getHover doc (Position 45 9)
      liftIO $ hover `shouldSatisfy` isJust

  -- describe "getHighlights" $
  --   it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
  --     doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"
  --     skipManyTill loggingNotification $ count 2 noDiagnostics
  --     highlights <- getHighlights doc (Position 27 4) -- addItem
  --     liftIO $ length highlights `shouldBe` 4

  -- describe "formatDoc" $
  --   it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
  --     doc <- openDoc "test/data/Format.hs" "haskell"
  --     oldContents <- documentContents doc
  --     formatDoc doc (FormattingOptions 4 True)
  --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)

  -- describe "formatRange" $
  --   it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
  --     doc <- openDoc "test/data/Format.hs" "haskell"
  --     oldContents <- documentContents doc
  --     formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))
  --     documentContents doc >>= liftIO . (`shouldNotBe` oldContents)

  describe "closeDoc" $
    it "works" $ \(hin, hout) ->
      let sesh =
            runSessionWithHandles hin hout def fullCaps "." $ do
              doc <- openDoc "test/data/Format.hs" "haskell"
              closeDoc doc
              -- need to evaluate to throw
              documentContents doc >>= liftIO . print
      in sesh `shouldThrow` anyException

  describe "satisfy" $
    it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      openDoc "test/data/Format.hs" "haskell"
      let pred (FromServerMess SWindowLogMessage _) = True
          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

  describe "dynamic capabilities" $ do

    it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
      loggingNotification -- initialized log message

      createDoc ".register" "haskell" ""
      message SClientRegisterCapability

      doc <- createDoc "Foo.watch" "haskell" ""
      msg <- message SWindowLogMessage
      liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"

      [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities
      liftIO $ do
        case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of
          Just (Right HRefl) ->
            regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List
                                [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])
          _ -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"

      -- now unregister it by sending a specific createDoc
      createDoc ".unregister" "haskell" ""
      message SClientUnregisterCapability

      createDoc "Bar.watch" "haskell" ""
      void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
      count 0 $ loggingNotification
      void $ anyResponse

    it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "" $ do
      curDir <- liftIO $ getCurrentDirectory

      loggingNotification -- initialized log message

      createDoc ".register.abs" "haskell" ""
      message SClientRegisterCapability

      doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
      msg <- message SWindowLogMessage
      liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"

      -- now unregister it by sending a specific createDoc
      createDoc ".unregister.abs" "haskell" ""
      message SClientUnregisterCapability

      createDoc (curDir </> "Bar.watch") "haskell" ""
      void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
      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,1,0]

didChangeCaps :: ClientCapabilities
didChangeCaps = def { _workspace = Just workspaceCaps }
  where
    workspaceCaps = def { _didChangeConfiguration = Just configCaps }
    configCaps = DidChangeConfigurationClientCapabilities (Just True)

docChangesCaps :: ClientCapabilities
docChangesCaps = def { _workspace = Just workspaceCaps }
  where
    workspaceCaps = def { _workspaceEdit = Just editCaps }
    editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing Nothing Nothing