Migrate tests for position mapping from DAML repository (#388)

Given that the code for this lives in ghcide it makes no sense for the
tests to be part of the DAML repository.

Author: cocreature

ghcide.cabal

@@ -218,13 +218,18 @@ test-suite ghcide-tests
         ghcide,
         ghc-typelits-knownnat,
         haddock-library,
+        haskell-lsp,
         haskell-lsp-types,
         lens,
         lsp-test >= 0.8,
         parser-combinators,
+        QuickCheck,
+        quickcheck-instances,
+        rope-utf16-splay,
         tasty,
-        tasty-hunit,
         tasty-expected-failure,
+        tasty-hunit,
+        tasty-quickcheck,
         text
     hs-source-dirs: test/cabal test/exe test/src
     include-dirs: include

test/exe/Main.hs

@@ -15,6 +15,9 @@ import Control.Monad.IO.Class (liftIO)
 import Data.Char (toLower)
 import Data.Foldable
 import Data.List
+import Data.Rope.UTF16 (Rope)
+import qualified Data.Rope.UTF16 as Rope
+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
 import Development.IDE.GHC.Util
 import qualified Data.Text as T
 import Development.IDE.Spans.Common
@@ -25,13 +28,17 @@ import qualified Language.Haskell.LSP.Test as LSPTest
 import Language.Haskell.LSP.Test hiding (openDoc')
 import Language.Haskell.LSP.Types
 import Language.Haskell.LSP.Types.Capabilities
+import Language.Haskell.LSP.VFS (applyChange)
 import System.Environment.Blank (setEnv)
 import System.FilePath
 import System.IO.Extra
 import System.Directory
+import Test.QuickCheck
+import Test.QuickCheck.Instances ()
 import Test.Tasty
-import Test.Tasty.HUnit
 import Test.Tasty.ExpectedFailure
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
 import Data.Maybe
 
 main :: IO ()
@@ -55,6 +62,7 @@ main = defaultMain $ testGroup "HIE"
   , thTests
   , unitTests
   , haddockTests
+  , positionMappingTests
   ]
 
 initializeResponseTests :: TestTree
@@ -1789,3 +1797,172 @@ openDoc' fp name contents = do
   res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
   sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
   return res
+
+positionMappingTests :: TestTree
+positionMappingTests =
+    testGroup "position mapping"
+        [ testGroup "toCurrent"
+              [ testCase "before" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "ab"
+                    (Position 0 0) @?= Just (Position 0 0)
+              , testCase "after, same line, same length" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "ab"
+                    (Position 0 3) @?= Just (Position 0 3)
+              , testCase "after, same line, increased length" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc"
+                    (Position 0 3) @?= Just (Position 0 4)
+              , testCase "after, same line, decreased length" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "a"
+                    (Position 0 3) @?= Just (Position 0 2)
+              , testCase "after, next line, no newline" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc"
+                    (Position 1 3) @?= Just (Position 1 3)
+              , testCase "after, next line, newline" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc\ndef"
+                    (Position 1 0) @?= Just (Position 2 0)
+              , testCase "after, same line, newline" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc\nd"
+                    (Position 0 4) @?= Just (Position 1 2)
+              , testCase "after, same line, newline + newline at end" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc\nd\n"
+                    (Position 0 4) @?= Just (Position 2 1)
+              , testCase "after, same line, newline + newline at end" $
+                toCurrent
+                    (Range (Position 0 1) (Position 0 1))
+                    "abc"
+                    (Position 0 1) @?= Just (Position 0 4)
+              ]
+        , testGroup "fromCurrent"
+              [ testCase "before" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "ab"
+                    (Position 0 0) @?= Just (Position 0 0)
+              , testCase "after, same line, same length" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "ab"
+                    (Position 0 3) @?= Just (Position 0 3)
+              , testCase "after, same line, increased length" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc"
+                    (Position 0 4) @?= Just (Position 0 3)
+              , testCase "after, same line, decreased length" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "a"
+                    (Position 0 2) @?= Just (Position 0 3)
+              , testCase "after, next line, no newline" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc"
+                    (Position 1 3) @?= Just (Position 1 3)
+              , testCase "after, next line, newline" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc\ndef"
+                    (Position 2 0) @?= Just (Position 1 0)
+              , testCase "after, same line, newline" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc\nd"
+                    (Position 1 2) @?= Just (Position 0 4)
+              , testCase "after, same line, newline + newline at end" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 3))
+                    "abc\nd\n"
+                    (Position 2 1) @?= Just (Position 0 4)
+              , testCase "after, same line, newline + newline at end" $
+                fromCurrent
+                    (Range (Position 0 1) (Position 0 1))
+                    "abc"
+                    (Position 0 4) @?= Just (Position 0 1)
+              ]
+        , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
+              [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
+                -- Note that it is important to use suchThatMap on all values at once
+                -- instead of only using it on the position. Otherwise you can get
+                -- into situations where there is no position that can be mapped back
+                -- for the edit which will result in QuickCheck looping forever.
+                let gen = do
+                        rope <- genRope
+                        range <- genRange rope
+                        PrintableText replacement <- arbitrary
+                        oldPos <- genPosition rope
+                        pure (range, replacement, oldPos)
+                forAll
+                    (suchThatMap gen
+                        (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
+                    \(range, replacement, oldPos, newPos) ->
+                    fromCurrent range replacement newPos === Just oldPos
+              , testProperty "toCurrent r t <=< fromCurrent r t" $ do
+                let gen = do
+                        rope <- genRope
+                        range <- genRange rope
+                        PrintableText replacement <- arbitrary
+                        let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
+                        newPos <- genPosition newRope
+                        pure (range, replacement, newPos)
+                forAll
+                    (suchThatMap gen
+                        (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
+                    \(range, replacement, newPos, oldPos) ->
+                    toCurrent range replacement oldPos === Just newPos
+              ]
+        ]
+
+newtype PrintableText = PrintableText { getPrintableText :: T.Text }
+    deriving Show
+
+instance Arbitrary PrintableText where
+    arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
+
+
+genRope :: Gen Rope
+genRope = Rope.fromText . getPrintableText <$> arbitrary
+
+genPosition :: Rope -> Gen Position
+genPosition r = do
+    row <- choose (0, max 0 $ rows - 1)
+    let columns = Rope.columns (nthLine row r)
+    column <- choose (0, max 0 $ columns - 1)
+    pure $ Position row column
+    where rows = Rope.rows r
+
+genRange :: Rope -> Gen Range
+genRange r = do
+    startPos@(Position startLine startColumn) <- genPosition r
+    let maxLineDiff = max 0 $ rows - 1 - startLine
+    endLine <- choose (startLine, startLine + maxLineDiff)
+    let columns = Rope.columns (nthLine endLine r)
+    endColumn <-
+        if startLine == endLine
+            then choose (startColumn, columns)
+            else choose (0, max 0 $ columns - 1)
+    pure $ Range startPos (Position endLine endColumn)
+    where rows = Rope.rows r
+
+-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
+nthLine :: Int -> Rope -> Rope
+nthLine i r
+    | i < 0 = error $ "Negative line number: " <> show i
+    | i == 0 && Rope.rows r == 0 = r
+    | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
+    | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r