Main.hs

{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE ViewPatterns             #-}
module Main
  ( main
  ) where

import           Control.Lens                  ((^.))
import           Control.Monad                 (unless)
import           Data.Either.Extra
import           Data.Foldable                 (find)
import           Data.Text                     (Text)
import qualified Data.Text                     as T
import           Data.Traversable              (for)
import qualified Ide.Plugin.ExplicitImports    as ExplicitImports
import qualified Language.LSP.Protocol.Lens    as L
import           Language.LSP.Protocol.Message
import           System.FilePath               ((</>))
import           Test.Hls

explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log
explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports"

main :: IO ()
main = defaultTestRunner $ testGroup "import-actions"
  [testGroup
    "Refine Imports"
    [ codeActionGoldenTest "RefineWithOverride" 3 1
    -- Although the client has inlay hints caps, refine is always provided by the code lens
    , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineUsualCase" 1
    , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineQualified" 0
    , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineQualifiedExplicit" 0
    ],
  testGroup
    "Make imports explicit"
    [ codeActionAllGoldenTest "ExplicitUsualCase" 3 0
    , codeActionAllResolveGoldenTest "ExplicitUsualCase" 3 0
    , inlayHintsTestWithCap "ExplicitUsualCase" 2 $ (@=?)
        [mkInlayHint (Position 2 16) "( a1 )"
                     (TextEdit (Range (Position 2 0) (Position 2 16)) "import ExplicitA ( a1 )")]
    , inlayHintsTestWithoutCap "ExplicitUsualCase" 2 $ (@=?) []
    , codeActionOnlyGoldenTest "ExplicitOnlyThis" 3 0
    , codeActionOnlyResolveGoldenTest "ExplicitOnlyThis" 3 0
    , inlayHintsTestWithCap "ExplicitOnlyThis" 3 $ (@=?)
        [mkInlayHint (Position 3 16) "( b1 )"
                     (TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitB ( b1 )")]
    , inlayHintsTestWithoutCap "ExplicitOnlyThis" 3 $ (@=?) []
    -- Only when the client does not support inlay hints, explicit will be provided by code lens
    , codeLensGoldenTest codeActionNoInlayHintsCaps notRefineImports "ExplicitUsualCase" 0
    , noCodeLensTest codeActionNoResolveCaps "ExplicitUsualCase"
    , codeActionBreakFile "ExplicitBreakFile" 4 0
    , inlayHintsTestWithCap "ExplicitBreakFile" 3 $ (@=?)
        [mkInlayHint (Position 3 16) "( a1 )"
                     (TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitA ( a1 )")]
    , inlayHintsTestWithoutCap "ExplicitBreakFile" 3 $ (@=?) []
    , codeActionStaleAction "ExplicitStaleAction" 4 0
    , testCase "No CodeAction when exported" $
      runSessionWithServer def explicitImportsPlugin testDataDir $ do
        doc <- openDoc "ExplicitExported.hs" "haskell"
        action <- getCodeActions doc (pointRange 3 0)
        liftIO $ action @?= []
    , testCase "No CodeLens when exported" $
      runSessionWithServer def explicitImportsPlugin testDataDir $ do
        doc <- openDoc "ExplicitExported.hs" "haskell"
        lenses <- getCodeLenses doc
        liftIO $ lenses @?= []
    , testCase "No InlayHints when exported" $
      runSessionWithServer def explicitImportsPlugin testDataDir $ do
        doc <- openDoc "ExplicitExported.hs" "haskell"
        inlayHints <- getInlayHints doc (pointRange 3 0)
        liftIO $ inlayHints @?= []
    , testGroup "Title abbreviation"
      [ testCase "not abbreviated" $
          let i = "import " <> T.replicate 70 "F" <> " (Athing, Bthing, Cthing)"
          in ExplicitImports.abbreviateImportTitle i @?= i
      , testCase "abbreviated in module name" $
          let i = "import " <> T.replicate 120 "F" <> " (Athing, Bthing, Cthing)"
              o = "import " <> T.replicate 97 "F" <> " ... (3 items)"
          in ExplicitImports.abbreviateImportTitle i @?= o
      , testCase "abbreviated in import list" $
          let i = "import " <> T.replicate 78 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)"
              o = "import " <> T.replicate 78 "F" <> " (Athing, Bthing, ... (3 items))"
          in ExplicitImports.abbreviateImportTitle i @?= o
      -- This one breaks earlier in the same import item, but still splits the list in the same place
      , testCase "abbreviated in import list (slightly shorter module)" $
          let i = "import " <> T.replicate 76 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)"
              o = "import " <> T.replicate 76 "F" <> " (Athing, Bthing, ... (3 items))"
          in ExplicitImports.abbreviateImportTitle i @?= o
      -- This one breaks later in the same import item, but still splits the list in the same place
      , testCase "abbreviated in import list (slightly longer module)" $
          let i = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, Cthing, Dthing, Ething)"
              o = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, ... (3 items))"
          in ExplicitImports.abbreviateImportTitle i @?= o
      ]
    , testGroup "Title abbreviation without module"
      [ testCase "not abbreviated" $
          let i = "import M (" <> T.replicate 70 "F" <> ", Athing, Bthing, Cthing)"
              o = "(FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF, Athing, Bthing, Cthing)"
          in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o
      , testCase "abbreviated that drop module name" $
          let i = "import " <> T.replicate 120 "F" <> " (Athing, Bthing, Cthing)"
              o = "(Athing, Bthing, Cthing)"
          in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o
      , testCase "abbreviated in import list" $
          let i = "import M (Athing, Bthing, " <> T.replicate 100 "F" <> ", Cthing, Dthing, Ething)"
              o = "(Athing, Bthing, ... (4 items))"
          in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o
      ]
    ],
  testGroup
    "Import package inlay hints"
    [ testGroup "Without package imports"
      (let testWithCap = inlayHintsTestWithCap "ImportUsual"
           testWithoutCap = inlayHintsTestWithoutCap "ImportUsual"
      in
        [ testWithCap 2 $ (@=?) [mkInlayHintNoTextEdit (Position 2 6) "\"base\""]
        , testWithCap 3 $ (@=?) [mkInlayHintNoTextEdit (Position 3 16) "\"containers\""]
        , testWithCap 4 $ (@=?) []
        , testWithoutCap 2 $ (@=?) []
        , testWithoutCap 3 $ (@=?) []
        , testWithoutCap 4 $ (@=?) []
        ])
    , testGroup "With package imports"
      (let testWithCap = inlayHintsTestWithCap "ImportWithPackageImport"
           testWithoutCap = inlayHintsTestWithoutCap "ImportWithPackageImport"
      in
        [ testWithCap 3 $ (@=?) []
        , testWithCap 4 $ (@=?) [mkInlayHintNoTextEdit (Position 4 16) "\"containers\""]
        , testWithCap 5 $ (@=?) []
        , testWithoutCap 3 $ (@=?) []
        , testWithoutCap 4 $ (@=?) []
        , testWithoutCap 5 $ (@=?) []
        ])
    , testGroup "When using ImportQualifiedPost"
      (let testWithCap = inlayHintsTestWithCap "ImportWithQualifiedPost"
           testWithoutCap = inlayHintsTestWithoutCap "ImportWithQualifiedPost"
      in
        [ testWithCap 3 $ (@=?) [mkInlayHintNoTextEdit (Position 3 6) "\"base\""]
        , testWithCap 4 $ (@=?) [mkInlayHintNoTextEdit (Position 4 6) "\"containers\""]
        , testWithCap 5 $ (@=?) []
        , testWithoutCap 3 $ (@=?) []
        , testWithoutCap 4 $ (@=?) []
        , testWithoutCap 5 $ (@=?) []
        ])
    ]]

-- code action tests

codeActionAllGoldenTest :: FilePath -> Int -> Int -> TestTree
codeActionAllGoldenTest fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do
  actions <- getCodeActions doc (pointRange l c)
  case find ((== Just "Make all imports explicit") . caTitle) actions of
    Just (InR x) -> executeCodeAction x
    _            -> liftIO $ assertFailure "Unable to find CodeAction"

codeActionBreakFile :: FilePath -> Int -> Int -> TestTree
-- If use `codeActionNoResolveCaps` instead of `codeActionNoInlayHintsCaps` here,
-- we will get a puzzling error: https://github.com/haskell/haskell-language-server/pull/4235#issuecomment-2189048997
codeActionBreakFile fp l c = goldenWithImportActions " code action" fp codeActionNoInlayHintsCaps $ \doc -> do
  _ <- getCodeLenses doc
  changeDoc doc [edit]
  actions <- getCodeActions doc (pointRange l c)
  case find ((== Just "Make all imports explicit") . caTitle) actions of
    Just (InR x) -> executeCodeAction x
    _            -> liftIO $ assertFailure "Unable to find CodeAction"
  where edit = TextDocumentContentChangeEvent $ InL
          TextDocumentContentChangePartial
            { _range = pointRange 2 29
            , _rangeLength = Nothing
            , _text = "x"
            }

codeActionStaleAction :: FilePath -> Int -> Int -> TestTree
codeActionStaleAction fp l c = goldenWithImportActions " code action" fp codeActionResolveCaps $ \doc -> do
  _ <- waitForDiagnostics
  actions <- getCodeActions doc (pointRange l c)
  changeDoc doc [edit]
  _ <- waitForDiagnostics
  case find ((== Just "Make this import explicit") . caTitle) actions of
    Just (InR x) ->
      maybeResolveCodeAction x >>=
        \case Just _  -> liftIO $ assertFailure "Code action still valid"
              Nothing -> pure ()
    _            -> liftIO $ assertFailure "Unable to find CodeAction"
  where edit = TextDocumentContentChangeEvent $ InL
          TextDocumentContentChangePartial
            { _range = Range (Position 6 0) (Position 6 0)
            , _rangeLength = Nothing
            , _text = "\ntesting = undefined"
            }

codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree
codeActionAllResolveGoldenTest fp l c = goldenWithImportActions " code action resolve" fp codeActionResolveCaps $ \doc -> do
  actions <- getCodeActions doc (pointRange l c)
  Just (InR x) <- pure $ find ((== Just "Make all imports explicit") . caTitle) actions
  resolved <- resolveCodeAction x
  executeCodeAction resolved

codeActionOnlyGoldenTest :: FilePath -> Int -> Int -> TestTree
codeActionOnlyGoldenTest fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do
  actions <- getCodeActions doc (pointRange l c)
  case find ((== Just "Make this import explicit") . caTitle) actions of
    Just (InR x) -> executeCodeAction x
    _            -> liftIO $ assertFailure "Unable to find CodeAction"

codeActionOnlyResolveGoldenTest :: FilePath -> Int -> Int -> TestTree
codeActionOnlyResolveGoldenTest fp l c = goldenWithImportActions " code action resolve" fp codeActionResolveCaps $ \doc -> do
  actions <- getCodeActions doc (pointRange l c)
  Just (InR x) <- pure $ find ((== Just "Make this import explicit") . caTitle) actions
  resolved <- resolveCodeAction x
  executeCodeAction resolved

maybeResolveCodeAction :: CodeAction -> Session (Maybe CodeAction)
maybeResolveCodeAction ca = do
  resolveResponse <- request SMethod_CodeActionResolve ca
  let resolved = resolveResponse ^. L.result
  pure $ eitherToMaybe resolved

caTitle :: (Command |? CodeAction) -> Maybe Text
caTitle (InR CodeAction {_title}) = Just _title
caTitle _                         = Nothing

-- code lens tests

codeLensGoldenTest :: ClientCapabilities -> (CodeLens -> Bool) -> FilePath -> Int -> TestTree
codeLensGoldenTest caps predicate fp i = goldenWithImportActions " code lens" fp caps $ \doc -> do
  codeLenses <- getCodeLenses doc
  resolvedCodeLenses <- for codeLenses resolveCodeLens
  (CodeLens {_command = Just c}) <- pure (filter predicate resolvedCodeLenses !! i)
  executeCmd c

noCodeLensTest :: ClientCapabilities -> FilePath -> TestTree
noCodeLensTest caps fp = do
  testCase (fp ++ " no code lens") $ run $ \_ -> do
    doc <- openDoc (fp ++ ".hs") "haskell"
    codeLenses <- getCodeLenses doc
    resolvedCodeLenses <- for codeLenses resolveCodeLens
    unless (null resolvedCodeLenses) $
      liftIO (assertFailure "Unexpected code lens")
  where
    run = runSessionWithTestConfig def
         { testDirLocation = Left testDataDir
         , testConfigCaps = caps
         , testLspConfig = def
         , testPluginDescriptor = explicitImportsPlugin
         }


notRefineImports :: CodeLens -> Bool
notRefineImports (CodeLens _ (Just (Command text _ _)) _)
  | "Refine imports to" `T.isPrefixOf` text = False
notRefineImports _ = True

-- inlay hints tests

inlayHintsTest :: ClientCapabilities -> String -> FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree
inlayHintsTest configCaps postfix fp line assert = testCase (fp ++ postfix) $ run $ \_ -> do
  doc <- openDoc (fp ++ ".hs") "haskell"
  inlayHints <- getInlayHints doc (lineRange line)
  liftIO $ assert inlayHints
  where
    -- zero-based position
    lineRange line = Range (Position line 0) (Position line 1000)
    run = runSessionWithTestConfig def
        { testDirLocation = Left testDataDir
        , testPluginDescriptor = explicitImportsPlugin
        , testConfigCaps = configCaps
        }

inlayHintsTestWithCap :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree
inlayHintsTestWithCap = inlayHintsTest fullLatestClientCaps " inlay hints with client caps"

inlayHintsTestWithoutCap :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree
inlayHintsTestWithoutCap = inlayHintsTest codeActionNoInlayHintsCaps " inlay hints without client caps"


mkInlayHint :: Position -> Text -> TextEdit -> InlayHint
mkInlayHint pos label textEdit =
  InlayHint
  { _position = pos
  , _label = InL label
  , _kind = Nothing
  , _textEdits = Just [textEdit]
  , _tooltip = Just $ InL "Make this import explicit"
  , _paddingLeft = Just True
  , _paddingRight = Nothing
  , _data_ = Nothing
  }

mkInlayHintNoTextEdit :: Position -> Text -> InlayHint
mkInlayHintNoTextEdit pos label =
  InlayHint
  { _position = pos
  , _label = InL label
  , _kind = Nothing
  , _textEdits = Nothing
  , _tooltip = Nothing
  , _paddingLeft = Just True
  , _paddingRight = Nothing
  , _data_ = Nothing
  }

-- Execute command and wait for result
executeCmd :: Command -> Session ()
executeCmd cmd = do
    executeCommand cmd
    _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)
    -- liftIO $ print _resp
    return ()

-- helpers

goldenWithImportActions :: String -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree
goldenWithImportActions title fp caps = goldenWithHaskellAndCaps def caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs"

testDataDir :: String
testDataDir = "plugins" </> "hls-explicit-imports-plugin" </> "test" </> "testdata"

pointRange :: Int -> Int -> Range
pointRange
  (subtract 1 -> fromIntegral -> line)
  (subtract 1 -> fromIntegral -> col) =
    Range (Position line col) (Position line $ col + 1)

-------------------------------------------------------------------------------
-- code action tests

codeActionGoldenTest :: FilePath -> Int -> Int -> TestTree
codeActionGoldenTest fp l c = goldenWithImportActions "" fp codeActionNoResolveCaps $ \doc -> do
  actions <- getCodeActions doc (pointRange l c)
  case find ((== Just "Refine all imports") . caTitle) actions of
    Just (InR x) -> executeCodeAction x
    _            -> liftIO $ assertFailure "Unable to find CodeAction"

isRefineImports :: CodeLens -> Bool
isRefineImports (CodeLens _ (Just (Command txt _ _)) _)
  | "Refine imports to" `T.isInfixOf` txt = True
isRefineImports _ = False