module UnitTests (tests) where
import Config (mkIdeTestFs)
import Control.Concurrent
import Control.Monad.IO.Class (liftIO)
import qualified Data.HashMap.Strict as HMS
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
import Data.IORef
import Data.IORef.Extra (atomicModifyIORef_)
import Data.List.Extra
import Data.String (IsString (fromString))
import qualified Data.Text as T
import Development.IDE.Core.FileStore (getModTime)
import Development.IDE.Import.DependencyInformation (DependencyInformation (..),
FilePathId (..),
PathIdMap (..),
ShowableModuleEnv (..),
transitiveReverseDependencies)
import Development.IDE.Import.FindImports (ArtifactsLocation (..))
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
import qualified Development.IDE.Types.Diagnostics as Diagnostics
import Development.IDE.Types.Location
import qualified FuzzySearch
import GHC.Unit.Module.Env (emptyModuleEnv)
import GHC.Unit.Module.Graph (emptyMG)
import Ide.Logger (Recorder,
WithPriority)
import Ide.PluginUtils (pluginDescToIdePlugins)
import Ide.Types
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types hiding
(SemanticTokenAbsolute (..),
SemanticTokenRelative (..),
SemanticTokensEdit (..),
mkRange)
import Language.LSP.Test
import Network.URI
import qualified Progress
import System.IO.Extra hiding
(withTempDir)
import System.Mem (performGC)
import Test.Hls (IdeState, def,
runSessionWithServerInTmpDir,
waitForProgressDone)
import Test.Hls.FileSystem
import Test.Tasty
import Test.Tasty.ExpectedFailure
import Test.Tasty.HUnit
import Text.Printf (printf)
tests :: TestTree
tests = do
testGroup "Unit"
[ testCase "empty file path does NOT work with the empty String literal" $
uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
, testCase "empty file path works using toNormalizedFilePath'" $
uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
, testCase "empty path URI" $ do
Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
uriScheme @?= "file:"
uriPath @?= ""
, testCase "from empty path URI" $ do
let uri = Uri "file://"
uriToFilePath' uri @?= Just ""
, testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do
let diag = Diagnostics.FileDiagnostic "" Diagnostics.ShowDiag Diagnostic
{ _codeDescription = Nothing
, _data_ = Nothing
, _range = Range
{ _start = Position{_line = 0, _character = 1}
, _end = Position{_line = 2, _character = 3}
}
, _severity = Nothing
, _code = Nothing
, _source = Nothing
, _message = ""
, _relatedInformation = Nothing
, _tags = Nothing
} Diagnostics.NoStructuredMessage
let shown = T.unpack (Diagnostics.showDiagnostics [diag])
let expected = "1:2-3:4"
assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $
expected `isInfixOf` shown
, testCase "notification handlers run in priority order" $ do
orderRef <- newIORef []
let
plugins ::Recorder (WithPriority Ghcide.Log) -> IdePlugins IdeState
plugins recorder = pluginDescToIdePlugins $
[ (priorityPluginDescriptor i)
{ pluginNotificationHandlers = mconcat
[ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->
liftIO $ atomicModifyIORef_ orderRef (i:)
]
}
| i <- [1..20]
] ++ Ghcide.descriptors recorder
priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i}
runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do
_ <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
actualOrder <- liftIO $ reverse <$> readIORef orderRef
-- Handlers are run in priority descending order
liftIO $ actualOrder @?= [20, 19 .. 1]
, ignoreTestBecause "The test fails sometimes showing 10000us" $
testCase "timestamps have millisecond resolution" $ do
resolution_us <- findResolution_us 1
let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us
assertBool msg (resolution_us <= 1000)
, testCase "transitiveReverseDependencies follows the chain" $ do
-- Chain: 0 imported by 1, 1 imported by 2, 2 imported by 3.
-- transitiveReverseDependencies of node 0 must contain {1, 2, 3},
-- not just the immediate reverse-dep {1}.
let path :: Int -> NormalizedFilePath
path i = toNormalizedFilePath' ("/M" ++ show i ++ ".hs")
loc :: Int -> ArtifactsLocation
loc i = ArtifactsLocation (path i) Nothing True Nothing
pathIdMap = PathIdMap
{ idToPathMap = IntMap.fromList [(i, loc i) | i <- [0..3]]
, pathToIdMap = HMS.fromList [(path i, FilePathId i) | i <- [0..3]]
, nextFreshId = 4
}
revDeps = IntMap.fromList
[ (0, IntSet.fromList [1])
, (1, IntSet.fromList [2])
, (2, IntSet.fromList [3])
]
depInfo = DependencyInformation
{ depErrorNodes = IntMap.empty
, depModules = IntMap.empty
, depModuleDeps = IntMap.empty
, depReverseModuleDeps = revDeps
, depPathIdMap = pathIdMap
, depBootMap = IntMap.empty
, depModuleFiles = ShowableModuleEnv emptyModuleEnv
, depModuleGraph = emptyMG
, depTransDepsFingerprints = IntMap.empty
, depTransReverseDepsFingerprints = IntMap.empty
, depImmediateReverseDepsFingerprints = IntMap.empty
}
(sort <$> transitiveReverseDependencies (path 0) depInfo)
@?= Just [path 1, path 2, path 3]
, Progress.tests
, FuzzySearch.tests
]
findResolution_us :: Int -> IO Int
findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"
findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do
performGC
atomicFileWriteString f ""
threadDelay delay_us
atomicFileWriteString f' ""
t <- getModTime f
t' <- getModTime f'
if t /= t' then return delay_us else findResolution_us (delay_us * 10)