Model language server after reactor example

ollef · Feb 6, 2024 · bb4c348 · bb4c348
1 parent 5cbf642
commit bb4c348
Show file tree

Hide file tree

Showing 5 changed files with 393 additions and 385 deletions.
diff --git a/app/Main.hs b/app/Main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -37,8 +38,12 @@ commands =
 
 languageServerCommand :: ParserInfo (IO ())
 languageServerCommand =
-  info (pure LanguageServer.run) $
-    fullDesc
+  info
+    ( pure do
+        ret <- LanguageServer.run
+        when (ret /= 0) $ exitWith $ ExitFailure ret
+    )
+    $ fullDesc
       <> progDesc "Start a language server"
 
 checkCommand :: ParserInfo (IO ())

diff --git a/package.yaml b/package.yaml
@@ -46,6 +46,7 @@ library:
     - aeson-casing
     - ansi-terminal
     - bytestring
+    - co-log-core
     - constraints
     - constraints-extras
     - containers

diff --git a/src/Command/Watch.hs b/src/Command/Watch.hs
@@ -1,10 +1,9 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Command.Watch where
 
-import Data.HashMap.Lazy (HashMap)
-import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import qualified Data.Text as Text
 import Data.Time.Clock
@@ -24,47 +23,49 @@ watch argumentFiles = do
   signalChangeVar <- newEmptyMVar
   fileStateVar <- newMVar mempty
   FSNotify.withManager \manager -> do
-    stopListening <- FileSystem.runWatcher watcher manager \(changedFiles, sourceDirectories, files) -> do
-      modifyMVar_ fileStateVar \(changedFiles', _, _) ->
-        pure (changedFiles <> changedFiles', sourceDirectories, files)
+    stopListening <- FileSystem.runWatcher watcher manager \projectFiles -> do
+      modifyMVar_ fileStateVar \projectFiles' ->
+        pure
+          projectFiles
+            { FileSystem.changedFiles =
+                projectFiles.changedFiles <> projectFiles'.changedFiles
+            }
       void $ tryPutMVar signalChangeVar ()
 
     (`finally` stopListening) $ do
       driverState <- Driver.initialState
       forever $ do
-        (changedFiles, sourceDirectories, files) <- waitForChanges signalChangeVar fileStateVar driverState
-        checkAndPrintErrors driverState changedFiles sourceDirectories files
+        projectFiles <- waitForChanges signalChangeVar fileStateVar driverState
+        checkAndPrintErrors driverState projectFiles
 
 waitForChanges
   :: MVar ()
-  -> MVar (HashSet FilePath, [FileSystem.Directory], HashMap FilePath Text)
+  -> MVar FileSystem.ProjectFiles
   -> Driver.State (Doc ann)
-  -> IO (HashSet FilePath, [FileSystem.Directory], HashMap FilePath Text)
+  -> IO FileSystem.ProjectFiles
 waitForChanges signalChangeVar fileStateVar driverState = do
-  (changedFiles, sourceDirectories, files) <-
-    modifyMVar fileStateVar \(changedFiles, sourceDirectories, files) ->
-      pure ((mempty, sourceDirectories, files), (changedFiles, sourceDirectories, files))
+  projectFiles <-
+    modifyMVar fileStateVar \projectFiles ->
+      pure (projectFiles {FileSystem.changedFiles = mempty}, projectFiles)
 
-  if HashSet.null changedFiles
+  if HashSet.null projectFiles.changedFiles
     then do
       takeMVar signalChangeVar
       waitForChanges signalChangeVar fileStateVar driverState
-    else pure (changedFiles, sourceDirectories, files)
+    else pure projectFiles
 
 checkAndPrintErrors
   :: Driver.State (Doc ann)
-  -> HashSet FilePath
-  -> [FileSystem.Directory]
-  -> HashMap FilePath Text
+  -> FileSystem.ProjectFiles
   -> IO ()
-checkAndPrintErrors driverState changedFiles sourceDirectories files = do
+checkAndPrintErrors driverState projectFiles = do
   startTime <- getCurrentTime
   (_, errs) <-
     Driver.runIncrementalTask
       driverState
-      changedFiles
-      (HashSet.fromList sourceDirectories)
-      (fmap Right files)
+      projectFiles.changedFiles
+      (HashSet.fromList projectFiles.sourceDirectories)
+      (fmap Right projectFiles.fileContents)
       Error.Hydrated.pretty
       Driver.Prune
       Driver.checkAll

diff --git a/src/FileSystem.hs b/src/FileSystem.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -120,7 +121,20 @@ bindForM (Watcher watchKeys) watchKey =
 
 -------------------------------------------------------------------------------
 
-watcherFromArguments :: [FilePath] -> IO (Watcher (HashSet FilePath, [Directory], HashMap FilePath Text))
+data ProjectFiles = ProjectFiles
+  { sourceDirectories :: [Directory]
+  , fileContents :: HashMap FilePath Text
+  , changedFiles :: HashSet FilePath
+  }
+
+instance Semigroup ProjectFiles where
+  ProjectFiles a1 b1 c1 <> ProjectFiles a2 b2 c2 =
+    ProjectFiles (a1 <> a2) (b1 <> b2) (c1 <> c2)
+
+instance Monoid ProjectFiles where
+  mempty = ProjectFiles mempty mempty mempty
+
+watcherFromArguments :: [FilePath] -> IO (Watcher ProjectFiles)
 watcherFromArguments files =
   case files of
     [] -> do
@@ -142,33 +156,40 @@ watcherFromArguments files =
               | isDir ->
                   pure $
                     ( \(changedFiles, files') ->
-                        ( changedFiles
-                        , [file']
-                        , files'
-                        )
+                        ProjectFiles
+                          { sourceDirectories = [file']
+                          , fileContents = files'
+                          , changedFiles
+                          }
                     )
                       <$> directoryWatcher Project.isSourcePath file'
               | Project.isProjectPath file' ->
                   pure $ projectWatcher file'
               | Project.isSourcePath file' ->
                   pure $
                     ( \maybeText ->
-                        ( HashSet.singleton file'
-                        , [FilePath.takeDirectory file']
-                        , foldMap (HashMap.singleton file') maybeText
-                        )
+                        ProjectFiles
+                          { sourceDirectories = [FilePath.takeDirectory file']
+                          , fileContents = foldMap (HashMap.singleton file') maybeText
+                          , changedFiles = HashSet.singleton file'
+                          }
                     )
                       <$> fileWatcher file'
               | otherwise ->
                   -- TODO report error?
                   mempty
 
-projectWatcher :: FilePath -> Watcher (HashSet FilePath, [Directory], HashMap FilePath Text)
+projectWatcher :: FilePath -> Watcher ProjectFiles
 projectWatcher file =
   bindForM (foldMap (HashSet.fromList . (.sourceDirectories)) <$> jsonFileWatcher @Project file) \sourceDirectory -> do
     sourceDirectory' <- liftIO $ Directory.canonicalizePath sourceDirectory
-    (changedFiles, files) <- directoryWatcher Project.isSourcePath sourceDirectory'
-    pure (changedFiles, [sourceDirectory'], files)
+    (changedFiles, fileContents) <- directoryWatcher Project.isSourcePath sourceDirectory'
+    pure
+      ProjectFiles
+        { sourceDirectories = [sourceDirectory']
+        , fileContents
+        , changedFiles
+        }
 
 fileWatcher :: FilePath -> Watcher (Maybe Text)
 fileWatcher filePath = Watcher \manager onChange -> do