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