{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Control.Lens hiding (List, (<.>))
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBSChar8
import Data.String (fromString)
import Development.IDE.Types.Logger (Priority (Debug),
Recorder (Recorder),
WithPriority (WithPriority),
makeDefaultStderrRecorder,
pretty)
import Ide.Plugin.CodeRange (Log, descriptor)
import qualified Ide.Plugin.CodeRange.RulesTest
import qualified Ide.Plugin.CodeRangeTest
import Language.LSP.Types.Lens
import System.FilePath ((<.>), (</>))
import Test.Hls
plugin :: PluginTestDescriptor Log
plugin = mkPluginTestDescriptor descriptor "codeRange"
main :: IO ()
main = do
defaultTestRunner $
testGroup "Code Range" [
testGroup "Integration Tests" [
selectionRangeGoldenTest "Import" [(4, 36), (1, 8)],
selectionRangeGoldenTest "Function" [(5, 19), (5, 12), (4, 4), (3, 5)],
selectionRangeGoldenTest "Empty" [(1, 5)],
foldingRangeGoldenTest "Function"
],
testGroup "Unit Tests" [
Ide.Plugin.CodeRangeTest.testTree,
Ide.Plugin.CodeRange.RulesTest.testTree
]
]
selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree
selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir </> testName <.> "golden" <.> "txt") $ do
res <- runSessionWithServer plugin testDataDir $ do
doc <- openDoc (testName <.> "hs") "haskell"
resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc
(List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions)
let res = resp ^. result
pure $ fmap showSelectionRangesForTest res
case res of
Left err -> assertFailure (show err)
Right golden -> pure golden
where
testDataDir :: FilePath
testDataDir = "test" </> "testdata" </> "selection-range"
showSelectionRangesForTest :: List SelectionRange -> ByteString
showSelectionRangesForTest (List selectionRanges) = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges
showSelectionRangeForTest :: SelectionRange -> ByteString
showSelectionRangeForTest selectionRange = go True (Just selectionRange)
where
go :: Bool -> Maybe SelectionRange -> ByteString
go _ Nothing = ""
go isFirst (Just (SelectionRange (Range sp ep) parent)) =
(if isFirst then "" else " => ") <> showPosition sp <> " " <> showPosition ep <> go False parent
showPosition :: Position -> ByteString
showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")"
showLBS = fromString . show
foldingRangeGoldenTest :: TestName -> TestTree
foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir </> testName <.> "golden" <.> "txt") $ do
res <- runSessionWithServer plugin testDataDir $ do
doc <- openDoc (testName <.> "hs") "haskell"
resp <- request STextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc
let res = resp ^. result
pure $ fmap showFoldingRangesForTest res
case res of
Left err -> assertFailure (show err)
Right golden -> pure golden
where
testDataDir :: FilePath
testDataDir = "test" </> "testdata" </> "folding-range"
showFoldingRangesForTest :: List FoldingRange -> ByteString
showFoldingRangesForTest (List foldingRanges) = LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges
showFoldingRangeForTest :: FoldingRange -> ByteString
showFoldingRangeForTest f@(FoldingRange sl (Just sc) el (Just ec) (Just frk)) = "((" <> showLBS sl <>", "<> showLBS sc <> ")" <> " : " <> "(" <> showLBS el <>", "<> showLBS ec<> ")) : " <> showFRK frk
showLBS = fromString . show
showFRK = fromString . show