@@ -15,6 +15,9 @@ import Control.Monad.IO.Class (liftIO)
1515import Data.Char (toLower)
1616import Data.Foldable
1717import Data.List
18+import Data.Rope.UTF16 (Rope)
19+import qualified Data.Rope.UTF16 as Rope
20+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
1821import Development.IDE.GHC.Util
1922import qualified Data.Text as T
2023import Development.IDE.Spans.Common
@@ -25,13 +28,17 @@ import qualified Language.Haskell.LSP.Test as LSPTest
2528import Language.Haskell.LSP.Test hiding (openDoc')
2629import Language.Haskell.LSP.Types
2730import Language.Haskell.LSP.Types.Capabilities
31+import Language.Haskell.LSP.VFS (applyChange)
2832import System.Environment.Blank (setEnv)
2933import System.FilePath
3034import System.IO.Extra
3135import System.Directory
36+import Test.QuickCheck
37+import Test.QuickCheck.Instances ()
3238import Test.Tasty
33−import Test.Tasty.HUnit
3439import Test.Tasty.ExpectedFailure
40+import Test.Tasty.HUnit
41+import Test.Tasty.QuickCheck
3542import Data.Maybe
3643
3744main :: IO ()
@@ -55,6 +62,7 @@ main = defaultMain $ testGroup "HIE"
5562 , thTests
5663 , unitTests
5764 , haddockTests
65+ , positionMappingTests
5866 ]
5967
6068initializeResponseTests :: TestTree
@@ -1789,3 +1797,172 @@ openDoc' fp name contents = do
17891797 res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
17901798 sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
17911799 return res
1800+
1801+positionMappingTests :: TestTree
1802+positionMappingTests =
1803+ testGroup "position mapping"
1804+ [ testGroup "toCurrent"
1805+ [ testCase "before" $
1806+ toCurrent
1807+ (Range (Position 0 1) (Position 0 3))
1808+ "ab"
1809+ (Position 0 0) @?= Just (Position 0 0)
1810+ , testCase "after, same line, same length" $
1811+ toCurrent
1812+ (Range (Position 0 1) (Position 0 3))
1813+ "ab"
1814+ (Position 0 3) @?= Just (Position 0 3)
1815+ , testCase "after, same line, increased length" $
1816+ toCurrent
1817+ (Range (Position 0 1) (Position 0 3))
1818+ "abc"
1819+ (Position 0 3) @?= Just (Position 0 4)
1820+ , testCase "after, same line, decreased length" $
1821+ toCurrent
1822+ (Range (Position 0 1) (Position 0 3))
1823+ "a"
1824+ (Position 0 3) @?= Just (Position 0 2)
1825+ , testCase "after, next line, no newline" $
1826+ toCurrent
1827+ (Range (Position 0 1) (Position 0 3))
1828+ "abc"
1829+ (Position 1 3) @?= Just (Position 1 3)
1830+ , testCase "after, next line, newline" $
1831+ toCurrent
1832+ (Range (Position 0 1) (Position 0 3))
1833+ "abc\ndef"
1834+ (Position 1 0) @?= Just (Position 2 0)
1835+ , testCase "after, same line, newline" $
1836+ toCurrent
1837+ (Range (Position 0 1) (Position 0 3))
1838+ "abc\nd"
1839+ (Position 0 4) @?= Just (Position 1 2)
1840+ , testCase "after, same line, newline + newline at end" $
1841+ toCurrent
1842+ (Range (Position 0 1) (Position 0 3))
1843+ "abc\nd\n"
1844+ (Position 0 4) @?= Just (Position 2 1)
1845+ , testCase "after, same line, newline + newline at end" $
1846+ toCurrent
1847+ (Range (Position 0 1) (Position 0 1))
1848+ "abc"
1849+ (Position 0 1) @?= Just (Position 0 4)
1850+ ]
1851+ , testGroup "fromCurrent"
1852+ [ testCase "before" $
1853+ fromCurrent
1854+ (Range (Position 0 1) (Position 0 3))
1855+ "ab"
1856+ (Position 0 0) @?= Just (Position 0 0)
1857+ , testCase "after, same line, same length" $
1858+ fromCurrent
1859+ (Range (Position 0 1) (Position 0 3))
1860+ "ab"
1861+ (Position 0 3) @?= Just (Position 0 3)
1862+ , testCase "after, same line, increased length" $
1863+ fromCurrent
1864+ (Range (Position 0 1) (Position 0 3))
1865+ "abc"
1866+ (Position 0 4) @?= Just (Position 0 3)
1867+ , testCase "after, same line, decreased length" $
1868+ fromCurrent
1869+ (Range (Position 0 1) (Position 0 3))
1870+ "a"
1871+ (Position 0 2) @?= Just (Position 0 3)
1872+ , testCase "after, next line, no newline" $
1873+ fromCurrent
1874+ (Range (Position 0 1) (Position 0 3))
1875+ "abc"
1876+ (Position 1 3) @?= Just (Position 1 3)
1877+ , testCase "after, next line, newline" $
1878+ fromCurrent
1879+ (Range (Position 0 1) (Position 0 3))
1880+ "abc\ndef"
1881+ (Position 2 0) @?= Just (Position 1 0)
1882+ , testCase "after, same line, newline" $
1883+ fromCurrent
1884+ (Range (Position 0 1) (Position 0 3))
1885+ "abc\nd"
1886+ (Position 1 2) @?= Just (Position 0 4)
1887+ , testCase "after, same line, newline + newline at end" $
1888+ fromCurrent
1889+ (Range (Position 0 1) (Position 0 3))
1890+ "abc\nd\n"
1891+ (Position 2 1) @?= Just (Position 0 4)
1892+ , testCase "after, same line, newline + newline at end" $
1893+ fromCurrent
1894+ (Range (Position 0 1) (Position 0 1))
1895+ "abc"
1896+ (Position 0 4) @?= Just (Position 0 1)
1897+ ]
1898+ , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
1899+ [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
1900+ -- Note that it is important to use suchThatMap on all values at once
1901+ -- instead of only using it on the position. Otherwise you can get
1902+ -- into situations where there is no position that can be mapped back
1903+ -- for the edit which will result in QuickCheck looping forever.
1904+ let gen = do
1905+ rope <- genRope
1906+ range <- genRange rope
1907+ PrintableText replacement <- arbitrary
1908+ oldPos <- genPosition rope
1909+ pure (range, replacement, oldPos)
1910+ forAll
1911+ (suchThatMap gen
1912+ (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
1913+ \(range, replacement, oldPos, newPos) ->
1914+ fromCurrent range replacement newPos === Just oldPos
1915+ , testProperty "toCurrent r t <=< fromCurrent r t" $ do
1916+ let gen = do
1917+ rope <- genRope
1918+ range <- genRange rope
1919+ PrintableText replacement <- arbitrary
1920+ let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
1921+ newPos <- genPosition newRope
1922+ pure (range, replacement, newPos)
1923+ forAll
1924+ (suchThatMap gen
1925+ (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
1926+ \(range, replacement, newPos, oldPos) ->
1927+ toCurrent range replacement oldPos === Just newPos
1928+ ]
1929+ ]
1930+
1931+newtype PrintableText = PrintableText { getPrintableText :: T.Text }
1932+ deriving Show
1933+
1934+instance Arbitrary PrintableText where
1935+ arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
1936+
1937+
1938+genRope :: Gen Rope
1939+genRope = Rope.fromText . getPrintableText <$> arbitrary
1940+
1941+genPosition :: Rope -> Gen Position
1942+genPosition r = do
1943+ row <- choose (0, max 0 $ rows - 1)
1944+ let columns = Rope.columns (nthLine row r)
1945+ column <- choose (0, max 0 $ columns - 1)
1946+ pure $ Position row column
1947+ where rows = Rope.rows r
1948+
1949+genRange :: Rope -> Gen Range
1950+genRange r = do
1951+ startPos@(Position startLine startColumn) <- genPosition r
1952+ let maxLineDiff = max 0 $ rows - 1 - startLine
1953+ endLine <- choose (startLine, startLine + maxLineDiff)
1954+ let columns = Rope.columns (nthLine endLine r)
1955+ endColumn <-
1956+ if startLine == endLine
1957+ then choose (startColumn, columns)
1958+ else choose (0, max 0 $ columns - 1)
1959+ pure $ Range startPos (Position endLine endColumn)
1960+ where rows = Rope.rows r
1961+
1962+-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
1963+nthLine :: Int -> Rope -> Rope
1964+nthLine i r
1965+ | i < 0 = error $ "Negative line number: " <> show i
1966+ | i == 0 && Rope.rows r == 0 = r
1967+ | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
1968+ | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r