Skip to content

Commit 9b1d6ba

Browse files
michaelpjmichaelpj
authored
Merge pull request #519 from haskell/mpj/formatting
Format with fourmolu
2 parents f0c62df + e062a55 commit 9b1d6ba

File tree

453 files changed

+5891
-4599
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

453 files changed

+5891
-4599
lines changed

‎.github/workflows/format.yaml‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
name: Format
2+
3+
on:
4+
push:
5+
branches:
6+
- master
7+
pull_request:
8+
9+
jobs:
10+
check-formatting:
11+
runs-on: ubuntu-latest
12+
13+
steps:
14+
- uses: actions/checkout@v3
15+
- uses: cachix/install-nix-action@v22
16+
with:
17+
nix_path: nixpkgs=channel:nixos-unstable
18+
- run: nix-shell --run "fourmolu -m check ."

‎.github/workflows/nix.yaml‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -17,8 +17,6 @@ jobs:
1717

1818
steps:
1919
- uses: actions/checkout@v3
20-
with:
21-
submodules: true
2220
- uses: cachix/install-nix-action@v22
2321
with:
2422
nix_path: nixpkgs=channel:nixos-unstable

‎fourmolu.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
indentation: 2

‎lsp-test/bench/SimpleBench.hs‎

Lines changed: 42 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -1,46 +1,49 @@
1-
{-# LANGUAGE RankNTypes #-}
1+
{-# LANGUAGE DuplicateRecordFields #-}
22
{-# LANGUAGE GADTs #-}
33
{-# LANGUAGE OverloadedStrings #-}
4-
{-# LANGUAGE DuplicateRecordFields #-}
4+
{-# LANGUAGE RankNTypes #-}
5+
56
module Main where
67

7-
import Language.LSP.Server
8-
import qualified Language.LSP.Test as Test
9-
import Language.LSP.Protocol.Types
10-
import Language.LSP.Protocol.Message
11-
import Control.Monad.IO.Class
8+
import Control.Concurrent
129
import Control.Monad
13-
import System.Process hiding (env)
10+
import Control.Monad.IO.Class
11+
import Data.IORef
12+
import Language.LSP.Protocol.Message
13+
import Language.LSP.Protocol.Types
14+
import Language.LSP.Server
15+
import Language.LSP.Test qualified as Test
1416
import System.Environment
17+
import System.Process hiding (env)
1518
import System.Time.Extra
16-
import Control.Concurrent
17-
import Data.IORef
1819

1920
handlers :: Handlers (LspM ())
20-
handlers = mconcat
21-
[ requestHandler SMethod_TextDocumentHover $ \req responder -> do
22-
let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
23-
Position _l _c' = pos
24-
rsp = Hover ms (Just range)
25-
ms = InL $ mkMarkdown "Hello world"
26-
range = Range pos pos
27-
responder (Right $ InL rsp)
28-
, requestHandler SMethod_TextDocumentDefinition $ \req responder -> do
29-
let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req
30-
responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos)
31-
]
21+
handlers =
22+
mconcat
23+
[ requestHandler SMethod_TextDocumentHover $ \req responder -> do
24+
let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
25+
Position _l _c' = pos
26+
rsp = Hover ms (Just range)
27+
ms = InL $ mkMarkdown "Hello world"
28+
range = Range pos pos
29+
responder (Right $ InL rsp)
30+
, requestHandler SMethod_TextDocumentDefinition $ \req responder -> do
31+
let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req
32+
responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos)
33+
]
3234

3335
server :: ServerDefinition ()
34-
server = ServerDefinition
35-
{ parseConfig = const $ const $ Right ()
36-
, onConfigChange = const $ pure ()
37-
, defaultConfig = ()
38-
, configSection = "demo"
39-
, doInitialize = \env _req -> pure $ Right env
40-
, staticHandlers = \_caps -> handlers
41-
, interpretHandler = \env -> Iso (runLspT env) liftIO
42-
, options = defaultOptions
43-
}
36+
server =
37+
ServerDefinition
38+
{ parseConfig = const $ const $ Right ()
39+
, onConfigChange = const $ pure ()
40+
, defaultConfig = ()
41+
, configSection = "demo"
42+
, doInitialize = \env _req -> pure $ Right env
43+
, staticHandlers = \_caps -> handlers
44+
, interpretHandler = \env -> Iso (runLspT env) liftIO
45+
, options = defaultOptions
46+
}
4447

4548
main :: IO ()
4649
main = do
@@ -59,13 +62,14 @@ main = do
5962
replicateM_ n $ do
6063
v <- liftIO $ readIORef i
6164
liftIO $ when (v `mod` 1000 == 0) $ putStrLn $ show v
62-
TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentHover $
63-
HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing
64-
TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentDefinition $
65-
DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing
65+
TResponseMessage{_result = Right (InL _)} <-
66+
Test.request SMethod_TextDocumentHover $
67+
HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing
68+
TResponseMessage{_result = Right (InL _)} <-
69+
Test.request SMethod_TextDocumentDefinition $
70+
DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing
6671

67-
liftIO $ modifyIORef' i (+1)
72+
liftIO $ modifyIORef' i (+ 1)
6873
pure ()
6974
end <- liftIO start
7075
liftIO $ putStrLn $ "Completed " <> show n <> " rounds in " <> showDuration end
71-

‎lsp-test/example/Test.hs‎

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,22 @@
11
{-# LANGUAGE OverloadedStrings #-}
2+
23
import Control.Applicative.Combinators
34
import Control.Monad.IO.Class
4-
import Language.LSP.Test
5-
import Language.LSP.Protocol.Types
65
import Language.LSP.Protocol.Message
6+
import Language.LSP.Protocol.Types
7+
import Language.LSP.Test
78

89
main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do
910
doc <- openDoc "Rename.hs" "haskell"
10-
11+
1112
-- Use your favourite favourite combinators.
1213
skipManyTill loggingNotification (count 1 publishDiagnosticsNotification)
1314

1415
-- Send requests and notifications and receive responses
15-
rsp <- request SMethod_TextDocumentDocumentSymbol $
16-
DocumentSymbolParams Nothing Nothing doc
16+
rsp <-
17+
request SMethod_TextDocumentDocumentSymbol $
18+
DocumentSymbolParams Nothing Nothing doc
1719
liftIO $ print rsp
1820

1921
-- Or use one of the helper functions
2022
getDocumentSymbols doc >>= liftIO . print
21-

‎lsp-test/func-test/FuncTest.hs‎

Lines changed: 74 additions & 68 deletions
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,27 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE OverloadedStrings #-}
13
{-# LANGUAGE RankNTypes #-}
2-
{-# LANGUAGE GADTs, OverloadedStrings #-}
4+
35
module Main where
46

5-
import Language.LSP.Server
6-
import qualified Language.LSP.Test as Test
7-
import Language.LSP.Protocol.Types
8-
import qualified Language.LSP.Protocol.Lens as L
9-
import Language.LSP.Protocol.Message
7+
import Colog.Core qualified as L
8+
import Control.Applicative.Combinators
9+
import Control.Exception
10+
import Control.Lens hiding (Iso, List)
11+
import Control.Monad
1012
import Control.Monad.IO.Class
13+
import Data.Maybe
14+
import Language.LSP.Protocol.Lens qualified as L
15+
import Language.LSP.Protocol.Message
16+
import Language.LSP.Protocol.Types
17+
import Language.LSP.Server
18+
import Language.LSP.Test qualified as Test
19+
import System.Exit
1120
import System.IO
12-
import Control.Monad
1321
import System.Process
14-
import Control.Applicative.Combinators
15-
import Control.Lens hiding (List, Iso)
1622
import Test.Hspec
17-
import Data.Maybe
1823
import UnliftIO
1924
import UnliftIO.Concurrent
20-
import Control.Exception
21-
import System.Exit
22-
import qualified Colog.Core as L
2325

2426
main :: IO ()
2527
main = hspec $ do
@@ -28,42 +30,44 @@ main = hspec $ do
2830
it "sends end notification if thread is killed" $ do
2931
(hinRead, hinWrite) <- createPipe
3032
(houtRead, houtWrite) <- createPipe
31-
33+
3234
killVar <- newEmptyMVar
3335

34-
let definition = ServerDefinition
35-
{ parseConfig = const $ const $ Right ()
36-
, onConfigChange = const $ pure ()
37-
, defaultConfig = ()
38-
, configSection = "demo"
39-
, doInitialize = \env _req -> pure $ Right env
40-
, staticHandlers = \_caps -> handlers killVar
41-
, interpretHandler = \env -> Iso (runLspT env) liftIO
42-
, options = defaultOptions
43-
}
36+
let definition =
37+
ServerDefinition
38+
{ parseConfig = const $ const $ Right ()
39+
, onConfigChange = const $ pure ()
40+
, defaultConfig = ()
41+
, configSection = "demo"
42+
, doInitialize = \env _req -> pure $ Right env
43+
, staticHandlers = \_caps -> handlers killVar
44+
, interpretHandler = \env -> Iso (runLspT env) liftIO
45+
, options = defaultOptions
46+
}
4447

4548
handlers :: MVar () -> Handlers (LspM ())
4649
handlers killVar =
4750
notificationHandler SMethod_Initialized $ \noti -> do
4851
tid <- withRunInIO $ \runInIO ->
49-
forkIO $ runInIO $
50-
withProgress "Doing something" NotCancellable $ \updater ->
51-
liftIO $ threadDelay (1 * 1000000)
52+
forkIO $
53+
runInIO $
54+
withProgress "Doing something" NotCancellable $ \updater ->
55+
liftIO $ threadDelay (1 * 1000000)
5256
liftIO $ void $ forkIO $ do
5357
takeMVar killVar
5458
killThread tid
55-
59+
5660
forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
57-
61+
5862
Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do
5963
-- First make sure that we get a $/progress begin notification
6064
skipManyTill Test.anyMessage $ do
6165
x <- Test.message SMethod_Progress
6266
guard $ has (L.params . L.value . _workDoneProgressBegin) x
63-
67+
6468
-- Then kill the thread
6569
liftIO $ putMVar killVar ()
66-
70+
6771
-- Then make sure we still get a $/progress end notification
6872
skipManyTill Test.anyMessage $ do
6973
x <- Test.message SMethod_Progress
@@ -73,58 +77,60 @@ main = hspec $ do
7377
it "keeps track of open workspace folders" $ do
7478
(hinRead, hinWrite) <- createPipe
7579
(houtRead, houtWrite) <- createPipe
76-
80+
7781
countVar <- newMVar 0
7882

7983
let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace"
8084
wf1 = WorkspaceFolder (filePathToUri "/foo/bar") "My workspace"
8185
wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace"
82-
83-
definition = ServerDefinition
84-
{ parseConfig = const $ const $ Right ()
85-
, onConfigChange = const $ pure ()
86-
, defaultConfig = ()
87-
, configSection = "demo"
88-
, doInitialize = \env _req -> pure $ Right env
89-
, staticHandlers = \_caps -> handlers
90-
, interpretHandler = \env -> Iso (runLspT env) liftIO
91-
, options = defaultOptions
92-
}
86+
87+
definition =
88+
ServerDefinition
89+
{ parseConfig = const $ const $ Right ()
90+
, onConfigChange = const $ pure ()
91+
, defaultConfig = ()
92+
, configSection = "demo"
93+
, doInitialize = \env _req -> pure $ Right env
94+
, staticHandlers = \_caps -> handlers
95+
, interpretHandler = \env -> Iso (runLspT env) liftIO
96+
, options = defaultOptions
97+
}
9398

9499
handlers :: Handlers (LspM ())
95-
handlers = mconcat
96-
[ notificationHandler SMethod_Initialized $ \noti -> do
97-
wfs <- fromJust <$> getWorkspaceFolders
98-
liftIO $ wfs `shouldContain` [wf0]
99-
, notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do
100-
i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i))
101-
wfs <- fromJust <$> getWorkspaceFolders
102-
liftIO $ case i of
103-
0 -> do
104-
wfs `shouldContain` [wf1]
105-
wfs `shouldContain` [wf0]
106-
1 -> do
107-
wfs `shouldNotContain` [wf1]
108-
wfs `shouldContain` [wf0]
109-
wfs `shouldContain` [wf2]
110-
_ -> error "Shouldn't be here"
111-
]
112-
100+
handlers =
101+
mconcat
102+
[ notificationHandler SMethod_Initialized $ \noti -> do
103+
wfs <- fromJust <$> getWorkspaceFolders
104+
liftIO $ wfs `shouldContain` [wf0]
105+
, notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do
106+
i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i))
107+
wfs <- fromJust <$> getWorkspaceFolders
108+
liftIO $ case i of
109+
0 -> do
110+
wfs `shouldContain` [wf1]
111+
wfs `shouldContain` [wf0]
112+
1 -> do
113+
wfs `shouldNotContain` [wf1]
114+
wfs `shouldContain` [wf0]
115+
wfs `shouldContain` [wf2]
116+
_ -> error "Shouldn't be here"
117+
]
118+
113119
server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
114-
115-
let config = Test.defaultConfig
116-
{ Test.initialWorkspaceFolders = Just [wf0]
117-
}
118-
120+
121+
let config =
122+
Test.defaultConfig
123+
{ Test.initialWorkspaceFolders = Just [wf0]
124+
}
125+
119126
changeFolders add rmv =
120127
let ev = WorkspaceFoldersChangeEvent add rmv
121128
ps = DidChangeWorkspaceFoldersParams ev
122-
in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps
129+
in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps
123130

124131
Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do
125132
changeFolders [wf1] []
126133
changeFolders [wf2] [wf1]
127134

128135
Left e <- waitCatch server
129136
fromException e `shouldBe` Just ExitSuccess
130-

0 commit comments

Comments
 (0)