1{-# LANGUAGE DuplicateRecordFields #-} 2{-# LANGUAGE NamedFieldPuns #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE TypeOperators #-} 5{-# LANGUAGE ViewPatterns #-} 6 7module Main 8 ( main 9 ) where 10 11import Control.Monad (void) 12import Data.List (find) 13import Data.Text (Text) 14import qualified Data.Text as T 15import qualified Data.Text.IO as T 16import qualified Ide.Plugin.Splice as Splice 17import Ide.Plugin.Splice.Types 18import System.FilePath 19import Test.Hls 20 21main :: IO () 22main = defaultTestRunner tests 23 24splicePlugin :: PluginDescriptor IdeState 25splicePlugin = Splice.descriptor "splice" 26 27tests :: TestTree 28tests = testGroup "splice" 29 [ goldenTest "TSimpleExp" Inplace 6 15 30 , goldenTest "TSimpleExp" Inplace 6 24 31 , goldenTest "TTypeAppExp" Inplace 7 5 32 , goldenTest "TErrorExp" Inplace 6 15 33 , goldenTest "TErrorExp" Inplace 6 51 34 , goldenTest "TQQExp" Inplace 6 17 35 , goldenTest "TQQExp" Inplace 6 25 36 , goldenTest "TQQExpError" Inplace 6 13 37 , goldenTest "TQQExpError" Inplace 6 22 38 , testGroup "Pattern Splices" 39 [ goldenTest "TSimplePat" Inplace 6 3 40 , goldenTest "TSimplePat" Inplace 6 22 41 , goldenTest "TSimplePat" Inplace 6 3 42 , goldenTest "TSimplePat" Inplace 6 22 43 , goldenTest "TErrorPat" Inplace 6 3 44 , goldenTest "TErrorPat" Inplace 6 18 45 , goldenTest "TQQPat" Inplace 6 3 46 , goldenTest "TQQPat" Inplace 6 11 47 , goldenTest "TQQPatError" Inplace 6 3 48 , goldenTest "TQQPatError" Inplace 6 11 49 ] 50 , goldenTest "TSimpleType" Inplace 5 12 51 , goldenTest "TSimpleType" Inplace 5 22 52 , goldenTest "TTypeTypeError" Inplace 7 12 53 , goldenTest "TTypeTypeError" Inplace 7 52 54 , goldenTest "TQQType" Inplace 8 19 55 , goldenTest "TQQType" Inplace 8 28 56 , goldenTest "TQQTypeTypeError" Inplace 8 19 57 , goldenTest "TQQTypeTypeError" Inplace 8 28 58 , goldenTest "TSimpleDecl" Inplace 8 1 59 , goldenTest "TQQDecl" Inplace 5 1 60 , goldenTestWithEdit "TTypeKindError" Inplace 7 9 61 , goldenTestWithEdit "TDeclKindError" Inplace 8 1 62 ] 63 64goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree 65goldenTest fp tc line col = 66 goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do 67 _ <- waitForDiagnostics 68 actions <- getCodeActions doc $ pointRange line col 69 case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of 70 Just (InR CodeAction {_command = Just c}) -> do 71 executeCommand c 72 void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) 73 _ -> liftIO $ assertFailure "No CodeAction detected" 74 75goldenTestWithEdit :: FilePath -> ExpandStyle -> Int -> Int -> TestTree 76goldenTestWithEdit fp tc line col = 77 goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do 78 orig <- documentContents doc 79 let 80 lns = T.lines orig 81 theRange = 82 Range 83 { _start = Position 0 0 84 , _end = Position (length lns + 1) 1 85 } 86 waitForProgressDone -- cradle 87 waitForProgressDone 88 alt <- liftIO $ T.readFile (fp <.> "error.hs") 89 void $ applyEdit doc $ TextEdit theRange alt 90 changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] 91 void waitForDiagnostics 92 actions <- getCodeActions doc $ pointRange line col 93 case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of 94 Just (InR CodeAction {_command = Just c}) -> do 95 executeCommand c 96 void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) 97 _ -> liftIO $ assertFailure "No CodeAction detected" 98 99testDataDir :: FilePath 100testDataDir = "test" </> "testdata" 101 102pointRange :: Int -> Int -> Range 103pointRange (subtract 1 -> line) (subtract 1 -> col) = 104 Range (Position line col) (Position line $ col + 1) 105 106-- | Get the title of a code action. 107codeActionTitle :: (Command |? CodeAction) -> Maybe Text 108codeActionTitle InL {} = Nothing 109codeActionTitle (InR CodeAction {_title}) = Just _title 110