{-# LANGUAGE OverloadedStrings #-}
module Main
( main
) where
import Control.Lens ((^.))
import qualified Ide.Plugin.Pragmas as Pragmas
import qualified Language.LSP.Types.Lens as L
import System.FilePath
import Test.Hls
main :: IO ()
main = defaultTestRunner tests
pragmasPlugin :: PluginDescriptor IdeState
pragmasPlugin = Pragmas.descriptor "pragmas"
tests :: TestTree
tests =
testGroup "pragmas"
[ codeActionTests
, completionTests
]
codeActionTests :: TestTree
codeActionTests =
testGroup "code actions"
[ goldenWithPragmas "adds TypeSynonymInstances pragma" "NeedsPragmas" $ \doc -> do
_ <- waitForDiagnosticsFromSource doc "typecheck"
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ "Add \"TypeSynonymInstances\"" `elem` map (^. L.title) cas @? "Contains TypeSynonymInstances code action"
liftIO $ "Add \"FlexibleInstances\"" `elem` map (^. L.title) cas @? "Contains FlexibleInstances code action"
executeCodeAction $ head cas
, goldenWithPragmas "adds TypeApplications pragma" "TypeApplications" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ "Add \"TypeApplications\"" `elem` map (^. L.title) cas @? "Contains TypeApplications code action"
executeCodeAction $ head cas
, goldenWithPragmas "no duplication" "NamedFieldPuns" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9))
liftIO $ length cas == 1 @? "Expected one code action, but got: " <> show cas
let ca = head cas
liftIO $ (ca ^. L.title == "Add \"NamedFieldPuns\"") @? "NamedFieldPuns code action"
executeCodeAction ca
, goldenWithPragmas "after shebang" "AfterShebang" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
executeCodeAction $ head cas
, goldenWithPragmas "append to existing pragmas" "AppendToExisting" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
executeCodeAction $ head cas
, goldenWithPragmas "before doc comments" "BeforeDocComment" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
executeCodeAction $ head cas
, goldenWithPragmas "before doc comments" "MissingSignatures" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ "Disable \"missing-signatures\" warnings" `elem` map (^. L.title) cas @? "Contains missing-signatures code action"
executeCodeAction $ head cas
, goldenWithPragmas "before doc comments" "UnusedImports" $ \doc -> do
_ <- waitForDiagnosticsFrom doc
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ "Disable \"unused-imports\" warnings" `elem` map (^. L.title) cas @? "Contains unused-imports code action"
executeCodeAction $ head cas
]
completionTests :: TestTree
completionTests =
testGroup "completions"
[ testCase "completes pragmas" $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- waitForDiagnostics
let te = TextEdit (Range (Position 0 4) (Position 0 34)) ""
_ <- applyEdit doc te
compls <- getCompletions doc (Position 0 4)
let item = head $ filter ((== "LANGUAGE") . (^. L.label)) compls
liftIO $ do
item ^. L.label @?= "LANGUAGE"
item ^. L.kind @?= Just CiKeyword
item ^. L.insertTextFormat @?= Just Snippet
item ^. L.insertText @?= Just "LANGUAGE ${1:extension} #-}"
, testCase "completes pragmas no close" $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc "Completion.hs" "haskell"
let te = TextEdit (Range (Position 0 4) (Position 0 24)) ""
_ <- applyEdit doc te
compls <- getCompletions doc (Position 0 4)
let item = head $ filter ((== "LANGUAGE") . (^. L.label)) compls
liftIO $ do
item ^. L.label @?= "LANGUAGE"
item ^. L.kind @?= Just CiKeyword
item ^. L.insertTextFormat @?= Just Snippet
item ^. L.insertText @?= Just "LANGUAGE ${1:extension}"
, testCase "completes options pragma" $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- waitForDiagnostics
let te = TextEdit (Range (Position 0 4) (Position 0 34)) "OPTIONS"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 0 4)
let item = head $ filter ((== "OPTIONS_GHC") . (^. L.label)) compls
liftIO $ do
item ^. L.label @?= "OPTIONS_GHC"
item ^. L.kind @?= Just CiKeyword
item ^. L.insertTextFormat @?= Just Snippet
item ^. L.insertText @?= Just "OPTIONS_GHC -${1:option} #-}"
, testCase "completes ghc options pragma values" $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc "Completion.hs" "haskell"
let te = TextEdit (Range (Position 0 0) (Position 0 0)) "{-# OPTIONS_GHC -Wno-red #-}\n"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 0 24)
let item = head $ filter ((== "Wno-redundant-constraints") . (^. L.label)) compls
liftIO $ do
item ^. L.label @?= "Wno-redundant-constraints"
item ^. L.kind @?= Just CiKeyword
item ^. L.insertTextFormat @?= Nothing
item ^. L.insertText @?= Nothing
, testCase "completes language extensions" $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- waitForDiagnostics
let te = TextEdit (Range (Position 0 24) (Position 0 31)) ""
_ <- applyEdit doc te
compls <- getCompletions doc (Position 0 24)
let item = head $ filter ((== "OverloadedStrings") . (^. L.label)) compls
liftIO $ do
item ^. L.label @?= "OverloadedStrings"
item ^. L.kind @?= Just CiKeyword
, testCase "completes the Strict language extension" $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- waitForDiagnostics
let te = TextEdit (Range (Position 0 13) (Position 0 31)) "Str"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 0 16)
let item = head $ filter ((== "Strict") . (^. L.label)) compls
liftIO $ do
item ^. L.label @?= "Strict"
item ^. L.kind @?= Just CiKeyword
, testCase "completes No- language extensions" $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- waitForDiagnostics
let te = TextEdit (Range (Position 0 13) (Position 0 31)) "NoOverload"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 0 23)
let item = head $ filter ((== "NoOverloadedStrings") . (^. L.label)) compls
liftIO $ do
item ^. L.label @?= "NoOverloadedStrings"
item ^. L.kind @?= Just CiKeyword
]
goldenWithPragmas :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
goldenWithPragmas title path = goldenWithHaskellDoc pragmasPlugin title testDataDir path "expected" "hs"
testDataDir :: FilePath
testDataDir = "test" </> "testdata"