Skip to content

Commit

Permalink
refactor server
Browse files Browse the repository at this point in the history
  • Loading branch information
@B04902047
B04902047 committed May 27, 2024
1 parent 0678493 commit b356881
Show file tree
Hide file tree
Showing 32 changed files with 876 additions and 2,421 deletions.
64 changes: 23 additions & 41 deletions gcl.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -55,34 +55,22 @@ library
Render.Syntax.Abstract
Render.Syntax.Common
Server
Server.CustomMethod
Server.GoToDefn
Server.Handler
Server.Handler.AutoCompletion
Server.Handler.CustomMethod
Server.Handler.Diagnostic
Server.Handler.GoToDefn
Server.Handler.CustomMethod.Reload
Server.Handler.CustomMethod.Types
Server.Handler.GoToDefinition
Server.Handler.Hover
Server.Handler2
Server.Handler2.AutoCompletion
Server.Handler2.CustomMethod
Server.Handler2.CustomMethod.HelloWorld
Server.Handler2.CustomMethod.InsertProofTemplate
Server.Handler2.CustomMethod.Inspect
Server.Handler2.CustomMethod.Refine
Server.Handler2.CustomMethod.Reload
Server.Handler2.CustomMethod.SubstituteRedex
Server.Handler2.CustomMethod.Utils
Server.Handler2.GoToDefinition
Server.Handler2.Hover
Server.Handler2.Initialized
Server.Handler2.SemanticTokens
Server.Handler2.Utils
Server.Handler.Initialized
Server.Handler.SemanticTokens
Server.Highlighting
Server.Hover
Server.IntervalMap
Server.Load
Server.Monad
Server.Pipeline
Server.PositionMapping
Server.SrcLoc
Syntax.Abstract
Syntax.Abstract.Instances.Json
Expand Down Expand Up @@ -111,10 +99,12 @@ library
src
ghc-options: -Wall -Werror=incomplete-patterns -fno-warn-orphans
build-depends:
aeson
Diff
, aeson
, base >=4.7 && <5
, bytestring
, containers
, deepseq
, free
, hashable
, lens
Expand Down Expand Up @@ -145,10 +135,12 @@ executable gcl
app
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -Werror=incomplete-patterns -fno-warn-orphans
build-depends:
aeson
Diff
, aeson
, base >=4.7 && <5
, bytestring
, containers
, deepseq
, free
, gcl
, hashable
Expand Down Expand Up @@ -221,34 +213,22 @@ test-suite gcl-test
Render.Syntax.Abstract
Render.Syntax.Common
Server
Server.CustomMethod
Server.GoToDefn
Server.Handler
Server.Handler.AutoCompletion
Server.Handler.CustomMethod
Server.Handler.Diagnostic
Server.Handler.GoToDefn
Server.Handler.CustomMethod.Reload
Server.Handler.CustomMethod.Types
Server.Handler.GoToDefinition
Server.Handler.Hover
Server.Handler2
Server.Handler2.AutoCompletion
Server.Handler2.CustomMethod
Server.Handler2.CustomMethod.HelloWorld
Server.Handler2.CustomMethod.InsertProofTemplate
Server.Handler2.CustomMethod.Inspect
Server.Handler2.CustomMethod.Refine
Server.Handler2.CustomMethod.Reload
Server.Handler2.CustomMethod.SubstituteRedex
Server.Handler2.CustomMethod.Utils
Server.Handler2.GoToDefinition
Server.Handler2.Hover
Server.Handler2.Initialized
Server.Handler2.SemanticTokens
Server.Handler2.Utils
Server.Handler.Initialized
Server.Handler.SemanticTokens
Server.Highlighting
Server.Hover
Server.IntervalMap
Server.Load
Server.Monad
Server.Pipeline
Server.PositionMapping
Server.SrcLoc
Syntax.Abstract
Syntax.Abstract.Instances.Json
Expand Down Expand Up @@ -277,10 +257,12 @@ test-suite gcl-test
src
ghc-options: -Wall -Werror=incomplete-patterns -fno-warn-orphans
build-depends:
aeson
Diff
, aeson
, base >=4.7 && <5
, bytestring
, containers
, deepseq
, directory
, filepath
, free
Expand Down
23 changes: 12 additions & 11 deletions package.yaml
View file
Original file line number Diff line number Diff line change
@@ -1,15 +1,15 @@
name: gcl
version: 0.1.0.0
name: gcl
version: 0.1.0.0
#synopsis:
#description:
homepage: https://github.com/scmlab/gcl
license: BSD3
author: Author name here
maintainer: banacorn@gmail.com
copyright: something
category: language
homepage: https://github.com/scmlab/gcl
license: BSD3
author: Author name here
maintainer: banacorn@gmail.com
copyright: something
category: language
extra-source-files:
- README.md
- README.md

dependencies:
- base >= 4.7 && < 5
Expand All @@ -30,12 +30,14 @@ dependencies:
- regex-applicative
- random
- vector
- lsp
- lsp
- lens
- multiset
- transformers
- template-haskell
- multistate
- deepseq
- Diff

library:
source-dirs: src
Expand All @@ -60,7 +62,6 @@ executables:
- -Werror=incomplete-patterns
- -fno-warn-orphans


tests:
gcl-test:
main: Test.hs
Expand Down
10 changes: 5 additions & 5 deletions src/Server.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,8 +14,8 @@ import Network.Simple.TCP ( HostPreference(Host)
, serve
)
import Network.Socket ( socketToHandle )
import Server.Handler2 ( handlers )
import Server.Monad
import Server.Handler ( handlers )
import Server.Monad (GlobalState, initGlobalEnv, runServerM, logChannel)

--------------------------------------------------------------------------------

Expand All @@ -34,12 +34,12 @@ run devMode port = do
else do
runServer (serverDefn env)
where
printLog :: GlobalEnv -> IO ()
printLog :: GlobalState -> IO ()
printLog env = forever $ do
result <- readChan (globalChan env)
result <- readChan (logChannel env)
when devMode $ do
Text.putStrLn result
serverDefn :: GlobalEnv -> ServerDefinition ()
serverDefn :: GlobalState -> ServerDefinition ()
serverDefn env = ServerDefinition
{ defaultConfig = ()
, onConfigurationChange = const $ pure $ Right ()
Expand Down
147 changes: 59 additions & 88 deletions src/Server/Handler.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,108 +2,79 @@
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BlockArguments #-}

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use lambda-case" #-}

module Server.Handler
( handlers
) where
module Server.Handler ( handlers ) where

import Control.Lens ( (^.) )
import qualified Data.Aeson as JSON
import qualified Data.Aeson as JSON
import Language.LSP.Server ( Handlers
, notificationHandler
, requestHandler
)
import Server.Monad hiding (logText)
import Server.Pipeline

import Error ( Error )
import qualified Language.LSP.Types as J
import qualified Language.LSP.Types.Lens as J
import qualified Language.LSP.Types as LSP
import qualified Language.LSP.Types.Lens as LSP

import qualified Server.Handler.Initialized as Initialized
import qualified Server.Handler.GoToDefinition as GoToDefinition
import qualified Server.Handler.AutoCompletion as AutoCompletion
import qualified Server.Handler.SemanticTokens as SemanticTokens
import qualified Server.Handler.CustomMethod as CustomMethod
import qualified Server.Handler.GoToDefn as GoToDefn
import qualified Server.Handler.Hover as Hover
import Server.Monad (ServerM, modifyPositionDelta)
import Server.PositionMapping (applyChange)
import Server.Load (load)

-- handlers of the LSP server
handlers :: Handlers ServerM
handlers = mconcat
[ notificationHandler J.SInitialized $ \_not -> do
pure ()
,
-- autocompletion
requestHandler J.STextDocumentCompletion $ \req responder -> do
let completionContext = req ^. J.params . J.context
let position = req ^. J.params . J.position
AutoCompletion.handler position completionContext >>= responder . Right
,
-- custom methods, not part of LSP
requestHandler (J.SCustomMethod "guabao") $ \req responder -> do
let params = req ^. J.params
CustomMethod.handler params (responder . Right . JSON.toJSON)
, notificationHandler J.STextDocumentDidChange $ \ntf -> do
let uri = ntf ^. (J.params . J.textDocument . J.uri)
interpret uri (customRequestToNotification uri) $ do
muted <- isMuted
if muted
then return []
else do
logText "\n ---> TextDocumentDidChange"
source <- getSource
parsed <- parse source
converted <- convert parsed
typeChecked <- typeCheck converted
swept <- sweep typeChecked
generateResponseAndDiagnostics swept
, notificationHandler J.STextDocumentDidOpen $ \ntf -> do
let uri = ntf ^. (J.params . J.textDocument . J.uri)
let source = ntf ^. (J.params . J.textDocument . J.text)
interpret uri (customRequestToNotification uri) $ do
logText "\n ---> TextDocumentDidOpen"
parsed <- parse source
converted <- convert parsed
typeChecked <- typeCheck converted
swept <- sweep typeChecked
generateResponseAndDiagnostics swept
, -- Goto Definition
requestHandler J.STextDocumentDefinition $ \req responder -> do
let uri = req ^. (J.params . J.textDocument . J.uri)
let pos = req ^. (J.params . J.position)
GoToDefn.handler uri pos (responder . Right . J.InR . J.InR . J.List)
, -- Hover
requestHandler J.STextDocumentHover $ \req responder -> do
let uri = req ^. (J.params . J.textDocument . J.uri)
let pos = req ^. (J.params . J.position)
Hover.handler uri pos (responder . Right)
, requestHandler J.STextDocumentSemanticTokensFull $ \req responder -> do
let uri = req ^. (J.params . J.textDocument . J.uri)
interpret uri (responder . ignoreErrors) $ do
logText "\n ---> Syntax Highlighting"
let legend = J.SemanticTokensLegend
(J.List J.knownSemanticTokenTypes)
(J.List J.knownSemanticTokenModifiers)
stage <- load
let
highlightings = case stage of
Raw _ -> []
Parsed result -> parsedHighlighings result
Converted result ->
parsedHighlighings (convertedPreviousStage result)
TypeChecked result -> parsedHighlighings
(convertedPreviousStage (typeCheckedPreviousStage result))
Swept result -> parsedHighlighings
(convertedPreviousStage
(typeCheckedPreviousStage (sweptPreviousStage result))
)
let tokens = J.makeSemanticTokens legend highlightings
case tokens of
Left t -> return $ Left $ J.ResponseError J.InternalError t Nothing
Right tokens' -> return $ Right $ Just tokens'
[ -- "initialized" - after initialize
notificationHandler LSP.SInitialized $ \_ntf -> do
Initialized.handler
, -- "textDocument/didOpen" - after open
notificationHandler LSP.STextDocumentDidOpen $ \ntf -> do
let uri = ntf ^. (LSP.params . LSP.textDocument . LSP.uri)
case LSP.uriToFilePath uri of
Nothing -> return ()
Just filePath -> load filePath (\_ -> return ())
, -- "textDocument/didChange" - after every edition
notificationHandler LSP.STextDocumentDidChange $ \ntf -> do
let uri :: LSP.Uri = ntf ^. (LSP.params . LSP.textDocument . LSP.uri)
let (LSP.List changes) = ntf ^. (LSP.params . LSP.contentChanges)
case LSP.uriToFilePath uri of
Nothing -> return ()
Just filePath -> modifyPositionDelta filePath (\positionDelta -> foldl applyChange positionDelta changes)
, -- "textDocument/completion" - autocompletion
requestHandler LSP.STextDocumentCompletion $ \req responder -> do
let completionContext = req ^. LSP.params . LSP.context
let position = req ^. LSP.params . LSP.position
AutoCompletion.handler position completionContext >>= (responder . Right . LSP.InR)
, -- "textDocument/definition" - go to definition
requestHandler LSP.STextDocumentDefinition $ \req responder -> do
let uri = req ^. (LSP.params . LSP.textDocument . LSP.uri)
let position = req ^. (LSP.params . LSP.position)
GoToDefinition.handler uri position (responder . Right . LSP.InR . LSP.InR . LSP.List)
-- , -- "textDocument/hover" - get hover information
-- requestHandler LSP.STextDocumentHover $ \req responder -> do
-- let uri = req ^. (LSP.params . LSP.textDocument . LSP.uri)
-- let pos = req ^. (LSP.params . LSP.position)
-- Hover.handler uri pos (responder . Right)
, -- "textDocument/semanticTokens/full" - get all semantic tokens
requestHandler LSP.STextDocumentSemanticTokensFull $ \req responder -> do
let uri = req ^. (LSP.params . LSP.textDocument . LSP.uri)
SemanticTokens.handler uri responder
, -- "guabao" - reload, refine, inspect and etc.
requestHandler (LSP.SCustomMethod "guabao") $ \req responder -> do
let params = req ^. LSP.params
CustomMethod.handler params (responder . Right . JSON.toJSON)
]

ignoreErrors
:: ([Error], Maybe (Either J.ResponseError (Maybe J.SemanticTokens)))
-> Either J.ResponseError (Maybe J.SemanticTokens)
ignoreErrors (_, Nothing) = Left $ J.ResponseError J.InternalError "?" Nothing
ignoreErrors (_, Just xs) = xs



-- elaborate :: A.Program -> Either Error E.Program
-- elaborate abstract =
Loading

0 comments on commit b356881

Please sign in to comment.