├── .gitignore ├── CHANGELOG.md ├── README.md ├── Setup.hs ├── cabal.project ├── exe ├── Decoding.hs ├── Main.hs ├── Messages.hs ├── Process.hs ├── Types.hs └── View.hs ├── hie.yaml ├── shell.nix └── simple-language-client.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for simple-language-client 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A LSP client where save events are powered by fsnotify and diagnostics 2 | displayed in a minimal terminal interface. 3 | 4 | ``` 5 | Welcome to simple-language-client 6 | 7 | Usage: simple-language-client [-s|--server ARG] DIR [--root-dir ARG] 8 | A language client powered by fsnotify 9 | 10 | Available options: 11 | -s,--server ARG Path to the language server (default: "ghcide") 12 | DIR The directory containing the source files to load 13 | --root-dir ARG Path to root dir 14 | -h,--help Show this help text 15 | ``` 16 | 17 | # Usage 18 | 19 | Start `simple-language-client` in the root directory of your project. By default it will 20 | try to call `ghcide` in order to start the language server. The argument is 21 | a directory of files which contains the component you want `ghcide` to load or 22 | a single root file which will be loaded on its own. 23 | 24 | ``` 25 | simple-language-client src/ 26 | ``` 27 | 28 | You can also specify to use `hie` by changing the server argument to a path to the 29 | `hie` executable. 30 | 31 | ``` 32 | simple-language-client -s hie src/ 33 | ``` 34 | 35 | Pointing the client at a single file also works: 36 | 37 | ``` 38 | simple-language-client exe/Main.hs 39 | ``` 40 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /exe/Decoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Decoding where 3 | 4 | import Prelude hiding ( id ) 5 | import Data.Aeson 6 | import Data.Foldable 7 | import Control.Exception 8 | import Control.Lens 9 | import qualified Data.ByteString.Lazy.Char8 as B 10 | import Data.Maybe 11 | import System.IO 12 | import System.IO.Error 13 | import Language.Haskell.LSP.Types 14 | import Language.Haskell.LSP.Types.Lens 15 | hiding ( error ) 16 | import Language.Haskell.LSP.Messages 17 | import qualified Data.HashMap.Strict as HM 18 | 19 | 20 | -- | Fetches the next message bytes based on 21 | -- the Content-Length header 22 | getNextMessage :: Handle -> IO B.ByteString 23 | getNextMessage h = do 24 | headers <- getHeaders h 25 | case read . init <$> lookup "Content-Length" headers of 26 | Nothing -> error "Non content length" 27 | Just size -> B.hGet h size 28 | 29 | addHeader :: B.ByteString -> B.ByteString 30 | addHeader content = B.concat 31 | [ "Content-Length: " 32 | , B.pack $ show $ B.length content 33 | , "\r\n" 34 | , "\r\n" 35 | , content 36 | ] 37 | 38 | getHeaders :: Handle -> IO [(String, String)] 39 | getHeaders h = do 40 | l <- catch (hGetLine h) eofHandler 41 | let (hname, val) = span (/= ':') l 42 | if null val then return [] else ((hname, drop 2 val) :) <$> getHeaders h 43 | where eofHandler e 44 | | isEOFError e = throw e 45 | | otherwise = throw e 46 | 47 | type RequestMap = HM.HashMap LspId ClientMethod 48 | 49 | newRequestMap :: RequestMap 50 | newRequestMap = HM.empty 51 | 52 | updateRequestMap :: LspId -> ClientMethod -> RequestMap -> RequestMap 53 | updateRequestMap lspid cmethod = HM.insert lspid cmethod 54 | 55 | getRequestMap :: [FromClientMessage] -> RequestMap 56 | getRequestMap = foldl helper HM.empty 57 | where 58 | helper acc msg = case msg of 59 | (ReqInitialize val) -> insert val acc 60 | (ReqShutdown val) -> insert val acc 61 | (ReqHover val) -> insert val acc 62 | (ReqCompletion val) -> insert val acc 63 | (ReqCompletionItemResolve val) -> insert val acc 64 | (ReqSignatureHelp val) -> insert val acc 65 | (ReqDefinition val) -> insert val acc 66 | (ReqTypeDefinition val) -> insert val acc 67 | (ReqFindReferences val) -> insert val acc 68 | (ReqDocumentHighlights val) -> insert val acc 69 | (ReqDocumentSymbols val) -> insert val acc 70 | (ReqWorkspaceSymbols val) -> insert val acc 71 | (ReqCodeAction val) -> insert val acc 72 | (ReqCodeLens val) -> insert val acc 73 | (ReqCodeLensResolve val) -> insert val acc 74 | (ReqDocumentFormatting val) -> insert val acc 75 | (ReqDocumentRangeFormatting val) -> insert val acc 76 | (ReqDocumentOnTypeFormatting val) -> insert val acc 77 | (ReqRename val) -> insert val acc 78 | (ReqExecuteCommand val) -> insert val acc 79 | (ReqDocumentLink val) -> insert val acc 80 | (ReqDocumentLinkResolve val) -> insert val acc 81 | (ReqWillSaveWaitUntil val) -> insert val acc 82 | _ -> acc 83 | insert m = HM.insert (m ^. id) (m ^. method) 84 | 85 | matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage 86 | matchResponseMsgType req = case req of 87 | Initialize -> RspInitialize . decoded 88 | Shutdown -> RspShutdown . decoded 89 | TextDocumentHover -> RspHover . decoded 90 | TextDocumentCompletion -> RspCompletion . decoded 91 | CompletionItemResolve -> RspCompletionItemResolve . decoded 92 | TextDocumentSignatureHelp -> RspSignatureHelp . decoded 93 | TextDocumentDefinition -> RspDefinition . decoded 94 | TextDocumentTypeDefinition -> RspTypeDefinition . decoded 95 | TextDocumentReferences -> RspFindReferences . decoded 96 | TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded 97 | TextDocumentDocumentSymbol -> RspDocumentSymbols . decoded 98 | WorkspaceSymbol -> RspWorkspaceSymbols . decoded 99 | TextDocumentCodeAction -> RspCodeAction . decoded 100 | TextDocumentCodeLens -> RspCodeLens . decoded 101 | CodeLensResolve -> RspCodeLensResolve . decoded 102 | TextDocumentFormatting -> RspDocumentFormatting . decoded 103 | TextDocumentRangeFormatting -> RspDocumentRangeFormatting . decoded 104 | TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting . decoded 105 | TextDocumentRename -> RspRename . decoded 106 | WorkspaceExecuteCommand -> RspExecuteCommand . decoded 107 | TextDocumentDocumentLink -> RspDocumentLink . decoded 108 | DocumentLinkResolve -> RspDocumentLinkResolve . decoded 109 | TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded 110 | x -> error . ((show x ++ " is not a request: ") ++) . show 111 | where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: " 112 | ++ show req ++ "\n" ++ show x) 113 | (decode x) 114 | 115 | decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage 116 | decodeFromServerMsg reqMap bytes = 117 | case HM.lookup "method" obj of 118 | Just methodStr -> case fromJSON methodStr of 119 | Success smethod -> case smethod of 120 | -- We can work out the type of the message 121 | TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes 122 | WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes 123 | WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes 124 | CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes 125 | Progress -> 126 | fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes] 127 | WindowWorkDoneProgressCreate -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes 128 | TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes 129 | WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes 130 | ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes 131 | ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes 132 | WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes 133 | WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" 134 | WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" 135 | CustomServerMethod _ 136 | | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes 137 | | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes 138 | | otherwise -> NotCustomServer $ fromJust $ decode bytes 139 | 140 | Error e -> error e 141 | 142 | Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of 143 | Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of 144 | Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type 145 | Nothing -> error "Couldn't match up response with request" 146 | Nothing -> error "Couldn't decode message" 147 | where obj = fromJust $ decode bytes :: Object 148 | -------------------------------------------------------------------------------- /exe/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE PartialTypeSignatures #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | {-# LANGUAGE NoMonomorphismRestriction #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | module Main where 10 | 11 | 12 | {- Plan 13 | - 14 | - 1. Start the LSP server using reflex-process and provide an event for 15 | - input/output 16 | - 2. Watch for file changes in the current directory using fsnotify 17 | - 3. Send a notification to the server on a file change 18 | - 4. Display the diagnostics when ghcide reports them 19 | -} 20 | import Control.Monad.Extra 21 | import Data.Maybe hiding (mapMaybe) 22 | import Language.Haskell.LSP.Messages 23 | import Language.Haskell.LSP.Types hiding (_workspace) 24 | import Data.Default 25 | import Reflex 26 | import qualified System.Posix.Process 27 | import System.Process (proc) 28 | import Reflex.Process 29 | import Control.Monad.IO.Class 30 | import qualified Data.Text as T 31 | import Language.Haskell.LSP.Types.Capabilities 32 | import System.Directory 33 | import Reflex.FSNotify (watchDirectory) 34 | import qualified System.FSNotify as FS 35 | import System.FilePath 36 | import System.FilePath.Find 37 | import System.Posix.Signals 38 | import Control.Retry 39 | import Control.Monad.Catch (Handler(..)) 40 | 41 | 42 | import Control.Exception hiding (Handler(..)) 43 | 44 | import Reflex.Vty 45 | 46 | import qualified Graphics.Vty.Input as V 47 | import qualified Data.Text.IO as T 48 | import qualified Data.Map as M 49 | import qualified Data.Set as Set 50 | import qualified Data.Aeson as A 51 | import qualified Data.Foldable as F 52 | 53 | import Reflex.Network 54 | 55 | 56 | import Options.Applicative hiding (switch) 57 | import Control.Monad(void) 58 | import Control.Monad.Fix 59 | 60 | import Types 61 | import Process 62 | import View 63 | 64 | getCurrentProcessID :: Num b => IO b 65 | getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID 66 | 67 | getHSFiles :: FilePath -> IO [FilePath] 68 | getHSFiles = findWithHandler (\_ _ -> return []) always 69 | (extension ==? ".hs" 70 | ||? extension ==? ".lhs") 71 | 72 | 73 | -- | If the path is a directory then find all files in that directory, 74 | -- otherwise just load the single file 75 | pathToFiles :: FilePath -> FilePath -> IO [FilePath] 76 | pathToFiles root_dir spec = do 77 | let dpath = if isRelative spec 78 | then root_dir spec 79 | else spec 80 | dexist <- doesDirectoryExist dpath 81 | if dexist 82 | then getHSFiles dpath 83 | -- Probably a file 84 | else return [dpath] 85 | 86 | watchHSDirectory :: (PostBuild t m, TriggerEvent t m, PerformEvent t m, 87 | MonadIO (Performable m)) => FilePath -> m (Event t FS.Event) 88 | watchHSDirectory absRootDir = do 89 | -- TODO: Separate the filesystem event logic into its own function 90 | -- Watch the project directory for changes 91 | pb <- getPostBuild 92 | fsEvents <- watchDirectory (noDebounce FS.defaultConfig) (absRootDir <$ pb) 93 | -- Should use the watched files to perform the filtering 94 | let filteredFsEvents = flip ffilter fsEvents $ \e -> 95 | takeExtension (FS.eventPath e) `elem` [".hs", ".lhs"] 96 | return filteredFsEvents 97 | 98 | 99 | startSession :: (Reflex t 100 | , TriggerEvent t m 101 | , PerformEvent t m 102 | , MonadIO (Performable m) 103 | , MonadHold t m 104 | , MonadIO m 105 | , MonadIO (Performable m) 106 | , PostBuild t m 107 | , MonadFix m) 108 | => Event t () 109 | -> String 110 | -> [String] 111 | -> ClientCapabilities 112 | -> FilePath 113 | -> [FilePath] 114 | -> m (Session t) 115 | startSession exit cmd args caps rootDir targets = mdo 116 | pid <- liftIO $ getCurrentProcessID 117 | absRootDir <- liftIO $ canonicalizePath rootDir 118 | let initializeParams = InitializeParams (Just pid) 119 | (Just $ T.pack absRootDir) 120 | (Just $ filePathToUri absRootDir) 121 | Nothing 122 | caps 123 | (Just TraceOff) 124 | Nothing 125 | 126 | -- Start watching the root directory for changes 127 | hsEvents <- watchHSDirectory absRootDir 128 | docModify <- performEvent (liftIO . fsNotifyToRequest sendOpen <$> attachPromptlyDyn openFiles hsEvents) 129 | -- Make an event which can be triggered manually 130 | (messageIn, sendMessage) <- mkMessageIn 131 | 132 | (open_e, sendOpen) <- newTriggerEvent 133 | 134 | let in_message = leftmost [messageIn, mapMaybe id docModify] 135 | 136 | let process = proc cmd args 137 | processConfig = 138 | ProcessConfig 139 | (attachPromptlyDynWith (\b a -> (a (IdInt b))) (counter st) in_message) 140 | (sigINT <$ exit) 141 | 142 | -- Start language server 143 | p <- createLSPProcess process processConfig 144 | 145 | -- Send initialisation request 146 | liftIO $ sendMessage (mkInitialiseRequest initializeParams) 147 | 148 | -- Open all files as specified by the target 149 | liftIO $ do 150 | iniFiles <- concatMapM (pathToFiles absRootDir) targets 151 | -- Choose one to get things going, further files are opened when 152 | -- fsnotify says they have changed. 153 | case iniFiles of 154 | [] -> return () 155 | (f:_) -> sendOpen f 156 | 157 | openFiles <- foldDyn Set.insert Set.empty opened_files 158 | 159 | let do_open f = openFile f >>= (f <$) . sendMessage 160 | opened_files <- performEvent (liftIO . do_open <$> open_e) 161 | 162 | st <- mkClientState sendMessage in_message 163 | 164 | debug <- mkDebugOutput (_processConfig_stdin processConfig) p 165 | diags <- mkDiags p 166 | status <- mkStatus p 167 | return (Session debug diags status p) 168 | 169 | mkDiags :: (Reflex t, MonadHold t m, MonadFix m) => LSPProcess t 170 | -> m (Dynamic t DiagMap) 171 | mkDiags p = foldDyn update emptyDiagMap (_process_stdout p) 172 | where 173 | update :: FromServerMessage -> DiagMap -> DiagMap 174 | update (NotPublishDiagnostics (NotificationMessage _ _ (PublishDiagnosticsParams uri (List ds)))) d 175 | = case ds of 176 | [] -> deleteDiag uri d 177 | _ -> addDiag uri ds d 178 | 179 | update _ d = d 180 | 181 | mkStatus :: (Reflex t, MonadHold t m, MonadFix m) => LSPProcess t 182 | -> m (Dynamic t ProgressStatus) 183 | mkStatus p = foldDyn update (ProgressStatus "" M.empty) (_process_stdout p) 184 | where 185 | update :: FromServerMessage -> ProgressStatus -> ProgressStatus 186 | update (NotWorkDoneProgressBegin (NotificationMessage _ _ (ProgressParams tok (WorkDoneProgressBeginParams tit _mc mm mp)))) (ProgressStatus _t ps) = 187 | ProgressStatus (renderProgress tit mm mp) (M.insert tok tit ps) 188 | update (NotWorkDoneProgressReport (NotificationMessage _ _ (ProgressParams tok (WorkDoneProgressReportParams _mc mm mp)))) prog@(ProgressStatus _t ps) = 189 | let mtit = M.lookup tok ps 190 | in case mtit of 191 | -- This case should never happen 192 | Nothing -> prog 193 | Just tit -> ProgressStatus (renderProgress tit mm mp) ps 194 | 195 | update (NotWorkDoneProgressEnd (NotificationMessage _ _ (ProgressParams tok (WorkDoneProgressEndParams _mm)))) (ProgressStatus t ps) = 196 | let ps' = M.delete tok ps 197 | in if M.null ps' 198 | then ProgressStatus "" ps' 199 | else ProgressStatus t ps 200 | 201 | update _ d = d 202 | 203 | 204 | getNewWatcher :: FromServerMessage -> [FileSystemWatcher] 205 | getNewWatcher (ReqRegisterCapability (RequestMessage _t _i _m (RegistrationParams rs))) = 206 | concat $ mapMaybe processRegistration (F.toList rs) 207 | where 208 | processRegistration :: Registration -> Maybe [FileSystemWatcher] 209 | processRegistration (Registration _rid WorkspaceDidChangeWatchedFiles (Just args)) = 210 | case A.fromJSON args of 211 | A.Error _s -> Nothing 212 | A.Success (DidChangeWatchedFilesRegistrationOptions { watchers = List ws }) 213 | -> Just ws 214 | getNewWatcher _ = [] 215 | 216 | renderProgress :: T.Text -> Maybe T.Text -> Maybe Double -> T.Text 217 | renderProgress rhead mm mp = p <> rhead <> m 218 | where 219 | p = fromMaybe "" ((<> " ") . T.pack . show <$> mp) 220 | m = fromMaybe "" ((": " <>) <$> mm) 221 | 222 | mkInitialiseRequest :: InitializeParams -> (LspId -> FromClientMessage) 223 | mkInitialiseRequest p i = ReqInitialize (RequestMessage "2.0" i Initialize p) 224 | 225 | fsNotifyToRequest :: (FilePath -> IO ()) -> (Set.Set FilePath, FS.Event) -> IO (Maybe (LspId -> FromClientMessage)) 226 | fsNotifyToRequest open_not (os, e) = do 227 | let fp = FS.eventPath e 228 | mt <- readFileRetry fp 229 | case mt of 230 | Nothing -> return Nothing 231 | Just t 232 | | fp `Set.member` os -> 233 | -- HACK, shouldn't use IdInt like this but need to increment the version 234 | -- each time. 235 | return $ Just $ \(IdInt i) -> NotDidChangeTextDocument (NotificationMessage "2.0" TextDocumentDidChange 236 | (DidChangeTextDocumentParams 237 | (VersionedTextDocumentIdentifier (filePathToUri (FS.eventPath e)) (Just i)) 238 | (List [TextDocumentContentChangeEvent Nothing Nothing t]) 239 | )) 240 | | otherwise -> do 241 | open_not fp 242 | return $ Just $ openFileNot fp t 243 | 244 | 245 | -- Try three times, for a timing issue but then return Nothing if it 246 | -- doesn't exist still. 247 | readFileRetry :: FilePath -> IO (Maybe T.Text) 248 | readFileRetry fp = 249 | let policy = limitRetries 3 250 | retry_act = recovering policy 251 | [\_ -> Handler (\(_e :: IOException) -> return True)] 252 | (\_ -> T.readFile fp) 253 | in (Just <$> retry_act) `catch` (\(_ :: IOException) -> return Nothing) 254 | 255 | 256 | openFile :: FilePath -> IO (LspId -> FromClientMessage) 257 | openFile fp = do 258 | t <- T.readFile fp 259 | return $ openFileNot fp t 260 | 261 | openFileNot :: FilePath -> T.Text -> LspId -> FromClientMessage 262 | openFileNot fp t _ = 263 | NotDidOpenTextDocument (NotificationMessage "2.0" TextDocumentDidOpen 264 | (DidOpenTextDocumentParams 265 | (TextDocumentItem (filePathToUri fp) "haskell" 0 t))) 266 | 267 | mkMessageIn :: TriggerEvent t m 268 | => m (Event t (LspId -> FromClientMessage) 269 | , (LspId -> FromClientMessage) -> IO () ) 270 | mkMessageIn = newTriggerEvent 271 | 272 | mkClientState :: (Reflex t, MonadHold t m, MonadFix m) 273 | => ((LspId -> FromClientMessage) -> IO ()) 274 | -> Event t a 275 | -> m (ClientState t) 276 | mkClientState send messageIn = do 277 | c <- count messageIn 278 | return $ ClientState { sendRequest = send 279 | , counter = c } 280 | 281 | 282 | data ClientArg = ClientArg 283 | { _clientArg_serverCommand :: String 284 | , _clientArg_files :: [FilePath] 285 | , _clientArg_root_dir :: Maybe FilePath 286 | } 287 | 288 | ghciArg :: Parser ClientArg 289 | ghciArg = ClientArg 290 | <$> strOption 291 | ( long "server" <> 292 | short 's' <> 293 | help "Path to the language server" <> 294 | showDefault <> 295 | value "ghcide" 296 | ) 297 | <*> some (argument str 298 | ( 299 | help "The directories containing the source files to load" 300 | <> metavar "DIRS" 301 | )) 302 | <*> optional (strOption (long "root-dir" <> help "Path to root dir")) 303 | 304 | 305 | lcCaps :: ClientCapabilities 306 | lcCaps = def { _window = Just (WindowClientCapabilities (Just True)) } 307 | 308 | main :: IO () 309 | main = do 310 | let opts = info (ghciArg <**> helper) $ mconcat 311 | [ fullDesc 312 | , progDesc "A language client powered by fsnotify" 313 | , header "Welcome to simple-language-client" 314 | ] 315 | ClientArg { _clientArg_serverCommand = cmd 316 | , _clientArg_files = file_dir 317 | , _clientArg_root_dir = mroot_dir } <- execParser opts 318 | root_dir <- maybe getCurrentDirectory return mroot_dir 319 | mainWidget $ mdo 320 | exit <- (() <$) <$> keyCombo (V.KChar 'c', [V.MCtrl]) 321 | d <- key (V.KChar 'd') 322 | 323 | session <- startSession exit cmd ["--lsp"] lcCaps root_dir file_dir 324 | 325 | let home = col $ do 326 | stretch $ col $ do 327 | stretch $ diagnosticsPane session 328 | fixed 3 $ boxStatic def $ text (current (currentMessage <$> status session)) 329 | fixed 3 $ boxStatic def $ text "simple-language-client: C-c - quit; d - debug" 330 | return $ leftmost 331 | [ Left () <$ d 332 | ] 333 | rec out <- networkHold home $ ffor (switch (current out)) $ \case 334 | Left () -> escapable (debugView session) 335 | Right () -> home 336 | 337 | let escapable w = do 338 | void w 339 | i <- input 340 | return $ fforMaybe i $ \case 341 | V.EvKey V.KEsc [] -> Just $ Right () 342 | _ -> Nothing 343 | 344 | return exit 345 | 346 | noDebounce :: FS.WatchConfig -> FS.WatchConfig 347 | noDebounce cfg = cfg { FS.confDebounce = FS.NoDebounce } 348 | 349 | 350 | --- 351 | -------------------------------------------------------------------------------------------------- 352 | -- The message definitions below probably belong in haskell-lsp-types 353 | -- Copied from ghcide 354 | 355 | data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions 356 | { watchers :: List FileSystemWatcher 357 | } 358 | 359 | instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where 360 | toJSON DidChangeWatchedFilesRegistrationOptions {..} = 361 | A.object ["watchers" A..= watchers] 362 | 363 | instance A.FromJSON DidChangeWatchedFilesRegistrationOptions where 364 | parseJSON = 365 | A.withObject "didChange" 366 | (\o -> DidChangeWatchedFilesRegistrationOptions <$> (o A..: "watchers")) 367 | 368 | data FileSystemWatcher = FileSystemWatcher 369 | { -- | The glob pattern to watch. 370 | -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles 371 | globPattern :: String 372 | -- | The kind of event to subscribe to. Defaults to all. 373 | -- Defined as a bitmap of Create(1), Change(2), and Delete(4) 374 | , kind :: Maybe Int 375 | } 376 | 377 | instance A.ToJSON FileSystemWatcher where 378 | toJSON FileSystemWatcher {..} = 379 | A.object 380 | $ ["globPattern" A..= globPattern] 381 | ++ [ "kind" A..= x | Just x <- [kind] ] 382 | 383 | instance A.FromJSON FileSystemWatcher where 384 | parseJSON = A.withObject "watcher" (\o -> FileSystemWatcher <$> o A..: "globPattern" 385 | <*> o A..:? "kind" ) 386 | 387 | 388 | -------------------------------------------------------------------------------- /exe/Messages.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Messages where 3 | 4 | import Data.Aeson 5 | import Language.Haskell.LSP.Messages 6 | import Language.Haskell.LSP.Types 7 | 8 | handleServerMessage 9 | :: forall a. 10 | (forall b c. RequestMessage ServerMethod b c -> a) 11 | -> (forall d. ResponseMessage d -> a) 12 | -> (forall e. NotificationMessage ServerMethod e -> a) 13 | -> FromServerMessage 14 | -> a 15 | handleServerMessage request response notification msg = case msg of 16 | (ReqRegisterCapability m) -> request m 17 | (ReqApplyWorkspaceEdit m) -> request m 18 | (ReqShowMessage m) -> request m 19 | (ReqUnregisterCapability m) -> request m 20 | (ReqCustomServer m) -> request m 21 | (ReqWorkDoneProgressCreate m) -> request m 22 | (RspInitialize m) -> response m 23 | (RspShutdown m) -> response m 24 | (RspHover m) -> response m 25 | (RspCompletion m) -> response m 26 | (RspCompletionItemResolve m) -> response m 27 | (RspSignatureHelp m) -> response m 28 | (RspDefinition m) -> response m 29 | (RspFindReferences m) -> response m 30 | (RspDocumentHighlights m) -> response m 31 | (RspDocumentSymbols m) -> response m 32 | (RspWorkspaceSymbols m) -> response m 33 | (RspCodeAction m) -> response m 34 | (RspCodeLens m) -> response m 35 | (RspCodeLensResolve m) -> response m 36 | (RspDocumentFormatting m) -> response m 37 | (RspDocumentRangeFormatting m) -> response m 38 | (RspDocumentOnTypeFormatting m) -> response m 39 | (RspRename m) -> response m 40 | (RspExecuteCommand m) -> response m 41 | (RspError m) -> response m 42 | (RspDocumentLink m) -> response m 43 | (RspDocumentLinkResolve m) -> response m 44 | (RspWillSaveWaitUntil m) -> response m 45 | (RspTypeDefinition m) -> response m 46 | (RspImplementation m) -> response m 47 | (RspDocumentColor m) -> response m 48 | (RspColorPresentation m) -> response m 49 | (RspFoldingRange m) -> response m 50 | (RspCustomServer m) -> response m 51 | (NotPublishDiagnostics m) -> notification m 52 | (NotLogMessage m) -> notification m 53 | (NotShowMessage m) -> notification m 54 | (NotWorkDoneProgressBegin m) -> notification m 55 | (NotWorkDoneProgressReport m) -> notification m 56 | (NotWorkDoneProgressEnd m) -> notification m 57 | (NotTelemetry m) -> notification m 58 | (NotCancelRequestFromServer m) -> notification m 59 | (NotCustomServer m) -> notification m 60 | 61 | handleClientMessage 62 | :: forall a. 63 | (forall b c . (ToJSON b, ToJSON c) => RequestMessage ClientMethod b c -> a) 64 | -> (forall d . ToJSON d => ResponseMessage d -> a) 65 | -> (forall e . ToJSON e => NotificationMessage ClientMethod e -> a) 66 | -> FromClientMessage 67 | -> a 68 | handleClientMessage request response notification msg = case msg of 69 | (ReqInitialize m) -> request m 70 | (ReqShutdown m) -> request m 71 | (ReqHover m) -> request m 72 | (ReqCompletion m) -> request m 73 | (ReqCompletionItemResolve m) -> request m 74 | (ReqSignatureHelp m) -> request m 75 | (ReqDefinition m) -> request m 76 | (ReqFindReferences m) -> request m 77 | (ReqDocumentHighlights m) -> request m 78 | (ReqDocumentSymbols m) -> request m 79 | (ReqWorkspaceSymbols m) -> request m 80 | (ReqCodeAction m) -> request m 81 | (ReqCodeLens m) -> request m 82 | (ReqCodeLensResolve m) -> request m 83 | (ReqDocumentFormatting m) -> request m 84 | (ReqDocumentRangeFormatting m) -> request m 85 | (ReqDocumentOnTypeFormatting m) -> request m 86 | (ReqPrepareRename m) -> request m 87 | (ReqRename m) -> request m 88 | (ReqExecuteCommand m) -> request m 89 | (ReqDocumentLink m) -> request m 90 | (ReqDocumentLinkResolve m) -> request m 91 | (ReqWillSaveWaitUntil m) -> request m 92 | (ReqImplementation m) -> request m 93 | (ReqTypeDefinition m) -> request m 94 | (ReqDocumentColor m) -> request m 95 | (ReqColorPresentation m) -> request m 96 | (ReqFoldingRange m) -> request m 97 | (RspApplyWorkspaceEdit m) -> response m 98 | (RspFromClient m) -> response m 99 | (NotInitialized m) -> notification m 100 | (NotExit m) -> notification m 101 | (NotCancelRequestFromClient m) -> notification m 102 | (NotDidChangeConfiguration m) -> notification m 103 | (NotDidOpenTextDocument m) -> notification m 104 | (NotDidChangeTextDocument m) -> notification m 105 | (NotDidCloseTextDocument m) -> notification m 106 | (NotWillSaveTextDocument m) -> notification m 107 | (NotDidSaveTextDocument m) -> notification m 108 | (NotDidChangeWatchedFiles m) -> notification m 109 | (NotDidChangeWorkspaceFolders m) -> notification m 110 | (NotWorkDoneProgressCancel m) -> notification m 111 | (ReqCustomClient m) -> request m 112 | (NotCustomClient m) -> notification m 113 | -------------------------------------------------------------------------------- /exe/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | module Process where 4 | 5 | import Control.Monad (void, when) 6 | import Control.Monad.IO.Class (MonadIO, liftIO) 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString.Lazy as BSL 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.Char8 as Char8 11 | import qualified GHC.IO.Handle as H 12 | import System.Process hiding (createProcess) 13 | import Control.Concurrent.MVar 14 | 15 | import Reflex 16 | import Reflex.Process 17 | import Decoding 18 | import Messages 19 | import Language.Haskell.LSP.Messages 20 | import Language.Haskell.LSP.Types 21 | import Data.Aeson 22 | 23 | convert :: FromClientMessage -> ByteString 24 | convert f = handleClientMessage h h h f 25 | where 26 | h m = BSL.toStrict (addHeader $ encode m) 27 | 28 | updateReqMap :: MVar RequestMap -> FromClientMessage -> IO () 29 | updateReqMap rvar = handleClientMessage request ignore ignore 30 | where 31 | request :: RequestMessage ClientMethod a b -> IO () 32 | request (RequestMessage _ i m _) 33 | = modifyMVar_ rvar (return . updateRequestMap i m) 34 | ignore _ = return () 35 | 36 | 37 | createLSPProcess 38 | :: (MonadIO m, TriggerEvent t m, PerformEvent t m, MonadIO (Performable m)) 39 | => CreateProcess 40 | -> ProcessConfig t FromClientMessage 41 | -> m (Process t FromServerMessage ByteString) 42 | createLSPProcess c p = do 43 | reqVar <- liftIO (newMVar newRequestMap) 44 | createRedirectedProcess (input reqVar) (output reqVar) err c p 45 | where 46 | input reqVar h = do 47 | H.hSetBuffering h H.NoBuffering 48 | let go e = do 49 | open <- H.hIsOpen h 50 | when open $ do 51 | writable <- H.hIsWritable h 52 | updateReqMap reqVar e 53 | when writable $ Char8.hPut h (convert e) 54 | return go 55 | 56 | output reqVar h trigger = do 57 | H.hSetBuffering h H.LineBuffering 58 | let go = do 59 | open <- H.hIsOpen h 60 | readable <- H.hIsReadable h 61 | when (open && readable) $ do 62 | out <- getNextMessage h 63 | if BSL.null out 64 | then return () 65 | else do 66 | reqMap <- readMVar reqVar 67 | void $ trigger (decodeFromServerMsg reqMap out) 68 | go 69 | return go 70 | err h trigger = do 71 | H.hSetBuffering h H.LineBuffering 72 | let go = do 73 | open <- H.hIsOpen h 74 | readable <- H.hIsReadable h 75 | when (open && readable) $ do 76 | out <- BS.hGetSome h 32768 77 | if BS.null out 78 | then return () 79 | else do 80 | void $ trigger out 81 | go 82 | return go 83 | -------------------------------------------------------------------------------- /exe/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE PartialTypeSignatures #-} 4 | module Types where 5 | 6 | 7 | {- Plan 8 | - 9 | - 1. Start the LSP server using reflex-process and provide an event for 10 | - input/output 11 | - 2. Watch for file changes in the current directory using fsnotify 12 | - 3. Send a notification to the server on a file change 13 | - 4. Display the diagnostics when ghcide reports them 14 | -} 15 | 16 | import Language.Haskell.LSP.Messages 17 | import Language.Haskell.LSP.Types 18 | import Reflex 19 | import Reflex.Process 20 | import Data.ByteString (ByteString) 21 | 22 | 23 | import qualified Data.Map as M 24 | import Data.Text (Text) 25 | 26 | 27 | 28 | type MessageOut t = Event t FromServerMessage 29 | type MessageIn t = Event t FromClientMessage 30 | 31 | type LSPProcess t = Process t FromServerMessage ByteString 32 | 33 | type DiagMap = M.Map Uri [Diagnostic] 34 | 35 | data ProgressStatus = ProgressStatus 36 | { currentMessage :: !Text 37 | , progresses :: !(M.Map ProgressToken Text) 38 | } 39 | 40 | emptyDiagMap :: DiagMap 41 | emptyDiagMap = M.empty 42 | 43 | addDiag :: Uri -> [Diagnostic] -> DiagMap -> DiagMap 44 | addDiag = M.insert 45 | 46 | deleteDiag :: Uri -> DiagMap -> DiagMap 47 | deleteDiag = M.delete 48 | 49 | data Session t = Session { debugCollection :: DebugCollection t 50 | , diagnostics :: Dynamic t DiagMap 51 | , status :: Dynamic t ProgressStatus 52 | , rawProcess :: LSPProcess t 53 | } 54 | 55 | -- Information displayed in the debug pane 56 | data DebugCollection t = DebugCollection { debug_out, debug_in, debug_err :: Behavior t ByteString } 57 | 58 | data ClientState t = ClientState { sendRequest :: (LspId -> FromClientMessage) -> IO () 59 | , counter :: Dynamic t Int 60 | } 61 | 62 | -------------------------------------------------------------------------------- /exe/View.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | - Module: Reflex.Vty.GHCi 3 | - Description: Vty widgets useful when building your own GHCi runner 4 | -} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE MultiWayIf #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE RecursiveDo #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TupleSections #-} 14 | {-# LANGUAGE NoMonomorphismRestriction #-} 15 | {-# LANGUAGE ViewPatterns #-} 16 | module View where 17 | 18 | import Control.Monad ((<=<), void) 19 | import Control.Monad.Fix (MonadFix) 20 | import Data.ByteString (ByteString) 21 | import qualified Data.Text as T 22 | import qualified Data.Text.Lazy as TL 23 | import qualified Data.Text.Encoding as T 24 | import qualified Data.ByteString.UTF8 as BSU -- from utf8-string 25 | import qualified Data.Map as M 26 | import qualified Graphics.Vty as V 27 | import qualified Data.Text.Zipper as TZ 28 | import Data.List 29 | 30 | import Language.Haskell.LSP.Types 31 | import Language.Haskell.LSP.Types.Lens (range, message, severity) 32 | import Control.Lens (view) 33 | 34 | import Reflex.Process 35 | import Reflex.Vty 36 | import Types 37 | 38 | -- | Display the overall status of the session 39 | statusDisplay 40 | :: ( PostBuild t m 41 | , MonadHold t m 42 | ) 43 | => Session t 44 | -> VtyWidget t m () 45 | statusDisplay g = do 46 | text <=< hold "" $ leftmost 47 | [ ("Command exited with " <>) . T.pack . show <$> _process_exit (rawProcess g) 48 | ] 49 | 50 | -- | A scrollable widget that displays a message at the bottom of the widget 51 | -- when there is additional content to view. 52 | scrollableOutput 53 | :: ( Reflex t 54 | , MonadNodeId m 55 | , MonadHold t m 56 | , MonadFix m 57 | , PostBuild t m 58 | ) 59 | => Behavior t ByteString 60 | -> VtyWidget t m () 61 | scrollableOutput out = col $ do 62 | dh <- displayHeight 63 | scroll <- stretch $ scrollableText never $ T.decodeUtf8 <$> out 64 | fixed 1 $ text $ 65 | let f h (ix, n) = if n - ix + 1 > h 66 | then "↓ More ↓" 67 | else "" 68 | in f <$> current dh <*> scroll 69 | 70 | -- | A scrollable widget that scrolls down as output goes past the end of the widget 71 | scrollingOutput 72 | :: ( Reflex t 73 | , Monad m 74 | , MonadHold t m 75 | , MonadFix m 76 | ) 77 | => Dynamic t ByteString 78 | -> VtyWidget t m () 79 | scrollingOutput out = do 80 | dh <- displayHeight 81 | let scrollBy h (ix, n) = 82 | if | ix == 0 && n <= h -> Nothing -- Scrolled to the top and we don't have to scroll down 83 | | n > h && n - ix - h == 0 -> Just 1 84 | | otherwise -> Nothing 85 | rec scroll <- scrollableText (tagMaybe (scrollBy <$> current dh <*> scroll) $ updated out) $ 86 | T.decodeUtf8 <$> current out 87 | return () 88 | 89 | scrollingOutputX 90 | :: ( Reflex t 91 | , Monad m 92 | , MonadHold t m 93 | , MonadFix m 94 | ) 95 | => Dynamic t [V.Image] 96 | -> VtyWidget t m () 97 | scrollingOutputX out = do 98 | dh <- displayHeight 99 | let scrollBy h (ix, n) = 100 | if | ix == 0 && n <= h -> Nothing -- Scrolled to the top and we don't have to scroll down 101 | | ix + h >= n -> Nothing -- Reached the end, no more scrolling 102 | | n > h && n - ix - h == 0 -> Just (ScrollLine 1) 103 | | otherwise -> Nothing 104 | rec scroll <- scrollable (tagMaybe (scrollBy <$> current dh <*> scroll) $ updated out) $ (current out) 105 | return () 106 | 107 | debugView 108 | :: ( MonadNodeId m 109 | , PostBuild t m 110 | , MonadHold t m 111 | , MonadFix m 112 | ) 113 | => Session t 114 | -> VtyWidget t m () 115 | debugView g = col $ do 116 | let DebugCollection{debug_err} = debugCollection g 117 | fixed 3 $ boxStatic def $ statusDisplay g 118 | --fixed 20 $ scrollableOutput $ debug_out 119 | --fixed 20 $ scrollableOutput $ debug_in 120 | stretch $ scrollableOutput $ debug_err 121 | 122 | collectOutput 123 | :: (Reflex t, MonadFix m, MonadHold t m) 124 | => Event t () 125 | -- ^ Clear output 126 | -> Event t ByteString 127 | -- ^ Output to add 128 | -> m (Dynamic t ByteString) 129 | collectOutput clear out = foldDyn ($) "" $ leftmost [ mappend <$> out 130 | , const "" <$ clear ] 131 | 132 | mkDebugOutput :: (Reflex t, MonadFix m, MonadHold t m, Show a) 133 | => MessageIn t -> Process t a ByteString 134 | -> m (DebugCollection t) 135 | mkDebugOutput i p = do 136 | sout <- collectOutput never (BSU.fromString . show <$> _process_stdout p) 137 | iout <- collectOutput never (BSU.fromString . show <$> i) 138 | serr <- collectOutput never (_process_stderr p) 139 | return $ DebugCollection (current sout) (current iout) (current serr) 140 | 141 | {- 142 | diagnosticsPane :: (PostBuild t m, MonadNodeId m, MonadHold t m, 143 | MonadFix m) => Session t -> VtyWidget t m () 144 | diagnosticsPane s = 145 | let ds = BSU.fromString 146 | . unlines 147 | . intersperse "---" 148 | . map moduleString 149 | . M.toList 150 | <$> diagnostics s 151 | in col $ stretch $ scrollableOutput $ current ds 152 | 153 | moduleString :: (Uri, [Diagnostic]) -> String 154 | moduleString (uri, ds) = 155 | unlines [T.unpack (getUri uri), renderDiags ds] 156 | 157 | renderDiags :: [Diagnostic] -> String 158 | renderDiags = unlines . intersperse "" . map renderDiag 159 | 160 | renderDiag :: Diagnostic -> String 161 | renderDiag d = renderRange (view range d) <> ":" <> T.unpack (view message d) 162 | 163 | renderRange :: Range -> String 164 | renderRange (Range s e) = renderPosition s ++ "-" ++ renderPosition e 165 | 166 | renderPosition :: Position -> String 167 | renderPosition (Position l c) = show l ++ ":" ++ show c 168 | -} 169 | 170 | diagnosticsPane :: (PostBuild t m, MonadNodeId m, MonadHold t m, 171 | MonadFix m) => Session t -> VtyWidget t m () 172 | diagnosticsPane s = do 173 | dw <- displayWidth 174 | let ds = concatMap (\(k, v) -> map (k,) v) . M.toList <$> diagnostics s 175 | void $ col $ stretch $ scrollingOutputX $ (renderDiags <$> dw <*> ds) 176 | 177 | {- 178 | moduleString :: (Uri, [Diagnostic]) -> String 179 | moduleString (uri, ds) = 180 | unlines [T.unpack (getUri uri), renderDiags ds] 181 | -} 182 | 183 | renderDiags :: Int -> [(Uri, Diagnostic)] -> [V.Image] 184 | renderDiags w = map (renderDiag w) 185 | 186 | renderDiag :: Int -> (Uri, Diagnostic) -> V.Image 187 | renderDiag w (u, d) = 188 | (diagHeader (u, d)) 189 | V.<-> 190 | (V.pad 2 0 0 0 $ V.vertCat (wrap w (view message d))) 191 | 192 | diagHeader :: (Uri, Diagnostic) -> V.Image 193 | diagHeader (u, d) = 194 | (V.text (diagStyle d) (renderRange (view range d))) 195 | V.<|> V.text V.defAttr ":" 196 | V.<|> V.text V.defAttr (TL.fromStrict (getUri u)) 197 | 198 | diagStyle :: Diagnostic -> V.Attr 199 | diagStyle d = case view severity d of 200 | Nothing -> V.defAttr 201 | Just DsError -> V.withForeColor V.defAttr V.brightRed 202 | Just DsWarning -> V.withForeColor V.defAttr V.yellow 203 | Just DsInfo -> V.withForeColor V.defAttr V.brightWhite 204 | Just DsHint -> V.withForeColor V.defAttr V.white 205 | 206 | wrap :: Int -> T.Text -> [V.Image] 207 | wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n') 208 | 209 | renderRange :: Range -> TL.Text 210 | renderRange (Range s e) = renderPosition s <> "-" <> renderPosition e 211 | 212 | renderPosition :: Position -> TL.Text 213 | renderPosition (Position l c) = TL.pack (show l) <> ":" <> TL.pack (show c) 214 | 215 | data ScrollEvent = ScrollItemDown | ScrollItemUp | ScrollLine Int 216 | 217 | -- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those 218 | -- that are hidden) 219 | scrollable 220 | :: forall t m. (Reflex t, MonadHold t m, MonadFix m) 221 | => Event t ScrollEvent 222 | -- ^ Number of items to scroll by 223 | -> Behavior t ([V.Image]) 224 | -> VtyWidget t m (Behavior t (Int, Int)) 225 | -- ^ (Current scroll position, total number of lines) 226 | scrollable scrollBy imgs = do 227 | dh <- displayHeight 228 | kup <- key V.KUp 229 | kdown <- key V.KDown 230 | pup <- key V.KPageUp 231 | pdown <- key V.KPageDown 232 | m <- mouseScroll 233 | let requestedScroll :: Event t ScrollEvent 234 | requestedScroll = leftmost 235 | [ ScrollItemDown <$ kdown 236 | , ScrollItemUp <$ kup 237 | , ScrollLine 20 <$ pdown 238 | , ScrollLine (-20) <$ pup 239 | , ffor m $ \case 240 | ScrollDirection_Up -> ScrollLine (-1) 241 | ScrollDirection_Down -> ScrollLine 1 242 | , scrollBy 243 | ] 244 | updateLine :: [Int] -> Int -> ScrollEvent -> Int -> Int 245 | updateLine hs dh' se ix = 246 | let maxN = (sum hs - dh') 247 | steps = scanl' (+) 0 hs 248 | in 249 | case se of 250 | ScrollLine delta -> min (max 0 (ix + delta)) maxN 251 | -- Find the next item which starts on a line more than the 252 | -- current line 253 | ScrollItemDown -> case dropWhile (<= ix) steps of 254 | -- No more steps, stay in the same place 255 | [] -> ix 256 | (s:_) -> s 257 | -- Find the previous item which starts on a line less than the 258 | -- current line 259 | ScrollItemUp -> case takeWhile (< ix) steps of 260 | [] -> 0 261 | (last -> s) -> s 262 | 263 | 264 | lineIndex :: Dynamic t Int 265 | <- foldDyn (\(h, (hs, delta)) ix -> updateLine hs h delta ix) 0 $ 266 | attach (current dh) (attach (map V.imageHeight <$> imgs) requestedScroll) 267 | tellImage $ (t <$> current lineIndex <*> (V.vertCat <$> imgs)) 268 | return $ (,) <$> ((+ 1) <$> current lineIndex) <*> (sum . map V.imageHeight <$> imgs) 269 | where 270 | --addLen is = V.string V.defAttr (show (scanr (+) 0 (map V.imageHeight is))) : is 271 | t ln i = V.translate 0 (negate ln) i 272 | 273 | tellImage :: ImageWriter t m => Behavior t V.Image -> m () 274 | tellImage i = tellImages ((:[]) <$> i) 275 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: {cabal: {component: "exe:simple-language-client"}} 2 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | with { pkgs = import {}; }; 2 | pkgs.mkShell 3 | { buildInputs = [ pkgs.haskell.compiler.ghc865 pkgs.zlib pkgs.haskellPackages.cabal-install pkgs.icu ]; 4 | shellHook=''export LD_LIBRARY_PATH=${pkgs.gmp}/lib:${pkgs.zlib}/lib:${pkgs.ncurses}/lib:${pkgs.icu}/lib''; 5 | } 6 | -------------------------------------------------------------------------------- /simple-language-client.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | -- Initial package description 'reflex-ghcide.cabal' generated by 'cabal 3 | -- init'. For further documentation, see 4 | -- http://haskell.org/cabal/users-guide/ 5 | 6 | name: simple-language-client 7 | version: 0.1.0.0 8 | -- synopsis: 9 | -- description: 10 | -- bug-reports: 11 | -- license: 12 | license-file: LICENSE 13 | author: Matthew Pickering 14 | maintainer: matthewtpickering@gmail.com 15 | -- copyright: 16 | -- category: 17 | build-type: Simple 18 | extra-source-files: CHANGELOG.md 19 | 20 | executable simple-language-client 21 | main-is: Main.hs 22 | other-modules: Decoding, View, Types, Messages, Process 23 | -- other-extensions: 24 | build-depends: base >=4.12 && <5 25 | , reflex-process >= 0.2 26 | , filepath 27 | , reflex-fsnotify <= 0.1.0.0 28 | , haskell-lsp 29 | , haskell-lsp-types 30 | , reflex 31 | , data-default 32 | , unix 33 | , process 34 | , text 35 | , directory 36 | , bytestring 37 | , aeson 38 | , unordered-containers 39 | , lens 40 | , reflex-vty 41 | , optparse-applicative 42 | , vty 43 | , fsnotify 44 | , utf8-string 45 | , containers 46 | , filemanip 47 | , extra 48 | , retry 49 | , exceptions 50 | hs-source-dirs: exe 51 | default-language: Haskell2010 52 | ghc-options: -threaded -Wall 53 | --------------------------------------------------------------------------------