From 33939ad2585e115dea9d96315e36225b8f8e6a6c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 19 Jul 2024 06:55:28 +0200
Subject: [PATCH 001/297] dont force state results #4545

---
 src/Language/PureScript/Ide/State.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 06eed507e4..3af0550ef2 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -201,8 +201,7 @@ populateVolatileStateSync = do
   st <- ideStateVar <$> ask
   let message duration = "Finished populating volatile state in: " <> displayTimeSpec duration
   results <- logPerf message $ do
-    !r <- liftIO (atomically (populateVolatileStateSTM st))
-    pure r
+    liftIO (atomically (populateVolatileStateSTM st))
   void $ Map.traverseWithKey
     (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
     (Map.filter reexportHasFailures results)
@@ -235,7 +234,7 @@ populateVolatileStateSTM ref = do
         & resolveOperators
         & resolveReexports reexportRefs
   setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache)
-  pure (force results)
+  pure results
 
 resolveLocations
   :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)

From bedc325e611d36fc75dd21f8b2c1ce1354b9a7e0 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 22 Jul 2024 14:07:12 +0200
Subject: [PATCH 002/297] add myself to contributors

---
 CONTRIBUTORS.md | 1 +
 1 file changed, 1 insertion(+)

diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 7213ef9c67..aa5ddefd3f 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -167,6 +167,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license] |
 | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license] |
 | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license] |
+| [@roryc89](https://github.com/roryc89) | Rory Campbell | [MIT license] |
 
 
 ### Contributors using Modified Terms

From 99fa9d061935061a04ad34c1f4f40e1ea485b000 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 22 Jul 2024 14:11:47 +0200
Subject: [PATCH 003/297] update changelog

---
 CHANGELOG.d/fix_issue-4545.md | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 CHANGELOG.d/fix_issue-4545.md

diff --git a/CHANGELOG.d/fix_issue-4545.md b/CHANGELOG.d/fix_issue-4545.md
new file mode 100644
index 0000000000..1d6462ee9c
--- /dev/null
+++ b/CHANGELOG.d/fix_issue-4545.md
@@ -0,0 +1 @@
+* Speed up IDE performance on large projects

From e0351903974372cfadfc077ac4abd9a72888b7cc Mon Sep 17 00:00:00 2001
From: Justin Garcia <purefunctor@gmail.com>
Date: Wed, 31 Jul 2024 01:48:50 +0800
Subject: [PATCH 004/297] Implement the focus command for limiting externs

---
 src/Language/PureScript/Ide.hs         | 17 +++++++++---
 src/Language/PureScript/Ide/Command.hs |  9 +++++++
 src/Language/PureScript/Ide/State.hs   | 36 ++++++++++++++++++++++++++
 src/Language/PureScript/Ide/Types.hs   |  9 ++++++-
 4 files changed, 67 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 57601c3d45..e0ecc4a8f7 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -22,6 +22,7 @@ import Protolude hiding (moduleName)
 
 import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Language.PureScript qualified as P
 import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..))
@@ -37,7 +38,7 @@ import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync, rebuildFileSync)
 import Language.PureScript.Ide.SourceFile (parseModulesFromFiles)
-import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState)
+import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState, setFocusedModules, getFocusedModules)
 import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..))
 import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn)
 import Language.PureScript.Ide.Usage (findUsages)
@@ -102,6 +103,8 @@ handleCommand c = case c of
     rebuildFileAsync file actualFile targets
   RebuildSync file actualFile targets ->
     rebuildFileSync file actualFile targets
+  Focus modulesToFocus ->
+    setFocusedModules modulesToFocus $> TextResult "Focused modules have been set."
   Cwd ->
     TextResult . T.pack <$> liftIO getCurrentDirectory
   Reset ->
@@ -215,10 +218,18 @@ loadModules
   => [P.ModuleName]
   -> m Success
 loadModules moduleNames = do
+  focusedModules <- getFocusedModules
   -- We resolve all the modulenames to externs files and load these into memory.
   oDir <- outputDirectory
-  let efPaths =
-        map (\mn -> oDir </> toS (P.runModuleName mn) </> P.externsFileName) moduleNames
+  let
+    -- But we only load the externs files that are in the focusedModules.
+    efModules = 
+        if Set.null focusedModules then 
+          moduleNames
+        else 
+          Set.toList $ Set.fromList moduleNames `Set.intersection` focusedModules
+    efPaths =
+        map (\mn -> oDir </> toS (P.runModuleName mn) </> P.externsFileName) efModules
   efiles <- traverse readExternFile efPaths
   traverse_ insertExterns efiles
 
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index ae4b6c9d8e..49e99a4474 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -62,6 +62,7 @@ data Command
     | List { listType :: ListType }
     | Rebuild FilePath (Maybe FilePath) (Set P.CodegenTarget)
     | RebuildSync FilePath (Maybe FilePath) (Set P.CodegenTarget)
+    | Focus [P.ModuleName]
     | Cwd
     | Reset
     | Quit
@@ -79,6 +80,7 @@ commandName c = case c of
   List{} -> "List"
   Rebuild{} -> "Rebuild"
   RebuildSync{} -> "RebuildSync"
+  Focus{} -> "Focus"
   Cwd{} -> "Cwd"
   Reset{} -> "Reset"
   Quit{} -> "Quit"
@@ -176,6 +178,13 @@ instance FromJSON Command where
           <$> params .: "file"
           <*> params .:? "actualFile"
           <*> (parseCodegenTargets =<< params .:? "codegen" .!= [ "js" ])
+      "focus" -> do
+        params' <- o .:? "params"
+        case params' of
+          Nothing -> 
+            pure (Focus [])
+          Just params ->
+            Focus <$> (map P.moduleNameFromString <$> params .:? "modules" .!= [])
       c -> fail ("Unknown command: " <> show c)
     where
       parseCodegenTargets ts =
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 06eed507e4..95cae598a4 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -31,6 +31,9 @@ module Language.PureScript.Ide.State
   , populateVolatileStateSTM
   , getOutputDirectory
   , updateCacheTimestamp
+  , getFocusedModules
+  , setFocusedModules
+  , setFocusedModulesSTM
   -- for tests
   , resolveOperatorsForModule
   , resolveInstances
@@ -44,6 +47,7 @@ import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.))
 import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 import Data.IORef (readIORef, writeIORef)
 import Data.Map.Lazy qualified as Map
+import Data.Set qualified as Set
 import Data.Time.Clock (UTCTime)
 import Data.Zip (unzip)
 import Language.PureScript qualified as P
@@ -141,6 +145,23 @@ setVolatileStateSTM ref vs = do
     x {ideVolatileState = vs}
   pure ()
 
+-- | Retrieves the ModifierState from the State.
+getModifierState :: Ide m => m IdeModifierState
+getModifierState = do
+  st <- ideStateVar <$> ask
+  liftIO (atomically (getModifierStateSTM st))
+
+-- | STM version of getModifierState
+getModifierStateSTM :: TVar IdeState -> STM IdeModifierState
+getModifierStateSTM ref = ideModifierState <$> readTVar ref
+
+-- | Sets the ModifierState inside Ide's state
+setModifierStateSTM :: TVar IdeState -> IdeModifierState -> STM ()
+setModifierStateSTM ref md = do
+  modifyTVar ref $ \x ->
+    x {ideModifierState = md}
+  pure ()
+
 -- | Checks if the given ModuleName matches the last rebuild cache and if it
 -- does returns all loaded definitions + the definitions inside the rebuild
 -- cache
@@ -450,3 +471,18 @@ resolveDataConstructorsForModule decls =
       & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor))
       & foldr (\(IdeDataConstructor name typeName type') ->
                   Map.insertWith (<>) typeName [(name, type')]) Map.empty
+
+getFocusedModules :: Ide m => m (Set P.ModuleName)
+getFocusedModules = do
+  IdeModifierState{mdFocusedModules = focusedModules} <- getModifierState
+  pure focusedModules
+
+setFocusedModules :: Ide m => [P.ModuleName] -> m ()
+setFocusedModules modulesToFocus = do
+  st <- ideStateVar <$> ask
+  liftIO (atomically (setFocusedModulesSTM st modulesToFocus)) 
+
+setFocusedModulesSTM :: TVar IdeState -> [P.ModuleName] -> STM ()
+setFocusedModulesSTM ref modulesToFocus = do
+  IdeModifierState{} <- getModifierStateSTM ref
+  setModifierStateSTM ref (IdeModifierState (Set.fromList modulesToFocus))
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 5fa304166b..600417ca0b 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -178,10 +178,11 @@ type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
 data IdeState = IdeState
   { ideFileState :: IdeFileState
   , ideVolatileState :: IdeVolatileState
+  , ideModifierState :: IdeModifierState
   } deriving (Show)
 
 emptyIdeState :: IdeState
-emptyIdeState = IdeState emptyFileState emptyVolatileState
+emptyIdeState = IdeState emptyFileState emptyVolatileState emptyModifierState
 
 emptyFileState :: IdeFileState
 emptyFileState = IdeFileState M.empty M.empty
@@ -189,6 +190,8 @@ emptyFileState = IdeFileState M.empty M.empty
 emptyVolatileState :: IdeVolatileState
 emptyVolatileState = IdeVolatileState (AstData M.empty) M.empty Nothing
 
+emptyModifierState :: IdeModifierState
+emptyModifierState = IdeModifierState mempty
 
 -- | @IdeFileState@ holds data that corresponds 1-to-1 to an entity on the
 -- filesystem. Externs correspond to the ExternsFiles the compiler emits into
@@ -213,6 +216,10 @@ data IdeVolatileState = IdeVolatileState
   , vsCachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
   } deriving (Show)
 
+data IdeModifierState = IdeModifierState
+  { mdFocusedModules :: Set P.ModuleName
+  } deriving (Show)
+
 newtype Match a = Match (P.ModuleName, a)
            deriving (Show, Eq, Functor)
 

From b1e4b01901aab877b0b539c36d3a8ff30b676221 Mon Sep 17 00:00:00 2001
From: Justin Garcia <purefunctor@gmail.com>
Date: Wed, 31 Jul 2024 01:48:50 +0800
Subject: [PATCH 005/297] Implement the focus command for limiting externs

---
 src/Language/PureScript/Ide.hs         | 17 +++++++++---
 src/Language/PureScript/Ide/Command.hs |  9 +++++++
 src/Language/PureScript/Ide/State.hs   | 36 ++++++++++++++++++++++++++
 src/Language/PureScript/Ide/Types.hs   |  9 ++++++-
 4 files changed, 67 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 57601c3d45..e0ecc4a8f7 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -22,6 +22,7 @@ import Protolude hiding (moduleName)
 
 import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Language.PureScript qualified as P
 import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..))
@@ -37,7 +38,7 @@ import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync, rebuildFileSync)
 import Language.PureScript.Ide.SourceFile (parseModulesFromFiles)
-import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState)
+import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState, setFocusedModules, getFocusedModules)
 import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..))
 import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn)
 import Language.PureScript.Ide.Usage (findUsages)
@@ -102,6 +103,8 @@ handleCommand c = case c of
     rebuildFileAsync file actualFile targets
   RebuildSync file actualFile targets ->
     rebuildFileSync file actualFile targets
+  Focus modulesToFocus ->
+    setFocusedModules modulesToFocus $> TextResult "Focused modules have been set."
   Cwd ->
     TextResult . T.pack <$> liftIO getCurrentDirectory
   Reset ->
@@ -215,10 +218,18 @@ loadModules
   => [P.ModuleName]
   -> m Success
 loadModules moduleNames = do
+  focusedModules <- getFocusedModules
   -- We resolve all the modulenames to externs files and load these into memory.
   oDir <- outputDirectory
-  let efPaths =
-        map (\mn -> oDir </> toS (P.runModuleName mn) </> P.externsFileName) moduleNames
+  let
+    -- But we only load the externs files that are in the focusedModules.
+    efModules = 
+        if Set.null focusedModules then 
+          moduleNames
+        else 
+          Set.toList $ Set.fromList moduleNames `Set.intersection` focusedModules
+    efPaths =
+        map (\mn -> oDir </> toS (P.runModuleName mn) </> P.externsFileName) efModules
   efiles <- traverse readExternFile efPaths
   traverse_ insertExterns efiles
 
diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs
index ae4b6c9d8e..49e99a4474 100644
--- a/src/Language/PureScript/Ide/Command.hs
+++ b/src/Language/PureScript/Ide/Command.hs
@@ -62,6 +62,7 @@ data Command
     | List { listType :: ListType }
     | Rebuild FilePath (Maybe FilePath) (Set P.CodegenTarget)
     | RebuildSync FilePath (Maybe FilePath) (Set P.CodegenTarget)
+    | Focus [P.ModuleName]
     | Cwd
     | Reset
     | Quit
@@ -79,6 +80,7 @@ commandName c = case c of
   List{} -> "List"
   Rebuild{} -> "Rebuild"
   RebuildSync{} -> "RebuildSync"
+  Focus{} -> "Focus"
   Cwd{} -> "Cwd"
   Reset{} -> "Reset"
   Quit{} -> "Quit"
@@ -176,6 +178,13 @@ instance FromJSON Command where
           <$> params .: "file"
           <*> params .:? "actualFile"
           <*> (parseCodegenTargets =<< params .:? "codegen" .!= [ "js" ])
+      "focus" -> do
+        params' <- o .:? "params"
+        case params' of
+          Nothing -> 
+            pure (Focus [])
+          Just params ->
+            Focus <$> (map P.moduleNameFromString <$> params .:? "modules" .!= [])
       c -> fail ("Unknown command: " <> show c)
     where
       parseCodegenTargets ts =
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 06eed507e4..95cae598a4 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -31,6 +31,9 @@ module Language.PureScript.Ide.State
   , populateVolatileStateSTM
   , getOutputDirectory
   , updateCacheTimestamp
+  , getFocusedModules
+  , setFocusedModules
+  , setFocusedModulesSTM
   -- for tests
   , resolveOperatorsForModule
   , resolveInstances
@@ -44,6 +47,7 @@ import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.))
 import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 import Data.IORef (readIORef, writeIORef)
 import Data.Map.Lazy qualified as Map
+import Data.Set qualified as Set
 import Data.Time.Clock (UTCTime)
 import Data.Zip (unzip)
 import Language.PureScript qualified as P
@@ -141,6 +145,23 @@ setVolatileStateSTM ref vs = do
     x {ideVolatileState = vs}
   pure ()
 
+-- | Retrieves the ModifierState from the State.
+getModifierState :: Ide m => m IdeModifierState
+getModifierState = do
+  st <- ideStateVar <$> ask
+  liftIO (atomically (getModifierStateSTM st))
+
+-- | STM version of getModifierState
+getModifierStateSTM :: TVar IdeState -> STM IdeModifierState
+getModifierStateSTM ref = ideModifierState <$> readTVar ref
+
+-- | Sets the ModifierState inside Ide's state
+setModifierStateSTM :: TVar IdeState -> IdeModifierState -> STM ()
+setModifierStateSTM ref md = do
+  modifyTVar ref $ \x ->
+    x {ideModifierState = md}
+  pure ()
+
 -- | Checks if the given ModuleName matches the last rebuild cache and if it
 -- does returns all loaded definitions + the definitions inside the rebuild
 -- cache
@@ -450,3 +471,18 @@ resolveDataConstructorsForModule decls =
       & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor))
       & foldr (\(IdeDataConstructor name typeName type') ->
                   Map.insertWith (<>) typeName [(name, type')]) Map.empty
+
+getFocusedModules :: Ide m => m (Set P.ModuleName)
+getFocusedModules = do
+  IdeModifierState{mdFocusedModules = focusedModules} <- getModifierState
+  pure focusedModules
+
+setFocusedModules :: Ide m => [P.ModuleName] -> m ()
+setFocusedModules modulesToFocus = do
+  st <- ideStateVar <$> ask
+  liftIO (atomically (setFocusedModulesSTM st modulesToFocus)) 
+
+setFocusedModulesSTM :: TVar IdeState -> [P.ModuleName] -> STM ()
+setFocusedModulesSTM ref modulesToFocus = do
+  IdeModifierState{} <- getModifierStateSTM ref
+  setModifierStateSTM ref (IdeModifierState (Set.fromList modulesToFocus))
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 5fa304166b..600417ca0b 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -178,10 +178,11 @@ type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
 data IdeState = IdeState
   { ideFileState :: IdeFileState
   , ideVolatileState :: IdeVolatileState
+  , ideModifierState :: IdeModifierState
   } deriving (Show)
 
 emptyIdeState :: IdeState
-emptyIdeState = IdeState emptyFileState emptyVolatileState
+emptyIdeState = IdeState emptyFileState emptyVolatileState emptyModifierState
 
 emptyFileState :: IdeFileState
 emptyFileState = IdeFileState M.empty M.empty
@@ -189,6 +190,8 @@ emptyFileState = IdeFileState M.empty M.empty
 emptyVolatileState :: IdeVolatileState
 emptyVolatileState = IdeVolatileState (AstData M.empty) M.empty Nothing
 
+emptyModifierState :: IdeModifierState
+emptyModifierState = IdeModifierState mempty
 
 -- | @IdeFileState@ holds data that corresponds 1-to-1 to an entity on the
 -- filesystem. Externs correspond to the ExternsFiles the compiler emits into
@@ -213,6 +216,10 @@ data IdeVolatileState = IdeVolatileState
   , vsCachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
   } deriving (Show)
 
+data IdeModifierState = IdeModifierState
+  { mdFocusedModules :: Set P.ModuleName
+  } deriving (Show)
+
 newtype Match a = Match (P.ModuleName, a)
            deriving (Show, Eq, Functor)
 

From b44f32867467e26e677d83884597a37c4d4e4704 Mon Sep 17 00:00:00 2001
From: Justin Garcia <purefunctor@gmail.com>
Date: Wed, 31 Jul 2024 04:27:53 +0800
Subject: [PATCH 006/297] Rename to IdeDurableState

---
 src/Language/PureScript/Ide/State.hs | 30 ++++++++++++++--------------
 src/Language/PureScript/Ide/Types.hs | 18 +++++++++++------
 2 files changed, 27 insertions(+), 21 deletions(-)

diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 95cae598a4..77a925ac1c 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -65,7 +65,8 @@ import System.Directory (getModificationTime)
 resetIdeState :: Ide m => m ()
 resetIdeState = do
   ideVar <- ideStateVar <$> ask
-  liftIO (atomically (writeTVar ideVar emptyIdeState))
+  durableState <- getDurableState
+  liftIO (atomically (writeTVar ideVar (emptyIdeState { ideDurableState = durableState })))
 
 getOutputDirectory :: Ide m => m FilePath
 getOutputDirectory = do
@@ -145,21 +146,21 @@ setVolatileStateSTM ref vs = do
     x {ideVolatileState = vs}
   pure ()
 
--- | Retrieves the ModifierState from the State.
-getModifierState :: Ide m => m IdeModifierState
-getModifierState = do
+-- | Retrieves the DurableState from the State.
+getDurableState :: Ide m => m IdeDurableState
+getDurableState = do
   st <- ideStateVar <$> ask
-  liftIO (atomically (getModifierStateSTM st))
+  liftIO (atomically (getDurableStateSTM st))
 
--- | STM version of getModifierState
-getModifierStateSTM :: TVar IdeState -> STM IdeModifierState
-getModifierStateSTM ref = ideModifierState <$> readTVar ref
+-- | STM version of getDurableState
+getDurableStateSTM :: TVar IdeState -> STM IdeDurableState
+getDurableStateSTM ref = ideDurableState <$> readTVar ref
 
--- | Sets the ModifierState inside Ide's state
-setModifierStateSTM :: TVar IdeState -> IdeModifierState -> STM ()
-setModifierStateSTM ref md = do
+-- | Sets the DurableState inside Ide's state
+setDurableStateSTM :: TVar IdeState -> IdeDurableState -> STM ()
+setDurableStateSTM ref md = do
   modifyTVar ref $ \x ->
-    x {ideModifierState = md}
+    x {ideDurableState = md}
   pure ()
 
 -- | Checks if the given ModuleName matches the last rebuild cache and if it
@@ -474,7 +475,7 @@ resolveDataConstructorsForModule decls =
 
 getFocusedModules :: Ide m => m (Set P.ModuleName)
 getFocusedModules = do
-  IdeModifierState{mdFocusedModules = focusedModules} <- getModifierState
+  IdeDurableState{drFocusedModules = focusedModules} <- getDurableState
   pure focusedModules
 
 setFocusedModules :: Ide m => [P.ModuleName] -> m ()
@@ -484,5 +485,4 @@ setFocusedModules modulesToFocus = do
 
 setFocusedModulesSTM :: TVar IdeState -> [P.ModuleName] -> STM ()
 setFocusedModulesSTM ref modulesToFocus = do
-  IdeModifierState{} <- getModifierStateSTM ref
-  setModifierStateSTM ref (IdeModifierState (Set.fromList modulesToFocus))
+  setDurableStateSTM ref (IdeDurableState (Set.fromList modulesToFocus))
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 600417ca0b..2f2b0b04ab 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -15,6 +15,7 @@ import Data.Aeson qualified as Aeson
 import Data.IORef (IORef)
 import Data.Time.Clock (UTCTime)
 import Data.Map.Lazy qualified as M
+import Data.Set qualified as S
 import Language.PureScript qualified as P
 import Language.PureScript.Errors.JSON qualified as P
 import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..))
@@ -178,11 +179,11 @@ type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
 data IdeState = IdeState
   { ideFileState :: IdeFileState
   , ideVolatileState :: IdeVolatileState
-  , ideModifierState :: IdeModifierState
+  , ideDurableState :: IdeDurableState
   } deriving (Show)
 
 emptyIdeState :: IdeState
-emptyIdeState = IdeState emptyFileState emptyVolatileState emptyModifierState
+emptyIdeState = IdeState emptyFileState emptyVolatileState emptyDurableState
 
 emptyFileState :: IdeFileState
 emptyFileState = IdeFileState M.empty M.empty
@@ -190,8 +191,8 @@ emptyFileState = IdeFileState M.empty M.empty
 emptyVolatileState :: IdeVolatileState
 emptyVolatileState = IdeVolatileState (AstData M.empty) M.empty Nothing
 
-emptyModifierState :: IdeModifierState
-emptyModifierState = IdeModifierState mempty
+emptyDurableState :: IdeDurableState
+emptyDurableState = IdeDurableState S.empty
 
 -- | @IdeFileState@ holds data that corresponds 1-to-1 to an entity on the
 -- filesystem. Externs correspond to the ExternsFiles the compiler emits into
@@ -216,8 +217,13 @@ data IdeVolatileState = IdeVolatileState
   , vsCachedRebuild :: Maybe (P.ModuleName, P.ExternsFile)
   } deriving (Show)
 
-data IdeModifierState = IdeModifierState
-  { mdFocusedModules :: Set P.ModuleName
+-- | @IdeDurableState@ holds data that persists across resets of the @IdeState@.
+-- This is particularly useful for configuration variables that can be modified
+-- during runtime. For instance, the module names for the "focus" feature are 
+-- stored in the drFocusedModules field, which the client populates using the
+-- @Focus@ command to specify only which modules to load.
+data IdeDurableState = IdeDurableState
+  { drFocusedModules :: Set P.ModuleName
   } deriving (Show)
 
 newtype Match a = Match (P.ModuleName, a)

From c19d377a734addaf5dfb03b732896de6b70a550c Mon Sep 17 00:00:00 2001
From: Justin Garcia <purefunctor@gmail.com>
Date: Wed, 31 Jul 2024 04:28:08 +0800
Subject: [PATCH 007/297] Refactor command handling in startServer

---
 app/Command/Ide.hs | 23 +++++++++++++----------
 1 file changed, 13 insertions(+), 10 deletions(-)

diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs
index f5a501af75..38fc9c7e36 100644
--- a/app/Command/Ide.hs
+++ b/app/Command/Ide.hs
@@ -28,7 +28,7 @@ import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy.Char8 qualified as BSL8
 import GHC.IO.Exception (IOErrorType(..), IOException(..))
 import Language.PureScript.Ide (handleCommand)
-import Language.PureScript.Ide.Command (Command(..), commandName)
+import Language.PureScript.Ide.Command (commandName, Command(..))
 import Language.PureScript.Ide.Util (decodeT, displayTimeSpec, encodeT, logPerf, runLogger)
 import Language.PureScript.Ide.Error (IdeError(..))
 import Language.PureScript.Ide.State (updateCacheTimestamp)
@@ -199,14 +199,22 @@ startServer port env = Network.withSocketsDo $ do
               logPerf message $ do
                 result <- runExceptT $ do
                   updateCacheTimestamp >>= \case
-                    Nothing -> pure ()
+                    Nothing -> 
+                      handleCommand cmd'
                     Just (before, after) -> do
                       -- If the cache db file was changed outside of the IDE
                       -- we trigger a reset before processing the command
                       $(logInfo) ("cachedb was changed from: " <> show before <> ", to: " <> show after)
-                      unless (isLoadAll cmd') $
-                        void (handleCommand Reset *> handleCommand (LoadSync []))
-                  handleCommand cmd'
+                      let doReload = handleCommand Reset *> handleCommand (LoadSync [])
+                      case cmd' of
+                        -- handleCommand on Load [] already resets the state.
+                        Load [] -> handleCommand cmd'
+                        -- Focus needs to fire before doReload, because we
+                        -- want to set the focused modules first before
+                        -- loading everything with LoadSync [].
+                        Focus _ -> handleCommand cmd' <* doReload
+                        -- Otherwise, just doReload and then handle.
+                        _ -> doReload *> handleCommand cmd'
                 liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of
                   Right r  -> Aeson.encode r
                   Left err -> Aeson.encode err
@@ -219,11 +227,6 @@ startServer port env = Network.withSocketsDo $ do
                 hFlush stdout
           liftIO $ catchGoneHandle (hClose h)
 
-isLoadAll :: Command -> Bool
-isLoadAll = \case
-  Load [] -> True
-  _ -> False
-
 catchGoneHandle :: IO () -> IO ()
 catchGoneHandle =
   handle (\e -> case e of

From 92fb93e31b3f908ac3f5c8e47ee4d83b8118bd12 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 1 Aug 2024 14:46:23 +0200
Subject: [PATCH 008/297] load modules concurrently #4545

---
 src/Language/PureScript/Ide.hs       | 7 ++++---
 src/Language/PureScript/Ide/Types.hs | 3 ++-
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 57601c3d45..42d3b5062c 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -43,6 +43,7 @@ import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, n
 import Language.PureScript.Ide.Usage (findUsages)
 import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist)
 import System.FilePath ((</>), normalise)
+import Control.Concurrent.Async.Lifted (mapConcurrently, mapConcurrently_)
 
 -- | Accepts a Command and runs it against psc-ide's State. This is the main
 -- entry point for the server.
@@ -219,8 +220,8 @@ loadModules moduleNames = do
   oDir <- outputDirectory
   let efPaths =
         map (\mn -> oDir </> toS (P.runModuleName mn) </> P.externsFileName) moduleNames
-  efiles <- traverse readExternFile efPaths
-  traverse_ insertExterns efiles
+  efiles <- mapConcurrently readExternFile efPaths
+  mapConcurrently_ insertExterns efiles
 
   -- We parse all source files, log eventual parse failures and insert the
   -- successful parses into the state.
@@ -228,7 +229,7 @@ loadModules moduleNames = do
     partitionEithers <$> (parseModulesFromFiles =<< findAllSourceFiles)
   unless (null failures) $
     logWarnN ("Failed to parse: " <> show failures)
-  traverse_ insertModule allModules
+  mapConcurrently_ insertModule allModules
 
   pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "
                     <> show (length allModules) <> " source files."))
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 5fa304166b..5c5c555af2 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -18,6 +18,7 @@ import Data.Map.Lazy qualified as M
 import Language.PureScript qualified as P
 import Language.PureScript.Errors.JSON qualified as P
 import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..))
+import Control.Monad.Trans.Control (MonadBaseControl)
 
 type ModuleIdent = Text
 type ModuleMap a = Map P.ModuleName a
@@ -173,7 +174,7 @@ data IdeEnvironment =
   , ideCacheDbTimestamp :: IORef (Maybe UTCTime)
   }
 
-type Ide m = (MonadIO m, MonadReader IdeEnvironment m)
+type Ide m = (MonadIO m, MonadBaseControl IO m, MonadReader IdeEnvironment m)
 
 data IdeState = IdeState
   { ideFileState :: IdeFileState

From 6fb43a4cea2bbcdcda66a8772e2655df4967cf55 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 1 Aug 2024 15:26:31 +0200
Subject: [PATCH 009/297] read ide files concurrently

---
 src/Language/PureScript/Ide/SourceFile.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index ea49fd6a55..b74f7a1b4b 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -29,6 +29,8 @@ import Language.PureScript.CST qualified as CST
 import Language.PureScript.Ide.Error (IdeError)
 import Language.PureScript.Ide.Types (DefinitionSites, IdeNamespace(..), IdeNamespaced(..), TypeAnnotations)
 import Language.PureScript.Ide.Util (ideReadFile)
+import Control.Concurrent.Async.Lifted (mapConcurrently)
+import Control.Monad.Trans.Control (MonadBaseControl)
 
 parseModule :: FilePath -> Text -> Either FilePath (FilePath, P.Module)
 parseModule path file =
@@ -37,11 +39,11 @@ parseModule path file =
     Right m -> Right (path, m)
 
 parseModulesFromFiles
-  :: (MonadIO m, MonadError IdeError m)
+  :: (MonadIO m, MonadBaseControl IO m, MonadError IdeError m)
   => [FilePath]
   -> m [Either FilePath (FilePath, P.Module)]
 parseModulesFromFiles paths = do
-  files <- traverse ideReadFile paths
+  files <- mapConcurrently ideReadFile paths
   pure (inParallel (map (uncurry parseModule) files))
   where
     inParallel :: [Either e (k, a)] -> [Either e (k, a)]

From 130593e4aa2737280327f05fde9ef3bac0f84703 Mon Sep 17 00:00:00 2001
From: Justin Garcia <purefunctor@gmail.com>
Date: Mon, 12 Aug 2024 16:50:45 +0800
Subject: [PATCH 010/297] Enable CI for oa-fork

---
 .github/workflows/ci.yml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index 2cd314dbf1..284a88c8b7 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -2,9 +2,9 @@ name: "CI"
 
 on:
   push:
-    branches: [ "master" ]
+    branches: [ "master", "oa-fork" ]
   pull_request:
-    branches: [ "master" ]
+    branches: [ "master", "oa-fork" ]
     paths:
       - .github/workflows/**/*.yml
       - app/**/*

From 3985ae7f5ba9f58b96bec6bf6adee12d9ce35f8b Mon Sep 17 00:00:00 2001
From: Justin Garcia <purefunctor@gmail.com>
Date: Mon, 12 Aug 2024 16:56:08 +0800
Subject: [PATCH 011/297] Build pre-release on oa-fork

---
 .github/workflows/ci.yml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index 284a88c8b7..9a49af5f43 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -30,7 +30,7 @@ defaults:
     shell: "bash"
 
 env:
-  CI_PRERELEASE: "${{ github.event_name == 'push' && github.ref == 'refs/heads/master' }}"
+  CI_PRERELEASE: "${{ github.event_name == 'push' && (github.ref == 'refs/heads/master' || github.ref == 'refs/heads/oa-fork') }}"
   CI_RELEASE: "${{ github.event_name == 'release' }}"
   STACK_VERSION: "2.15.1"
 

From fead96f5d25f221f599b4723312ffbbcb99fefc4 Mon Sep 17 00:00:00 2001
From: Justin Garcia <purefunctor@gmail.com>
Date: Mon, 12 Aug 2024 17:04:14 +0800
Subject: [PATCH 012/297] Disable CI_PRERELEASE again

---
 .github/workflows/ci.yml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index 9a49af5f43..284a88c8b7 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -30,7 +30,7 @@ defaults:
     shell: "bash"
 
 env:
-  CI_PRERELEASE: "${{ github.event_name == 'push' && (github.ref == 'refs/heads/master' || github.ref == 'refs/heads/oa-fork') }}"
+  CI_PRERELEASE: "${{ github.event_name == 'push' && github.ref == 'refs/heads/master' }}"
   CI_RELEASE: "${{ github.event_name == 'release' }}"
   STACK_VERSION: "2.15.1"
 

From e989935ba47bc5c1a37e9d73d840be26d968302d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 9 Sep 2024 07:14:59 +0200
Subject: [PATCH 013/297] Remove Generic and NFData instances from IDE types

---
 src/Language/PureScript/Ide/Reexports.hs |  3 +--
 src/Language/PureScript/Ide/Types.hs     | 28 ++++++++++++------------
 2 files changed, 15 insertions(+), 16 deletions(-)

diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs
index a50b9de7a9..3da2a0a82e 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -35,9 +35,8 @@ data ReexportResult a
   = ReexportResult
   { reResolved :: a
   , reFailed   :: [(P.ModuleName, P.DeclarationRef)]
-  } deriving (Show, Eq, Functor, Generic)
+  } deriving (Show, Eq, Functor)
 
-instance NFData a => NFData (ReexportResult a)
 
 -- | Uses the passed formatter to format the resolved module, and adds possible
 -- failures
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 5fa304166b..41532a3c51 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -31,43 +31,43 @@ data IdeDeclaration
   | IdeDeclValueOperator IdeValueOperator
   | IdeDeclTypeOperator IdeTypeOperator
   | IdeDeclModule P.ModuleName
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord)
 
 data IdeValue = IdeValue
   { _ideValueIdent :: P.Ident
   , _ideValueType :: P.SourceType
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 data IdeType = IdeType
  { _ideTypeName :: P.ProperName 'P.TypeName
  , _ideTypeKind :: P.SourceType
  , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.SourceType)]
- } deriving (Show, Eq, Ord, Generic, NFData)
+ } deriving (Show, Eq, Ord)
 
 data IdeTypeSynonym = IdeTypeSynonym
   { _ideSynonymName :: P.ProperName 'P.TypeName
   , _ideSynonymType :: P.SourceType
   , _ideSynonymKind :: P.SourceType
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 data IdeDataConstructor = IdeDataConstructor
   { _ideDtorName :: P.ProperName 'P.ConstructorName
   , _ideDtorTypeName :: P.ProperName 'P.TypeName
   , _ideDtorType :: P.SourceType
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 data IdeTypeClass = IdeTypeClass
   { _ideTCName :: P.ProperName 'P.ClassName
   , _ideTCKind :: P.SourceType
   , _ideTCInstances :: [IdeInstance]
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 data IdeInstance = IdeInstance
   { _ideInstanceModule :: P.ModuleName
   , _ideInstanceName :: P.Ident
   , _ideInstanceTypes :: [P.SourceType]
   , _ideInstanceConstraints :: Maybe [P.SourceConstraint]
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 data IdeValueOperator = IdeValueOperator
   { _ideValueOpName :: P.OpName 'P.ValueOpName
@@ -75,7 +75,7 @@ data IdeValueOperator = IdeValueOperator
   , _ideValueOpPrecedence :: P.Precedence
   , _ideValueOpAssociativity :: P.Associativity
   , _ideValueOpType :: Maybe P.SourceType
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 data IdeTypeOperator = IdeTypeOperator
   { _ideTypeOpName :: P.OpName 'P.TypeOpName
@@ -83,7 +83,7 @@ data IdeTypeOperator = IdeTypeOperator
   , _ideTypeOpPrecedence :: P.Precedence
   , _ideTypeOpAssociativity :: P.Associativity
   , _ideTypeOpKind :: Maybe P.SourceType
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 _IdeDeclValue :: Traversal' IdeDeclaration IdeValue
 _IdeDeclValue f (IdeDeclValue x) = map IdeDeclValue (f x)
@@ -131,7 +131,7 @@ makeLenses ''IdeTypeOperator
 data IdeDeclarationAnn = IdeDeclarationAnn
   { _idaAnnotation :: Annotation
   , _idaDeclaration :: IdeDeclaration
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 data Annotation
   = Annotation
@@ -139,7 +139,7 @@ data Annotation
   , _annExportedFrom :: Maybe P.ModuleName
   , _annTypeAnnotation :: Maybe P.SourceType
   , _annDocumentation :: Maybe Text
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  } deriving (Show, Eq, Ord)
 
 makeLenses ''Annotation
 makeLenses ''IdeDeclarationAnn
@@ -152,7 +152,7 @@ type TypeAnnotations = Map P.Ident P.SourceType
 newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations))
   -- ^ SourceSpans for the definition sites of values and types as well as type
   -- annotations found in a module
-  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable)
+  deriving (Show, Eq, Ord, Functor, Foldable)
 
 data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone
   deriving (Show, Eq)
@@ -313,7 +313,7 @@ encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifie
 
 -- | Denotes the different namespaces a name in PureScript can reside in.
 data IdeNamespace = IdeNSValue | IdeNSType | IdeNSModule
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord)
 
 instance FromJSON IdeNamespace where
   parseJSON = Aeson.withText "Namespace" $ \case
@@ -324,4 +324,4 @@ instance FromJSON IdeNamespace where
 
 -- | A name tagged with a namespace
 data IdeNamespaced = IdeNamespaced IdeNamespace Text
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord)

From 4bf5d8d35ade563e281c58ab491c17e9bde582eb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 9 Sep 2024 07:26:19 +0200
Subject: [PATCH 014/297] Remove perf log as result is no longer forced

---
 src/Language/PureScript/Ide/State.hs | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index 3af0550ef2..32478d7000 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -54,7 +54,7 @@ import Language.PureScript.Ide.Externs (convertExterns)
 import Language.PureScript.Ide.Reexports (ReexportResult(..), prettyPrintReexportResult, reexportHasFailures, resolveReexports)
 import Language.PureScript.Ide.SourceFile (extractAstInformation)
 import Language.PureScript.Ide.Types
-import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger)
+import Language.PureScript.Ide.Util (discardAnn, opNameT, properNameT, runLogger)
 import System.Directory (getModificationTime)
 
 -- | Resets all State inside psc-ide
@@ -199,9 +199,7 @@ cachedRebuild = vsCachedRebuild <$> getVolatileState
 populateVolatileStateSync :: (Ide m, MonadLogger m) => m ()
 populateVolatileStateSync = do
   st <- ideStateVar <$> ask
-  let message duration = "Finished populating volatile state in: " <> displayTimeSpec duration
-  results <- logPerf message $ do
-    liftIO (atomically (populateVolatileStateSTM st))
+  results <- liftIO (atomically (populateVolatileStateSTM st))
   void $ Map.traverseWithKey
     (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
     (Map.filter reexportHasFailures results)

From 48761ab5d9f7193654f48cbaec47dfbb8766a5e1 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 13 Sep 2024 15:23:13 +0200
Subject: [PATCH 015/297] adds LSP module

---
 purescript.cabal               |  5 ++-
 src/Language/PureScript/LSP.hs | 58 ++++++++++++++++++++++++++++++++++
 stack.yaml                     |  4 +++
 3 files changed, 66 insertions(+), 1 deletion(-)
 create mode 100644 src/Language/PureScript/LSP.hs

diff --git a/purescript.cabal b/purescript.cabal
index 0d32ce4814..b42960ffe2 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -208,7 +208,9 @@ common defaults
     transformers-base >=0.4.6 && <0.5,
     utf8-string >=1.0.2 && <1.1,
     vector >=0.12.3.1 && <0.13,
-    witherable >=0.4.2 && <0.5
+    witherable >=0.4.2 && <0.5,
+    lsp >=2.2.0 && <3.0,
+    lsp-types >=2.2.0 && <3.0
 
 library
   import: defaults
@@ -332,6 +334,7 @@ library
     Language.PureScript.Linter.Exhaustive
     Language.PureScript.Linter.Imports
     Language.PureScript.Linter.Wildcards
+    Language.PureScript.LSP
     Language.PureScript.Make
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
new file mode 100644
index 0000000000..075570c238
--- /dev/null
+++ b/src/Language/PureScript/LSP.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.PureScript.LSP where
+
+import Control.Monad.IO.Class ()
+import Data.Text qualified as T
+import Language.LSP.Protocol.Message
+import Language.LSP.Protocol.Types
+import Language.LSP.Server
+import Protolude hiding (moduleName)
+
+handlers :: Handlers (LspM ())
+handlers =
+  mconcat
+    [ notificationHandler SMethod_Initialized $ \_not -> do
+        let params =
+              ShowMessageRequestParams
+                MessageType_Info
+                "Turn on code lenses?"
+                (Just [MessageActionItem "Turn on", MessageActionItem "Don't"])
+        _ <- sendRequest SMethod_WindowShowMessageRequest params $ \case
+          Right (InL (MessageActionItem "Turn on")) -> do
+            let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False)
+
+            _ <- registerCapability mempty SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do
+              let cmd = Command "Say hello" "lsp-hello-command" Nothing
+                  rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing]
+              responder $ Right $ InL rsp
+            pure ()
+          Right _ ->
+            sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "Not turning on code lenses")
+          Left err ->
+            sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Error $ "Something went wrong!\n" <> T.pack (show err))
+        pure (),
+      requestHandler SMethod_TextDocumentHover $ \req responder -> do
+        let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
+            Position _l _c' = pos
+            rsp = Hover (InL ms) (Just range)
+            ms = mkMarkdown "Hello world"
+            range = Range pos pos
+        responder (Right $ InL rsp)
+    ]
+
+main :: IO Int
+main =
+  runServer $
+    ServerDefinition
+      { parseConfig = const $ const $ Right (),
+        onConfigChange = const $ pure (),
+        defaultConfig = (),
+        configSection = "demo",
+        doInitialize = \env _req -> pure $ Right env,
+        staticHandlers = \_caps -> handlers,
+        interpretHandler = \env -> Iso (runLspT env) liftIO,
+        options = defaultOptions
+      }
\ No newline at end of file
diff --git a/stack.yaml b/stack.yaml
index 88b27b1a46..f0c51eb4ed 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -27,6 +27,10 @@ extra-deps:
 - hspec-2.10.9
 - hspec-core-2.10.9
 - hspec-discover-2.10.9
+- lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c
+- lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215
+- mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409
+- row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
 nix:
   packages:
   - zlib

From 99afac3671f72baab6881f34497b98b9b23055d3 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 16 Sep 2024 15:15:34 +0200
Subject: [PATCH 016/297] using reactor

---
 app/Command/Lsp.hs             |  85 +++++++++
 app/Main.hs                    |   4 +
 purescript.cabal               |   7 +-
 src/Language/PureScript/LSP.hs | 339 ++++++++++++++++++++++++++++-----
 4 files changed, 387 insertions(+), 48 deletions(-)
 create mode 100644 app/Command/Lsp.hs

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
new file mode 100644
index 0000000000..c7028eef92
--- /dev/null
+++ b/app/Command/Lsp.hs
@@ -0,0 +1,85 @@
+module Command.Lsp (command) where
+
+import Control.Concurrent.STM (newTVarIO)
+import Data.IORef (newIORef)
+import Language.PureScript.Ide.Types (IdeConfiguration (..), IdeEnvironment (..), IdeLogLevel (..), emptyIdeState)
+import Language.PureScript.Lsp as Lsp
+import Options.Applicative qualified as Opts
+import Protolude
+import SharedCLI qualified
+import System.Directory (setCurrentDirectory)
+
+data ServerOptions = ServerOptions
+  { _serverDirectory :: Maybe FilePath,
+    _serverGlobs :: [FilePath],
+    _serverGlobsFromFile :: Maybe FilePath,
+    _serverGlobsExcluded :: [FilePath],
+    _serverOutputPath :: FilePath,
+    _serverLoglevel :: IdeLogLevel
+  }
+  deriving (Show)
+
+command :: Opts.Parser (IO ())
+command = Opts.helper <*> subcommands
+  where
+    subcommands :: Opts.Parser (IO ())
+    subcommands =
+      (Opts.subparser . fold)
+        [ Opts.command
+            "server"
+            ( Opts.info
+                (fmap server serverOptions <**> Opts.helper)
+                (Opts.progDesc "Start a server process")
+            )
+        ]
+
+    server :: ServerOptions -> IO ()
+    server opts'@(ServerOptions dir globs globsFromFile globsExcluded outputPath logLevel) = do
+      when
+        (logLevel == LogDebug || logLevel == LogAll)
+        (putText "Parsed Options:" *> print opts')
+      maybe (pure ()) setCurrentDirectory dir
+      ideState <- newTVarIO emptyIdeState
+      let conf =
+            IdeConfiguration
+              { confLogLevel = logLevel,
+                confOutputPath = outputPath,
+                confGlobs = globs,
+                confGlobsFromFile = globsFromFile,
+                confGlobsExclude = globsExcluded
+              }
+      ts <- newIORef Nothing
+      let env =
+            IdeEnvironment
+              { ideStateVar = ideState,
+                ideConfiguration = conf,
+                ideCacheDbTimestamp = ts
+              }
+      startServer env
+
+    serverOptions :: Opts.Parser ServerOptions
+    serverOptions =
+      ServerOptions
+        <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
+        <*> many SharedCLI.inputFile
+        <*> SharedCLI.globInputFile
+        <*> many SharedCLI.excludeFiles
+        <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
+        <*> ( parseLogLevel
+                <$> Opts.strOption
+                  ( Opts.long "log-level"
+                      `mappend` Opts.value ""
+                      `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""
+                  )
+            )
+
+    parseLogLevel :: Text -> IdeLogLevel
+    parseLogLevel s = case s of
+      "debug" -> LogDebug
+      "perf" -> LogPerf
+      "all" -> LogAll
+      "none" -> LogNone
+      _ -> LogDefault
+
+    startServer _ = do
+      Lsp.main
\ No newline at end of file
diff --git a/app/Main.hs b/app/Main.hs
index c925a4a313..5f1e521249 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -8,6 +8,7 @@ import Command.Docs qualified as Docs
 import Command.Graph qualified as Graph
 import Command.Hierarchy qualified as Hierarchy
 import Command.Ide qualified as Ide
+import Command.Lsp qualified as Lsp
 import Command.Publish qualified as Publish
 import Command.REPL qualified as REPL
 import Control.Monad (join)
@@ -76,6 +77,9 @@ main = do
         , Opts.command "ide"
             (Opts.info Ide.command
               (Opts.progDesc "Start or query an IDE server process"))
+        , Opts.command "lsp"
+            (Opts.info Lsp.command
+              (Opts.progDesc "Start or query an IDE server process using the Language Server Protocol"))
         , Opts.command "publish"
             (Opts.info Publish.command
               (Opts.progDesc "Generates documentation packages for upload to Pursuit"))
diff --git a/purescript.cabal b/purescript.cabal
index b42960ffe2..570bb22c24 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -210,7 +210,9 @@ common defaults
     vector >=0.12.3.1 && <0.13,
     witherable >=0.4.2 && <0.5,
     lsp >=2.2.0 && <3.0,
-    lsp-types >=2.2.0 && <3.0
+    lsp-types >=2.2.0 && <3.0,
+    co-log-core >= 0.3.2.0 && < 0.4,
+    prettyprinter >= 1.7.0 && < 2.0
 
 library
   import: defaults
@@ -334,7 +336,7 @@ library
     Language.PureScript.Linter.Exhaustive
     Language.PureScript.Linter.Imports
     Language.PureScript.Linter.Wildcards
-    Language.PureScript.LSP
+    Language.PureScript.Lsp
     Language.PureScript.Make
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
@@ -425,6 +427,7 @@ executable purs
     Command.Graph
     Command.Hierarchy
     Command.Ide
+    Command.Lsp
     Command.Publish
     Command.REPL
     SharedCLI
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 075570c238..a56e1cb254 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -1,58 +1,305 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
-module Language.PureScript.LSP where
+module Language.PureScript.Lsp where
 
-import Control.Monad.IO.Class ()
+import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
+import Colog.Core qualified as L
+import Control.Concurrent.STM.TChan
+import Control.Exception qualified as E
+import Control.Lens hiding (Iso)
+import Data.Aeson qualified as J
 import Data.Text qualified as T
-import Language.LSP.Protocol.Message
-import Language.LSP.Protocol.Types
+import Language.LSP.Diagnostics
+import Language.LSP.Logging (defaultClientLogger)
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as LSP
+import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Server
-import Protolude hiding (moduleName)
+import Language.LSP.Server as LSP.Server
+import Language.LSP.VFS
+import Prettyprinter
+import Protolude hiding (to)
+import System.IO as IO
 
-handlers :: Handlers (LspM ())
-handlers =
+-- -- ---------------------------------------------------------------------
+-- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
+-- {-# ANN module ("HLint: ignore Redundant do" :: String) #-}
+-- {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
+
+-- -- ---------------------------------------------------------------------
+-- --
+
+main :: IO ()
+main = do
+  run >>= \case
+    0 -> exitSuccess
+    c -> exitWith . ExitFailure $ c
+
+-- ---------------------------------------------------------------------
+
+data Config = Config {fooTheBar :: Bool, wibbleFactor :: Int}
+  deriving (Generic, J.ToJSON, J.FromJSON, Show)
+
+run :: IO Int
+run = flip E.catches execptionHandlers $ do
+  rin <- atomically newTChan :: IO (TChan ReactorInput)
+
+  let -- Three loggers:
+      -- 1. To stderr
+      -- 2. To the client (filtered by severity)
+      -- 3. To both
+      stderrLogger :: LogAction IO (WithSeverity T.Text)
+      stderrLogger = L.cmap show L.logStringStderr
+      clientLogger :: LogAction (LspM Config) (WithSeverity T.Text)
+      clientLogger = defaultClientLogger
+      dualLogger :: LogAction (LspM Config) (WithSeverity T.Text)
+      dualLogger = clientLogger <> L.hoistLogAction liftIO stderrLogger
+
+      serverDefinition =
+        ServerDefinition
+          { defaultConfig = Config {fooTheBar = False, wibbleFactor = 0},
+            parseConfig = \_old v -> do
+              case J.fromJSON v of
+                J.Error e -> Left (T.pack e)
+                J.Success cfg -> Right cfg,
+            onConfigChange = const $ pure (),
+            configSection = "demo",
+            doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env),
+            -- Handlers log to both the client and stderr
+            staticHandlers = \_caps -> lspHandlers dualLogger rin,
+            interpretHandler = \env -> Iso (runLspT env) liftIO,
+            options = lspOptions
+          }
+
+  let logToText = T.pack . show . pretty
+  runServerWithHandles
+    -- Log to both the client and stderr when we can, stderr beforehand
+    (L.cmap (fmap logToText) stderrLogger)
+    (L.cmap (fmap logToText) dualLogger)
+    stdin
+    stdout
+    serverDefinition
+  where
+    execptionHandlers =
+      [ E.Handler ioExcept,
+        E.Handler someExcept
+      ]
+    ioExcept (e :: E.IOException) = IO.print e >> return 1
+    someExcept (e :: E.SomeException) = IO.print e >> return 1
+
+-- ---------------------------------------------------------------------
+
+syncOptions :: LSP.TextDocumentSyncOptions
+syncOptions =
+  LSP.TextDocumentSyncOptions
+    { LSP._openClose = Just True,
+      LSP._change = Just LSP.TextDocumentSyncKind_Incremental,
+      LSP._willSave = Just False,
+      LSP._willSaveWaitUntil = Just False,
+      LSP._save = Just $ LSP.InR $ LSP.SaveOptions $ Just False
+    }
+
+lspOptions :: Options
+lspOptions =
+  defaultOptions
+    { optTextDocumentSync = Just syncOptions,
+      optExecuteCommandCommands = Just ["lsp-hello-command"]
+    }
+
+-- ---------------------------------------------------------------------
+
+-- The reactor is a process that serialises and buffers all requests from the
+-- LSP client, so they can be sent to the backend compiler one at a time, and a
+-- reply sent.
+
+newtype ReactorInput
+  = ReactorAction (IO ())
+
+-- | Analyze the file and send any diagnostics to the client in a
+-- "textDocument/publishDiagnostics" notification
+sendDiagnostics :: LSP.NormalizedUri -> Maybe Int32 -> LspM Config ()
+sendDiagnostics fileUri version = do
+  let diags =
+        [ LSP.Diagnostic
+            (LSP.Range (LSP.Position 0 1) (LSP.Position 0 5))
+            (Just LSP.DiagnosticSeverity_Warning) -- severity
+            Nothing -- code
+            Nothing
+            (Just "lsp-hello") -- source
+            "Example diagnostic message"
+            Nothing -- tags
+            (Just [])
+            Nothing
+        ]
+  publishDiagnostics 100 fileUri version (partitionBySource diags)
+
+-- ---------------------------------------------------------------------
+
+-- | The single point that all events flow through, allowing management of state
+-- to stitch replies and requests together from the two asynchronous sides: lsp
+-- server and backend compiler
+reactor :: L.LogAction IO (WithSeverity T.Text) -> TChan ReactorInput -> IO ()
+reactor logger inp = do
+  logger <& "Started the reactor" `WithSeverity` Info
+  forever $ do
+    ReactorAction act <- atomically $ readTChan inp
+    act
+
+-- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
+-- input into the reactor
+lspHandlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> TChan ReactorInput -> Handlers m
+lspHandlers logger rin = mapHandlers goReq goNot (handlers logger)
+  where
+    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (LspM Config) a -> LSP.Server.Handler (LspM Config) a
+    goReq f msg k = do
+      env <- getLspEnv
+      liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k)
+
+    goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (LspM Config) a -> LSP.Server.Handler (LspM Config) a
+    goNot f msg = do
+      env <- getLspEnv
+      liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg)
+
+-- | Where the actual logic resides for handling requests and notifications.
+handlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> Handlers m
+handlers logger =
   mconcat
-    [ notificationHandler SMethod_Initialized $ \_not -> do
+    [ notificationHandler LSP.SMethod_Initialized $ \_msg -> do
+        logger <& "Processing the Initialized notification" `WithSeverity` Info
+
+        -- We're initialized! Lets send a showMessageRequest now
         let params =
-              ShowMessageRequestParams
-                MessageType_Info
-                "Turn on code lenses?"
-                (Just [MessageActionItem "Turn on", MessageActionItem "Don't"])
-        _ <- sendRequest SMethod_WindowShowMessageRequest params $ \case
-          Right (InL (MessageActionItem "Turn on")) -> do
-            let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False)
-
-            _ <- registerCapability mempty SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do
-              let cmd = Command "Say hello" "lsp-hello-command" Nothing
-                  rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing]
-              responder $ Right $ InL rsp
-            pure ()
-          Right _ ->
-            sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "Not turning on code lenses")
-          Left err ->
-            sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Error $ "Something went wrong!\n" <> T.pack (show err))
-        pure (),
-      requestHandler SMethod_TextDocumentHover $ \req responder -> do
-        let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req
-            Position _l _c' = pos
-            rsp = Hover (InL ms) (Just range)
-            ms = mkMarkdown "Hello world"
-            range = Range pos pos
-        responder (Right $ InL rsp)
+              LSP.ShowMessageRequestParams
+                LSP.MessageType_Warning
+                "What's your favourite language extension?"
+                (Just [LSP.MessageActionItem "Rank2Types", LSP.MessageActionItem "NPlusKPatterns"])
+
+        void $ sendRequest LSP.SMethod_WindowShowMessageRequest params $ \case
+          Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error
+          Right _ -> do
+            sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Excellent choice")
+
+            -- We can dynamically register a capability once the user accepts it
+            sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Turning on code lenses dynamically")
+
+            let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False)
+
+            void
+              $ registerCapability
+                mempty
+                LSP.SMethod_TextDocumentCodeLens
+                regOpts
+              $ \_req responder -> do
+                logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info
+                let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing
+                    rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing]
+                responder (Right $ LSP.InL rsp),
+      notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do
+        let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri
+            fileName = LSP.uriToFilePath doc
+        logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info
+        sendDiagnostics (LSP.toNormalizedUri doc) (Just 0),
+      notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
+        cfg <- getConfig
+        logger L.<& ("Configuration changed: " <> T.pack (show (msg, cfg))) `WithSeverity` Info
+        sendNotification LSP.SMethod_WindowShowMessage $
+          LSP.ShowMessageParams LSP.MessageType_Info $
+            "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)),
+      notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do
+        let doc =
+              msg
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to LSP.toNormalizedUri
+        logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info
+        mdoc <- getVirtualFile doc
+        case mdoc of
+          Just (VirtualFile _version str _) -> do
+            logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info
+          Nothing -> do
+            logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info,
+      notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do
+        let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri
+            fileName = LSP.uriToFilePath doc
+        logger <& ("Processing DidSaveTextDocument  for: " <> T.pack (show fileName)) `WithSeverity` Info
+        sendDiagnostics (LSP.toNormalizedUri doc) Nothing,
+      requestHandler LSP.SMethod_TextDocumentRename $ \req responder -> do
+        logger <& "Processing a textDocument/rename request" `WithSeverity` Info
+        let params = req ^. LSP.params
+            LSP.Position l c = params ^. LSP.position
+            newName = params ^. LSP.newName
+        vdoc <- getVersionedTextDoc (params ^. LSP.textDocument)
+        -- Replace some text at the position with what the user entered
+        let edit = LSP.InL $ LSP.TextEdit (LSP.mkRange l c l (c + fromIntegral (T.length newName))) newName
+            tde = LSP.TextDocumentEdit (LSP._versionedTextDocumentIdentifier # vdoc) [edit]
+            -- "documentChanges" field is preferred over "changes"
+            rsp = LSP.WorkspaceEdit Nothing (Just [LSP.InL tde]) Nothing
+        responder (Right $ LSP.InL rsp),
+      requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do
+        logger <& "Processing a textDocument/hover request" `WithSeverity` Info
+        let LSP.HoverParams _doc pos _workDone = req ^. LSP.params
+            LSP.Position _l _c' = pos
+            rsp = LSP.Hover ms (Just range)
+            ms = LSP.InL $ LSP.mkMarkdown "Your type info here!"
+            range = LSP.Range pos pos
+        responder (Right $ LSP.InL rsp),
+      requestHandler LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do
+        logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info
+        let LSP.DocumentSymbolParams _ _ doc = req ^. LSP.params
+            loc = LSP.Location (doc ^. LSP.uri) (LSP.Range (LSP.Position 0 0) (LSP.Position 0 0))
+            rsp = [LSP.SymbolInformation "lsp-hello" LSP.SymbolKind_Function Nothing Nothing Nothing loc]
+        responder (Right $ LSP.InL rsp),
+      requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do
+        logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info
+        let params = req ^. LSP.params
+            doc = params ^. LSP.textDocument
+            diags = params ^. LSP.context . LSP.diagnostics
+            -- makeCommand only generates commands for diagnostics whose source is us
+            makeCommand d
+              | (LSP.Range s _) <- d ^. LSP.range,
+                (Just "lsp-hello") <- d ^. LSP.source =
+                  let title = fromMaybe "" $ Just "Apply LSP hello command:" <> head (T.lines $ d ^. LSP.message)
+                      -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above
+                      cmd = "lsp-hello-command"
+                      -- need 'file' and 'start_pos'
+                      args =
+                        [ J.object [("file", J.object [("textDocument", J.toJSON doc)])],
+                          J.object [("start_pos", J.object [("position", J.toJSON s)])]
+                        ]
+                      cmdparams = Just args
+                   in [LSP.Command title cmd cmdparams]
+            makeCommand _ = []
+            rsp = map LSP.InL $ concatMap makeCommand diags
+        responder (Right $ LSP.InL rsp),
+      requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do
+        logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info
+        let params = req ^. LSP.params
+            margs = params ^. LSP.arguments
+
+        logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug
+        responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request
+        void $ withProgress "Executing some long running command" (req ^. LSP.params . LSP.workDoneToken) Cancellable $ \update ->
+          forM [(0 :: LSP.UInt) .. 10] $ \i -> do
+            update (ProgressAmount (Just (i * 10)) (Just "Doing stuff"))
+            liftIO $ threadDelay (1 * 1000000)
     ]
 
-main :: IO Int
-main =
-  runServer $
-    ServerDefinition
-      { parseConfig = const $ const $ Right (),
-        onConfigChange = const $ pure (),
-        defaultConfig = (),
-        configSection = "demo",
-        doInitialize = \env _req -> pure $ Right env,
-        staticHandlers = \_caps -> handlers,
-        interpretHandler = \env -> Iso (runLspT env) liftIO,
-        options = defaultOptions
-      }
\ No newline at end of file
+-- ---------------------------------------------------------------------
+-- main :: IO Int
+-- main = do
+--   runServer $
+--     ServerDefinition
+--       { parseConfig = const $ const $ Right (),
+--         onConfigChange = const $ pure (),
+--         defaultConfig = (),
+--         configSection = "purescript-lsp",
+--         doInitialize = \env _req -> pure $ Right env,
+--         staticHandlers = \_caps -> handlers,
+--         interpretHandler = \env -> Iso (runLspT env) liftIO,
+--         options = defaultOptions
+--       }
\ No newline at end of file

From 6fdd8627c89c0704b70c73cb193ac299ea1f02eb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 16 Sep 2024 16:05:08 +0200
Subject: [PATCH 017/297] adds simple lsp server

---
 app/Command/Ide.hs                   |  3 ++
 purescript.cabal                     |  1 +
 src/Language/PureScript/LSP.hs       | 24 +++--------
 src/Language/PureScript/LspSimple.hs | 63 ++++++++++++++++++++++++++++
 4 files changed, 73 insertions(+), 18 deletions(-)
 create mode 100644 src/Language/PureScript/LspSimple.hs

diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs
index 38fc9c7e36..359240785b 100644
--- a/app/Command/Ide.hs
+++ b/app/Command/Ide.hs
@@ -178,6 +178,9 @@ command = Opts.helper <*> subcommands where
     "none" -> LogNone
     _ -> LogDefault
 
+
+-- runM env 
+
 startServer :: Network.PortNumber -> IdeEnvironment -> IO ()
 startServer port env = Network.withSocketsDo $ do
   sock <- listenOnLocalhost port
diff --git a/purescript.cabal b/purescript.cabal
index 570bb22c24..901e34700d 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -337,6 +337,7 @@ library
     Language.PureScript.Linter.Imports
     Language.PureScript.Linter.Wildcards
     Language.PureScript.Lsp
+    Language.PureScript.LspSimple
     Language.PureScript.Make
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index a56e1cb254..d6d1560718 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -4,7 +4,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
-module Language.PureScript.Lsp where
+module Language.PureScript.Lsp (main) where
 
 import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
 import Colog.Core qualified as L
@@ -18,7 +18,6 @@ import Language.LSP.Logging (defaultClientLogger)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as LSP
-import Language.LSP.Server
 import Language.LSP.Server as LSP.Server
 import Language.LSP.VFS
 import Prettyprinter
@@ -202,7 +201,11 @@ handlers logger =
         let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri
             fileName = LSP.uriToFilePath doc
         logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info
-        sendDiagnostics (LSP.toNormalizedUri doc) (Just 0),
+        case fileName of
+          Nothing -> logger <& "No filename found" `WithSeverity` Error
+          Just _path -> do
+            -- res <- _ $rebuildFileAsync path Nothing (Set.singleton JS)
+            sendDiagnostics (LSP.toNormalizedUri doc) (Just 0),
       notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
         cfg <- getConfig
         logger L.<& ("Configuration changed: " <> T.pack (show (msg, cfg))) `WithSeverity` Info
@@ -288,18 +291,3 @@ handlers logger =
             update (ProgressAmount (Just (i * 10)) (Just "Doing stuff"))
             liftIO $ threadDelay (1 * 1000000)
     ]
-
--- ---------------------------------------------------------------------
--- main :: IO Int
--- main = do
---   runServer $
---     ServerDefinition
---       { parseConfig = const $ const $ Right (),
---         onConfigChange = const $ pure (),
---         defaultConfig = (),
---         configSection = "purescript-lsp",
---         doInitialize = \env _req -> pure $ Right env,
---         staticHandlers = \_caps -> handlers,
---         interpretHandler = \env -> Iso (runLspT env) liftIO,
---         options = defaultOptions
---       }
\ No newline at end of file
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
new file mode 100644
index 0000000000..3f7fe32f33
--- /dev/null
+++ b/src/Language/PureScript/LspSimple.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+
+module Language.PureScript.LspSimple where
+
+import Data.Text qualified as T
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server qualified as Server
+import Language.PureScript.Ide.Types (IdeEnvironment)
+import Protolude
+
+type HandlerM = Server.LspT () (ReaderT IdeEnvironment IO)
+
+handlers :: Server.Handlers HandlerM
+handlers =
+  mconcat
+    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
+        let params =
+              Types.ShowMessageRequestParams
+                Types.MessageType_Info
+                "Turn on code lenses?"
+                (Just [Types.MessageActionItem "Turn on", Types.MessageActionItem "Don't"])
+        _ <- Server.sendRequest Message.SMethod_WindowShowMessageRequest params $ \case
+          Right (Types.InL (Types.MessageActionItem "Turn on")) -> do
+            let regOpts = Types.CodeLensRegistrationOptions (Types.InR Types.Null) Nothing (Just False)
+
+            _ <- Server.registerCapability mempty Message.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do
+              let cmd = Types.Command "Say hello" "lsp-hello-command" Nothing
+                  rsp = [Types.CodeLens (Types.mkRange 0 0 0 100) (Just cmd) Nothing]
+              responder $ Right $ Types.InL rsp
+            pure ()
+          Right _ ->
+            Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info "Not turning on code lenses")
+          Left err ->
+            Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Error $ "Something went wrong!\n" <> T.pack (show err))
+        pure (),
+      Server.requestHandler Message.SMethod_TextDocumentHover $ \req responder -> do
+        let Message.TRequestMessage _ _ _ (Types.HoverParams _doc pos _workDone) = req
+            Types.Position _l _c' = pos
+            rsp = Types.Hover (Types.InL ms) (Just range)
+            ms = Types.mkMarkdown "Hello world"
+            range = Types.Range pos pos
+        responder (Right $ Types.InL rsp),
+      Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
+        pure ()
+    ]
+
+-- main :: IO Int
+-- main =
+--   Server.runServer $
+--     Server.ServerDefinition
+--       { parseConfig = const $ const $ Right (),
+--         onConfigChange = const $ pure (),
+--         defaultConfig = (),
+--         configSection = "oa-purescript",
+--         doInitialize = \env _req -> pure $ Right env,
+--         staticHandlers = \_caps -> handlers,
+--         interpretHandler = \env -> Server.Iso (Server.runLspT env) liftIO,
+--         options = Server.defaultOptions
+--       }
\ No newline at end of file

From cedeb8a7fb35a3418861f8b07f7686d4914a6ae9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 17 Sep 2024 11:52:21 +0200
Subject: [PATCH 018/297] adds HandlerM and IdeM

---
 purescript.cabal                     |  3 +-
 src/Language/PureScript/Ide.hs       |  1 +
 src/Language/PureScript/LspSimple.hs | 54 +++++++++++++++++++---------
 3 files changed, 41 insertions(+), 17 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index 901e34700d..c2fda4afa9 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -212,7 +212,8 @@ common defaults
     lsp >=2.2.0 && <3.0,
     lsp-types >=2.2.0 && <3.0,
     co-log-core >= 0.3.2.0 && < 0.4,
-    prettyprinter >= 1.7.0 && < 2.0
+    prettyprinter >= 1.7.0 && < 2.0,
+    unliftio-core >= 0.2.0.0 && < 0.3
 
 library
   import: defaults
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 95ef36fde4..c374a47b58 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -16,6 +16,7 @@
 
 module Language.PureScript.Ide
        ( handleCommand
+       , loadModulesAsync
        ) where
 
 import Protolude hiding (moduleName)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 3f7fe32f33..4d070793f8 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -1,20 +1,34 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.LspSimple where
 
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader (mapReaderT)
 import Data.Text qualified as T
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
-import Language.PureScript.Ide.Types (IdeEnvironment)
+import Language.PureScript.Ide (loadModulesAsync)
+import Language.PureScript.Ide.Error (IdeError)
+import Language.PureScript.Ide.Types (IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration))
+import Language.PureScript.Ide.Util (runLogger)
 import Protolude
+import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
 
-type HandlerM = Server.LspT () (ReaderT IdeEnvironment IO)
+type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
 
-handlers :: Server.Handlers HandlerM
+type IdeM = ReaderT IdeEnvironment (LoggingT (ExceptT IdeError IO))
+
+runIde :: IdeM a -> HandlerM config (Either IdeError a)
+runIde = lift . mapReaderT (mapLoggingT runExceptT)
+
+handlers :: Server.Handlers (HandlerM ())
 handlers =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
@@ -45,19 +59,27 @@ handlers =
             range = Types.Range pos pos
         responder (Right $ Types.InL rsp),
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
+        res <- runIde $ loadModulesAsync []
+        -- publishD
         pure ()
     ]
 
--- main :: IO Int
--- main =
---   Server.runServer $
---     Server.ServerDefinition
---       { parseConfig = const $ const $ Right (),
---         onConfigChange = const $ pure (),
---         defaultConfig = (),
---         configSection = "oa-purescript",
---         doInitialize = \env _req -> pure $ Right env,
---         staticHandlers = \_caps -> handlers,
---         interpretHandler = \env -> Server.Iso (Server.runLspT env) liftIO,
---         options = Server.defaultOptions
---       }
\ No newline at end of file
+main :: IdeEnvironment -> IO Int
+main ideEnv =
+  Server.runServer $
+    Server.ServerDefinition
+      { parseConfig = const $ const $ Right (),
+        onConfigChange = const $ pure (),
+        defaultConfig = (),
+        configSection = "oa-purescript",
+        doInitialize = \env _req -> pure $ Right env,
+        staticHandlers = \_caps -> handlers,
+        interpretHandler = \env ->
+          Server.Iso
+            ( runLogger (confLogLevel (ideConfiguration ideEnv))
+                . flip runReaderT ideEnv
+                . Server.runLspT env
+            )
+            liftIO,
+        options = Server.defaultOptions
+      }
\ No newline at end of file

From ad78e3907d042867f55219884f066e1ec5317566 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 17 Sep 2024 11:54:53 +0200
Subject: [PATCH 019/297] use lsp simple

---
 app/Command/Lsp.hs                   | 11 ++++++++---
 src/Language/PureScript/LspSimple.hs |  2 +-
 2 files changed, 9 insertions(+), 4 deletions(-)

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index c7028eef92..04f0935607 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -3,7 +3,7 @@ module Command.Lsp (command) where
 import Control.Concurrent.STM (newTVarIO)
 import Data.IORef (newIORef)
 import Language.PureScript.Ide.Types (IdeConfiguration (..), IdeEnvironment (..), IdeLogLevel (..), emptyIdeState)
-import Language.PureScript.Lsp as Lsp
+import Language.PureScript.LspSimple as Lsp
 import Options.Applicative qualified as Opts
 import Protolude
 import SharedCLI qualified
@@ -81,5 +81,10 @@ command = Opts.helper <*> subcommands
       "none" -> LogNone
       _ -> LogDefault
 
-    startServer _ = do
-      Lsp.main
\ No newline at end of file
+    startServer env = do
+      code <- Lsp.main env
+      exitWith
+        ( case code of
+            0 -> ExitSuccess
+            _ -> ExitFailure code
+        )
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 4d070793f8..179df37716 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -71,7 +71,7 @@ main ideEnv =
       { parseConfig = const $ const $ Right (),
         onConfigChange = const $ pure (),
         defaultConfig = (),
-        configSection = "oa-purescript",
+        configSection = "oa-purescript-simple",
         doInitialize = \env _req -> pure $ Right env,
         staticHandlers = \_caps -> handlers,
         interpretHandler = \env ->

From 0eeba12b259a1dff8fccd4fd93a3ed25c0cf6ce5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 00:46:59 +0200
Subject: [PATCH 020/297] diagnotics sending

---
 src/Language/PureScript/Ide/Error.hs |   1 +
 src/Language/PureScript/LspSimple.hs | 191 ++++++++++++++++++++++-----
 2 files changed, 156 insertions(+), 36 deletions(-)

diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 8a23f574e0..535af939dc 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -15,6 +15,7 @@
 module Language.PureScript.Ide.Error
        ( IdeError(..)
        , prettyPrintTypeSingleLine
+       , textError
        ) where
 
 import Data.Aeson (KeyValue(..), ToJSON(..), Value, object)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 179df37716..6bbd8e74c9 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -6,19 +6,28 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 
-module Language.PureScript.LspSimple where
+module Language.PureScript.LspSimple (main) where
 
+import Control.Lens ((^.))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
+import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as T
+import Language.LSP.Diagnostics (partitionBySource)
+import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types (Uri, toNormalizedUri)
 import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server (getConfig, publishDiagnostics)
 import Language.LSP.Server qualified as Server
-import Language.PureScript.Ide (loadModulesAsync)
-import Language.PureScript.Ide.Error (IdeError)
-import Language.PureScript.Ide.Types (IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration))
+import Language.PureScript.Errors (ErrorMessage (ErrorMessage), ErrorMessageHint, MultipleErrors (runMultipleErrors), defaultPPEOptions, errorCode, errorDocUri, errorSpan, prettyPrintSingleError)
+import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
+import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
+import Language.PureScript.Ide.Types (IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
 import Language.PureScript.Ide.Util (runLogger)
 import Protolude
+import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
 
 type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
@@ -32,38 +41,137 @@ handlers :: Server.Handlers (HandlerM ())
 handlers =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
-        let params =
-              Types.ShowMessageRequestParams
-                Types.MessageType_Info
-                "Turn on code lenses?"
-                (Just [Types.MessageActionItem "Turn on", Types.MessageActionItem "Don't"])
-        _ <- Server.sendRequest Message.SMethod_WindowShowMessageRequest params $ \case
-          Right (Types.InL (Types.MessageActionItem "Turn on")) -> do
-            let regOpts = Types.CodeLensRegistrationOptions (Types.InR Types.Null) Nothing (Just False)
-
-            _ <- Server.registerCapability mempty Message.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do
-              let cmd = Types.Command "Say hello" "lsp-hello-command" Nothing
-                  rsp = [Types.CodeLens (Types.mkRange 0 0 0 100) (Just cmd) Nothing]
-              responder $ Right $ Types.InL rsp
-            pure ()
-          Right _ ->
-            Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info "Not turning on code lenses")
-          Left err ->
-            Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Error $ "Something went wrong!\n" <> T.pack (show err))
-        pure (),
-      Server.requestHandler Message.SMethod_TextDocumentHover $ \req responder -> do
-        let Message.TRequestMessage _ _ _ (Types.HoverParams _doc pos _workDone) = req
-            Types.Position _l _c' = pos
-            rsp = Types.Hover (Types.InL ms) (Just range)
-            ms = Types.mkMarkdown "Hello world"
-            range = Types.Range pos pos
-        responder (Right $ Types.InL rsp),
+        log_ ("OA purs lsp server initialized" :: T.Text)
+        sendInfoMsg "OA purs lsp server initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        res <- runIde $ loadModulesAsync []
-        -- publishD
-        pure ()
+        sendInfoMsg "TextDocumentDidOpen"
+        rebuildFileFromMsg msg,
+      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
+        sendInfoMsg "TextDocumentDidChange"
+        rebuildFileFromMsg msg,
+      Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
+        sendInfoMsg "SMethod_TextDocumentDidSave"
+        rebuildFileFromMsg msg,
+      Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
+        cfg <- getConfig
+        sendInfoMsg $ "Config changed: " <> show cfg,
+      Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
+        sendInfoMsg "SMethod_SetTrace",
+      --  Message.serverMethodJSON Message.SMethod_TextDocumentPublishDiagnostics _,
+      --  Message.regHelper Message.SMethod_TextDocumentPublishDiagnostics _,
+      --  $ \msg -> do
+      --   sendInfoMsg "SMethod_TextDocumentPublishDiagnostics",
+      Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \msg res -> do
+        sendInfoMsg "SMethod_TextDocumentDiagnostic"
+        diags <- getFileDiagnotics msg
+        res $
+          Right $
+            Types.DocumentDiagnosticReport $
+              Types.InL $
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diags Nothing
+                --  $ \msg -> do
+                --   sendInfoMsg "SMethod_TextDocumentDiagnostic"
     ]
 
+rebuildFileFromMsg :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri) => s -> HandlerM config ()
+rebuildFileFromMsg msg = do
+  let doc :: Uri
+      doc = getDocument msg
+      fileName = Types.uriToFilePath doc
+  case fileName of
+    Just file -> do
+      res <- runIde $ rebuildFile file
+      sendDiagnostics doc res
+    Nothing ->
+      sendInfoMsg $ "No file path for uri: " <> show doc
+
+getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config [Types.Diagnostic]
+getFileDiagnotics msg = do
+  let doc :: Uri
+      doc = getDocument msg
+      fileName = Types.uriToFilePath doc
+  case fileName of
+    Just file -> do
+      res <- runIde $ rebuildFile file
+      getResultDiagnostics doc res
+    Nothing -> do
+      sendInfoMsg $ "No file path for uri: " <> show doc
+      pure []
+
+rebuildFile :: FilePath -> IdeM Success
+rebuildFile file = rebuildFileAsync file Nothing mempty
+
+getDocument :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
+getDocument msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
+
+sendDiagnostics :: Uri -> Either IdeError Success -> HandlerM config ()
+sendDiagnostics uri res = do
+  diags <- getResultDiagnostics uri res
+  publishDiagnostics 100 (toNormalizedUri uri) Nothing (partitionBySource diags)
+
+getResultDiagnostics :: Uri -> Either IdeError Success -> HandlerM config [Types.Diagnostic]
+getResultDiagnostics uri res = case res of
+  Right success ->
+    case success of
+      RebuildSuccess errs -> pure $ errorMessageDiagnostic <$> runMultipleErrors errs
+      TextResult _ -> pure []
+      _ -> pure []
+  Left (RebuildError _ errs) -> pure $ errorMessageDiagnostic <$> runMultipleErrors errs
+  Left err -> do
+    sendError err
+    pure []
+  where
+    errorMessageDiagnostic :: ErrorMessage -> Types.Diagnostic
+    errorMessageDiagnostic msg@((ErrorMessage hints _)) =
+      Types.Diagnostic
+        (Types.Range start end)
+        (Just Types.DiagnosticSeverity_Error)
+        (Just $ Types.InR $ errorCode msg)
+        (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
+        (T.pack <$> spanName)
+        (T.pack $ render $ prettyPrintSingleError defaultPPEOptions msg)
+        Nothing
+        (Just $ hintToRelated <$> hints)
+        Nothing
+      where
+        notFound = Types.Position 0 0
+        (spanName, start, end) = getPositions $ errorSpan msg
+
+        getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
+
+        getPositionsMb = fmap $ \spans ->
+          let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+                NEL.head spans
+           in ( Just name,
+                Types.Position (fromIntegral startLine) (fromIntegral startCol),
+                Types.Position (fromIntegral endLine) (fromIntegral endCol)
+              )
+
+        hintToRelated :: Errors.ErrorMessageHint -> Types.DiagnosticRelatedInformation
+        hintToRelated hint =
+          Types.DiagnosticRelatedInformation
+            (Types.Location uri (Types.Range hintStart hintEnd))
+            (show hint)
+          where
+            (_, hintStart, hintEnd) = fromMaybe (Nothing, start, end) $ getPositionsMb $ getHintSpans hint
+
+getHintSpans :: ErrorMessageHint -> Maybe (NEL.NonEmpty Errors.SourceSpan)
+getHintSpans hint = case hint of
+  Errors.PositionedError span -> Just span
+  Errors.RelatedPositions span -> Just span
+  _ -> Nothing
+
+sendError :: IdeError -> HandlerM config ()
+sendError err =
+  Server.sendNotification
+    Message.SMethod_WindowShowMessage
+    ( Types.ShowMessageParams Types.MessageType_Error $
+        "Something went wrong:\n" <> textError err
+    )
+
+sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
+sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
+
 main :: IdeEnvironment -> IO Int
 main ideEnv =
   Server.runServer $
@@ -72,8 +180,10 @@ main ideEnv =
         onConfigChange = const $ pure (),
         defaultConfig = (),
         configSection = "oa-purescript-simple",
-        doInitialize = \env _req -> pure $ Right env,
-        staticHandlers = \_caps -> handlers,
+        doInitialize = \env _req -> do
+          logT "Init OA purs lsp server"
+          pure $ Right env,
+        staticHandlers = \_caps -> do handlers,
         interpretHandler = \env ->
           Server.Iso
             ( runLogger (confLogLevel (ideConfiguration ideEnv))
@@ -82,4 +192,13 @@ main ideEnv =
             )
             liftIO,
         options = Server.defaultOptions
-      }
\ No newline at end of file
+      }
+
+log_ :: (MonadIO m, Show a) => a -> m ()
+log_ = logToFile "log.txt" . show
+
+logT :: (MonadIO m) => Text -> m ()
+logT = logToFile "log.txt"
+
+logToFile :: (MonadIO m) => FilePath -> Text -> m ()
+logToFile path txt = liftIO $ appendFile path $ txt <> "\n"
\ No newline at end of file

From daed3ec286c462527e789b6a8d286ebfec0bc909 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 00:50:15 +0200
Subject: [PATCH 021/297] fix diagnotics spans

---
 src/Language/PureScript/LspSimple.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 6bbd8e74c9..37bb16dca5 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -143,8 +143,8 @@ getResultDiagnostics uri res = case res of
           let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
                 NEL.head spans
            in ( Just name,
-                Types.Position (fromIntegral startLine) (fromIntegral startCol),
-                Types.Position (fromIntegral endLine) (fromIntegral endCol)
+                Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
+                Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
               )
 
         hintToRelated :: Errors.ErrorMessageHint -> Types.DiagnosticRelatedInformation

From 6a489aaec8d20702873f4eb8a461af63a238e492 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 01:11:07 +0200
Subject: [PATCH 022/297] remove duplicate hints

---
 src/Language/PureScript/Errors.hs    | 10 ++++++++++
 src/Language/PureScript/LspSimple.hs | 30 +++++-----------------------
 2 files changed, 15 insertions(+), 25 deletions(-)

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 6a15c3690c..96b5061c7e 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -625,6 +625,16 @@ defaultPPEOptions = PPEOptions
   , ppeRelativeDirectory = mempty
   , ppeFileContents      = []
   }
+  
+noColorPPEOptions :: PPEOptions
+noColorPPEOptions = PPEOptions
+  { ppeCodeColor         = Nothing
+  , ppeFull              = False
+  , ppeLevel             = Error
+  , ppeShowDocs          = True
+  , ppeRelativeDirectory = mempty
+  , ppeFileContents      = []
+  }
 
 -- | Pretty print a single error, simplifying if necessary
 prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 37bb16dca5..f00a14f2ee 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -20,7 +20,7 @@ import Language.LSP.Protocol.Types (Uri, toNormalizedUri)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig, publishDiagnostics)
 import Language.LSP.Server qualified as Server
-import Language.PureScript.Errors (ErrorMessage (ErrorMessage), ErrorMessageHint, MultipleErrors (runMultipleErrors), defaultPPEOptions, errorCode, errorDocUri, errorSpan, prettyPrintSingleError)
+import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, prettyPrintSingleError, noColorPPEOptions)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
@@ -57,20 +57,14 @@ handlers =
         sendInfoMsg $ "Config changed: " <> show cfg,
       Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
         sendInfoMsg "SMethod_SetTrace",
-      --  Message.serverMethodJSON Message.SMethod_TextDocumentPublishDiagnostics _,
-      --  Message.regHelper Message.SMethod_TextDocumentPublishDiagnostics _,
-      --  $ \msg -> do
-      --   sendInfoMsg "SMethod_TextDocumentPublishDiagnostics",
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \msg res -> do
         sendInfoMsg "SMethod_TextDocumentDiagnostic"
-        diags <- getFileDiagnotics msg
+        diagnotics <- getFileDiagnotics msg
         res $
           Right $
             Types.DocumentDiagnosticReport $
               Types.InL $
-                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diags Nothing
-                --  $ \msg -> do
-                --   sendInfoMsg "SMethod_TextDocumentDiagnostic"
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnotics Nothing
     ]
 
 rebuildFileFromMsg :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri) => s -> HandlerM config ()
@@ -129,9 +123,9 @@ getResultDiagnostics uri res = case res of
         (Just $ Types.InR $ errorCode msg)
         (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
         (T.pack <$> spanName)
-        (T.pack $ render $ prettyPrintSingleError defaultPPEOptions msg)
+        (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
+        Nothing
         Nothing
-        (Just $ hintToRelated <$> hints)
         Nothing
       where
         notFound = Types.Position 0 0
@@ -147,20 +141,6 @@ getResultDiagnostics uri res = case res of
                 Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
               )
 
-        hintToRelated :: Errors.ErrorMessageHint -> Types.DiagnosticRelatedInformation
-        hintToRelated hint =
-          Types.DiagnosticRelatedInformation
-            (Types.Location uri (Types.Range hintStart hintEnd))
-            (show hint)
-          where
-            (_, hintStart, hintEnd) = fromMaybe (Nothing, start, end) $ getPositionsMb $ getHintSpans hint
-
-getHintSpans :: ErrorMessageHint -> Maybe (NEL.NonEmpty Errors.SourceSpan)
-getHintSpans hint = case hint of
-  Errors.PositionedError span -> Just span
-  Errors.RelatedPositions span -> Just span
-  _ -> Nothing
-
 sendError :: IdeError -> HandlerM config ()
 sendError err =
   Server.sendNotification

From 03efe2f2645cddaa3730888a6909b87899fba3ee Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 01:45:41 +0200
Subject: [PATCH 023/297] loading all modules

---
 src/Language/PureScript/Ide.hs       |  1 +
 src/Language/PureScript/LspSimple.hs | 31 +++++++++++++++-------------
 2 files changed, 18 insertions(+), 14 deletions(-)

diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index c374a47b58..76b558755d 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -17,6 +17,7 @@
 module Language.PureScript.Ide
        ( handleCommand
        , loadModulesAsync
+       , findAvailableExterns
        ) where
 
 import Protolude hiding (moduleName)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index f00a14f2ee..0146519341 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -20,8 +20,9 @@ import Language.LSP.Protocol.Types (Uri, toNormalizedUri)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig, publishDiagnostics)
 import Language.LSP.Server qualified as Server
-import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, prettyPrintSingleError, noColorPPEOptions)
+import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Ide (findAvailableExterns, loadModulesAsync)
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
 import Language.PureScript.Ide.Types (IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
@@ -41,6 +42,7 @@ handlers :: Server.Handlers (HandlerM ())
 handlers =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
+        void $ runIde $ findAvailableExterns >>= loadModulesAsync
         log_ ("OA purs lsp server initialized" :: T.Text)
         sendInfoMsg "OA purs lsp server initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
@@ -69,34 +71,35 @@ handlers =
 
 rebuildFileFromMsg :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri) => s -> HandlerM config ()
 rebuildFileFromMsg msg = do
-  let doc :: Uri
-      doc = getDocument msg
-      fileName = Types.uriToFilePath doc
+  let uri :: Uri
+      uri = getMsgUri msg
+      fileName = Types.uriToFilePath uri
   case fileName of
     Just file -> do
       res <- runIde $ rebuildFile file
-      sendDiagnostics doc res
+      sendDiagnostics uri res
     Nothing ->
-      sendInfoMsg $ "No file path for uri: " <> show doc
+      sendInfoMsg $ "No file path for uri: " <> show uri
 
 getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config [Types.Diagnostic]
 getFileDiagnotics msg = do
-  let doc :: Uri
-      doc = getDocument msg
-      fileName = Types.uriToFilePath doc
+  let uri :: Uri
+      uri = getMsgUri msg
+      fileName = Types.uriToFilePath uri
   case fileName of
     Just file -> do
       res <- runIde $ rebuildFile file
-      getResultDiagnostics doc res
+      getResultDiagnostics uri res
     Nothing -> do
-      sendInfoMsg $ "No file path for uri: " <> show doc
+      sendInfoMsg $ "No file path for uri: " <> show uri
       pure []
 
 rebuildFile :: FilePath -> IdeM Success
-rebuildFile file = rebuildFileAsync file Nothing mempty
+rebuildFile file = do
+  rebuildFileAsync file Nothing mempty
 
-getDocument :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
-getDocument msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
+getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
+getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
 
 sendDiagnostics :: Uri -> Either IdeError Success -> HandlerM config ()
 sendDiagnostics uri res = do

From 468450244c402bf816384152817018c051f06fca Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 01:51:01 +0200
Subject: [PATCH 024/297] labels warnings as warnings

---
 src/Language/PureScript/LspSimple.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 0146519341..194c6293fb 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -110,19 +110,19 @@ getResultDiagnostics :: Uri -> Either IdeError Success -> HandlerM config [Types
 getResultDiagnostics uri res = case res of
   Right success ->
     case success of
-      RebuildSuccess errs -> pure $ errorMessageDiagnostic <$> runMultipleErrors errs
+      RebuildSuccess errs -> pure $ errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> runMultipleErrors errs
       TextResult _ -> pure []
       _ -> pure []
-  Left (RebuildError _ errs) -> pure $ errorMessageDiagnostic <$> runMultipleErrors errs
+  Left (RebuildError _ errs) -> pure $ errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> runMultipleErrors errs
   Left err -> do
     sendError err
     pure []
   where
-    errorMessageDiagnostic :: ErrorMessage -> Types.Diagnostic
-    errorMessageDiagnostic msg@((ErrorMessage hints _)) =
+    errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
+    errorMessageDiagnostic severity msg@((ErrorMessage hints _)) =
       Types.Diagnostic
         (Types.Range start end)
-        (Just Types.DiagnosticSeverity_Error)
+        (Just severity)
         (Just $ Types.InR $ errorCode msg)
         (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
         (T.pack <$> spanName)

From fbd65c03fe3524a1afb2c9bb8650b3e58b170264 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 14:26:18 +0200
Subject: [PATCH 025/297] adds Serialise to ErrorMessage

---
 src/Language/PureScript/AST/Binders.hs        |   3 +-
 src/Language/PureScript/AST/Declarations.hs   | 761 ++++++++----------
 src/Language/PureScript/AST/Literals.hs       |   3 +-
 src/Language/PureScript/Bundle.hs             | 475 +++++------
 src/Language/PureScript/CST/Errors.hs         |   8 +-
 src/Language/PureScript/CST/Layout.hs         |   3 +-
 src/Language/PureScript/CST/Types.hs          | 313 +++----
 src/Language/PureScript/Environment.hs        |   5 +-
 src/Language/PureScript/Errors.hs             |  10 +-
 src/Language/PureScript/LspSimple.hs          |  45 +-
 .../PureScript/TypeClassDictionaries.hs       |   2 +
 11 files changed, 830 insertions(+), 798 deletions(-)

diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 1f427755f0..236cfb468a 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -13,6 +13,7 @@ import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified)
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Types (SourceType)
+import Codec.Serialise (Serialise)
 
 -- |
 -- Data type for binders
@@ -64,7 +65,7 @@ data Binder
   -- A binder with a type annotation
   --
   | TypedBinder SourceType Binder
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index cf0c83a42d..7a2ab064b6 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -3,54 +3,50 @@
 
 -- |
 -- Data types for modules and declarations
---
 module Language.PureScript.AST.Declarations where
 
-import Prelude
-import Protolude.Exceptions (hush)
-
 import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
-import Data.Functor.Identity (Identity(..))
-
-import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON)
+import Data.Aeson.TH (Options (..), SumEncoding (..), defaultOptions, deriveJSON)
+import Data.Functor.Identity (Identity (..))
+import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 import Data.Text (Text)
-import Data.List.NonEmpty qualified as NEL
 import GHC.Generics (Generic)
-
 import Language.PureScript.AST.Binders (Binder)
-import Language.PureScript.AST.Literals (Literal(..))
+import Language.PureScript.AST.Declarations.ChainId (ChainId)
+import Language.PureScript.AST.Literals (Literal (..))
 import Language.PureScript.AST.Operators (Fixity)
 import Language.PureScript.AST.SourcePos (SourceAnn, SourceSpan)
-import Language.PureScript.AST.Declarations.ChainId (ChainId)
-import Language.PureScript.Types (SourceConstraint, SourceType)
-import Language.PureScript.PSString (PSString)
+import Language.PureScript.Comments (Comment)
+import Language.PureScript.Constants.Prim qualified as C
+import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
 import Language.PureScript.Label (Label)
-import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), toMaybeModuleName)
+import Language.PureScript.Names (Ident (..), ModuleName (..), Name (..), OpName, OpNameType (..), ProperName, ProperNameType (..), Qualified (..), QualifiedBy (..), toMaybeModuleName, pattern ByNullSourcePos)
+import Language.PureScript.PSString (PSString)
 import Language.PureScript.Roles (Role)
 import Language.PureScript.TypeClassDictionaries (NamedDict)
-import Language.PureScript.Comments (Comment)
-import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
-import Language.PureScript.Constants.Prim qualified as C
+import Language.PureScript.Types (SourceConstraint, SourceType)
+import Protolude.Exceptions (hush)
+import Prelude
 
 -- | A map of locally-bound names in scope.
 type Context = [(Ident, SourceType)]
 
 -- | Holds the data necessary to do type directed search for typed holes
 data TypeSearch
-  = TSBefore Environment
-  -- ^ An Environment captured for later consumption by type directed search
-  | TSAfter
-  -- ^ Results of applying type directed search to the previously captured
-  -- Environment
-    { tsAfterIdentifiers :: [(Qualified Text, SourceType)]
-    -- ^ The identifiers that fully satisfy the subsumption check
-    , tsAfterRecordFields :: Maybe [(Label, SourceType)]
-    -- ^ Record fields that are available on the first argument to the typed
-    -- hole
-    }
-  deriving (Show, Generic, NFData)
+  = -- | An Environment captured for later consumption by type directed search
+    TSBefore Environment
+  | -- | Results of applying type directed search to the previously captured
+    -- Environment
+    TSAfter
+      { -- | The identifiers that fully satisfy the subsumption check
+        tsAfterIdentifiers :: [(Qualified Text, SourceType)],
+        -- | Record fields that are available on the first argument to the typed
+        -- hole
+        tsAfterRecordFields :: Maybe [(Label, SourceType)]
+      }
+  deriving (Show, Generic, Serialise, NFData)
 
 onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch
 onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
@@ -90,7 +86,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- | Categories of hints
 data HintCategory
@@ -112,13 +108,12 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
 -- a list of declarations, and a list of the declarations that are
 -- explicitly exported. If the export list is Nothing, everything is exported.
---
 data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
   deriving (Show)
 
@@ -139,71 +134,60 @@ getModuleDeclarations (Module _ _ _ declarations _) = declarations
 --
 -- Will not import an unqualified module if that module has already been imported qualified.
 -- (See #2197)
---
 addDefaultImport :: Qualified ModuleName -> Module -> Module
 addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) =
-  if isExistingImport `any` decls || mn == toImport then m
-  else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs' : decls) exps
+  if isExistingImport `any` decls || mn == toImport
+    then m
+    else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs' : decls) exps
   where
-  toImportAs' = toMaybeModuleName toImportAs
+    toImportAs' = toMaybeModuleName toImportAs
 
-  isExistingImport (ImportDeclaration _ mn' _ as')
-    | mn' == toImport =
-        case toImportAs' of
-          Nothing -> True
-          _ -> as' == toImportAs'
-  isExistingImport _ = False
+    isExistingImport (ImportDeclaration _ mn' _ as')
+      | mn' == toImport =
+          case toImportAs' of
+            Nothing -> True
+            _ -> as' == toImportAs'
+    isExistingImport _ = False
 
 -- | Adds import declarations to a module for an implicit Prim import and Prim
 -- | qualified as Prim, as necessary.
 importPrim :: Module -> Module
 importPrim =
-  let
-    primModName = C.M_Prim
-  in
-    addDefaultImport (Qualified (ByModuleName primModName) primModName)
-      . addDefaultImport (Qualified ByNullSourcePos primModName)
+  let primModName = C.M_Prim
+   in addDefaultImport (Qualified (ByModuleName primModName) primModName)
+        . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
   deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- An item in a list of explicit imports or exports
---
 data DeclarationRef
-  -- |
-  -- A type class
-  --
-  = TypeClassRef SourceSpan (ProperName 'ClassName)
-  -- |
-  -- A type operator
-  --
-  | TypeOpRef SourceSpan (OpName 'TypeOpName)
-  -- |
-  -- A type constructor with data constructors
-  --
-  | TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
-  -- |
-  -- A value
-  --
-  | ValueRef SourceSpan Ident
-  -- |
-  -- A value-level operator
-  --
-  | ValueOpRef SourceSpan (OpName 'ValueOpName)
-  -- |
-  -- A type class instance, created during typeclass desugaring
-  --
-  | TypeInstanceRef SourceSpan Ident NameSource
-  -- |
-  -- A module, in its entirety
-  --
-  | ModuleRef SourceSpan ModuleName
-  -- |
-  -- A value re-exported from another module. These will be inserted during
-  -- elaboration in name desugaring.
-  --
-  | ReExportRef SourceSpan ExportSource DeclarationRef
+  = -- |
+    -- A type class
+    TypeClassRef SourceSpan (ProperName 'ClassName)
+  | -- |
+    -- A type operator
+    TypeOpRef SourceSpan (OpName 'TypeOpName)
+  | -- |
+    -- A type constructor with data constructors
+    TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
+  | -- |
+    -- A value
+    ValueRef SourceSpan Ident
+  | -- |
+    -- A value-level operator
+    ValueOpRef SourceSpan (OpName 'ValueOpName)
+  | -- |
+    -- A type class instance, created during typeclass desugaring
+    TypeInstanceRef SourceSpan Ident NameSource
+  | -- |
+    -- A module, in its entirety
+    ModuleRef SourceSpan ModuleName
+  | -- |
+    -- A value re-exported from another module. These will be inserted during
+    -- elaboration in name desugaring.
+    ReExportRef SourceSpan ExportSource DeclarationRef
   deriving (Show, Generic, NFData, Serialise)
 
 instance Eq DeclarationRef where
@@ -228,21 +212,20 @@ instance Ord DeclarationRef where
   ReExportRef _ mn ref `compare` ReExportRef _ mn' ref' = compare mn mn' <> compare ref ref'
   compare ref ref' =
     compare (orderOf ref) (orderOf ref')
-      where
-        orderOf :: DeclarationRef -> Int
-        orderOf TypeClassRef{} = 0
-        orderOf TypeOpRef{} = 1
-        orderOf TypeRef{} = 2
-        orderOf ValueRef{} = 3
-        orderOf ValueOpRef{} = 4
-        orderOf TypeInstanceRef{} = 5
-        orderOf ModuleRef{} = 6
-        orderOf ReExportRef{} = 7
-
-data ExportSource =
-  ExportSource
-  { exportSourceImportedFrom :: Maybe ModuleName
-  , exportSourceDefinedIn :: ModuleName
+    where
+      orderOf :: DeclarationRef -> Int
+      orderOf TypeClassRef {} = 0
+      orderOf TypeOpRef {} = 1
+      orderOf TypeRef {} = 2
+      orderOf ValueRef {} = 3
+      orderOf ValueOpRef {} = 4
+      orderOf TypeInstanceRef {} = 5
+      orderOf ModuleRef {} = 6
+      orderOf ReExportRef {} = 7
+
+data ExportSource = ExportSource
+  { exportSourceImportedFrom :: Maybe ModuleName,
+    exportSourceDefinedIn :: ModuleName
   }
   deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
@@ -287,25 +270,21 @@ getTypeClassRef (TypeClassRef _ name) = Just name
 getTypeClassRef _ = Nothing
 
 isModuleRef :: DeclarationRef -> Bool
-isModuleRef ModuleRef{} = True
+isModuleRef ModuleRef {} = True
 isModuleRef _ = False
 
 -- |
 -- The data type which specifies type of import declaration
---
 data ImportDeclarationType
-  -- |
-  -- An import with no explicit list: `import M`.
-  --
-  = Implicit
-  -- |
-  -- An import with an explicit list of references to import: `import M (foo)`
-  --
-  | Explicit [DeclarationRef]
-  -- |
-  -- An import with a list of references to hide: `import M hiding (foo)`
-  --
-  | Hiding [DeclarationRef]
+  = -- |
+    -- An import with no explicit list: `import M`.
+    Implicit
+  | -- |
+    -- An import with an explicit list of references to import: `import M (foo)`
+    Explicit [DeclarationRef]
+  | -- |
+    -- An import with a list of references to hide: `import M hiding (foo)`
+    Hiding [DeclarationRef]
   deriving (Eq, Show, Generic, Serialise, NFData)
 
 isExplicit :: ImportDeclarationType -> Bool
@@ -320,10 +299,11 @@ isExplicit _ = False
 -- In this example, @T@ is the identifier and @[representational, phantom]@ is
 -- the list of roles (@T@ presumably having two parameters).
 data RoleDeclarationData = RoleDeclarationData
-  { rdeclSourceAnn :: !SourceAnn
-  , rdeclIdent :: !(ProperName 'TypeName)
-  , rdeclRoles :: ![Role]
-  } deriving (Show, Eq, Generic, NFData)
+  { rdeclSourceAnn :: !SourceAnn,
+    rdeclIdent :: !(ProperName 'TypeName),
+    rdeclRoles :: ![Role]
+  }
+  deriving (Show, Eq, Generic, Serialise, NFData)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -331,10 +311,11 @@ data RoleDeclarationData = RoleDeclarationData
 --
 -- In this example @identity@ is the identifier and @forall a. a -> a@ the type.
 data TypeDeclarationData = TypeDeclarationData
-  { tydeclSourceAnn :: !SourceAnn
-  , tydeclIdent :: !Ident
-  , tydeclType :: !SourceType
-  } deriving (Show, Eq, Generic, NFData)
+  { tydeclSourceAnn :: !SourceAnn,
+    tydeclIdent :: !Ident,
+    tydeclType :: !SourceType
+  }
+  deriving (Show, Eq, Generic, Serialise, NFData)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -349,109 +330,97 @@ unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td)
 --
 -- In this example @double@ is the identifier, @x@ is a binder and @x + x@ is the expression.
 data ValueDeclarationData a = ValueDeclarationData
-  { valdeclSourceAnn :: !SourceAnn
-  , valdeclIdent :: !Ident
-  -- ^ The declared value's name
-  , valdeclName :: !NameKind
-  -- ^ Whether or not this value is exported/visible
-  , valdeclBinders :: ![Binder]
-  , valdeclExpression :: !a
-  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable)
+  { valdeclSourceAnn :: !SourceAnn,
+    -- | The declared value's name
+    valdeclIdent :: !Ident,
+    -- | Whether or not this value is exported/visible
+    valdeclName :: !NameKind,
+    valdeclBinders :: ![Binder],
+    valdeclExpression :: !a
+  }
+  deriving (Show, Functor, Generic, Serialise, NFData, Foldable, Traversable)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
 getValueDeclaration _ = Nothing
 
 pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
-pattern ValueDecl sann ident name binders expr
-  = ValueDeclaration (ValueDeclarationData sann ident name binders expr)
+pattern ValueDecl sann ident name binders expr =
+  ValueDeclaration (ValueDeclarationData sann ident name binders expr)
 
 data DataConstructorDeclaration = DataConstructorDeclaration
-  { dataCtorAnn :: !SourceAnn
-  , dataCtorName :: !(ProperName 'ConstructorName)
-  , dataCtorFields :: ![(Ident, SourceType)]
-  } deriving (Show, Eq, Generic, NFData)
+  { dataCtorAnn :: !SourceAnn,
+    dataCtorName :: !(ProperName 'ConstructorName),
+    dataCtorFields :: ![(Ident, SourceType)]
+  }
+  deriving (Show, Eq, Generic, Serialise, NFData)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
-mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. }
+mapDataCtorFields f DataConstructorDeclaration {..} = DataConstructorDeclaration {dataCtorFields = f dataCtorFields, ..}
 
-traverseDataCtorFields :: Monad m => ([(Ident, SourceType)] -> m [(Ident, SourceType)]) -> DataConstructorDeclaration -> m DataConstructorDeclaration
-traverseDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration dataCtorAnn dataCtorName <$> f dataCtorFields
+traverseDataCtorFields :: (Monad m) => ([(Ident, SourceType)] -> m [(Ident, SourceType)]) -> DataConstructorDeclaration -> m DataConstructorDeclaration
+traverseDataCtorFields f DataConstructorDeclaration {..} = DataConstructorDeclaration dataCtorAnn dataCtorName <$> f dataCtorFields
 
 -- |
 -- The data type of declarations
---
 data Declaration
-  -- |
-  -- A data type declaration (data or newtype, name, arguments, data constructors)
-  --
-  = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceType)] [DataConstructorDeclaration]
-  -- |
-  -- A minimal mutually recursive set of data type declarations
-  --
-  | DataBindingGroupDeclaration (NEL.NonEmpty Declaration)
-  -- |
-  -- A type synonym declaration (name, arguments, type)
-  --
-  | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceType)] SourceType
-  -- |
-  -- A kind signature declaration
-  --
-  | KindDeclaration SourceAnn KindSignatureFor (ProperName 'TypeName) SourceType
-  -- |
-  -- A role declaration (name, roles)
-  --
-  | RoleDeclaration {-# UNPACK #-} !RoleDeclarationData
-  -- |
-  -- A type declaration for a value (name, ty)
-  --
-  | TypeDeclaration {-# UNPACK #-} !TypeDeclarationData
-  -- |
-  -- A value declaration (name, top-level binders, optional guard, value)
-  --
-  | ValueDeclaration {-# UNPACK #-} !(ValueDeclarationData [GuardedExpr])
-  -- |
-  -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value)
-  | BoundValueDeclaration SourceAnn Binder Expr
-  -- |
-  -- A minimal mutually recursive set of value declarations
-  --
-  | BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr))
-  -- |
-  -- A foreign import declaration (name, type)
-  --
-  | ExternDeclaration SourceAnn Ident SourceType
-  -- |
-  -- A data type foreign import (name, kind)
-  --
-  | ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceType
-  -- |
-  -- A fixity declaration
-  --
-  | FixityDeclaration SourceAnn (Either ValueFixity TypeFixity)
-  -- |
-  -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
-  --
-  | ImportDeclaration SourceAnn ModuleName ImportDeclarationType (Maybe ModuleName)
-  -- |
-  -- A type class declaration (name, argument, implies, member declarations)
-  --
-  | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceType)] [SourceConstraint] [FunctionalDependency] [Declaration]
-  -- |
-  -- A type instance declaration (instance chain, chain index, name,
-  -- dependencies, class name, instance types, member declarations)
-  --
-  -- The first @SourceAnn@ serves as the annotation for the entire
-  -- declaration, while the second @SourceAnn@ serves as the
-  -- annotation for the type class and its arguments.
-  | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
-  deriving (Show, Generic, NFData)
+  = -- |
+    -- A data type declaration (data or newtype, name, arguments, data constructors)
+    DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceType)] [DataConstructorDeclaration]
+  | -- |
+    -- A minimal mutually recursive set of data type declarations
+    DataBindingGroupDeclaration (NEL.NonEmpty Declaration)
+  | -- |
+    -- A type synonym declaration (name, arguments, type)
+    TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceType)] SourceType
+  | -- |
+    -- A kind signature declaration
+    KindDeclaration SourceAnn KindSignatureFor (ProperName 'TypeName) SourceType
+  | -- |
+    -- A role declaration (name, roles)
+    RoleDeclaration {-# UNPACK #-} !RoleDeclarationData
+  | -- |
+    -- A type declaration for a value (name, ty)
+    TypeDeclaration {-# UNPACK #-} !TypeDeclarationData
+  | -- |
+    -- A value declaration (name, top-level binders, optional guard, value)
+    ValueDeclaration {-# UNPACK #-} !(ValueDeclarationData [GuardedExpr])
+  | -- |
+    -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value)
+    BoundValueDeclaration SourceAnn Binder Expr
+  | -- |
+    -- A minimal mutually recursive set of value declarations
+    BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr))
+  | -- |
+    -- A foreign import declaration (name, type)
+    ExternDeclaration SourceAnn Ident SourceType
+  | -- |
+    -- A data type foreign import (name, kind)
+    ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceType
+  | -- |
+    -- A fixity declaration
+    FixityDeclaration SourceAnn (Either ValueFixity TypeFixity)
+  | -- |
+    -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
+    ImportDeclaration SourceAnn ModuleName ImportDeclarationType (Maybe ModuleName)
+  | -- |
+    -- A type class declaration (name, argument, implies, member declarations)
+    TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceType)] [SourceConstraint] [FunctionalDependency] [Declaration]
+  | -- |
+    -- A type instance declaration (instance chain, chain index, name,
+    -- dependencies, class name, instance types, member declarations)
+    --
+    -- The first @SourceAnn@ serves as the annotation for the entire
+    -- declaration, while the second @SourceAnn@ serves as the
+    -- annotation for the type class and its arguments.
+    TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
+  deriving (Show, Generic, Serialise, NFData)
 
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
 pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))
@@ -462,17 +431,17 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
-  = DerivedInstance
-  -- ^ This is a derived instance
-  | NewtypeInstance
-  -- ^ This is an instance derived from a newtype
-  | ExplicitInstance [Declaration]
-  -- ^ This is a regular (explicit) instance
-  deriving (Show, Generic, NFData)
+  = -- | This is a derived instance
+    DerivedInstance
+  | -- | This is an instance derived from a newtype
+    NewtypeInstance
+  | -- | This is a regular (explicit) instance
+    ExplicitInstance [Declaration]
+  deriving (Show, Generic, Serialise, NFData)
 
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -488,7 +457,7 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -523,61 +492,54 @@ declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n)
 declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n)
 declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n)
 declName (TypeInstanceDeclaration _ _ _ _ n _ _ _ _) = IdentName <$> hush n
-declName (RoleDeclaration RoleDeclarationData{..}) = Just (TyName rdeclIdent)
-declName ImportDeclaration{} = Nothing
-declName BindingGroupDeclaration{} = Nothing
-declName DataBindingGroupDeclaration{} = Nothing
-declName BoundValueDeclaration{} = Nothing
-declName KindDeclaration{} = Nothing
-declName TypeDeclaration{} = Nothing
+declName (RoleDeclaration RoleDeclarationData {..}) = Just (TyName rdeclIdent)
+declName ImportDeclaration {} = Nothing
+declName BindingGroupDeclaration {} = Nothing
+declName DataBindingGroupDeclaration {} = Nothing
+declName BoundValueDeclaration {} = Nothing
+declName KindDeclaration {} = Nothing
+declName TypeDeclaration {} = Nothing
 
 -- |
 -- Test if a declaration is a value declaration
---
 isValueDecl :: Declaration -> Bool
-isValueDecl ValueDeclaration{} = True
+isValueDecl ValueDeclaration {} = True
 isValueDecl _ = False
 
 -- |
 -- Test if a declaration is a data type declaration
---
 isDataDecl :: Declaration -> Bool
-isDataDecl DataDeclaration{} = True
+isDataDecl DataDeclaration {} = True
 isDataDecl _ = False
 
 -- |
 -- Test if a declaration is a type synonym declaration
---
 isTypeSynonymDecl :: Declaration -> Bool
-isTypeSynonymDecl TypeSynonymDeclaration{} = True
+isTypeSynonymDecl TypeSynonymDeclaration {} = True
 isTypeSynonymDecl _ = False
 
 -- |
 -- Test if a declaration is a module import
---
 isImportDecl :: Declaration -> Bool
-isImportDecl ImportDeclaration{} = True
+isImportDecl ImportDeclaration {} = True
 isImportDecl _ = False
 
 -- |
 -- Test if a declaration is a role declaration
---
 isRoleDecl :: Declaration -> Bool
-isRoleDecl RoleDeclaration{} = True
+isRoleDecl RoleDeclaration {} = True
 isRoleDecl _ = False
 
 -- |
 -- Test if a declaration is a data type foreign import
---
 isExternDataDecl :: Declaration -> Bool
-isExternDataDecl ExternDataDeclaration{} = True
+isExternDataDecl ExternDataDeclaration {} = True
 isExternDataDecl _ = False
 
 -- |
 -- Test if a declaration is a fixity declaration
---
 isFixityDecl :: Declaration -> Bool
-isFixityDecl FixityDeclaration{} = True
+isFixityDecl FixityDeclaration {} = True
 isFixityDecl _ = False
 
 getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity)
@@ -586,234 +548,195 @@ getFixityDecl _ = Nothing
 
 -- |
 -- Test if a declaration is a foreign import
---
 isExternDecl :: Declaration -> Bool
-isExternDecl ExternDeclaration{} = True
+isExternDecl ExternDeclaration {} = True
 isExternDecl _ = False
 
 -- |
 -- Test if a declaration is a type class instance declaration
---
 isTypeClassInstanceDecl :: Declaration -> Bool
-isTypeClassInstanceDecl TypeInstanceDeclaration{} = True
+isTypeClassInstanceDecl TypeInstanceDeclaration {} = True
 isTypeClassInstanceDecl _ = False
 
 -- |
 -- Test if a declaration is a type class declaration
---
 isTypeClassDecl :: Declaration -> Bool
-isTypeClassDecl TypeClassDeclaration{} = True
+isTypeClassDecl TypeClassDeclaration {} = True
 isTypeClassDecl _ = False
 
 -- |
 -- Test if a declaration is a kind signature declaration.
---
 isKindDecl :: Declaration -> Bool
-isKindDecl KindDeclaration{} = True
+isKindDecl KindDeclaration {} = True
 isKindDecl _ = False
 
 -- |
 -- Recursively flatten data binding groups in the list of declarations
 flattenDecls :: [Declaration] -> [Declaration]
 flattenDecls = concatMap flattenOne
-    where flattenOne :: Declaration -> [Declaration]
-          flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
-          flattenOne d = [d]
+  where
+    flattenOne :: Declaration -> [Declaration]
+    flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
+    flattenOne d = [d]
 
 -- |
 -- A guard is just a boolean-valued expression that appears alongside a set of binders
---
-data Guard = ConditionGuard Expr
-           | PatternGuard Binder Expr
-           deriving (Show, Generic, NFData)
+data Guard
+  = ConditionGuard Expr
+  | PatternGuard Binder Expr
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-                 deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
 
 -- |
 -- Data type for expressions and terms
---
 data Expr
-  -- |
-  -- A literal value
-  --
-  = Literal SourceSpan (Literal Expr)
-  -- |
-  -- A prefix -, will be desugared
-  --
-  | UnaryMinus SourceSpan Expr
-  -- |
-  -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
-  -- will be removed.
-  --
-  | BinaryNoParens Expr Expr Expr
-  -- |
-  -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
-  -- will be removed.
-  --
-  -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents
-  -- certain traversals from matching.
-  --
-  | Parens Expr
-  -- |
-  -- An record property accessor expression (e.g. `obj.x` or `_.x`).
-  -- Anonymous arguments will be removed during desugaring and expanded
-  -- into a lambda that reads a property from a record.
-  --
-  | Accessor PSString Expr
-  -- |
-  -- Partial record update
-  --
-  | ObjectUpdate Expr [(PSString, Expr)]
-  -- |
-  -- Object updates with nested support: `x { foo { bar = e } }`
-  -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s
-  --
-  | ObjectUpdateNested Expr (PathTree Expr)
-  -- |
-  -- Function introduction
-  --
-  | Abs Binder Expr
-  -- |
-  -- Function application
-  --
-  | App Expr Expr
-  -- |
-  -- A type application (e.g. `f @Int`)
-  --
-  | VisibleTypeApp Expr SourceType
-  -- |
-  -- Hint that an expression is unused.
-  -- This is used to ignore type class dictionaries that are necessarily empty.
-  -- The inner expression lets us solve subgoals before eliminating the whole expression.
-  -- The code gen will render this as `undefined`, regardless of what the inner expression is.
-  | Unused Expr
-  -- |
-  -- Variable
-  --
-  | Var SourceSpan (Qualified Ident)
-  -- |
-  -- An operator. This will be desugared into a function during the "operators"
-  -- phase of desugaring.
-  --
-  | Op SourceSpan (Qualified (OpName 'ValueOpName))
-  -- |
-  -- Conditional (if-then-else expression)
-  --
-  | IfThenElse Expr Expr Expr
-  -- |
-  -- A data constructor
-  --
-  | Constructor SourceSpan (Qualified (ProperName 'ConstructorName))
-  -- |
-  -- A case expression. During the case expansion phase of desugaring, top-level binders will get
-  -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
-  --
-  | Case [Expr] [CaseAlternative]
-  -- |
-  -- A value with a type annotation
-  --
-  | TypedValue Bool Expr SourceType
-  -- |
-  -- A let binding
-  --
-  | Let WhereProvenance [Declaration] Expr
-  -- |
-  -- A do-notation block
-  --
-  | Do (Maybe ModuleName) [DoNotationElement]
-  -- |
-  -- An ado-notation block
-  --
-  | Ado (Maybe ModuleName) [DoNotationElement] Expr
-  -- |
-  -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
-  -- placeholders will be replaced with actual expressions representing type classes dictionaries which
-  -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
-  -- at superclass implementations when searching for a dictionary, the type class name and
-  -- instance type, and the type class dictionaries in scope.
-  --
-  | TypeClassDictionary SourceConstraint
-                        (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-                        [ErrorMessageHint]
-  -- |
-  -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
-  --
-  | DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType]
-  -- |
-  -- A placeholder for a type class instance to be derived during typechecking
-  --
-  | DerivedInstancePlaceholder (Qualified (ProperName 'ClassName)) InstanceDerivationStrategy
-  -- |
-  -- A placeholder for an anonymous function argument
-  --
-  | AnonymousArgument
-  -- |
-  -- A typed hole that will be turned into a hint/error during typechecking
-  --
-  | Hole Text
-  -- |
-  -- A value with source position information
-  --
-  | PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, NFData)
+  = -- |
+    -- A literal value
+    Literal SourceSpan (Literal Expr)
+  | -- |
+    -- A prefix -, will be desugared
+    UnaryMinus SourceSpan Expr
+  | -- |
+    -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
+    -- will be removed.
+    BinaryNoParens Expr Expr Expr
+  | -- |
+    -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
+    -- will be removed.
+    --
+    -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents
+    -- certain traversals from matching.
+    Parens Expr
+  | -- |
+    -- An record property accessor expression (e.g. `obj.x` or `_.x`).
+    -- Anonymous arguments will be removed during desugaring and expanded
+    -- into a lambda that reads a property from a record.
+    Accessor PSString Expr
+  | -- |
+    -- Partial record update
+    ObjectUpdate Expr [(PSString, Expr)]
+  | -- |
+    -- Object updates with nested support: `x { foo { bar = e } }`
+    -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s
+    ObjectUpdateNested Expr (PathTree Expr)
+  | -- |
+    -- Function introduction
+    Abs Binder Expr
+  | -- |
+    -- Function application
+    App Expr Expr
+  | -- |
+    -- A type application (e.g. `f @Int`)
+    VisibleTypeApp Expr SourceType
+  | -- |
+    -- Hint that an expression is unused.
+    -- This is used to ignore type class dictionaries that are necessarily empty.
+    -- The inner expression lets us solve subgoals before eliminating the whole expression.
+    -- The code gen will render this as `undefined`, regardless of what the inner expression is.
+    Unused Expr
+  | -- |
+    -- Variable
+    Var SourceSpan (Qualified Ident)
+  | -- |
+    -- An operator. This will be desugared into a function during the "operators"
+    -- phase of desugaring.
+    Op SourceSpan (Qualified (OpName 'ValueOpName))
+  | -- |
+    -- Conditional (if-then-else expression)
+    IfThenElse Expr Expr Expr
+  | -- |
+    -- A data constructor
+    Constructor SourceSpan (Qualified (ProperName 'ConstructorName))
+  | -- |
+    -- A case expression. During the case expansion phase of desugaring, top-level binders will get
+    -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
+    Case [Expr] [CaseAlternative]
+  | -- |
+    -- A value with a type annotation
+    TypedValue Bool Expr SourceType
+  | -- |
+    -- A let binding
+    Let WhereProvenance [Declaration] Expr
+  | -- |
+    -- A do-notation block
+    Do (Maybe ModuleName) [DoNotationElement]
+  | -- |
+    -- An ado-notation block
+    Ado (Maybe ModuleName) [DoNotationElement] Expr
+  | -- |
+    -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
+    -- placeholders will be replaced with actual expressions representing type classes dictionaries which
+    -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
+    -- at superclass implementations when searching for a dictionary, the type class name and
+    -- instance type, and the type class dictionaries in scope.
+    TypeClassDictionary
+      SourceConstraint
+      (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
+      [ErrorMessageHint]
+  | -- |
+    -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
+    DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType]
+  | -- |
+    -- A placeholder for a type class instance to be derived during typechecking
+    DerivedInstancePlaceholder (Qualified (ProperName 'ClassName)) InstanceDerivationStrategy
+  | -- |
+    -- A placeholder for an anonymous function argument
+    AnonymousArgument
+  | -- |
+    -- A typed hole that will be turned into a hint/error during typechecking
+    Hole Text
+  | -- |
+    -- A value with source position information
+    PositionedValue SourceSpan [Comment] Expr
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- Metadata that tells where a let binding originated
---
 data WhereProvenance
-  -- |
-  -- The let binding was originally a where clause
-  --
-  = FromWhere
-  -- |
-  -- The let binding was always a let binding
-  --
-  | FromLet
-  deriving (Show, Generic, NFData)
+  = -- |
+    -- The let binding was originally a where clause
+    FromWhere
+  | -- |
+    -- The let binding was always a let binding
+    FromLet
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- An alternative in a case statement
---
 data CaseAlternative = CaseAlternative
   { -- |
     -- A collection of binders with which to match the inputs
-    --
-    caseAlternativeBinders :: [Binder]
+    caseAlternativeBinders :: [Binder],
     -- |
     -- The result expression or a collect of guarded expressions
-    --
-  , caseAlternativeResult :: [GuardedExpr]
-  } deriving (Show, Generic, NFData)
+    caseAlternativeResult :: [GuardedExpr]
+  }
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- A statement in a do-notation block
---
 data DoNotationElement
-  -- |
-  -- A monadic value without a binder
-  --
-  = DoNotationValue Expr
-  -- |
-  -- A monadic value with a binder
-  --
-  | DoNotationBind Binder Expr
-  -- |
-  -- A let statement, i.e. a pure value with a binder
-  --
-  | DoNotationLet [Declaration]
-  -- |
-  -- A do notation element with source position information
-  --
-  | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
-  deriving (Show, Generic, NFData)
-
+  = -- |
+    -- A monadic value without a binder
+    DoNotationValue Expr
+  | -- |
+    -- A monadic value with a binder
+    DoNotationBind Binder Expr
+  | -- |
+    -- A let statement, i.e. a pure value with a binder
+    DoNotationLet [Declaration]
+  | -- |
+    -- A do notation element with source position information
+    PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
+  deriving (Show, Generic, Serialise, NFData)
 
 -- For a record update such as:
 --
@@ -839,20 +762,24 @@ data DoNotationElement
 --
 
 newtype PathTree t = PathTree (AssocList PSString (PathNode t))
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
-  deriving newtype NFData
+  deriving (Show, Eq, Ord, Functor, Foldable, Generic, Traversable)
+  deriving newtype (NFData)
+
+instance (Serialise t) => Serialise (PathTree t)
 
 data PathNode t = Leaf t | Branch (PathTree t)
-  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)
+  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise)
+
+newtype AssocList k t = AssocList {runAssocList :: [(k, t)]}
+  deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic)
+  deriving newtype (NFData)
 
-newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
-  deriving (Show, Eq, Ord, Foldable, Functor, Traversable)
-  deriving newtype NFData
+instance (Serialise t, Serialise k) => Serialise (AssocList k t)
 
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource)
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource)
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''NameSource)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ExportSource)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DeclarationRef)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ImportDeclarationType)
 
 isTrueExpr :: Expr -> Bool
 isTrueExpr (Literal _ (BooleanLiteral True)) = True
diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index 05e06ab8f9..c723fbd219 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -8,6 +8,7 @@ import Prelude
 import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 import Language.PureScript.PSString (PSString)
+import Codec.Serialise.Class qualified as S
 
 -- |
 -- Data type for literal values. Parameterised so it can be used for Exprs and
@@ -38,4 +39,4 @@ data Literal a
   -- An object literal
   --
   | ObjectLiteral [(PSString, a)]
-  deriving (Eq, Ord, Show, Functor, Generic, NFData)
+  deriving (Eq, Ord, Show, Functor, Generic, S.Serialise, NFData)
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index f40cc44e9f..a5705e2f96 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -1,39 +1,38 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
 -- |
 -- Bundles compiled PureScript modules for the browser.
 --
 -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
 -- performs dead code elimination, filters empty modules,
 -- and generates the final JavaScript bundle.
-{-# LANGUAGE DeriveAnyClass #-}
 module Language.PureScript.Bundle
-  ( ModuleIdentifier(..)
-  , ModuleType(..)
-  , ErrorMessage(..)
-  , printErrorMessage
-  , ForeignModuleExports(..)
-  , getExportedIdentifiers
-  , ForeignModuleImports(..)
-  , getImportedModules
-  , Module
-  ) where
-
-import Prelude
-
+  ( ModuleIdentifier (..),
+    ModuleType (..),
+    ErrorMessage (..),
+    printErrorMessage,
+    ForeignModuleExports (..),
+    getExportedIdentifiers,
+    ForeignModuleImports (..),
+    getImportedModules,
+    Module,
+  )
+where
+
+import Codec.Serialise qualified as S
 import Control.DeepSeq (NFData)
-import Control.Monad.Error.Class (MonadError(..))
-
+import Control.Monad.Error.Class (MonadError (..))
 import Data.Aeson ((.=))
+import Data.Aeson qualified as A
 import Data.Char (chr, digitToInt)
 import Data.Foldable (fold)
 import Data.Maybe (mapMaybe, maybeToList)
-import Data.Aeson qualified as A
 import Data.Text.Lazy qualified as LT
-
 import GHC.Generics (Generic)
-
-import Language.JavaScript.Parser (JSAST(..), JSAnnot(..), JSAssignOp(..), JSExpression(..), JSStatement(..), renderToText)
-import Language.JavaScript.Parser.AST (JSCommaList(..), JSCommaTrailingList(..), JSExportClause(..), JSExportDeclaration(..), JSExportSpecifier(..), JSFromClause(..), JSIdent(..), JSImportDeclaration(..), JSModuleItem(..), JSObjectProperty(..), JSObjectPropertyList, JSPropertyName(..), JSVarInitializer(..))
+import Language.JavaScript.Parser (JSAST (..), JSAnnot (..), JSAssignOp (..), JSExpression (..), JSStatement (..), renderToText)
+import Language.JavaScript.Parser.AST (JSCommaList (..), JSCommaTrailingList (..), JSExportClause (..), JSExportDeclaration (..), JSExportSpecifier (..), JSFromClause (..), JSIdent (..), JSImportDeclaration (..), JSModuleItem (..), JSObjectProperty (..), JSObjectPropertyList, JSPropertyName (..), JSVarInitializer (..))
 import Language.JavaScript.Process.Minify (minifyJS)
+import Prelude
 
 -- | The type of error messages. We separate generation and rendering of errors using a data
 -- type, in case we need to match on error types later.
@@ -46,14 +45,14 @@ data ErrorMessage
   | ErrorInModule ModuleIdentifier ErrorMessage
   | MissingEntryPoint String
   | MissingMainModule String
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, S.Serialise, NFData)
 
 -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
 -- foreign modules.
 data ModuleType
   = Regular
   | Foreign
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 showModuleType :: ModuleType -> String
 showModuleType Regular = "Regular"
@@ -61,13 +60,14 @@ showModuleType Foreign = "Foreign"
 
 -- | A module is identified by its module name and its type.
 data ModuleIdentifier = ModuleIdentifier String ModuleType
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 instance A.ToJSON ModuleIdentifier where
   toJSON (ModuleIdentifier name mt) =
-    A.object [ "name" .= name
-             , "type" .= show mt
-             ]
+    A.object
+      [ "name" .= name,
+        "type" .= show mt
+      ]
 
 data Visibility
   = Public
@@ -107,107 +107,115 @@ data ModuleElement
 instance A.ToJSON ModuleElement where
   toJSON = \case
     (Import _ name (Right target)) ->
-      A.object [ "type"   .= A.String "Import"
-               , "name"   .= name
-               , "target" .= target
-               ]
+      A.object
+        [ "type" .= A.String "Import",
+          "name" .= name,
+          "target" .= target
+        ]
     (Import _ name (Left targetPath)) ->
-      A.object [ "type"       .= A.String "Import"
-               , "name"       .= name
-               , "targetPath" .= targetPath
-               ]
+      A.object
+        [ "type" .= A.String "Import",
+          "name" .= name,
+          "targetPath" .= targetPath
+        ]
     (Member _ visibility name _ dependsOn) ->
-      A.object [ "type"       .= A.String "Member"
-               , "name"       .= name
-               , "visibility" .= show visibility
-               , "dependsOn"  .= map keyToJSON dependsOn
-               ]
+      A.object
+        [ "type" .= A.String "Member",
+          "name" .= name,
+          "visibility" .= show visibility,
+          "dependsOn" .= map keyToJSON dependsOn
+        ]
     (ExportsList exports) ->
-      A.object [ "type"    .= A.String "ExportsList"
-               , "exports" .= map exportToJSON exports
-               ]
+      A.object
+        [ "type" .= A.String "ExportsList",
+          "exports" .= map exportToJSON exports
+        ]
     (Other stmt) ->
-      A.object [ "type" .= A.String "Other"
-               , "js"   .= getFragment (JSAstStatement stmt JSNoAnnot)
-               ]
+      A.object
+        [ "type" .= A.String "Other",
+          "js" .= getFragment (JSAstStatement stmt JSNoAnnot)
+        ]
     (Skip item) ->
-      A.object [ "type" .= A.String "Skip"
-               , "js"   .= getFragment (JSAstModule [item] JSNoAnnot)
-               ]
-
+      A.object
+        [ "type" .= A.String "Skip",
+          "js" .= getFragment (JSAstModule [item] JSNoAnnot)
+        ]
     where
-
-    keyToJSON (mid, member, visibility) =
-      A.object [ "module"     .= mid
-               , "member"     .= member
-               , "visibility" .= show visibility
-               ]
-
-    exportToJSON (RegularExport sourceName, name, _, dependsOn) =
-      A.object [ "type"       .= A.String "RegularExport"
-               , "name"       .= name
-               , "sourceName" .= sourceName
-               , "dependsOn"  .= map keyToJSON dependsOn
-               ]
-    exportToJSON (ForeignReexport, name, _, dependsOn) =
-      A.object [ "type"      .= A.String "ForeignReexport"
-               , "name"      .= name
-               , "dependsOn" .= map keyToJSON dependsOn
-               ]
-
-    getFragment = ellipsize . renderToText . minifyJS
-      where
-      ellipsize text = if LT.compareLength text 20 == GT then LT.take 19 text `LT.snoc` ellipsis else text
-      ellipsis = '\x2026'
+      keyToJSON (mid, member, visibility) =
+        A.object
+          [ "module" .= mid,
+            "member" .= member,
+            "visibility" .= show visibility
+          ]
+
+      exportToJSON (RegularExport sourceName, name, _, dependsOn) =
+        A.object
+          [ "type" .= A.String "RegularExport",
+            "name" .= name,
+            "sourceName" .= sourceName,
+            "dependsOn" .= map keyToJSON dependsOn
+          ]
+      exportToJSON (ForeignReexport, name, _, dependsOn) =
+        A.object
+          [ "type" .= A.String "ForeignReexport",
+            "name" .= name,
+            "dependsOn" .= map keyToJSON dependsOn
+          ]
+
+      getFragment = ellipsize . renderToText . minifyJS
+        where
+          ellipsize text = if LT.compareLength text 20 == GT then LT.take 19 text `LT.snoc` ellipsis else text
+          ellipsis = '\x2026'
 
 -- | A module is just a list of elements of the types listed above.
 data Module = Module ModuleIdentifier (Maybe FilePath) [ModuleElement] deriving (Show)
 
 instance A.ToJSON Module where
   toJSON (Module moduleId filePath elements) =
-    A.object [ "moduleId" .= moduleId
-             , "filePath" .= filePath
-             , "elements" .= elements
-             ]
+    A.object
+      [ "moduleId" .= moduleId,
+        "filePath" .= filePath,
+        "elements" .= elements
+      ]
 
 -- | Prepare an error message for consumption by humans.
 printErrorMessage :: ErrorMessage -> [String]
 printErrorMessage (UnsupportedModulePath s) =
-  [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ")."
-  , "The following file names are supported:"
-  , "  1) index.js (PureScript native modules)"
-  , "  2) foreign.js (PureScript ES foreign modules)"
-  , "  3) foreign.cjs (PureScript CommonJS foreign modules)"
+  [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ").",
+    "The following file names are supported:",
+    "  1) index.js (PureScript native modules)",
+    "  2) foreign.js (PureScript ES foreign modules)",
+    "  3) foreign.cjs (PureScript CommonJS foreign modules)"
   ]
 printErrorMessage InvalidTopLevel =
-  [ "Expected a list of source elements at the top level." ]
+  ["Expected a list of source elements at the top level."]
 printErrorMessage (UnableToParseModule err) =
-  [ "The module could not be parsed:"
-  , err
+  [ "The module could not be parsed:",
+    err
   ]
 printErrorMessage UnsupportedImport =
-  [ "An import was unsupported."
-  , "Modules can be imported with ES namespace imports declarations:"
-  , "  import * as module from \"Module.Name\""
-  , "Alternatively, they can be also be imported with the CommonJS require function:"
-  , "  var module = require(\"Module.Name\")"
+  [ "An import was unsupported.",
+    "Modules can be imported with ES namespace imports declarations:",
+    "  import * as module from \"Module.Name\"",
+    "Alternatively, they can be also be imported with the CommonJS require function:",
+    "  var module = require(\"Module.Name\")"
   ]
 printErrorMessage UnsupportedExport =
-  [ "An export was unsupported."
-  , "Declarations can be exported as ES named exports:"
-  , "  export var decl"
-  , "Existing identifiers can be exported as well:"
-  , "  export { name }"
-  , "They can also be renamed on export:"
-  , "  export { name as alias }"
-  , "Alternatively, CommonJS exports can be defined in one of two ways:"
-  , "  1) exports.name = value"
-  , "  2) exports = { name: value }"
+  [ "An export was unsupported.",
+    "Declarations can be exported as ES named exports:",
+    "  export var decl",
+    "Existing identifiers can be exported as well:",
+    "  export { name }",
+    "They can also be renamed on export:",
+    "  export { name as alias }",
+    "Alternatively, CommonJS exports can be defined in one of two ways:",
+    "  1) exports.name = value",
+    "  2) exports = { name: value }"
   ]
 printErrorMessage (ErrorInModule mid e) =
   ("Error in module " ++ displayIdentifier mid ++ ":")
-  : ""
-  : map ("  " ++) (printErrorMessage e)
+    : ""
+    : map ("  " ++) (printErrorMessage e)
   where
     displayIdentifier (ModuleIdentifier name ty) =
       name ++ " (" ++ showModuleType ty ++ ")"
@@ -226,28 +234,28 @@ fromStringLiteral _ = Nothing
 strValue :: String -> String
 strValue str = go $ drop 1 str
   where
-  go ('\\' : 'b' : xs) = '\b' : go xs
-  go ('\\' : 'f' : xs) = '\f' : go xs
-  go ('\\' : 'n' : xs) = '\n' : go xs
-  go ('\\' : 'r' : xs) = '\r' : go xs
-  go ('\\' : 't' : xs) = '\t' : go xs
-  go ('\\' : 'v' : xs) = '\v' : go xs
-  go ('\\' : '0' : xs) = '\0' : go xs
-  go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs
-    where
-    a' = 16 * digitToInt a
-    b' = digitToInt b
-  go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs
-    where
-    a' = 16 * 16 * 16 * digitToInt a
-    b' = 16 * 16 * digitToInt b
-    c' = 16 * digitToInt c
-    d' = digitToInt d
-  go ('\\' : x : xs) = x : go xs
-  go "\"" = ""
-  go "'" = ""
-  go (x : xs) = x : go xs
-  go "" = ""
+    go ('\\' : 'b' : xs) = '\b' : go xs
+    go ('\\' : 'f' : xs) = '\f' : go xs
+    go ('\\' : 'n' : xs) = '\n' : go xs
+    go ('\\' : 'r' : xs) = '\r' : go xs
+    go ('\\' : 't' : xs) = '\t' : go xs
+    go ('\\' : 'v' : xs) = '\v' : go xs
+    go ('\\' : '0' : xs) = '\0' : go xs
+    go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs
+      where
+        a' = 16 * digitToInt a
+        b' = digitToInt b
+    go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs
+      where
+        a' = 16 * 16 * 16 * digitToInt a
+        b' = 16 * 16 * digitToInt b
+        c' = 16 * digitToInt c
+        d' = digitToInt d
+    go ('\\' : x : xs) = x : go xs
+    go "\"" = ""
+    go "'" = ""
+    go (x : xs) = x : go xs
+    go "" = ""
 
 commaList :: JSCommaList a -> [a]
 commaList JSLNil = []
@@ -280,18 +288,19 @@ exportStatementIdentifiers _ = []
 varNames :: JSCommaList JSExpression -> [String]
 varNames = mapMaybe varName . commaList
   where
-  varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident
-  varName _ = Nothing
+    varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident
+    varName _ = Nothing
 
-data ForeignModuleExports =
-  ForeignModuleExports
-    { cjsExports :: [String]
-    , esExports :: [String]
-    } deriving (Show)
+data ForeignModuleExports = ForeignModuleExports
+  { cjsExports :: [String],
+    esExports :: [String]
+  }
+  deriving (Show)
 
 instance Semigroup ForeignModuleExports where
   (ForeignModuleExports cjsExports esExports) <> (ForeignModuleExports cjsExports' esExports') =
     ForeignModuleExports (cjsExports <> cjsExports') (esExports <> esExports')
+
 instance Monoid ForeignModuleExports where
   mempty = ForeignModuleExports [] []
 
@@ -299,149 +308,155 @@ instance Monoid ForeignModuleExports where
 --
 -- TODO: what if we assign to exports.foo and then later assign to
 -- module.exports (presumably overwriting exports.foo)?
-getExportedIdentifiers :: forall m. (MonadError ErrorMessage m)
-                          => String
-                          -> JSAST
-                          -> m ForeignModuleExports
+getExportedIdentifiers ::
+  forall m.
+  (MonadError ErrorMessage m) =>
+  String ->
+  JSAST ->
+  m ForeignModuleExports
 getExportedIdentifiers mname top
   | JSAstModule jsModuleItems _ <- top = fold <$> traverse go jsModuleItems
   | otherwise = err InvalidTopLevel
   where
-  err :: ErrorMessage -> m a
-  err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
-
-  go (JSModuleStatementListItem jsStatement)
-    | Just props <- matchExportsAssignment jsStatement
-    = do cjsExports <- traverse toIdent (trailingCommaList props)
-         pure ForeignModuleExports{ cjsExports, esExports = [] }
-    | Just (Public, name, _) <- matchMember jsStatement
-    = pure ForeignModuleExports{ cjsExports = [name], esExports = [] }
-    | otherwise
-    = pure mempty
-  go (JSModuleExportDeclaration _ jsExportDeclaration) =
-    pure ForeignModuleExports{ cjsExports = [], esExports = exportDeclarationIdentifiers jsExportDeclaration }
-  go _ = pure mempty
-
-  toIdent (JSPropertyNameandValue name _ [_]) =
-    extractLabel' name
-  toIdent _ =
-    err UnsupportedExport
-
-  extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
-
-  exportDeclarationIdentifiers (JSExportFrom jsExportClause _ _) =
-    exportClauseIdentifiers jsExportClause
-  exportDeclarationIdentifiers (JSExportLocals jsExportClause _) =
-    exportClauseIdentifiers jsExportClause
-  exportDeclarationIdentifiers (JSExport jsStatement _) =
-    exportStatementIdentifiers jsStatement
-
-  exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) =
-    mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers
-
-  exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent
-  exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs
-
-data ForeignModuleImports =
-  ForeignModuleImports
-    { cjsImports :: [String]
-    , esImports :: [String]
-    } deriving (Show)
+    err :: ErrorMessage -> m a
+    err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
+
+    go (JSModuleStatementListItem jsStatement)
+      | Just props <- matchExportsAssignment jsStatement =
+          do
+            cjsExports <- traverse toIdent (trailingCommaList props)
+            pure ForeignModuleExports {cjsExports, esExports = []}
+      | Just (Public, name, _) <- matchMember jsStatement =
+          pure ForeignModuleExports {cjsExports = [name], esExports = []}
+      | otherwise =
+          pure mempty
+    go (JSModuleExportDeclaration _ jsExportDeclaration) =
+      pure ForeignModuleExports {cjsExports = [], esExports = exportDeclarationIdentifiers jsExportDeclaration}
+    go _ = pure mempty
+
+    toIdent (JSPropertyNameandValue name _ [_]) =
+      extractLabel' name
+    toIdent _ =
+      err UnsupportedExport
+
+    extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
+
+    exportDeclarationIdentifiers (JSExportFrom jsExportClause _ _) =
+      exportClauseIdentifiers jsExportClause
+    exportDeclarationIdentifiers (JSExportLocals jsExportClause _) =
+      exportClauseIdentifiers jsExportClause
+    exportDeclarationIdentifiers (JSExport jsStatement _) =
+      exportStatementIdentifiers jsStatement
+
+    exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) =
+      mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers
+
+    exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent
+    exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs
+
+data ForeignModuleImports = ForeignModuleImports
+  { cjsImports :: [String],
+    esImports :: [String]
+  }
+  deriving (Show)
 
 instance Semigroup ForeignModuleImports where
   (ForeignModuleImports cjsImports esImports) <> (ForeignModuleImports cjsImports' esImports') =
     ForeignModuleImports (cjsImports <> cjsImports') (esImports <> esImports')
+
 instance Monoid ForeignModuleImports where
   mempty = ForeignModuleImports [] []
 
 -- Get a list of all the imported module identifiers from a foreign module.
-getImportedModules :: forall m. (MonadError ErrorMessage m)
-                          => String
-                          -> JSAST
-                          -> m ForeignModuleImports
+getImportedModules ::
+  forall m.
+  (MonadError ErrorMessage m) =>
+  String ->
+  JSAST ->
+  m ForeignModuleImports
 getImportedModules mname top
   | JSAstModule jsModuleItems _ <- top = pure $ foldMap go jsModuleItems
   | otherwise = err InvalidTopLevel
   where
-  err :: ErrorMessage -> m a
-  err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
+    err :: ErrorMessage -> m a
+    err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
 
-  go (JSModuleStatementListItem jsStatement)
-    | Just (_, mid) <- matchRequire jsStatement
-    = ForeignModuleImports{ cjsImports = [mid], esImports = [] }
-  go (JSModuleImportDeclaration _ jsImportDeclaration) =
-    ForeignModuleImports{ cjsImports = [], esImports = [importDeclarationModuleId jsImportDeclaration] }
-  go _ = mempty
+    go (JSModuleStatementListItem jsStatement)
+      | Just (_, mid) <- matchRequire jsStatement =
+          ForeignModuleImports {cjsImports = [mid], esImports = []}
+    go (JSModuleImportDeclaration _ jsImportDeclaration) =
+      ForeignModuleImports {cjsImports = [], esImports = [importDeclarationModuleId jsImportDeclaration]}
+    go _ = mempty
 
-  importDeclarationModuleId (JSImportDeclaration _ (JSFromClause _ _ mid) _) = mid
-  importDeclarationModuleId (JSImportDeclarationBare _ mid _) = mid
+    importDeclarationModuleId (JSImportDeclaration _ (JSFromClause _ _ mid) _) = mid
+    importDeclarationModuleId (JSImportDeclarationBare _ mid _) = mid
 
 -- Matches JS statements like this:
 -- var ModuleName = require("file");
 matchRequire :: JSStatement -> Maybe (String, String)
 matchRequire stmt
-  | JSVariable _ jsInit _ <- stmt
-  , [JSVarInitExpression var varInit] <- commaList jsInit
-  , JSIdentifier _ importName <- var
-  , JSVarInit _ jsInitEx <- varInit
-  , JSMemberExpression req _ argsE _ <- jsInitEx
-  , JSIdentifier _ "require" <- req
-  , [ Just importPath ] <- map fromStringLiteral (commaList argsE)
-  = Just (importName, importPath)
-  | otherwise
-  = Nothing
+  | JSVariable _ jsInit _ <- stmt,
+    [JSVarInitExpression var varInit] <- commaList jsInit,
+    JSIdentifier _ importName <- var,
+    JSVarInit _ jsInitEx <- varInit,
+    JSMemberExpression req _ argsE _ <- jsInitEx,
+    JSIdentifier _ "require" <- req,
+    [Just importPath] <- map fromStringLiteral (commaList argsE) =
+      Just (importName, importPath)
+  | otherwise =
+      Nothing
 
 -- Matches JS member declarations.
 matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression)
 matchMember stmt
-  | Just (name, decl) <- matchInternalMember stmt
-  = pure (Internal, name, decl)
+  | Just (name, decl) <- matchInternalMember stmt =
+      pure (Internal, name, decl)
   -- exports.foo = expr; exports["foo"] = expr;
-  | JSAssignStatement e (JSAssign _) decl _ <- stmt
-  , Just name <- exportsAccessor e
-  = Just (Public, name, decl)
-  | otherwise
-  = Nothing
+  | JSAssignStatement e (JSAssign _) decl _ <- stmt,
+    Just name <- exportsAccessor e =
+      Just (Public, name, decl)
+  | otherwise =
+      Nothing
 
 matchInternalMember :: JSStatement -> Maybe (String, JSExpression)
 matchInternalMember stmt
   -- var foo = expr;
-  | JSVariable _ jsInit _ <- stmt
-  , [JSVarInitExpression var varInit] <- commaList jsInit
-  , JSIdentifier _ name <- var
-  , JSVarInit _ decl <- varInit
-  = pure (name, decl)
+  | JSVariable _ jsInit _ <- stmt,
+    [JSVarInitExpression var varInit] <- commaList jsInit,
+    JSIdentifier _ name <- var,
+    JSVarInit _ decl <- varInit =
+      pure (name, decl)
   -- function foo(...args) { body }
-  | JSFunction a0 jsIdent a1 args a2 body _ <- stmt
-  , JSIdentName _ name <- jsIdent
-  = pure (name, JSFunctionExpression a0 jsIdent a1 args a2 body)
-  | otherwise
-  = Nothing
+  | JSFunction a0 jsIdent a1 args a2 body _ <- stmt,
+    JSIdentName _ name <- jsIdent =
+      pure (name, JSFunctionExpression a0 jsIdent a1 args a2 body)
+  | otherwise =
+      Nothing
 
 -- Matches exports.* or exports["*"] expressions and returns the property name.
 exportsAccessor :: JSExpression -> Maybe String
 exportsAccessor (JSMemberDot exports _ nm)
-  | JSIdentifier _ "exports" <- exports
-  , JSIdentifier _ name <- nm
-  = Just name
+  | JSIdentifier _ "exports" <- exports,
+    JSIdentifier _ name <- nm =
+      Just name
 exportsAccessor (JSMemberSquare exports _ nm _)
-  | JSIdentifier _ "exports" <- exports
-  , Just name <- fromStringLiteral nm
-  = Just name
+  | JSIdentifier _ "exports" <- exports,
+    Just name <- fromStringLiteral nm =
+      Just name
 exportsAccessor _ = Nothing
 
 -- Matches assignments to module.exports, like this:
 -- module.exports = { ... }
 matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList
 matchExportsAssignment stmt
-  | JSAssignStatement e (JSAssign _) decl _ <- stmt
-  , JSMemberDot module' _ exports <- e
-  , JSIdentifier _ "module" <- module'
-  , JSIdentifier _ "exports" <- exports
-  , JSObjectLiteral _ props _ <- decl
-  = Just props
-  | otherwise
-  = Nothing
+  | JSAssignStatement e (JSAssign _) decl _ <- stmt,
+    JSMemberDot module' _ exports <- e,
+    JSIdentifier _ "module" <- module',
+    JSIdentifier _ "exports" <- exports,
+    JSObjectLiteral _ props _ <- decl =
+      Just props
+  | otherwise =
+      Nothing
 
 extractLabel :: JSPropertyName -> Maybe String
 extractLabel (JSPropertyString _ nm) = Just $ strValue nm
diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs
index 3682f2f0a5..9ef54eb37a 100644
--- a/src/Language/PureScript/CST/Errors.hs
+++ b/src/Language/PureScript/CST/Errors.hs
@@ -20,6 +20,8 @@ import Language.PureScript.CST.Layout (LayoutStack)
 import Language.PureScript.CST.Print (printToken)
 import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToken(..), Token(..))
 import Text.Printf (printf)
+import Codec.Serialise (Serialise)
+import Codec.Serialise qualified as S
 
 data ParserErrorType
   = ErrWildcardInType
@@ -59,7 +61,7 @@ data ParserErrorType
   | ErrConstraintInForeignImportSyntax
   | ErrEof
   | ErrCustom String
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data ParserWarningType
   = WarnDeprecatedRowSyntax
@@ -67,7 +69,7 @@ data ParserWarningType
   | WarnDeprecatedKindImportSyntax
   | WarnDeprecatedKindExportSyntax
   | WarnDeprecatedCaseOfOffsideSyntax
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, Serialise, NFData)
 
 data ParserErrorInfo a = ParserErrorInfo
   { errRange :: SourceRange
@@ -76,6 +78,8 @@ data ParserErrorInfo a = ParserErrorInfo
   , errType :: a
   } deriving (Show, Eq, Generic, NFData)
 
+instance Serialise a => Serialise (ParserErrorInfo a)
+
 type ParserError = ParserErrorInfo ParserErrorType
 type ParserWarning = ParserErrorInfo ParserWarningType
 
diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs
index 2f41df6b4f..d52fba78f9 100644
--- a/src/Language/PureScript/CST/Layout.hs
+++ b/src/Language/PureScript/CST/Layout.hs
@@ -178,6 +178,7 @@ import Data.Foldable (find)
 import Data.Function ((&))
 import GHC.Generics (Generic)
 import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..))
+import Codec.Serialise qualified as S
 
 type LayoutStack = [(SourcePos, LayoutDelim)]
 
@@ -204,7 +205,7 @@ data LayoutDelim
   | LytOf
   | LytDo
   | LytAdo
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 isIndented :: LayoutDelim -> Bool
 isIndented = \case
diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs
index ba90f7e95b..084fb6f3c4 100644
--- a/src/Language/PureScript/CST/Types.hs
+++ b/src/Language/PureScript/CST/Types.hs
@@ -1,51 +1,54 @@
 {-# LANGUAGE DeriveAnyClass #-}
+
 -- | This module contains data types for the entire PureScript surface language. Every
 -- token is represented in the tree, and every token is annotated with
 -- whitespace and comments (both leading and trailing). This means one can write
 -- an exact printer so that `print . parse = id`. Every constructor is laid out
 -- with tokens in left-to-right order. The core productions are given a slot for
 -- arbitrary annotations, however this is not used by the parser.
-
 module Language.PureScript.CST.Types where
 
-import Prelude
-
+import Codec.Serialise qualified as S
 import Control.DeepSeq (NFData)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Data.Void (Void)
 import GHC.Generics (Generic)
 import Language.PureScript.Names qualified as N
-import Language.PureScript.Roles qualified as R
 import Language.PureScript.PSString (PSString)
+import Language.PureScript.Roles qualified as R
+import Prelude
 
 data SourcePos = SourcePos
-  { srcLine :: {-# UNPACK #-} !Int
-  , srcColumn :: {-# UNPACK #-} !Int
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  { srcLine :: {-# UNPACK #-} !Int,
+    srcColumn :: {-# UNPACK #-} !Int
+  }
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data SourceRange = SourceRange
-  { srcStart :: !SourcePos
-  , srcEnd :: !SourcePos
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  { srcStart :: !SourcePos,
+    srcEnd :: !SourcePos
+  }
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data Comment l
   = Comment !Text
   | Space {-# UNPACK #-} !Int
   | Line !l
-  deriving (Show, Eq, Ord, Generic, Functor, NFData)
+  deriving (Show, Eq, Ord, Generic, Functor, S.Serialise, NFData)
 
 data LineFeed = LF | CRLF
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data TokenAnn = TokenAnn
-  { tokRange :: !SourceRange
-  , tokLeadingComments :: ![Comment LineFeed]
-  , tokTrailingComments :: ![Comment Void]
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  { tokRange :: !SourceRange,
+    tokLeadingComments :: ![Comment LineFeed],
+    tokTrailingComments :: ![Comment Void]
+  }
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data SourceStyle = ASCII | Unicode
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data Token
   = TokLeftParen
@@ -81,51 +84,60 @@ data Token
   | TokLayoutSep
   | TokLayoutEnd
   | TokEof
-  deriving (Show, Eq, Ord, Generic, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data SourceToken = SourceToken
-  { tokAnn :: !TokenAnn
-  , tokValue :: !Token
-  } deriving (Show, Eq, Ord, Generic, NFData)
+  { tokAnn :: !TokenAnn,
+    tokValue :: !Token
+  }
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data Ident = Ident
   { getIdent :: Text
-  } deriving (Show, Eq, Ord, Generic)
+  }
+  deriving (Show, Eq, Ord, Generic)
 
 data Name a = Name
-  { nameTok :: SourceToken
-  , nameValue :: a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { nameTok :: SourceToken,
+    nameValue :: a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data QualifiedName a = QualifiedName
-  { qualTok :: SourceToken
-  , qualModule :: Maybe N.ModuleName
-  , qualName :: a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { qualTok :: SourceToken,
+    qualModule :: Maybe N.ModuleName,
+    qualName :: a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Label = Label
-  { lblTok :: SourceToken
-  , lblName :: PSString
-  } deriving (Show, Eq, Ord, Generic)
+  { lblTok :: SourceToken,
+    lblName :: PSString
+  }
+  deriving (Show, Eq, Ord, Generic)
 
 data Wrapped a = Wrapped
-  { wrpOpen :: SourceToken
-  , wrpValue :: a
-  , wrpClose :: SourceToken
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { wrpOpen :: SourceToken,
+    wrpValue :: a,
+    wrpClose :: SourceToken
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Separated a = Separated
-  { sepHead :: a
-  , sepTail :: [(SourceToken, a)]
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { sepHead :: a,
+    sepTail :: [(SourceToken, a)]
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Labeled a b = Labeled
-  { lblLabel :: a
-  , lblSep :: SourceToken
-  , lblValue  :: b
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { lblLabel :: a,
+    lblSep :: SourceToken,
+    lblValue :: b
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 type Delimited a = Wrapped (Maybe (Separated a))
+
 type DelimitedNonEmpty a = Wrapped (Separated a)
 
 data OneOrDelimited a
@@ -165,20 +177,22 @@ data Constraint a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Row a = Row
-  { rowLabels :: Maybe (Separated (Labeled Label (Type a)))
-  , rowTail :: Maybe (SourceToken, Type a)
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { rowLabels :: Maybe (Separated (Labeled Label (Type a))),
+    rowTail :: Maybe (SourceToken, Type a)
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Module a = Module
-  { modAnn :: a
-  , modKeyword :: SourceToken
-  , modNamespace :: Name N.ModuleName
-  , modExports :: Maybe (DelimitedNonEmpty (Export a))
-  , modWhere :: SourceToken
-  , modImports :: [ImportDecl a]
-  , modDecls :: [Declaration a]
-  , modTrailingComments :: [Comment LineFeed]
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { modAnn :: a,
+    modKeyword :: SourceToken,
+    modNamespace :: Name N.ModuleName,
+    modExports :: Maybe (DelimitedNonEmpty (Export a)),
+    modWhere :: SourceToken,
+    modImports :: [ImportDecl a],
+    modDecls :: [Declaration a],
+    modTrailingComments :: [Comment LineFeed]
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Export a
   = ExportValue a (Name Ident)
@@ -210,9 +224,10 @@ data Declaration a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Instance a = Instance
-  { instHead :: InstanceHead a
-  , instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a))
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { instHead :: InstanceHead a,
+    instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a))
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data InstanceBinding a
   = InstanceBindingSignature a (Labeled (Name Ident) (Type a))
@@ -220,12 +235,13 @@ data InstanceBinding a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data ImportDecl a = ImportDecl
-  { impAnn :: a
-  , impKeyword :: SourceToken
-  , impModule :: Name N.ModuleName
-  , impNames :: Maybe (Maybe SourceToken, DelimitedNonEmpty (Import a))
-  , impQual :: Maybe (SourceToken, Name N.ModuleName)
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { impAnn :: a,
+    impKeyword :: SourceToken,
+    impModule :: Name N.ModuleName,
+    impNames :: Maybe (Maybe SourceToken, DelimitedNonEmpty (Import a)),
+    impQual :: Maybe (SourceToken, Name N.ModuleName)
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Import a
   = ImportValue a (Name Ident)
@@ -236,24 +252,27 @@ data Import a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DataHead a = DataHead
-  { dataHdKeyword :: SourceToken
-  , dataHdName :: Name (N.ProperName 'N.TypeName)
-  , dataHdVars :: [TypeVarBinding a]
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { dataHdKeyword :: SourceToken,
+    dataHdName :: Name (N.ProperName 'N.TypeName),
+    dataHdVars :: [TypeVarBinding a]
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DataCtor a = DataCtor
-  { dataCtorAnn :: a
-  , dataCtorName :: Name (N.ProperName 'N.ConstructorName)
-  , dataCtorFields :: [Type a]
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { dataCtorAnn :: a,
+    dataCtorName :: Name (N.ProperName 'N.ConstructorName),
+    dataCtorFields :: [Type a]
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data ClassHead a = ClassHead
-  { clsKeyword :: SourceToken
-  , clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken)
-  , clsName :: Name (N.ProperName 'N.ClassName)
-  , clsVars :: [TypeVarBinding a]
-  , clsFundeps :: Maybe (SourceToken, Separated ClassFundep)
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { clsKeyword :: SourceToken,
+    clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken),
+    clsName :: Name (N.ProperName 'N.ClassName),
+    clsVars :: [TypeVarBinding a],
+    clsFundeps :: Maybe (SourceToken, Separated ClassFundep)
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data ClassFundep
   = FundepDetermined SourceToken (NonEmpty (Name Ident))
@@ -261,12 +280,13 @@ data ClassFundep
   deriving (Show, Eq, Ord, Generic)
 
 data InstanceHead a = InstanceHead
-  { instKeyword :: SourceToken
-  , instNameSep :: Maybe (Name Ident, SourceToken)
-  , instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken)
-  , instClass :: QualifiedName (N.ProperName 'N.ClassName)
-  , instTypes :: [Type a]
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { instKeyword :: SourceToken,
+    instNameSep :: Maybe (Name Ident, SourceToken),
+    instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken),
+    instClass :: QualifiedName (N.ProperName 'N.ClassName),
+    instTypes :: [Type a]
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Fixity
   = Infix
@@ -280,16 +300,18 @@ data FixityOp
   deriving (Show, Eq, Ord, Generic)
 
 data FixityFields = FixityFields
-  { fxtKeyword :: (SourceToken, Fixity)
-  , fxtPrec :: (SourceToken, Integer)
-  , fxtOp :: FixityOp
-  } deriving (Show, Eq, Ord, Generic)
+  { fxtKeyword :: (SourceToken, Fixity),
+    fxtPrec :: (SourceToken, Integer),
+    fxtOp :: FixityOp
+  }
+  deriving (Show, Eq, Ord, Generic)
 
 data ValueBindingFields a = ValueBindingFields
-  { valName :: Name Ident
-  , valBinders :: [Binder a]
-  , valGuarded :: Guarded a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { valName :: Name Ident,
+    valBinders :: [Binder a],
+    valGuarded :: Guarded a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Guarded a
   = Unconditional SourceToken (Where a)
@@ -297,16 +319,18 @@ data Guarded a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data GuardedExpr a = GuardedExpr
-  { grdBar :: SourceToken
-  , grdPatterns :: Separated (PatternGuard a)
-  , grdSep :: SourceToken
-  , grdWhere :: Where a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { grdBar :: SourceToken,
+    grdPatterns :: Separated (PatternGuard a),
+    grdSep :: SourceToken,
+    grdWhere :: Where a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data PatternGuard a = PatternGuard
-  { patBinder :: Maybe (Binder a, SourceToken)
-  , patExpr :: Expr a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { patBinder :: Maybe (Binder a, SourceToken),
+    patExpr :: Expr a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Foreign a
   = ForeignValue (Labeled (Name Ident) (Type a))
@@ -315,9 +339,10 @@ data Foreign a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Role = Role
-  { roleTok :: SourceToken
-  , roleValue :: R.Role
-  } deriving (Show, Eq, Ord, Generic)
+  { roleTok :: SourceToken,
+    roleValue :: R.Role
+  }
+  deriving (Show, Eq, Ord, Generic)
 
 data Expr a
   = ExprHole a (Name Ident)
@@ -359,45 +384,51 @@ data RecordUpdate a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data RecordAccessor a = RecordAccessor
-  { recExpr :: Expr a
-  , recDot :: SourceToken
-  , recPath :: Separated Label
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { recExpr :: Expr a,
+    recDot :: SourceToken,
+    recPath :: Separated Label
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Lambda a = Lambda
-  { lmbSymbol :: SourceToken
-  , lmbBinders :: NonEmpty (Binder a)
-  , lmbArr :: SourceToken
-  , lmbBody :: Expr a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { lmbSymbol :: SourceToken,
+    lmbBinders :: NonEmpty (Binder a),
+    lmbArr :: SourceToken,
+    lmbBody :: Expr a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data IfThenElse a = IfThenElse
-  { iteIf :: SourceToken
-  , iteCond :: Expr a
-  , iteThen :: SourceToken
-  , iteTrue :: Expr a
-  , iteElse :: SourceToken
-  , iteFalse :: Expr a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { iteIf :: SourceToken,
+    iteCond :: Expr a,
+    iteThen :: SourceToken,
+    iteTrue :: Expr a,
+    iteElse :: SourceToken,
+    iteFalse :: Expr a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data CaseOf a = CaseOf
-  { caseKeyword :: SourceToken
-  , caseHead :: Separated (Expr a)
-  , caseOf :: SourceToken
-  , caseBranches :: NonEmpty (Separated (Binder a), Guarded a)
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { caseKeyword :: SourceToken,
+    caseHead :: Separated (Expr a),
+    caseOf :: SourceToken,
+    caseBranches :: NonEmpty (Separated (Binder a), Guarded a)
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data LetIn a = LetIn
-  { letKeyword :: SourceToken
-  , letBindings :: NonEmpty (LetBinding a)
-  , letIn :: SourceToken
-  , letBody :: Expr a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { letKeyword :: SourceToken,
+    letBindings :: NonEmpty (LetBinding a),
+    letIn :: SourceToken,
+    letBody :: Expr a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Where a = Where
-  { whereExpr :: Expr a
-  , whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a))
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { whereExpr :: Expr a,
+    whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a))
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data LetBinding a
   = LetBindingSignature a (Labeled (Name Ident) (Type a))
@@ -406,9 +437,10 @@ data LetBinding a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DoBlock a = DoBlock
-  { doKeyword :: SourceToken
-  , doStatements :: NonEmpty (DoStatement a)
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { doKeyword :: SourceToken,
+    doStatements :: NonEmpty (DoStatement a)
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DoStatement a
   = DoLet SourceToken (NonEmpty (LetBinding a))
@@ -417,11 +449,12 @@ data DoStatement a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data AdoBlock a = AdoBlock
-  { adoKeyword :: SourceToken
-  , adoStatements :: [DoStatement a]
-  , adoIn :: SourceToken
-  , adoResult :: Expr a
-  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { adoKeyword :: SourceToken,
+    adoStatements :: [DoStatement a],
+    adoIn :: SourceToken,
+    adoResult :: Expr a
+  }
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Binder a
   = BinderWildcard a SourceToken
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index e1f857031f..49b6a935a5 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Language.PureScript.Environment where
 
 import Prelude
@@ -45,7 +46,7 @@ data Environment = Environment
   -- scope (ie dictionaries brought in by a constrained type).
   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
   -- ^ Type classes
-  } deriving (Show, Generic)
+  } deriving (Show, Generic, Serialise)
 
 instance NFData Environment
 
@@ -71,7 +72,7 @@ data TypeClassData = TypeClassData
   -- ^ A sets of arguments that can be used to infer all other arguments.
   , typeClassIsEmpty :: Bool
   -- ^ Whether or not dictionaries for this type class are necessarily empty.
-  } deriving (Show, Generic)
+  } deriving (Show, Generic, Serialise)
 
 instance NFData TypeClassData
 
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 96b5061c7e..890a3a6476 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -56,6 +56,8 @@ import System.Console.ANSI qualified as ANSI
 import System.FilePath (makeRelative)
 import Text.PrettyPrint.Boxes qualified as Box
 import Witherable (wither)
+import Codec.Serialise (Serialise)
+import Codec.Serialise.Class (Serialise(encode, decode))
 
 -- | A type of error messages
 data SimpleErrorMessage
@@ -199,12 +201,16 @@ data SimpleErrorMessage
   | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool
   | CannotSkipTypeApplication SourceType
   | CannotApplyExpressionOfTypeOnType SourceType SourceType
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 data ErrorMessage = ErrorMessage
   [ErrorMessageHint]
   SimpleErrorMessage
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
+  
+-- instance Serialise ErrorMessage where
+--   encode = genericEncode
+--   decode = _
 
 newtype ErrorSuggestion = ErrorSuggestion Text
 
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 194c6293fb..0ee26d6ca8 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -30,6 +30,12 @@ import Language.PureScript.Ide.Util (runLogger)
 import Protolude
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
+import Codec.Serialise (serialise)
+import Data.Aeson (ToJSON(toJSON))
+import Data.Text.Lazy qualified as TL
+import Data.Text.Encoding qualified as T
+import Data.ByteArray qualified as B
+import Data.ByteString.Lazy qualified as BL
 
 type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
 
@@ -66,9 +72,44 @@ handlers =
           Right $
             Types.DocumentDiagnosticReport $
               Types.InL $
-                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnotics Nothing
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnotics Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
+        sendInfoMsg "SMethod_TextDocumentCodeAction"
+        let params = req ^. LSP.params
+            doc = params ^. LSP.textDocument
+            diags = params ^. LSP.context . LSP.diagnostics
+        -- pure _
+        -- diagnotics <- getFileDiagnotics msg
+        res $
+          Right $
+            Types.InL $
+              [ Types.InR $
+                  Types.CodeAction
+                    "Fix all"
+                    Nothing
+                    (Just diags)
+                    Nothing
+                    Nothing
+                    Nothing
+                    Nothing
+                    Nothing
+              ]
     ]
 
+--     { _title       :: Text -- ^ A short, human-readable, title for this code action.
+-- , _kind        :: Maybe CodeActionKind -- ^ The kind of the code action. Used to filter code actions.
+-- , _diagnostics :: Maybe (List Diagnostic) -- ^ The diagnostics that this code action resolves.
+-- , _edit        :: Maybe WorkspaceEdit -- ^ The workspace edit this code action performs.
+-- , _command     :: Maybe Command -- ^ A command this code action executes. If a code action
+--                                 -- provides an edit and a command, first the edit is
+--                                 -- executed and then the command.
+-- , _isPreferred :: Maybe Bool -- ^ Marks this as a preferred action.
+--                           -- Preferred actions are used by the `auto fix` command and can be targeted by keybindings.
+--                           -- A quick fix should be marked preferred if it properly addresses the underlying error.
+--                           -- A refactoring should be marked preferred if it is the most reasonable choice of actions to take.
+-- , _disabled    :: Maybe Reason -- ^ Marks that the code action cannot currently be applied.
+-- }
+
 rebuildFileFromMsg :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri) => s -> HandlerM config ()
 rebuildFileFromMsg msg = do
   let uri :: Uri
@@ -129,7 +170,7 @@ getResultDiagnostics uri res = case res of
         (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
         Nothing
         Nothing
-        Nothing
+        (Just $ toJSON $ T.decodeUtf8 $ B.concat $ BL.toChunks $ serialise msg)
       where
         notFound = Types.Position 0 0
         (spanName, start, end) = getPositions $ errorSpan msg
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 593e8c1a8d..a26a2b24cf 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -9,6 +9,7 @@ import Data.Text (Text, pack)
 import Language.PureScript.AST.Declarations.ChainId (ChainId)
 import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify)
 import Language.PureScript.Types (SourceConstraint, SourceType)
+import Codec.Serialise (Serialise)
 
 --
 -- Data representing a type class dictionary which is in scope
@@ -40,6 +41,7 @@ data TypeClassDictionaryInScope v
     deriving (Show, Functor, Foldable, Traversable, Generic)
 
 instance NFData v => NFData (TypeClassDictionaryInScope v)
+instance Serialise v => Serialise (TypeClassDictionaryInScope v)
 
 type NamedDict = TypeClassDictionaryInScope (Qualified Ident)
 

From 42318c82baee7ebf247340866f71a617a735efb9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 16:05:05 +0200
Subject: [PATCH 026/297] remove unused import

---
 src/Language/PureScript/Errors.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 890a3a6476..57ff245773 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -57,7 +57,6 @@ import System.FilePath (makeRelative)
 import Text.PrettyPrint.Boxes qualified as Box
 import Witherable (wither)
 import Codec.Serialise (Serialise)
-import Codec.Serialise.Class (Serialise(encode, decode))
 
 -- | A type of error messages
 data SimpleErrorMessage

From d2b8096fcd0446d034346b38b496946dcaf9c7af Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 18 Sep 2024 17:55:33 +0200
Subject: [PATCH 027/297] adds fix all

---
 src/Language/PureScript/LspSimple.hs | 39 +++++++++++++++++++---------
 1 file changed, 27 insertions(+), 12 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 0ee26d6ca8..02a067813e 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -5,14 +5,20 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.LspSimple (main) where
 
+import Codec.Serialise (serialise, deserialise)
 import Control.Lens ((^.))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
+import Data.Aeson qualified as A
+import Data.ByteArray qualified as B
+import Data.ByteString.Lazy qualified as BL
 import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
 import Language.LSP.Diagnostics (partitionBySource)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
@@ -30,12 +36,6 @@ import Language.PureScript.Ide.Util (runLogger)
 import Protolude
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
-import Codec.Serialise (serialise)
-import Data.Aeson (ToJSON(toJSON))
-import Data.Text.Lazy qualified as TL
-import Data.Text.Encoding qualified as T
-import Data.ByteArray qualified as B
-import Data.ByteString.Lazy qualified as BL
 
 type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
 
@@ -76,7 +76,7 @@ handlers =
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentCodeAction"
         let params = req ^. LSP.params
-            doc = params ^. LSP.textDocument
+            -- doc = params ^. LSP.textDocument
             diags = params ^. LSP.context . LSP.diagnostics
         -- pure _
         -- diagnotics <- getFileDiagnotics msg
@@ -86,11 +86,11 @@ handlers =
               [ Types.InR $
                   Types.CodeAction
                     "Fix all"
-                    Nothing
+                    (Just Types.CodeActionKind_QuickFix)
                     (Just diags)
-                    Nothing
-                    Nothing
-                    Nothing
+                    (Just True)
+                    Nothing -- disabled
+                    (Just $ Types.WorkspaceEdit Nothing Nothing Nothing)
                     Nothing
                     Nothing
               ]
@@ -170,7 +170,8 @@ getResultDiagnostics uri res = case res of
         (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
         Nothing
         Nothing
-        (Just $ toJSON $ T.decodeUtf8 $ B.concat $ BL.toChunks $ serialise msg)
+        -- (Just $ encodeErrorMessage msg)
+        Nothing
       where
         notFound = Types.Position 0 0
         (spanName, start, end) = getPositions $ errorSpan msg
@@ -196,6 +197,20 @@ sendError err =
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
 
+encodeErrorMessage :: ErrorMessage -> A.Value
+encodeErrorMessage msg = A.toJSON $ TE.decodeUtf8 $ B.concat $ BL.toChunks $ serialise msg
+
+decodeErrorMessage :: A.Value -> Either Text ErrorMessage
+decodeErrorMessage json = do
+  fromJson :: Text <- case A.fromJSON json of
+    A.Success a -> Right a
+    A.Error err -> Left $ T.pack err
+  deserialise $ toUtf8Lazy fromJson
+
+  -- Left ""
+
+--  fromJSON json & TE.encodeUtf8  & _ & BL.fromChunks $ _
+
 main :: IdeEnvironment -> IO Int
 main ideEnv =
   Server.runServer $

From b4764c648c8c7c90b7c0c76f3a0bf02807396f89 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Sep 2024 10:42:24 +0200
Subject: [PATCH 028/297] start adding workspace edit action

---
 src/Language/PureScript/Errors.hs    |   4 -
 src/Language/PureScript/LspSimple.hs | 210 ++++++++++++++-------------
 2 files changed, 108 insertions(+), 106 deletions(-)

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 57ff245773..fb374a7737 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -206,10 +206,6 @@ data ErrorMessage = ErrorMessage
   [ErrorMessageHint]
   SimpleErrorMessage
   deriving (Show, Generic, Serialise, NFData)
-  
--- instance Serialise ErrorMessage where
---   encode = genericEncode
---   decode = _
 
 newtype ErrorSuggestion = ErrorSuggestion Text
 
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 02a067813e..f33fba658a 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -9,20 +9,24 @@
 
 module Language.PureScript.LspSimple (main) where
 
-import Codec.Serialise (serialise, deserialise)
+import Codec.Serialise (deserialise, serialise)
 import Control.Lens ((^.))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
+import Control.Monad.Supply.Class (MonadSupply (fresh))
 import Data.Aeson qualified as A
+import Data.Aeson.KeyMap (insert)
 import Data.ByteArray qualified as B
 import Data.ByteString.Lazy qualified as BL
+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
 import Data.List.NonEmpty qualified as NEL
+import Data.Map qualified as Map
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
 import Language.LSP.Diagnostics (partitionBySource)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
-import Language.LSP.Protocol.Types (Uri, toNormalizedUri)
+import Language.LSP.Protocol.Types (Diagnostic, Uri, toNormalizedUri)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig, publishDiagnostics)
 import Language.LSP.Server qualified as Server
@@ -41,14 +45,22 @@ type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
 
 type IdeM = ReaderT IdeEnvironment (LoggingT (ExceptT IdeError IO))
 
-runIde :: IdeM a -> HandlerM config (Either IdeError a)
-runIde = lift . mapReaderT (mapLoggingT runExceptT)
+liftIde :: IdeM a -> HandlerM config (Either IdeError a)
+liftIde = lift . mapReaderT (mapLoggingT runExceptT)
 
-handlers :: Server.Handlers (HandlerM ())
-handlers =
+type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
+
+insertDiagnosticError :: (MonadIO m, Ord k) => IORef (Map k a) -> k -> a -> m ()
+insertDiagnosticError diagErrs diag err = liftIO $ modifyIORef diagErrs (Map.insert diag err)
+
+getDiagnosticError :: (MonadIO m, Ord k) => IORef (Map k a) -> k -> m (Maybe a)
+getDiagnosticError diagErrs diags = liftIO $ Map.lookup diags <$> readIORef diagErrs
+
+handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
+handlers diagErrs =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
-        void $ runIde $ findAvailableExterns >>= loadModulesAsync
+        void $ liftIde $ findAvailableExterns >>= loadModulesAsync
         log_ ("OA purs lsp server initialized" :: T.Text)
         sendInfoMsg "OA purs lsp server initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
@@ -78,6 +90,8 @@ handlers =
         let params = req ^. LSP.params
             -- doc = params ^. LSP.textDocument
             diags = params ^. LSP.context . LSP.diagnostics
+            uri = getMsgUri req
+
         -- pure _
         -- diagnotics <- getFileDiagnotics msg
         res $
@@ -90,101 +104,92 @@ handlers =
                     (Just diags)
                     (Just True)
                     Nothing -- disabled
-                    (Just $ Types.WorkspaceEdit Nothing Nothing Nothing)
+                    ( Just $
+                        Types.WorkspaceEdit
+                          Nothing
+                          -- (Just $ Map.singleton uri [Types.TextEdit _ _])
+                          Nothing
+                          Nothing
+                    )
                     Nothing
                     Nothing
               ]
     ]
-
---     { _title       :: Text -- ^ A short, human-readable, title for this code action.
--- , _kind        :: Maybe CodeActionKind -- ^ The kind of the code action. Used to filter code actions.
--- , _diagnostics :: Maybe (List Diagnostic) -- ^ The diagnostics that this code action resolves.
--- , _edit        :: Maybe WorkspaceEdit -- ^ The workspace edit this code action performs.
--- , _command     :: Maybe Command -- ^ A command this code action executes. If a code action
---                                 -- provides an edit and a command, first the edit is
---                                 -- executed and then the command.
--- , _isPreferred :: Maybe Bool -- ^ Marks this as a preferred action.
---                           -- Preferred actions are used by the `auto fix` command and can be targeted by keybindings.
---                           -- A quick fix should be marked preferred if it properly addresses the underlying error.
---                           -- A refactoring should be marked preferred if it is the most reasonable choice of actions to take.
--- , _disabled    :: Maybe Reason -- ^ Marks that the code action cannot currently be applied.
--- }
-
-rebuildFileFromMsg :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri) => s -> HandlerM config ()
-rebuildFileFromMsg msg = do
-  let uri :: Uri
-      uri = getMsgUri msg
-      fileName = Types.uriToFilePath uri
-  case fileName of
-    Just file -> do
-      res <- runIde $ rebuildFile file
-      sendDiagnostics uri res
-    Nothing ->
-      sendInfoMsg $ "No file path for uri: " <> show uri
-
-getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config [Types.Diagnostic]
-getFileDiagnotics msg = do
-  let uri :: Uri
-      uri = getMsgUri msg
-      fileName = Types.uriToFilePath uri
-  case fileName of
-    Just file -> do
-      res <- runIde $ rebuildFile file
-      getResultDiagnostics uri res
-    Nothing -> do
-      sendInfoMsg $ "No file path for uri: " <> show uri
-      pure []
-
-rebuildFile :: FilePath -> IdeM Success
-rebuildFile file = do
-  rebuildFileAsync file Nothing mempty
-
-getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
-getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
-
-sendDiagnostics :: Uri -> Either IdeError Success -> HandlerM config ()
-sendDiagnostics uri res = do
-  diags <- getResultDiagnostics uri res
-  publishDiagnostics 100 (toNormalizedUri uri) Nothing (partitionBySource diags)
-
-getResultDiagnostics :: Uri -> Either IdeError Success -> HandlerM config [Types.Diagnostic]
-getResultDiagnostics uri res = case res of
-  Right success ->
-    case success of
-      RebuildSuccess errs -> pure $ errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> runMultipleErrors errs
-      TextResult _ -> pure []
-      _ -> pure []
-  Left (RebuildError _ errs) -> pure $ errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> runMultipleErrors errs
-  Left err -> do
-    sendError err
-    pure []
   where
-    errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
-    errorMessageDiagnostic severity msg@((ErrorMessage hints _)) =
-      Types.Diagnostic
-        (Types.Range start end)
-        (Just severity)
-        (Just $ Types.InR $ errorCode msg)
-        (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
-        (T.pack <$> spanName)
-        (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
-        Nothing
-        Nothing
-        -- (Just $ encodeErrorMessage msg)
-        Nothing
+    rebuildFileFromMsg :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri) => s -> HandlerM config ()
+    rebuildFileFromMsg msg = do
+      let uri :: Uri
+          uri = getMsgUri msg
+          fileName = Types.uriToFilePath uri
+      case fileName of
+        Just file -> do
+          res <- liftIde $ rebuildFile file
+          sendDiagnostics uri res
+        Nothing ->
+          sendInfoMsg $ "No file path for uri: " <> show uri
+
+    getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config [Types.Diagnostic]
+    getFileDiagnotics msg = do
+      let uri :: Uri
+          uri = getMsgUri msg
+          fileName = Types.uriToFilePath uri
+      case fileName of
+        Just file -> do
+          res <- liftIde $ rebuildFile file
+          getResultDiagnostics uri res
+        Nothing -> do
+          sendInfoMsg $ "No file path for uri: " <> show uri
+          pure []
+
+    getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
+    getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
+
+    sendDiagnostics :: Uri -> Either IdeError Success -> HandlerM config ()
+    sendDiagnostics uri res = do
+      diags <- getResultDiagnostics uri res
+      publishDiagnostics 100 (toNormalizedUri uri) Nothing (partitionBySource diags)
+
+    getResultDiagnostics :: Uri -> Either IdeError Success -> HandlerM config [Types.Diagnostic]
+    getResultDiagnostics uri res = case res of
+      Right success ->
+        case success of
+          RebuildSuccess errs -> do
+            let diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> runMultipleErrors errs
+            insertDiagnosticError diagErrs diags errs
+            pure diags
+          TextResult _ -> pure []
+          _ -> pure []
+      Left (RebuildError _ errs) -> pure $ errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> runMultipleErrors errs
+      Left err -> do
+        sendError err
+        pure []
       where
-        notFound = Types.Position 0 0
-        (spanName, start, end) = getPositions $ errorSpan msg
-
-        getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
-
-        getPositionsMb = fmap $ \spans ->
-          let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
-                NEL.head spans
-           in ( Just name,
-                Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
-                Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
-              )
+        errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
+        errorMessageDiagnostic severity msg@((ErrorMessage hints _)) =
+          Types.Diagnostic
+            (Types.Range start end)
+            (Just severity)
+            (Just $ Types.InR $ errorCode msg)
+            (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
+            (T.pack <$> spanName)
+            (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
+            Nothing
+            Nothing
+            -- (Just $ encodeErrorMessage msg)
+            Nothing
+          where
+            notFound = Types.Position 0 0
+            (spanName, start, end) = getPositions $ errorSpan msg
+
+            getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
+
+            getPositionsMb = fmap $ \spans ->
+              let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+                    NEL.head spans
+               in ( Just name,
+                    Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
+                    Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
+                  )
 
 sendError :: IdeError -> HandlerM config ()
 sendError err =
@@ -194,6 +199,10 @@ sendError err =
         "Something went wrong:\n" <> textError err
     )
 
+rebuildFile :: FilePath -> IdeM Success
+rebuildFile file = do
+  rebuildFileAsync file Nothing mempty
+
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
 
@@ -207,12 +216,9 @@ decodeErrorMessage json = do
     A.Error err -> Left $ T.pack err
   deserialise $ toUtf8Lazy fromJson
 
-  -- Left ""
-
---  fromJSON json & TE.encodeUtf8  & _ & BL.fromChunks $ _
-
 main :: IdeEnvironment -> IO Int
-main ideEnv =
+main ideEnv = do
+  diagErrs <- newIORef Map.empty
   Server.runServer $
     Server.ServerDefinition
       { parseConfig = const $ const $ Right (),
@@ -222,7 +228,7 @@ main ideEnv =
         doInitialize = \env _req -> do
           logT "Init OA purs lsp server"
           pure $ Right env,
-        staticHandlers = \_caps -> do handlers,
+        staticHandlers = \_caps -> do handlers diagErrs,
         interpretHandler = \env ->
           Server.Iso
             ( runLogger (confLogLevel (ideConfiguration ideEnv))

From 0ed70ef6415095878f01f6eade971d1a2cd2e93c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Sep 2024 10:42:46 +0200
Subject: [PATCH 029/297] clean up

---
 src/Language/PureScript/LspSimple.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index f33fba658a..26547332d9 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 
 module Language.PureScript.LspSimple (main) where
 
@@ -13,9 +14,7 @@ import Codec.Serialise (deserialise, serialise)
 import Control.Lens ((^.))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
-import Control.Monad.Supply.Class (MonadSupply (fresh))
 import Data.Aeson qualified as A
-import Data.Aeson.KeyMap (insert)
 import Data.ByteArray qualified as B
 import Data.ByteString.Lazy qualified as BL
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
@@ -155,7 +154,7 @@ handlers diagErrs =
         case success of
           RebuildSuccess errs -> do
             let diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> runMultipleErrors errs
-            insertDiagnosticError diagErrs diags errs
+            -- insertDiagnosticError diagErrs diags errs
             pure diags
           TextResult _ -> pure []
           _ -> pure []

From e9e2c139217c245fabeffbb1d3bc17d853438dac Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Sep 2024 11:42:02 +0200
Subject: [PATCH 030/297] adds FromJSON and ToJSON instances to ErrorMessage

---
 src/Language/PureScript/AST/Binders.hs        |   3 +-
 src/Language/PureScript/AST/Declarations.hs   |  98 ++++++++---
 .../PureScript/AST/Declarations/ChainId.hs    |   3 +-
 src/Language/PureScript/AST/Literals.hs       |   3 +-
 src/Language/PureScript/AST/Operators.hs      |   7 +-
 src/Language/PureScript/Bundle.hs             |  13 +-
 src/Language/PureScript/CST/Errors.hs         |   7 +-
 src/Language/PureScript/CST/Layout.hs         |   3 +-
 src/Language/PureScript/CST/Types.hs          |  17 +-
 src/Language/PureScript/Environment.hs        |  10 +-
 src/Language/PureScript/Errors.hs             |   5 +-
 src/Language/PureScript/LspSimple.hs          |  16 +-
 src/Language/PureScript/Names.hs              | 155 ++++++++++--------
 .../PureScript/TypeClassDictionaries.hs       |   3 +
 14 files changed, 219 insertions(+), 124 deletions(-)

diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 236cfb468a..e05effce0c 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -14,6 +14,7 @@ import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, Pro
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Types (SourceType)
 import Codec.Serialise (Serialise)
+import Data.Aeson qualified as A
 
 -- |
 -- Data type for binders
@@ -65,7 +66,7 @@ data Binder
   -- A binder with a type annotation
   --
   | TypedBinder SourceType Binder
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Show, Generic, NFData, A.FromJSON, A.ToJSON, Serialise)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 7a2ab064b6..23e4af3a31 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -1,13 +1,13 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TemplateHaskell #-}
-
 -- |
 -- Data types for modules and declarations
 module Language.PureScript.AST.Declarations where
 
 import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
-import Data.Aeson.TH (Options (..), SumEncoding (..), defaultOptions, deriveJSON)
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson qualified as A
+import Data.Aeson.TH (Options (..), SumEncoding (..), defaultOptions)
 import Data.Functor.Identity (Identity (..))
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
@@ -46,7 +46,7 @@ data TypeSearch
         -- hole
         tsAfterRecordFields :: Maybe [(Label, SourceType)]
       }
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch
 onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
@@ -86,7 +86,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 -- | Categories of hints
 data HintCategory
@@ -108,7 +108,7 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
@@ -158,7 +158,7 @@ importPrim =
         . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Show, Generic, NFData, Serialise, A.FromJSON, A.ToJSON)
 
 -- |
 -- An item in a list of explicit imports or exports
@@ -190,6 +190,12 @@ data DeclarationRef
     ReExportRef SourceSpan ExportSource DeclarationRef
   deriving (Show, Generic, NFData, Serialise)
 
+instance FromJSON DeclarationRef where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
+instance ToJSON DeclarationRef where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 instance Eq DeclarationRef where
   (TypeClassRef _ name) == (TypeClassRef _ name') = name == name'
   (TypeOpRef _ name) == (TypeOpRef _ name') = name == name'
@@ -229,6 +235,12 @@ data ExportSource = ExportSource
   }
   deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
+instance FromJSON ExportSource where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
+instance ToJSON ExportSource where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 declRefSourceSpan :: DeclarationRef -> SourceSpan
 declRefSourceSpan (TypeRef ss _ _) = ss
 declRefSourceSpan (TypeOpRef ss _) = ss
@@ -287,6 +299,12 @@ data ImportDeclarationType
     Hiding [DeclarationRef]
   deriving (Eq, Show, Generic, Serialise, NFData)
 
+instance FromJSON ImportDeclarationType where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
+instance ToJSON ImportDeclarationType where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 isExplicit :: ImportDeclarationType -> Bool
 isExplicit (Explicit _) = True
 isExplicit _ = False
@@ -303,7 +321,7 @@ data RoleDeclarationData = RoleDeclarationData
     rdeclIdent :: !(ProperName 'TypeName),
     rdeclRoles :: ![Role]
   }
-  deriving (Show, Eq, Generic, Serialise, NFData)
+  deriving (Show, Eq, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -315,7 +333,7 @@ data TypeDeclarationData = TypeDeclarationData
     tydeclIdent :: !Ident,
     tydeclType :: !SourceType
   }
-  deriving (Show, Eq, Generic, Serialise, NFData)
+  deriving (Show, Eq, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -338,7 +356,7 @@ data ValueDeclarationData a = ValueDeclarationData
     valdeclBinders :: ![Binder],
     valdeclExpression :: !a
   }
-  deriving (Show, Functor, Generic, Serialise, NFData, Foldable, Traversable)
+  deriving (Show, Functor, Generic, Serialise, FromJSON, ToJSON, NFData, Foldable, Traversable)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
@@ -353,7 +371,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration
     dataCtorName :: !(ProperName 'ConstructorName),
     dataCtorFields :: ![(Ident, SourceType)]
   }
-  deriving (Show, Eq, Generic, Serialise, NFData)
+  deriving (Show, Eq, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
 mapDataCtorFields f DataConstructorDeclaration {..} = DataConstructorDeclaration {dataCtorFields = f dataCtorFields, ..}
@@ -416,11 +434,17 @@ data Declaration
     TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
   deriving (Show, Generic, Serialise, NFData)
 
+instance FromJSON Declaration where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
+instance ToJSON Declaration where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
-  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
-  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
 pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))
@@ -431,7 +455,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
@@ -443,6 +467,14 @@ data TypeInstanceBody
     ExplicitInstance [Declaration]
   deriving (Show, Generic, Serialise, NFData)
 
+-- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''TypeInstanceBody)
+
+instance FromJSON TypeInstanceBody where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
+instance ToJSON TypeInstanceBody where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
 
@@ -457,7 +489,7 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -584,13 +616,13 @@ flattenDecls = concatMap flattenOne
 data Guard
   = ConditionGuard Expr
   | PatternGuard Binder Expr
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
@@ -696,7 +728,7 @@ data Expr
   | -- |
     -- A value with source position information
     PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, A.FromJSON, A.ToJSON, NFData)
 
 -- |
 -- Metadata that tells where a let binding originated
@@ -707,7 +739,7 @@ data WhereProvenance
   | -- |
     -- The let binding was always a let binding
     FromLet
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 -- |
 -- An alternative in a case statement
@@ -719,7 +751,7 @@ data CaseAlternative = CaseAlternative
     -- The result expression or a collect of guarded expressions
     caseAlternativeResult :: [GuardedExpr]
   }
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 -- |
 -- A statement in a do-notation block
@@ -738,6 +770,11 @@ data DoNotationElement
     PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
   deriving (Show, Generic, Serialise, NFData)
 
+instance FromJSON DoNotationElement where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+instance ToJSON DoNotationElement where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 -- For a record update such as:
 --
 --  x { foo = 0
@@ -766,20 +803,31 @@ newtype PathTree t = PathTree (AssocList PSString (PathNode t))
   deriving newtype (NFData)
 
 instance (Serialise t) => Serialise (PathTree t)
+instance (A.FromJSON t) => A.FromJSON (PathTree t)
+instance (A.ToJSON t) => A.ToJSON (PathTree t)
 
 data PathNode t = Leaf t | Branch (PathTree t)
-  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise)
+  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise, A.FromJSON, A.ToJSON)
 
 newtype AssocList k t = AssocList {runAssocList :: [(k, t)]}
   deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic)
   deriving newtype (NFData)
 
 instance (Serialise t, Serialise k) => Serialise (AssocList k t)
+instance (A.FromJSON t, A.FromJSON k) => A.FromJSON (AssocList k t)
+instance (A.ToJSON t, A.ToJSON k) => A.ToJSON (AssocList k t)
+
+-- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''NameSource)
+
+-- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ExportSource)
+
+-- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DeclarationRef)
+
+-- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ImportDeclarationType)
+
+-- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Declaration)
 
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''NameSource)
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ExportSource)
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DeclarationRef)
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ImportDeclarationType)
+-- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DoNotationElement)
 
 isTrueExpr :: Expr -> Bool
 isTrueExpr (Literal _ (BooleanLiteral True)) = True
diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs
index aacfc11fe8..df2a1ac46e 100644
--- a/src/Language/PureScript/AST/Declarations/ChainId.hs
+++ b/src/Language/PureScript/AST/Declarations/ChainId.hs
@@ -7,6 +7,7 @@ import Prelude
 import Language.PureScript.AST.SourcePos qualified as Pos
 import Control.DeepSeq (NFData)
 import Codec.Serialise (Serialise)
+import Data.Aeson qualified as A
 
 -- |
 -- For a given instance chain, stores the chain's file name and
@@ -14,7 +15,7 @@ import Codec.Serialise (Serialise)
 -- This data is used to determine which instances are part of
 -- the same instance chain.
 newtype ChainId = ChainId (String, Pos.SourcePos)
-  deriving (Eq, Ord, Show, NFData, Serialise)
+  deriving (Eq, Ord, Show, NFData, A.FromJSON, A.ToJSON, Serialise)
 
 mkChainId :: String -> Pos.SourcePos -> ChainId
 mkChainId fileName startingSourcePos = ChainId (fileName, startingSourcePos)
diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index c723fbd219..01639399a3 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -9,6 +9,7 @@ import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 import Language.PureScript.PSString (PSString)
 import Codec.Serialise.Class qualified as S
+import Data.Aeson qualified as A
 
 -- |
 -- Data type for literal values. Parameterised so it can be used for Exprs and
@@ -39,4 +40,4 @@ data Literal a
   -- An object literal
   --
   | ObjectLiteral [(PSString, a)]
-  deriving (Eq, Ord, Show, Functor, Generic, S.Serialise, NFData)
+  deriving (Eq, Ord, Show, Functor, Generic, A.FromJSON, A.ToJSON, S.Serialise, NFData)
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index eb217a2444..61258f3ba2 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -8,7 +8,7 @@ import Prelude
 import Codec.Serialise (Serialise)
 import GHC.Generics (Generic)
 import Control.DeepSeq (NFData)
-import Data.Aeson ((.=))
+import Data.Aeson ((.=), (.:))
 import Data.Aeson qualified as A
 
 import Language.PureScript.Crash (internalError)
@@ -58,3 +58,8 @@ instance A.ToJSON Fixity where
     A.object [ "associativity" .= associativity
              , "precedence" .= precedence
              ]
+instance A.FromJSON Fixity where 
+  parseJSON = A.withObject "Fixity" $ \o -> do
+    associativity <- o .: "associativity"
+    precedence <- o .: "precedence"
+    pure $ Fixity associativity precedence
\ No newline at end of file
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index a5705e2f96..b4752ec0dd 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -45,14 +45,14 @@ data ErrorMessage
   | ErrorInModule ModuleIdentifier ErrorMessage
   | MissingEntryPoint String
   | MissingMainModule String
-  deriving (Show, Generic, S.Serialise, NFData)
+  deriving (Show, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
 -- foreign modules.
 data ModuleType
   = Regular
   | Foreign
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 showModuleType :: ModuleType -> String
 showModuleType Regular = "Regular"
@@ -69,6 +69,15 @@ instance A.ToJSON ModuleIdentifier where
         "type" .= show mt
       ]
 
+instance A.FromJSON ModuleIdentifier where
+  parseJSON = A.withObject "ModuleIdentifier" $ \o -> do
+    name <- o A..: "name"
+    mt :: String <- o A..: "type"
+    case mt of
+      "Regular" -> pure $ ModuleIdentifier name Regular
+      "Foreign" -> pure $ ModuleIdentifier name Foreign
+      _ -> fail "Invalid module type"
+
 data Visibility
   = Public
   | Internal
diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs
index 9ef54eb37a..9b23548f67 100644
--- a/src/Language/PureScript/CST/Errors.hs
+++ b/src/Language/PureScript/CST/Errors.hs
@@ -22,6 +22,7 @@ import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToke
 import Text.Printf (printf)
 import Codec.Serialise (Serialise)
 import Codec.Serialise qualified as S
+import Data.Aeson qualified as A
 
 data ParserErrorType
   = ErrWildcardInType
@@ -61,7 +62,7 @@ data ParserErrorType
   | ErrConstraintInForeignImportSyntax
   | ErrEof
   | ErrCustom String
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data ParserWarningType
   = WarnDeprecatedRowSyntax
@@ -69,7 +70,7 @@ data ParserWarningType
   | WarnDeprecatedKindImportSyntax
   | WarnDeprecatedKindExportSyntax
   | WarnDeprecatedCaseOfOffsideSyntax
-  deriving (Show, Eq, Ord, Generic, Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data ParserErrorInfo a = ParserErrorInfo
   { errRange :: SourceRange
@@ -79,6 +80,8 @@ data ParserErrorInfo a = ParserErrorInfo
   } deriving (Show, Eq, Generic, NFData)
 
 instance Serialise a => Serialise (ParserErrorInfo a)
+instance A.FromJSON a => A.FromJSON (ParserErrorInfo a)
+instance A.ToJSON a => A.ToJSON (ParserErrorInfo a)
 
 type ParserError = ParserErrorInfo ParserErrorType
 type ParserWarning = ParserErrorInfo ParserWarningType
diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs
index d52fba78f9..71785d572f 100644
--- a/src/Language/PureScript/CST/Layout.hs
+++ b/src/Language/PureScript/CST/Layout.hs
@@ -179,6 +179,7 @@ import Data.Function ((&))
 import GHC.Generics (Generic)
 import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..))
 import Codec.Serialise qualified as S
+import Data.Aeson qualified as A
 
 type LayoutStack = [(SourcePos, LayoutDelim)]
 
@@ -205,7 +206,7 @@ data LayoutDelim
   | LytOf
   | LytDo
   | LytAdo
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 isIndented :: LayoutDelim -> Bool
 isIndented = \case
diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs
index 084fb6f3c4..df94cc598a 100644
--- a/src/Language/PureScript/CST/Types.hs
+++ b/src/Language/PureScript/CST/Types.hs
@@ -10,6 +10,7 @@ module Language.PureScript.CST.Types where
 
 import Codec.Serialise qualified as S
 import Control.DeepSeq (NFData)
+import Data.Aeson qualified as A
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Data.Void (Void)
@@ -23,32 +24,32 @@ data SourcePos = SourcePos
   { srcLine :: {-# UNPACK #-} !Int,
     srcColumn :: {-# UNPACK #-} !Int
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data SourceRange = SourceRange
   { srcStart :: !SourcePos,
     srcEnd :: !SourcePos
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data Comment l
   = Comment !Text
   | Space {-# UNPACK #-} !Int
   | Line !l
-  deriving (Show, Eq, Ord, Generic, Functor, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, Functor, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data LineFeed = LF | CRLF
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data TokenAnn = TokenAnn
   { tokRange :: !SourceRange,
     tokLeadingComments :: ![Comment LineFeed],
     tokTrailingComments :: ![Comment Void]
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data SourceStyle = ASCII | Unicode
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data Token
   = TokLeftParen
@@ -84,13 +85,13 @@ data Token
   | TokLayoutSep
   | TokLayoutEnd
   | TokEof
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data SourceToken = SourceToken
   { tokAnn :: !TokenAnn,
     tokValue :: !Token
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
 
 data Ident = Ident
   { getIdent :: Text
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 49b6a935a5..8394b05e10 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -46,7 +46,7 @@ data Environment = Environment
   -- scope (ie dictionaries brought in by a constrained type).
   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
   -- ^ Type classes
-  } deriving (Show, Generic, Serialise)
+  } deriving (Show, Generic, Serialise, A.FromJSON, A.ToJSON)
 
 instance NFData Environment
 
@@ -72,7 +72,7 @@ data TypeClassData = TypeClassData
   -- ^ A sets of arguments that can be used to infer all other arguments.
   , typeClassIsEmpty :: Bool
   -- ^ Whether or not dictionaries for this type class are necessarily empty.
-  } deriving (Show, Generic, Serialise)
+  } deriving (Show, Generic, Serialise, A.FromJSON, A.ToJSON)
 
 instance NFData TypeClassData
 
@@ -238,6 +238,8 @@ data NameVisibility
 
 instance NFData NameVisibility
 instance Serialise NameVisibility
+instance A.FromJSON NameVisibility
+instance A.ToJSON NameVisibility
 
 -- | A flag for whether a name is for an private or public value - only public values will be
 -- included in a generated externs file.
@@ -249,7 +251,7 @@ data NameKind
   -- ^ A public value for a module member or foreign import declaration
   | External
   -- ^ A name for member introduced by foreign import
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq, Generic, A.FromJSON, A.ToJSON)
 
 instance NFData NameKind
 instance Serialise NameKind
@@ -270,6 +272,8 @@ data TypeKind
 
 instance NFData TypeKind
 instance Serialise TypeKind
+instance A.FromJSON TypeKind
+instance A.ToJSON TypeKind
 
 -- | The type ('data' or 'newtype') of a data type declaration
 data DataDeclType
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index fb374a7737..b4392fc415 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -57,6 +57,7 @@ import System.FilePath (makeRelative)
 import Text.PrettyPrint.Boxes qualified as Box
 import Witherable (wither)
 import Codec.Serialise (Serialise)
+import Data.Aeson (FromJSON, ToJSON)
 
 -- | A type of error messages
 data SimpleErrorMessage
@@ -200,12 +201,12 @@ data SimpleErrorMessage
   | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool
   | CannotSkipTypeApplication SourceType
   | CannotApplyExpressionOfTypeOnType SourceType SourceType
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 data ErrorMessage = ErrorMessage
   [ErrorMessageHint]
   SimpleErrorMessage
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
 
 newtype ErrorSuggestion = ErrorSuggestion Text
 
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 26547332d9..d5bfdea63f 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -1,12 +1,10 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
-{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 
 module Language.PureScript.LspSimple (main) where
 
@@ -84,6 +82,7 @@ handlers diagErrs =
             Types.DocumentDiagnosticReport $
               Types.InL $
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnotics Nothing,
+                
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentCodeAction"
         let params = req ^. LSP.params
@@ -95,7 +94,7 @@ handlers diagErrs =
         -- diagnotics <- getFileDiagnotics msg
         res $
           Right $
-            Types.InL $
+            Types.InL
               [ Types.InR $
                   Types.CodeAction
                     "Fix all"
@@ -135,7 +134,7 @@ handlers diagErrs =
       case fileName of
         Just file -> do
           res <- liftIde $ rebuildFile file
-          getResultDiagnostics uri res
+          getResultDiagnostics res
         Nothing -> do
           sendInfoMsg $ "No file path for uri: " <> show uri
           pure []
@@ -145,16 +144,15 @@ handlers diagErrs =
 
     sendDiagnostics :: Uri -> Either IdeError Success -> HandlerM config ()
     sendDiagnostics uri res = do
-      diags <- getResultDiagnostics uri res
+      diags <- getResultDiagnostics res
       publishDiagnostics 100 (toNormalizedUri uri) Nothing (partitionBySource diags)
 
-    getResultDiagnostics :: Uri -> Either IdeError Success -> HandlerM config [Types.Diagnostic]
-    getResultDiagnostics uri res = case res of
+    getResultDiagnostics :: Either IdeError Success -> HandlerM config [Types.Diagnostic]
+    getResultDiagnostics res = case res of
       Right success ->
         case success of
           RebuildSuccess errs -> do
             let diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> runMultipleErrors errs
-            -- insertDiagnosticError diagErrs diags errs
             pure diags
           TextResult _ -> pure []
           _ -> pure []
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index e5df3610bf..f0f219ef22 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -1,26 +1,22 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 -- |
 -- Data types for names
---
 module Language.PureScript.Names where
 
-import Prelude
-
 import Codec.Serialise (Serialise)
 import Control.Applicative ((<|>))
-import Control.Monad.Supply.Class (MonadSupply(..))
 import Control.DeepSeq (NFData)
+import Control.Monad.Supply.Class (MonadSupply (..))
+import Data.Aeson (FromJSON (..), FromJSONKey (..), Options (..), SumEncoding (..), ToJSON (..), ToJSONKey (..), defaultOptions, parseJSON2, toJSON2, withArray)
+import Data.Aeson qualified as A
 import Data.Functor.Contravariant (contramap)
-import Data.Vector qualified as V
-
-import GHC.Generics (Generic)
-import Data.Aeson (FromJSON(..), FromJSONKey(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..), defaultOptions, parseJSON2, toJSON2, withArray)
-import Data.Aeson.TH (deriveJSON)
 import Data.Text (Text)
 import Data.Text qualified as T
-
+import Data.Vector qualified as V
+import GHC.Generics (Generic)
 import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
+import Prelude
 
 -- | A sum of the possible name types, useful for error and lint messages.
 data Name
@@ -34,8 +30,13 @@ data Name
   deriving (Eq, Ord, Show, Generic)
 
 instance NFData Name
+
 instance Serialise Name
 
+instance A.FromJSON Name
+
+instance A.ToJSON Name
+
 getIdentName :: Name -> Maybe Ident
 getIdentName (IdentName name) = Just name
 getIdentName _ = Nothing
@@ -66,40 +67,49 @@ getClassName _ = Nothing
 -- `Ident` because functions that match on `Ident` can ignore all
 -- `InternalIdent`s with a single pattern, and thus don't have to change if
 -- a new `InternalIdentData` constructor is created.
---
 data InternalIdentData
-  -- Used by CoreFn.Laziness
-  = RuntimeLazyFactory | Lazy !Text
+  = -- Used by CoreFn.Laziness
+    RuntimeLazyFactory
+  | Lazy !Text
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData InternalIdentData
+
 instance Serialise InternalIdentData
 
+instance FromJSON InternalIdentData where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
+instance ToJSON InternalIdentData where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 -- |
 -- Names for value identifiers
---
 data Ident
-  -- |
-  -- An alphanumeric identifier
-  --
-  = Ident Text
-  -- |
-  -- A generated name for an identifier
-  --
-  | GenIdent (Maybe Text) Integer
-  -- |
-  -- A generated name used only for type-checking
-  --
-  | UnusedIdent
-  -- |
-  -- A generated name used only for internal transformations
-  --
-  | InternalIdent !InternalIdentData
+  = -- |
+    -- An alphanumeric identifier
+    Ident Text
+  | -- |
+    -- A generated name for an identifier
+    GenIdent (Maybe Text) Integer
+  | -- |
+    -- A generated name used only for type-checking
+    UnusedIdent
+  | -- |
+    -- A generated name used only for internal transformations
+    InternalIdent !InternalIdentData
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData Ident
+
 instance Serialise Ident
 
+instance FromJSON Ident where
+  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
+instance ToJSON Ident where
+  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
+
 unusedIdent :: Text
 unusedIdent = "$__unused"
 
@@ -108,28 +118,28 @@ runIdent (Ident i) = i
 runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
 runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
 runIdent UnusedIdent = unusedIdent
-runIdent InternalIdent{} = error "unexpected InternalIdent"
+runIdent InternalIdent {} = error "unexpected InternalIdent"
 
 showIdent :: Ident -> Text
 showIdent = runIdent
 
-freshIdent :: MonadSupply m => Text -> m Ident
+freshIdent :: (MonadSupply m) => Text -> m Ident
 freshIdent name = GenIdent (Just name) <$> fresh
 
-freshIdent' :: MonadSupply m => m Ident
+freshIdent' :: (MonadSupply m) => m Ident
 freshIdent' = GenIdent Nothing <$> fresh
 
 isPlainIdent :: Ident -> Bool
-isPlainIdent Ident{} = True
+isPlainIdent Ident {} = True
 isPlainIdent _ = False
 
 -- |
 -- Operator alias names.
---
-newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
+newtype OpName (a :: OpNameType) = OpName {runOpName :: Text}
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData (OpName a)
+
 instance Serialise (OpName a)
 
 instance ToJSON (OpName a) where
@@ -143,7 +153,6 @@ showOp op = "(" <> runOpName op <> ")"
 
 -- |
 -- The closed set of operator alias types.
---
 data OpNameType = ValueOpName | TypeOpName | AnyOpName
 
 eraseOpName :: OpName a -> OpName 'AnyOpName
@@ -154,11 +163,11 @@ coerceOpName = OpName . runOpName
 
 -- |
 -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
---
-newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
+newtype ProperName (a :: ProperNameType) = ProperName {runProperName :: Text}
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData (ProperName a)
+
 instance Serialise (ProperName a)
 
 instance ToJSON (ProperName a) where
@@ -167,29 +176,31 @@ instance ToJSON (ProperName a) where
 instance FromJSON (ProperName a) where
   parseJSON = fmap ProperName . parseJSON
 
+instance A.ToJSONKey (ProperName a)
+
+instance A.FromJSONKey (ProperName a)
+
 -- |
 -- The closed set of proper name types.
---
 data ProperNameType
   = TypeName
   | ConstructorName
   | ClassName
   | Namespace
+  deriving (Generic, A.FromJSON, A.ToJSON)
 
 -- |
 -- Coerces a ProperName from one ProperNameType to another. This should be used
 -- with care, and is primarily used to convert ClassNames into TypeNames after
 -- classes have been desugared.
---
 coerceProperName :: ProperName a -> ProperName b
 coerceProperName = ProperName . runProperName
 
 -- |
 -- Module names
---
 newtype ModuleName = ModuleName Text
   deriving (Show, Eq, Ord, Generic)
-  deriving newtype Serialise
+  deriving newtype (Serialise)
 
 instance NFData ModuleName
 
@@ -211,8 +222,17 @@ pattern ByNullSourcePos :: QualifiedBy
 pattern ByNullSourcePos = BySourcePos (SourcePos 0 0)
 
 instance NFData QualifiedBy
+
 instance Serialise QualifiedBy
 
+instance A.FromJSON QualifiedBy
+
+instance A.ToJSON QualifiedBy
+
+instance A.FromJSONKey QualifiedBy
+
+instance A.ToJSONKey QualifiedBy
+
 isBySourcePos :: QualifiedBy -> Bool
 isBySourcePos (BySourcePos _) = True
 isBySourcePos _ = False
@@ -227,15 +247,15 @@ toMaybeModuleName (BySourcePos _) = Nothing
 
 -- |
 -- A qualified name, i.e. a name with an optional module name
---
 data Qualified a = Qualified QualifiedBy a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
-instance NFData a => NFData (Qualified a)
-instance Serialise a => Serialise (Qualified a)
+instance (NFData a) => NFData (Qualified a)
+
+instance (Serialise a) => Serialise (Qualified a)
 
 showQualified :: (a -> Text) -> Qualified a -> Text
-showQualified f (Qualified (BySourcePos  _) a) = f a
+showQualified f (Qualified (BySourcePos _) a) = f a
 showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a
 
 getQual :: Qualified a -> Maybe ModuleName
@@ -243,14 +263,12 @@ getQual (Qualified qb _) = toMaybeModuleName qb
 
 -- |
 -- Provide a default module name, if a name is unqualified
---
 qualify :: ModuleName -> Qualified a -> (ModuleName, a)
 qualify m (Qualified (BySourcePos _) a) = (m, a)
 qualify _ (Qualified (ByModuleName m) a) = (m, a)
 
 -- |
 -- Makes a qualified value from a name and module name.
---
 mkQualified :: a -> ModuleName -> Qualified a
 mkQualified name mn = Qualified (ByModuleName mn) name
 
@@ -261,48 +279,48 @@ disqualify (Qualified _ a) = a
 -- |
 -- Remove the qualification from a value when it is qualified with a particular
 -- module name.
---
 disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a
 disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a
 disqualifyFor _ _ = Nothing
 
 -- |
 -- Checks whether a qualified value is actually qualified with a module reference
---
 isQualified :: Qualified a -> Bool
-isQualified (Qualified (BySourcePos  _) _) = False
+isQualified (Qualified (BySourcePos _) _) = False
 isQualified _ = True
 
 -- |
 -- Checks whether a qualified value is not actually qualified with a module reference
---
 isUnqualified :: Qualified a -> Bool
 isUnqualified = not . isQualified
 
 -- |
 -- Checks whether a qualified value is qualified with a particular module
---
 isQualifiedWith :: ModuleName -> Qualified a -> Bool
 isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn'
 isQualifiedWith _ _ = False
 
-instance ToJSON a => ToJSON (Qualified a) where
+instance (ToJSON a) => ToJSON (Qualified a) where
   toJSON (Qualified qb a) = case qb of
     ByModuleName mn -> toJSON2 (mn, a)
     BySourcePos ss -> toJSON2 (ss, a)
 
-instance FromJSON a => FromJSON (Qualified a) where
+instance (FromJSON a) => FromJSON (Qualified a) where
   parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName'
     where
-    byModule = do
-      (mn, a) <- parseJSON2 v
-      pure $ Qualified (ByModuleName mn) a
-    bySourcePos = do
-      (ss, a) <- parseJSON2 v
-      pure $ Qualified (BySourcePos ss) a
-    byMaybeModuleName' = do
-      (mn, a) <- parseJSON2 v
-      pure $ Qualified (byMaybeModuleName mn) a
+      byModule = do
+        (mn, a) <- parseJSON2 v
+        pure $ Qualified (ByModuleName mn) a
+      bySourcePos = do
+        (ss, a) <- parseJSON2 v
+        pure $ Qualified (BySourcePos ss) a
+      byMaybeModuleName' = do
+        (mn, a) <- parseJSON2 v
+        pure $ Qualified (byMaybeModuleName mn) a
+
+instance (ToJSON a, ToJSONKey a) => ToJSONKey (Qualified a)
+
+instance (FromJSON a, FromJSONKey a) => FromJSONKey (Qualified a)
 
 instance ToJSON ModuleName where
   toJSON (ModuleName name) = toJSON (T.splitOn "." name)
@@ -318,5 +336,6 @@ instance ToJSONKey ModuleName where
 instance FromJSONKey ModuleName where
   fromJSONKey = fmap moduleNameFromString fromJSONKey
 
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData)
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
+instance A.FromJSONKey Ident
+
+instance A.ToJSONKey Ident
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index a26a2b24cf..4530fe9f0e 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -10,6 +10,7 @@ import Language.PureScript.AST.Declarations.ChainId (ChainId)
 import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify)
 import Language.PureScript.Types (SourceConstraint, SourceType)
 import Codec.Serialise (Serialise)
+import Data.Aeson (FromJSON, ToJSON)
 
 --
 -- Data representing a type class dictionary which is in scope
@@ -42,6 +43,8 @@ data TypeClassDictionaryInScope v
 
 instance NFData v => NFData (TypeClassDictionaryInScope v)
 instance Serialise v => Serialise (TypeClassDictionaryInScope v)
+instance FromJSON v => FromJSON (TypeClassDictionaryInScope v)
+instance ToJSON v => ToJSON (TypeClassDictionaryInScope v)
 
 type NamedDict = TypeClassDictionaryInScope (Qualified Ident)
 

From f0450713f55ea2f0f620926d39ab404bee1c50cb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Sep 2024 18:05:30 +0200
Subject: [PATCH 031/297] adds suggestions

---
 src/Language/PureScript/Errors/JSON.hs |  26 ++---
 src/Language/PureScript/LspSimple.hs   | 138 ++++++++++++++-----------
 2 files changed, 91 insertions(+), 73 deletions(-)

diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs
index 9e2af78668..127699d6c8 100644
--- a/src/Language/PureScript/Errors/JSON.hs
+++ b/src/Language/PureScript/Errors/JSON.hs
@@ -60,16 +60,18 @@ toJSONError verbose level files e =
   spans :: Maybe (NEL.NonEmpty P.SourceSpan)
   spans = P.errorSpan e
 
-  toErrorPosition :: P.SourceSpan -> ErrorPosition
-  toErrorPosition ss =
-    ErrorPosition (P.sourcePosLine   (P.spanStart ss))
-                  (P.sourcePosColumn (P.spanStart ss))
-                  (P.sourcePosLine   (P.spanEnd   ss))
-                  (P.sourcePosColumn (P.spanEnd   ss))
-  toSuggestion :: P.ErrorMessage -> Maybe ErrorSuggestion
-  toSuggestion em =
-    case P.errorSuggestion $ P.unwrapErrorMessage em of
-      Nothing -> Nothing
-      Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em)
+toErrorPosition :: P.SourceSpan -> ErrorPosition
+toErrorPosition ss =
+  ErrorPosition (P.sourcePosLine   (P.spanStart ss))
+                (P.sourcePosColumn (P.spanStart ss))
+                (P.sourcePosLine   (P.spanEnd   ss))
+                (P.sourcePosColumn (P.spanEnd   ss))
 
-  suggestionText (P.ErrorSuggestion s) = s
+toSuggestion :: P.ErrorMessage -> Maybe ErrorSuggestion
+toSuggestion em =
+  case P.errorSuggestion $ P.unwrapErrorMessage em of
+    Nothing -> Nothing
+    Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em)
+
+suggestionText :: P.ErrorSuggestion -> Text
+suggestionText (P.ErrorSuggestion s) = s
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index d5bfdea63f..7f00f3fe48 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
@@ -18,17 +20,19 @@ import Data.ByteString.Lazy qualified as BL
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
-import Language.LSP.Diagnostics (partitionBySource)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
-import Language.LSP.Protocol.Types (Diagnostic, Uri, toNormalizedUri)
+import Language.LSP.Protocol.Types (Diagnostic, Uri)
 import Language.LSP.Protocol.Types qualified as Types
-import Language.LSP.Server (getConfig, publishDiagnostics)
+import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Errors.JSON (toSuggestion)
+import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Ide (findAvailableExterns, loadModulesAsync)
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
@@ -47,12 +51,19 @@ liftIde = lift . mapReaderT (mapLoggingT runExceptT)
 
 type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
 
-insertDiagnosticError :: (MonadIO m, Ord k) => IORef (Map k a) -> k -> a -> m ()
-insertDiagnosticError diagErrs diag err = liftIO $ modifyIORef diagErrs (Map.insert diag err)
+insertDiagnosticError :: (MonadIO m, Ord k) => IORef (Map k a) -> a -> k -> m ()
+insertDiagnosticError diagErrs err diag = liftIO $ modifyIORef diagErrs (Map.insert diag err)
+
+insertDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [a] -> [k] -> m ()
+insertDiagnosticErrors diagErrs errs diags = liftIO $ modifyIORef diagErrs (Map.union $ Map.fromList $ zip diags errs)
 
 getDiagnosticError :: (MonadIO m, Ord k) => IORef (Map k a) -> k -> m (Maybe a)
 getDiagnosticError diagErrs diags = liftIO $ Map.lookup diags <$> readIORef diagErrs
 
+getDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [k] -> m (Map k a)
+getDiagnosticErrors diagErrs diags = liftIO $ flip Map.restrictKeys (Set.fromList diags) <$> readIORef diagErrs
+
+-- z = combin
 handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
@@ -61,14 +72,11 @@ handlers diagErrs =
         log_ ("OA purs lsp server initialized" :: T.Text)
         sendInfoMsg "OA purs lsp server initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        sendInfoMsg "TextDocumentDidOpen"
-        rebuildFileFromMsg msg,
+        sendInfoMsg "TextDocumentDidOpen",
       Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
-        sendInfoMsg "TextDocumentDidChange"
-        rebuildFileFromMsg msg,
+        sendInfoMsg "TextDocumentDidChange",
       Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
-        sendInfoMsg "SMethod_TextDocumentDidSave"
-        rebuildFileFromMsg msg,
+        sendInfoMsg "SMethod_TextDocumentDidSave",
       Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
         cfg <- getConfig
         sendInfoMsg $ "Config changed: " <> show cfg,
@@ -76,13 +84,13 @@ handlers diagErrs =
         sendInfoMsg "SMethod_SetTrace",
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \msg res -> do
         sendInfoMsg "SMethod_TextDocumentDiagnostic"
-        diagnotics <- getFileDiagnotics msg
+        (errs, diagnostics) <- getFileDiagnotics msg
+        insertDiagnosticErrors diagErrs errs diagnostics
         res $
           Right $
             Types.DocumentDiagnosticReport $
               Types.InL $
-                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnotics Nothing,
-                
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentCodeAction"
         let params = req ^. LSP.params
@@ -90,43 +98,53 @@ handlers diagErrs =
             diags = params ^. LSP.context . LSP.diagnostics
             uri = getMsgUri req
 
-        -- pure _
-        -- diagnotics <- getFileDiagnotics msg
+        errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
+
+        -- let getRanges :: [Types.Command Types.|? Types.CodeAction] -> [Types.Range]
+        --     getRanges = foldMap \case
+        --       Types.InL _ -> []
+        --       Types.InR (Types.CodeAction _ _ _ _ _ (Just (Types.WorkspaceEdit (Just edits) _ _)) _ _) ->
+        --         (getEditRange =<< Map.toList edits) : []
+        --       _ -> []
+
+        --     getEditRange :: (Uri, [Types.TextEdit]) -> [Types.Range]
+        --     getEditRange (_, edits) = edits 
         res $
           Right $
-            Types.InL
-              [ Types.InR $
-                  Types.CodeAction
-                    "Fix all"
-                    (Just Types.CodeActionKind_QuickFix)
-                    (Just diags)
-                    (Just True)
-                    Nothing -- disabled
-                    ( Just $
-                        Types.WorkspaceEdit
-                          Nothing
-                          -- (Just $ Map.singleton uri [Types.TextEdit _ _])
-                          Nothing
-                          Nothing
-                    )
-                    Nothing
-                    Nothing
-              ]
+            Types.InL $
+              errs & fmap \(diag, err) ->
+                let textEdits :: [Types.TextEdit]
+                    textEdits =
+                      toSuggestion err
+                        & maybeToList
+                          >>= suggestionToEdit
+
+                    suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
+                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
+                      let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
+                          end = Types.Position (fromIntegral $ endLine) (fromIntegral $ endColumn)
+                          range = Types.Range start end
+                       in pure $ Types.TextEdit (Types.Range start end) replacement
+                    suggestionToEdit _ = []
+
+                 in Types.InR $
+                      Types.CodeAction
+                        "Apply suggestion"
+                        (Just Types.CodeActionKind_QuickFix)
+                        (Just diags)
+                        (Just True)
+                        Nothing -- disabled
+                        ( Just $
+                            Types.WorkspaceEdit
+                              (Just $ Map.singleton uri textEdits)
+                              Nothing
+                              (Just _)
+                        )
+                        Nothing
+                        Nothing
     ]
   where
-    rebuildFileFromMsg :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri) => s -> HandlerM config ()
-    rebuildFileFromMsg msg = do
-      let uri :: Uri
-          uri = getMsgUri msg
-          fileName = Types.uriToFilePath uri
-      case fileName of
-        Just file -> do
-          res <- liftIde $ rebuildFile file
-          sendDiagnostics uri res
-        Nothing ->
-          sendInfoMsg $ "No file path for uri: " <> show uri
-
-    getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config [Types.Diagnostic]
+    getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
     getFileDiagnotics msg = do
       let uri :: Uri
           uri = getMsgUri msg
@@ -137,29 +155,28 @@ handlers diagErrs =
           getResultDiagnostics res
         Nothing -> do
           sendInfoMsg $ "No file path for uri: " <> show uri
-          pure []
+          pure ([], [])
 
     getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
     getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
 
-    sendDiagnostics :: Uri -> Either IdeError Success -> HandlerM config ()
-    sendDiagnostics uri res = do
-      diags <- getResultDiagnostics res
-      publishDiagnostics 100 (toNormalizedUri uri) Nothing (partitionBySource diags)
-
-    getResultDiagnostics :: Either IdeError Success -> HandlerM config [Types.Diagnostic]
+    getResultDiagnostics :: Either IdeError Success -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
     getResultDiagnostics res = case res of
       Right success ->
         case success of
           RebuildSuccess errs -> do
-            let diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> runMultipleErrors errs
-            pure diags
-          TextResult _ -> pure []
-          _ -> pure []
-      Left (RebuildError _ errs) -> pure $ errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> runMultipleErrors errs
+            let errors = runMultipleErrors errs
+                diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
+            pure (errors, diags)
+          TextResult _ -> pure ([], [])
+          _ -> pure ([], [])
+      Left (RebuildError _ errs) -> do
+        let errors = runMultipleErrors errs
+            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
+        pure (errors, diags)
       Left err -> do
         sendError err
-        pure []
+        pure ([], [])
       where
         errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
         errorMessageDiagnostic severity msg@((ErrorMessage hints _)) =
@@ -172,7 +189,6 @@ handlers diagErrs =
             (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
             Nothing
             Nothing
-            -- (Just $ encodeErrorMessage msg)
             Nothing
           where
             notFound = Types.Position 0 0

From 0b670a810ab9f942519040e826165aed862720d8 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Sep 2024 18:09:33 +0200
Subject: [PATCH 032/297] Revert "adds FromJSON and ToJSON instances to
 ErrorMessage"

This reverts commit e9e2c139217c245fabeffbb1d3bc17d853438dac.
---
 src/Language/PureScript/AST/Binders.hs        |   3 +-
 src/Language/PureScript/AST/Declarations.hs   |  98 +++--------
 .../PureScript/AST/Declarations/ChainId.hs    |   3 +-
 src/Language/PureScript/AST/Literals.hs       |   3 +-
 src/Language/PureScript/AST/Operators.hs      |   7 +-
 src/Language/PureScript/Bundle.hs             |  13 +-
 src/Language/PureScript/CST/Errors.hs         |   7 +-
 src/Language/PureScript/CST/Layout.hs         |   3 +-
 src/Language/PureScript/CST/Types.hs          |  17 +-
 src/Language/PureScript/Environment.hs        |  10 +-
 src/Language/PureScript/Errors.hs             |   5 +-
 src/Language/PureScript/LspSimple.hs          |   4 +-
 src/Language/PureScript/Names.hs              | 155 ++++++++----------
 .../PureScript/TypeClassDictionaries.hs       |   3 -
 14 files changed, 118 insertions(+), 213 deletions(-)

diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index e05effce0c..236cfb468a 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -14,7 +14,6 @@ import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, Pro
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Types (SourceType)
 import Codec.Serialise (Serialise)
-import Data.Aeson qualified as A
 
 -- |
 -- Data type for binders
@@ -66,7 +65,7 @@ data Binder
   -- A binder with a type annotation
   --
   | TypedBinder SourceType Binder
-  deriving (Show, Generic, NFData, A.FromJSON, A.ToJSON, Serialise)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 23e4af3a31..7a2ab064b6 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -1,13 +1,13 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TemplateHaskell #-}
+
 -- |
 -- Data types for modules and declarations
 module Language.PureScript.AST.Declarations where
 
 import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Aeson qualified as A
-import Data.Aeson.TH (Options (..), SumEncoding (..), defaultOptions)
+import Data.Aeson.TH (Options (..), SumEncoding (..), defaultOptions, deriveJSON)
 import Data.Functor.Identity (Identity (..))
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
@@ -46,7 +46,7 @@ data TypeSearch
         -- hole
         tsAfterRecordFields :: Maybe [(Label, SourceType)]
       }
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch
 onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
@@ -86,7 +86,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- | Categories of hints
 data HintCategory
@@ -108,7 +108,7 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
@@ -158,7 +158,7 @@ importPrim =
         . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
-  deriving (Show, Generic, NFData, Serialise, A.FromJSON, A.ToJSON)
+  deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- An item in a list of explicit imports or exports
@@ -190,12 +190,6 @@ data DeclarationRef
     ReExportRef SourceSpan ExportSource DeclarationRef
   deriving (Show, Generic, NFData, Serialise)
 
-instance FromJSON DeclarationRef where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
-instance ToJSON DeclarationRef where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 instance Eq DeclarationRef where
   (TypeClassRef _ name) == (TypeClassRef _ name') = name == name'
   (TypeOpRef _ name) == (TypeOpRef _ name') = name == name'
@@ -235,12 +229,6 @@ data ExportSource = ExportSource
   }
   deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
-instance FromJSON ExportSource where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
-instance ToJSON ExportSource where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 declRefSourceSpan :: DeclarationRef -> SourceSpan
 declRefSourceSpan (TypeRef ss _ _) = ss
 declRefSourceSpan (TypeOpRef ss _) = ss
@@ -299,12 +287,6 @@ data ImportDeclarationType
     Hiding [DeclarationRef]
   deriving (Eq, Show, Generic, Serialise, NFData)
 
-instance FromJSON ImportDeclarationType where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
-instance ToJSON ImportDeclarationType where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 isExplicit :: ImportDeclarationType -> Bool
 isExplicit (Explicit _) = True
 isExplicit _ = False
@@ -321,7 +303,7 @@ data RoleDeclarationData = RoleDeclarationData
     rdeclIdent :: !(ProperName 'TypeName),
     rdeclRoles :: ![Role]
   }
-  deriving (Show, Eq, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Eq, Generic, Serialise, NFData)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -333,7 +315,7 @@ data TypeDeclarationData = TypeDeclarationData
     tydeclIdent :: !Ident,
     tydeclType :: !SourceType
   }
-  deriving (Show, Eq, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Eq, Generic, Serialise, NFData)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -356,7 +338,7 @@ data ValueDeclarationData a = ValueDeclarationData
     valdeclBinders :: ![Binder],
     valdeclExpression :: !a
   }
-  deriving (Show, Functor, Generic, Serialise, FromJSON, ToJSON, NFData, Foldable, Traversable)
+  deriving (Show, Functor, Generic, Serialise, NFData, Foldable, Traversable)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
@@ -371,7 +353,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration
     dataCtorName :: !(ProperName 'ConstructorName),
     dataCtorFields :: ![(Ident, SourceType)]
   }
-  deriving (Show, Eq, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Eq, Generic, Serialise, NFData)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
 mapDataCtorFields f DataConstructorDeclaration {..} = DataConstructorDeclaration {dataCtorFields = f dataCtorFields, ..}
@@ -434,17 +416,11 @@ data Declaration
     TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
   deriving (Show, Generic, Serialise, NFData)
 
-instance FromJSON Declaration where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
-instance ToJSON Declaration where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
-  deriving (Eq, Ord, Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
-  deriving (Eq, Ord, Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
 pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))
@@ -455,7 +431,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
@@ -467,14 +443,6 @@ data TypeInstanceBody
     ExplicitInstance [Declaration]
   deriving (Show, Generic, Serialise, NFData)
 
--- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''TypeInstanceBody)
-
-instance FromJSON TypeInstanceBody where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
-instance ToJSON TypeInstanceBody where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
 
@@ -489,7 +457,7 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -616,13 +584,13 @@ flattenDecls = concatMap flattenOne
 data Guard
   = ConditionGuard Expr
   | PatternGuard Binder Expr
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
@@ -728,7 +696,7 @@ data Expr
   | -- |
     -- A value with source position information
     PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- Metadata that tells where a let binding originated
@@ -739,7 +707,7 @@ data WhereProvenance
   | -- |
     -- The let binding was always a let binding
     FromLet
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- An alternative in a case statement
@@ -751,7 +719,7 @@ data CaseAlternative = CaseAlternative
     -- The result expression or a collect of guarded expressions
     caseAlternativeResult :: [GuardedExpr]
   }
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- A statement in a do-notation block
@@ -770,11 +738,6 @@ data DoNotationElement
     PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
   deriving (Show, Generic, Serialise, NFData)
 
-instance FromJSON DoNotationElement where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-instance ToJSON DoNotationElement where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 -- For a record update such as:
 --
 --  x { foo = 0
@@ -803,31 +766,20 @@ newtype PathTree t = PathTree (AssocList PSString (PathNode t))
   deriving newtype (NFData)
 
 instance (Serialise t) => Serialise (PathTree t)
-instance (A.FromJSON t) => A.FromJSON (PathTree t)
-instance (A.ToJSON t) => A.ToJSON (PathTree t)
 
 data PathNode t = Leaf t | Branch (PathTree t)
-  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise, A.FromJSON, A.ToJSON)
+  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise)
 
 newtype AssocList k t = AssocList {runAssocList :: [(k, t)]}
   deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic)
   deriving newtype (NFData)
 
 instance (Serialise t, Serialise k) => Serialise (AssocList k t)
-instance (A.FromJSON t, A.FromJSON k) => A.FromJSON (AssocList k t)
-instance (A.ToJSON t, A.ToJSON k) => A.ToJSON (AssocList k t)
-
--- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''NameSource)
-
--- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ExportSource)
-
--- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DeclarationRef)
-
--- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ImportDeclarationType)
-
--- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Declaration)
 
--- $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DoNotationElement)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''NameSource)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ExportSource)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DeclarationRef)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ImportDeclarationType)
 
 isTrueExpr :: Expr -> Bool
 isTrueExpr (Literal _ (BooleanLiteral True)) = True
diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs
index df2a1ac46e..aacfc11fe8 100644
--- a/src/Language/PureScript/AST/Declarations/ChainId.hs
+++ b/src/Language/PureScript/AST/Declarations/ChainId.hs
@@ -7,7 +7,6 @@ import Prelude
 import Language.PureScript.AST.SourcePos qualified as Pos
 import Control.DeepSeq (NFData)
 import Codec.Serialise (Serialise)
-import Data.Aeson qualified as A
 
 -- |
 -- For a given instance chain, stores the chain's file name and
@@ -15,7 +14,7 @@ import Data.Aeson qualified as A
 -- This data is used to determine which instances are part of
 -- the same instance chain.
 newtype ChainId = ChainId (String, Pos.SourcePos)
-  deriving (Eq, Ord, Show, NFData, A.FromJSON, A.ToJSON, Serialise)
+  deriving (Eq, Ord, Show, NFData, Serialise)
 
 mkChainId :: String -> Pos.SourcePos -> ChainId
 mkChainId fileName startingSourcePos = ChainId (fileName, startingSourcePos)
diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index 01639399a3..c723fbd219 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -9,7 +9,6 @@ import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 import Language.PureScript.PSString (PSString)
 import Codec.Serialise.Class qualified as S
-import Data.Aeson qualified as A
 
 -- |
 -- Data type for literal values. Parameterised so it can be used for Exprs and
@@ -40,4 +39,4 @@ data Literal a
   -- An object literal
   --
   | ObjectLiteral [(PSString, a)]
-  deriving (Eq, Ord, Show, Functor, Generic, A.FromJSON, A.ToJSON, S.Serialise, NFData)
+  deriving (Eq, Ord, Show, Functor, Generic, S.Serialise, NFData)
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index 61258f3ba2..eb217a2444 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -8,7 +8,7 @@ import Prelude
 import Codec.Serialise (Serialise)
 import GHC.Generics (Generic)
 import Control.DeepSeq (NFData)
-import Data.Aeson ((.=), (.:))
+import Data.Aeson ((.=))
 import Data.Aeson qualified as A
 
 import Language.PureScript.Crash (internalError)
@@ -58,8 +58,3 @@ instance A.ToJSON Fixity where
     A.object [ "associativity" .= associativity
              , "precedence" .= precedence
              ]
-instance A.FromJSON Fixity where 
-  parseJSON = A.withObject "Fixity" $ \o -> do
-    associativity <- o .: "associativity"
-    precedence <- o .: "precedence"
-    pure $ Fixity associativity precedence
\ No newline at end of file
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index b4752ec0dd..a5705e2f96 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -45,14 +45,14 @@ data ErrorMessage
   | ErrorInModule ModuleIdentifier ErrorMessage
   | MissingEntryPoint String
   | MissingMainModule String
-  deriving (Show, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Generic, S.Serialise, NFData)
 
 -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
 -- foreign modules.
 data ModuleType
   = Regular
   | Foreign
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 showModuleType :: ModuleType -> String
 showModuleType Regular = "Regular"
@@ -69,15 +69,6 @@ instance A.ToJSON ModuleIdentifier where
         "type" .= show mt
       ]
 
-instance A.FromJSON ModuleIdentifier where
-  parseJSON = A.withObject "ModuleIdentifier" $ \o -> do
-    name <- o A..: "name"
-    mt :: String <- o A..: "type"
-    case mt of
-      "Regular" -> pure $ ModuleIdentifier name Regular
-      "Foreign" -> pure $ ModuleIdentifier name Foreign
-      _ -> fail "Invalid module type"
-
 data Visibility
   = Public
   | Internal
diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs
index 9b23548f67..9ef54eb37a 100644
--- a/src/Language/PureScript/CST/Errors.hs
+++ b/src/Language/PureScript/CST/Errors.hs
@@ -22,7 +22,6 @@ import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToke
 import Text.Printf (printf)
 import Codec.Serialise (Serialise)
 import Codec.Serialise qualified as S
-import Data.Aeson qualified as A
 
 data ParserErrorType
   = ErrWildcardInType
@@ -62,7 +61,7 @@ data ParserErrorType
   | ErrConstraintInForeignImportSyntax
   | ErrEof
   | ErrCustom String
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data ParserWarningType
   = WarnDeprecatedRowSyntax
@@ -70,7 +69,7 @@ data ParserWarningType
   | WarnDeprecatedKindImportSyntax
   | WarnDeprecatedKindExportSyntax
   | WarnDeprecatedCaseOfOffsideSyntax
-  deriving (Show, Eq, Ord, Generic, Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, Serialise, NFData)
 
 data ParserErrorInfo a = ParserErrorInfo
   { errRange :: SourceRange
@@ -80,8 +79,6 @@ data ParserErrorInfo a = ParserErrorInfo
   } deriving (Show, Eq, Generic, NFData)
 
 instance Serialise a => Serialise (ParserErrorInfo a)
-instance A.FromJSON a => A.FromJSON (ParserErrorInfo a)
-instance A.ToJSON a => A.ToJSON (ParserErrorInfo a)
 
 type ParserError = ParserErrorInfo ParserErrorType
 type ParserWarning = ParserErrorInfo ParserWarningType
diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs
index 71785d572f..d52fba78f9 100644
--- a/src/Language/PureScript/CST/Layout.hs
+++ b/src/Language/PureScript/CST/Layout.hs
@@ -179,7 +179,6 @@ import Data.Function ((&))
 import GHC.Generics (Generic)
 import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..))
 import Codec.Serialise qualified as S
-import Data.Aeson qualified as A
 
 type LayoutStack = [(SourcePos, LayoutDelim)]
 
@@ -206,7 +205,7 @@ data LayoutDelim
   | LytOf
   | LytDo
   | LytAdo
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 isIndented :: LayoutDelim -> Bool
 isIndented = \case
diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs
index df94cc598a..084fb6f3c4 100644
--- a/src/Language/PureScript/CST/Types.hs
+++ b/src/Language/PureScript/CST/Types.hs
@@ -10,7 +10,6 @@ module Language.PureScript.CST.Types where
 
 import Codec.Serialise qualified as S
 import Control.DeepSeq (NFData)
-import Data.Aeson qualified as A
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Data.Void (Void)
@@ -24,32 +23,32 @@ data SourcePos = SourcePos
   { srcLine :: {-# UNPACK #-} !Int,
     srcColumn :: {-# UNPACK #-} !Int
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data SourceRange = SourceRange
   { srcStart :: !SourcePos,
     srcEnd :: !SourcePos
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data Comment l
   = Comment !Text
   | Space {-# UNPACK #-} !Int
   | Line !l
-  deriving (Show, Eq, Ord, Generic, Functor, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, Functor, S.Serialise, NFData)
 
 data LineFeed = LF | CRLF
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data TokenAnn = TokenAnn
   { tokRange :: !SourceRange,
     tokLeadingComments :: ![Comment LineFeed],
     tokTrailingComments :: ![Comment Void]
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data SourceStyle = ASCII | Unicode
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data Token
   = TokLeftParen
@@ -85,13 +84,13 @@ data Token
   | TokLayoutSep
   | TokLayoutEnd
   | TokEof
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data SourceToken = SourceToken
   { tokAnn :: !TokenAnn,
     tokValue :: !Token
   }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, A.FromJSON, A.ToJSON, NFData)
+  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 data Ident = Ident
   { getIdent :: Text
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 8394b05e10..49b6a935a5 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -46,7 +46,7 @@ data Environment = Environment
   -- scope (ie dictionaries brought in by a constrained type).
   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
   -- ^ Type classes
-  } deriving (Show, Generic, Serialise, A.FromJSON, A.ToJSON)
+  } deriving (Show, Generic, Serialise)
 
 instance NFData Environment
 
@@ -72,7 +72,7 @@ data TypeClassData = TypeClassData
   -- ^ A sets of arguments that can be used to infer all other arguments.
   , typeClassIsEmpty :: Bool
   -- ^ Whether or not dictionaries for this type class are necessarily empty.
-  } deriving (Show, Generic, Serialise, A.FromJSON, A.ToJSON)
+  } deriving (Show, Generic, Serialise)
 
 instance NFData TypeClassData
 
@@ -238,8 +238,6 @@ data NameVisibility
 
 instance NFData NameVisibility
 instance Serialise NameVisibility
-instance A.FromJSON NameVisibility
-instance A.ToJSON NameVisibility
 
 -- | A flag for whether a name is for an private or public value - only public values will be
 -- included in a generated externs file.
@@ -251,7 +249,7 @@ data NameKind
   -- ^ A public value for a module member or foreign import declaration
   | External
   -- ^ A name for member introduced by foreign import
-  deriving (Show, Eq, Generic, A.FromJSON, A.ToJSON)
+  deriving (Show, Eq, Generic)
 
 instance NFData NameKind
 instance Serialise NameKind
@@ -272,8 +270,6 @@ data TypeKind
 
 instance NFData TypeKind
 instance Serialise TypeKind
-instance A.FromJSON TypeKind
-instance A.ToJSON TypeKind
 
 -- | The type ('data' or 'newtype') of a data type declaration
 data DataDeclType
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index b4392fc415..fb374a7737 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -57,7 +57,6 @@ import System.FilePath (makeRelative)
 import Text.PrettyPrint.Boxes qualified as Box
 import Witherable (wither)
 import Codec.Serialise (Serialise)
-import Data.Aeson (FromJSON, ToJSON)
 
 -- | A type of error messages
 data SimpleErrorMessage
@@ -201,12 +200,12 @@ data SimpleErrorMessage
   | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool
   | CannotSkipTypeApplication SourceType
   | CannotApplyExpressionOfTypeOnType SourceType SourceType
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 data ErrorMessage = ErrorMessage
   [ErrorMessageHint]
   SimpleErrorMessage
-  deriving (Show, Generic, Serialise, FromJSON, ToJSON, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 newtype ErrorSuggestion = ErrorSuggestion Text
 
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 7f00f3fe48..51c8b76aa5 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -1,12 +1,14 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 
 module Language.PureScript.LspSimple (main) where
 
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index f0f219ef22..e5df3610bf 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -1,22 +1,26 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 -- |
 -- Data types for names
+--
 module Language.PureScript.Names where
 
+import Prelude
+
 import Codec.Serialise (Serialise)
 import Control.Applicative ((<|>))
+import Control.Monad.Supply.Class (MonadSupply(..))
 import Control.DeepSeq (NFData)
-import Control.Monad.Supply.Class (MonadSupply (..))
-import Data.Aeson (FromJSON (..), FromJSONKey (..), Options (..), SumEncoding (..), ToJSON (..), ToJSONKey (..), defaultOptions, parseJSON2, toJSON2, withArray)
-import Data.Aeson qualified as A
 import Data.Functor.Contravariant (contramap)
-import Data.Text (Text)
-import Data.Text qualified as T
 import Data.Vector qualified as V
+
 import GHC.Generics (Generic)
+import Data.Aeson (FromJSON(..), FromJSONKey(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..), defaultOptions, parseJSON2, toJSON2, withArray)
+import Data.Aeson.TH (deriveJSON)
+import Data.Text (Text)
+import Data.Text qualified as T
+
 import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
-import Prelude
 
 -- | A sum of the possible name types, useful for error and lint messages.
 data Name
@@ -30,13 +34,8 @@ data Name
   deriving (Eq, Ord, Show, Generic)
 
 instance NFData Name
-
 instance Serialise Name
 
-instance A.FromJSON Name
-
-instance A.ToJSON Name
-
 getIdentName :: Name -> Maybe Ident
 getIdentName (IdentName name) = Just name
 getIdentName _ = Nothing
@@ -67,49 +66,40 @@ getClassName _ = Nothing
 -- `Ident` because functions that match on `Ident` can ignore all
 -- `InternalIdent`s with a single pattern, and thus don't have to change if
 -- a new `InternalIdentData` constructor is created.
+--
 data InternalIdentData
-  = -- Used by CoreFn.Laziness
-    RuntimeLazyFactory
-  | Lazy !Text
+  -- Used by CoreFn.Laziness
+  = RuntimeLazyFactory | Lazy !Text
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData InternalIdentData
-
 instance Serialise InternalIdentData
 
-instance FromJSON InternalIdentData where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
-instance ToJSON InternalIdentData where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 -- |
 -- Names for value identifiers
+--
 data Ident
-  = -- |
-    -- An alphanumeric identifier
-    Ident Text
-  | -- |
-    -- A generated name for an identifier
-    GenIdent (Maybe Text) Integer
-  | -- |
-    -- A generated name used only for type-checking
-    UnusedIdent
-  | -- |
-    -- A generated name used only for internal transformations
-    InternalIdent !InternalIdentData
+  -- |
+  -- An alphanumeric identifier
+  --
+  = Ident Text
+  -- |
+  -- A generated name for an identifier
+  --
+  | GenIdent (Maybe Text) Integer
+  -- |
+  -- A generated name used only for type-checking
+  --
+  | UnusedIdent
+  -- |
+  -- A generated name used only for internal transformations
+  --
+  | InternalIdent !InternalIdentData
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData Ident
-
 instance Serialise Ident
 
-instance FromJSON Ident where
-  parseJSON = A.genericParseJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
-instance ToJSON Ident where
-  toJSON = A.genericToJSON defaultOptions {sumEncoding = ObjectWithSingleField}
-
 unusedIdent :: Text
 unusedIdent = "$__unused"
 
@@ -118,28 +108,28 @@ runIdent (Ident i) = i
 runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
 runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
 runIdent UnusedIdent = unusedIdent
-runIdent InternalIdent {} = error "unexpected InternalIdent"
+runIdent InternalIdent{} = error "unexpected InternalIdent"
 
 showIdent :: Ident -> Text
 showIdent = runIdent
 
-freshIdent :: (MonadSupply m) => Text -> m Ident
+freshIdent :: MonadSupply m => Text -> m Ident
 freshIdent name = GenIdent (Just name) <$> fresh
 
-freshIdent' :: (MonadSupply m) => m Ident
+freshIdent' :: MonadSupply m => m Ident
 freshIdent' = GenIdent Nothing <$> fresh
 
 isPlainIdent :: Ident -> Bool
-isPlainIdent Ident {} = True
+isPlainIdent Ident{} = True
 isPlainIdent _ = False
 
 -- |
 -- Operator alias names.
-newtype OpName (a :: OpNameType) = OpName {runOpName :: Text}
+--
+newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData (OpName a)
-
 instance Serialise (OpName a)
 
 instance ToJSON (OpName a) where
@@ -153,6 +143,7 @@ showOp op = "(" <> runOpName op <> ")"
 
 -- |
 -- The closed set of operator alias types.
+--
 data OpNameType = ValueOpName | TypeOpName | AnyOpName
 
 eraseOpName :: OpName a -> OpName 'AnyOpName
@@ -163,11 +154,11 @@ coerceOpName = OpName . runOpName
 
 -- |
 -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
-newtype ProperName (a :: ProperNameType) = ProperName {runProperName :: Text}
+--
+newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData (ProperName a)
-
 instance Serialise (ProperName a)
 
 instance ToJSON (ProperName a) where
@@ -176,31 +167,29 @@ instance ToJSON (ProperName a) where
 instance FromJSON (ProperName a) where
   parseJSON = fmap ProperName . parseJSON
 
-instance A.ToJSONKey (ProperName a)
-
-instance A.FromJSONKey (ProperName a)
-
 -- |
 -- The closed set of proper name types.
+--
 data ProperNameType
   = TypeName
   | ConstructorName
   | ClassName
   | Namespace
-  deriving (Generic, A.FromJSON, A.ToJSON)
 
 -- |
 -- Coerces a ProperName from one ProperNameType to another. This should be used
 -- with care, and is primarily used to convert ClassNames into TypeNames after
 -- classes have been desugared.
+--
 coerceProperName :: ProperName a -> ProperName b
 coerceProperName = ProperName . runProperName
 
 -- |
 -- Module names
+--
 newtype ModuleName = ModuleName Text
   deriving (Show, Eq, Ord, Generic)
-  deriving newtype (Serialise)
+  deriving newtype Serialise
 
 instance NFData ModuleName
 
@@ -222,17 +211,8 @@ pattern ByNullSourcePos :: QualifiedBy
 pattern ByNullSourcePos = BySourcePos (SourcePos 0 0)
 
 instance NFData QualifiedBy
-
 instance Serialise QualifiedBy
 
-instance A.FromJSON QualifiedBy
-
-instance A.ToJSON QualifiedBy
-
-instance A.FromJSONKey QualifiedBy
-
-instance A.ToJSONKey QualifiedBy
-
 isBySourcePos :: QualifiedBy -> Bool
 isBySourcePos (BySourcePos _) = True
 isBySourcePos _ = False
@@ -247,15 +227,15 @@ toMaybeModuleName (BySourcePos _) = Nothing
 
 -- |
 -- A qualified name, i.e. a name with an optional module name
+--
 data Qualified a = Qualified QualifiedBy a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
-instance (NFData a) => NFData (Qualified a)
-
-instance (Serialise a) => Serialise (Qualified a)
+instance NFData a => NFData (Qualified a)
+instance Serialise a => Serialise (Qualified a)
 
 showQualified :: (a -> Text) -> Qualified a -> Text
-showQualified f (Qualified (BySourcePos _) a) = f a
+showQualified f (Qualified (BySourcePos  _) a) = f a
 showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a
 
 getQual :: Qualified a -> Maybe ModuleName
@@ -263,12 +243,14 @@ getQual (Qualified qb _) = toMaybeModuleName qb
 
 -- |
 -- Provide a default module name, if a name is unqualified
+--
 qualify :: ModuleName -> Qualified a -> (ModuleName, a)
 qualify m (Qualified (BySourcePos _) a) = (m, a)
 qualify _ (Qualified (ByModuleName m) a) = (m, a)
 
 -- |
 -- Makes a qualified value from a name and module name.
+--
 mkQualified :: a -> ModuleName -> Qualified a
 mkQualified name mn = Qualified (ByModuleName mn) name
 
@@ -279,48 +261,48 @@ disqualify (Qualified _ a) = a
 -- |
 -- Remove the qualification from a value when it is qualified with a particular
 -- module name.
+--
 disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a
 disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a
 disqualifyFor _ _ = Nothing
 
 -- |
 -- Checks whether a qualified value is actually qualified with a module reference
+--
 isQualified :: Qualified a -> Bool
-isQualified (Qualified (BySourcePos _) _) = False
+isQualified (Qualified (BySourcePos  _) _) = False
 isQualified _ = True
 
 -- |
 -- Checks whether a qualified value is not actually qualified with a module reference
+--
 isUnqualified :: Qualified a -> Bool
 isUnqualified = not . isQualified
 
 -- |
 -- Checks whether a qualified value is qualified with a particular module
+--
 isQualifiedWith :: ModuleName -> Qualified a -> Bool
 isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn'
 isQualifiedWith _ _ = False
 
-instance (ToJSON a) => ToJSON (Qualified a) where
+instance ToJSON a => ToJSON (Qualified a) where
   toJSON (Qualified qb a) = case qb of
     ByModuleName mn -> toJSON2 (mn, a)
     BySourcePos ss -> toJSON2 (ss, a)
 
-instance (FromJSON a) => FromJSON (Qualified a) where
+instance FromJSON a => FromJSON (Qualified a) where
   parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName'
     where
-      byModule = do
-        (mn, a) <- parseJSON2 v
-        pure $ Qualified (ByModuleName mn) a
-      bySourcePos = do
-        (ss, a) <- parseJSON2 v
-        pure $ Qualified (BySourcePos ss) a
-      byMaybeModuleName' = do
-        (mn, a) <- parseJSON2 v
-        pure $ Qualified (byMaybeModuleName mn) a
-
-instance (ToJSON a, ToJSONKey a) => ToJSONKey (Qualified a)
-
-instance (FromJSON a, FromJSONKey a) => FromJSONKey (Qualified a)
+    byModule = do
+      (mn, a) <- parseJSON2 v
+      pure $ Qualified (ByModuleName mn) a
+    bySourcePos = do
+      (ss, a) <- parseJSON2 v
+      pure $ Qualified (BySourcePos ss) a
+    byMaybeModuleName' = do
+      (mn, a) <- parseJSON2 v
+      pure $ Qualified (byMaybeModuleName mn) a
 
 instance ToJSON ModuleName where
   toJSON (ModuleName name) = toJSON (T.splitOn "." name)
@@ -336,6 +318,5 @@ instance ToJSONKey ModuleName where
 instance FromJSONKey ModuleName where
   fromJSONKey = fmap moduleNameFromString fromJSONKey
 
-instance A.FromJSONKey Ident
-
-instance A.ToJSONKey Ident
\ No newline at end of file
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 4530fe9f0e..a26a2b24cf 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -10,7 +10,6 @@ import Language.PureScript.AST.Declarations.ChainId (ChainId)
 import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify)
 import Language.PureScript.Types (SourceConstraint, SourceType)
 import Codec.Serialise (Serialise)
-import Data.Aeson (FromJSON, ToJSON)
 
 --
 -- Data representing a type class dictionary which is in scope
@@ -43,8 +42,6 @@ data TypeClassDictionaryInScope v
 
 instance NFData v => NFData (TypeClassDictionaryInScope v)
 instance Serialise v => Serialise (TypeClassDictionaryInScope v)
-instance FromJSON v => FromJSON (TypeClassDictionaryInScope v)
-instance ToJSON v => ToJSON (TypeClassDictionaryInScope v)
 
 type NamedDict = TypeClassDictionaryInScope (Qualified Ident)
 

From 34a98d7ba33a9fb8e098c17bda9a6c0b44563f26 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Sep 2024 18:11:06 +0200
Subject: [PATCH 033/297] Revert "adds Serialise to ErrorMessage"

This reverts commit fbd65c03fe3524a1afb2c9bb8650b3e58b170264.
---
 src/Language/PureScript/AST/Binders.hs        |   3 +-
 src/Language/PureScript/AST/Declarations.hs   | 761 ++++++++++--------
 src/Language/PureScript/AST/Literals.hs       |   3 +-
 src/Language/PureScript/Bundle.hs             | 475 ++++++-----
 src/Language/PureScript/CST/Errors.hs         |   8 +-
 src/Language/PureScript/CST/Layout.hs         |   3 +-
 src/Language/PureScript/CST/Types.hs          | 313 ++++---
 src/Language/PureScript/Environment.hs        |   5 +-
 src/Language/PureScript/Errors.hs             |   5 +-
 src/Language/PureScript/LspSimple.hs          |  17 +-
 .../PureScript/TypeClassDictionaries.hs       |   2 -
 11 files changed, 797 insertions(+), 798 deletions(-)

diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 236cfb468a..1f427755f0 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -13,7 +13,6 @@ import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified)
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Types (SourceType)
-import Codec.Serialise (Serialise)
 
 -- |
 -- Data type for binders
@@ -65,7 +64,7 @@ data Binder
   -- A binder with a type annotation
   --
   | TypedBinder SourceType Binder
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Show, Generic, NFData)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 7a2ab064b6..cf0c83a42d 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -3,50 +3,54 @@
 
 -- |
 -- Data types for modules and declarations
+--
 module Language.PureScript.AST.Declarations where
 
+import Prelude
+import Protolude.Exceptions (hush)
+
 import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
-import Data.Aeson.TH (Options (..), SumEncoding (..), defaultOptions, deriveJSON)
-import Data.Functor.Identity (Identity (..))
-import Data.List.NonEmpty qualified as NEL
+import Data.Functor.Identity (Identity(..))
+
+import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON)
 import Data.Map qualified as M
 import Data.Text (Text)
+import Data.List.NonEmpty qualified as NEL
 import GHC.Generics (Generic)
+
 import Language.PureScript.AST.Binders (Binder)
-import Language.PureScript.AST.Declarations.ChainId (ChainId)
-import Language.PureScript.AST.Literals (Literal (..))
+import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.AST.Operators (Fixity)
 import Language.PureScript.AST.SourcePos (SourceAnn, SourceSpan)
-import Language.PureScript.Comments (Comment)
-import Language.PureScript.Constants.Prim qualified as C
-import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
-import Language.PureScript.Label (Label)
-import Language.PureScript.Names (Ident (..), ModuleName (..), Name (..), OpName, OpNameType (..), ProperName, ProperNameType (..), Qualified (..), QualifiedBy (..), toMaybeModuleName, pattern ByNullSourcePos)
+import Language.PureScript.AST.Declarations.ChainId (ChainId)
+import Language.PureScript.Types (SourceConstraint, SourceType)
 import Language.PureScript.PSString (PSString)
+import Language.PureScript.Label (Label)
+import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), toMaybeModuleName)
 import Language.PureScript.Roles (Role)
 import Language.PureScript.TypeClassDictionaries (NamedDict)
-import Language.PureScript.Types (SourceConstraint, SourceType)
-import Protolude.Exceptions (hush)
-import Prelude
+import Language.PureScript.Comments (Comment)
+import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
+import Language.PureScript.Constants.Prim qualified as C
 
 -- | A map of locally-bound names in scope.
 type Context = [(Ident, SourceType)]
 
 -- | Holds the data necessary to do type directed search for typed holes
 data TypeSearch
-  = -- | An Environment captured for later consumption by type directed search
-    TSBefore Environment
-  | -- | Results of applying type directed search to the previously captured
-    -- Environment
-    TSAfter
-      { -- | The identifiers that fully satisfy the subsumption check
-        tsAfterIdentifiers :: [(Qualified Text, SourceType)],
-        -- | Record fields that are available on the first argument to the typed
-        -- hole
-        tsAfterRecordFields :: Maybe [(Label, SourceType)]
-      }
-  deriving (Show, Generic, Serialise, NFData)
+  = TSBefore Environment
+  -- ^ An Environment captured for later consumption by type directed search
+  | TSAfter
+  -- ^ Results of applying type directed search to the previously captured
+  -- Environment
+    { tsAfterIdentifiers :: [(Qualified Text, SourceType)]
+    -- ^ The identifiers that fully satisfy the subsumption check
+    , tsAfterRecordFields :: Maybe [(Label, SourceType)]
+    -- ^ Record fields that are available on the first argument to the typed
+    -- hole
+    }
+  deriving (Show, Generic, NFData)
 
 onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch
 onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f)
@@ -86,7 +90,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, NFData)
 
 -- | Categories of hints
 data HintCategory
@@ -108,12 +112,13 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, NFData)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
 -- a list of declarations, and a list of the declarations that are
 -- explicitly exported. If the export list is Nothing, everything is exported.
+--
 data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef])
   deriving (Show)
 
@@ -134,60 +139,71 @@ getModuleDeclarations (Module _ _ _ declarations _) = declarations
 --
 -- Will not import an unqualified module if that module has already been imported qualified.
 -- (See #2197)
+--
 addDefaultImport :: Qualified ModuleName -> Module -> Module
 addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) =
-  if isExistingImport `any` decls || mn == toImport
-    then m
-    else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs' : decls) exps
+  if isExistingImport `any` decls || mn == toImport then m
+  else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs' : decls) exps
   where
-    toImportAs' = toMaybeModuleName toImportAs
+  toImportAs' = toMaybeModuleName toImportAs
 
-    isExistingImport (ImportDeclaration _ mn' _ as')
-      | mn' == toImport =
-          case toImportAs' of
-            Nothing -> True
-            _ -> as' == toImportAs'
-    isExistingImport _ = False
+  isExistingImport (ImportDeclaration _ mn' _ as')
+    | mn' == toImport =
+        case toImportAs' of
+          Nothing -> True
+          _ -> as' == toImportAs'
+  isExistingImport _ = False
 
 -- | Adds import declarations to a module for an implicit Prim import and Prim
 -- | qualified as Prim, as necessary.
 importPrim :: Module -> Module
 importPrim =
-  let primModName = C.M_Prim
-   in addDefaultImport (Qualified (ByModuleName primModName) primModName)
-        . addDefaultImport (Qualified ByNullSourcePos primModName)
+  let
+    primModName = C.M_Prim
+  in
+    addDefaultImport (Qualified (ByModuleName primModName) primModName)
+      . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
   deriving (Show, Generic, NFData, Serialise)
 
 -- |
 -- An item in a list of explicit imports or exports
+--
 data DeclarationRef
-  = -- |
-    -- A type class
-    TypeClassRef SourceSpan (ProperName 'ClassName)
-  | -- |
-    -- A type operator
-    TypeOpRef SourceSpan (OpName 'TypeOpName)
-  | -- |
-    -- A type constructor with data constructors
-    TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
-  | -- |
-    -- A value
-    ValueRef SourceSpan Ident
-  | -- |
-    -- A value-level operator
-    ValueOpRef SourceSpan (OpName 'ValueOpName)
-  | -- |
-    -- A type class instance, created during typeclass desugaring
-    TypeInstanceRef SourceSpan Ident NameSource
-  | -- |
-    -- A module, in its entirety
-    ModuleRef SourceSpan ModuleName
-  | -- |
-    -- A value re-exported from another module. These will be inserted during
-    -- elaboration in name desugaring.
-    ReExportRef SourceSpan ExportSource DeclarationRef
+  -- |
+  -- A type class
+  --
+  = TypeClassRef SourceSpan (ProperName 'ClassName)
+  -- |
+  -- A type operator
+  --
+  | TypeOpRef SourceSpan (OpName 'TypeOpName)
+  -- |
+  -- A type constructor with data constructors
+  --
+  | TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
+  -- |
+  -- A value
+  --
+  | ValueRef SourceSpan Ident
+  -- |
+  -- A value-level operator
+  --
+  | ValueOpRef SourceSpan (OpName 'ValueOpName)
+  -- |
+  -- A type class instance, created during typeclass desugaring
+  --
+  | TypeInstanceRef SourceSpan Ident NameSource
+  -- |
+  -- A module, in its entirety
+  --
+  | ModuleRef SourceSpan ModuleName
+  -- |
+  -- A value re-exported from another module. These will be inserted during
+  -- elaboration in name desugaring.
+  --
+  | ReExportRef SourceSpan ExportSource DeclarationRef
   deriving (Show, Generic, NFData, Serialise)
 
 instance Eq DeclarationRef where
@@ -212,20 +228,21 @@ instance Ord DeclarationRef where
   ReExportRef _ mn ref `compare` ReExportRef _ mn' ref' = compare mn mn' <> compare ref ref'
   compare ref ref' =
     compare (orderOf ref) (orderOf ref')
-    where
-      orderOf :: DeclarationRef -> Int
-      orderOf TypeClassRef {} = 0
-      orderOf TypeOpRef {} = 1
-      orderOf TypeRef {} = 2
-      orderOf ValueRef {} = 3
-      orderOf ValueOpRef {} = 4
-      orderOf TypeInstanceRef {} = 5
-      orderOf ModuleRef {} = 6
-      orderOf ReExportRef {} = 7
-
-data ExportSource = ExportSource
-  { exportSourceImportedFrom :: Maybe ModuleName,
-    exportSourceDefinedIn :: ModuleName
+      where
+        orderOf :: DeclarationRef -> Int
+        orderOf TypeClassRef{} = 0
+        orderOf TypeOpRef{} = 1
+        orderOf TypeRef{} = 2
+        orderOf ValueRef{} = 3
+        orderOf ValueOpRef{} = 4
+        orderOf TypeInstanceRef{} = 5
+        orderOf ModuleRef{} = 6
+        orderOf ReExportRef{} = 7
+
+data ExportSource =
+  ExportSource
+  { exportSourceImportedFrom :: Maybe ModuleName
+  , exportSourceDefinedIn :: ModuleName
   }
   deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
@@ -270,21 +287,25 @@ getTypeClassRef (TypeClassRef _ name) = Just name
 getTypeClassRef _ = Nothing
 
 isModuleRef :: DeclarationRef -> Bool
-isModuleRef ModuleRef {} = True
+isModuleRef ModuleRef{} = True
 isModuleRef _ = False
 
 -- |
 -- The data type which specifies type of import declaration
+--
 data ImportDeclarationType
-  = -- |
-    -- An import with no explicit list: `import M`.
-    Implicit
-  | -- |
-    -- An import with an explicit list of references to import: `import M (foo)`
-    Explicit [DeclarationRef]
-  | -- |
-    -- An import with a list of references to hide: `import M hiding (foo)`
-    Hiding [DeclarationRef]
+  -- |
+  -- An import with no explicit list: `import M`.
+  --
+  = Implicit
+  -- |
+  -- An import with an explicit list of references to import: `import M (foo)`
+  --
+  | Explicit [DeclarationRef]
+  -- |
+  -- An import with a list of references to hide: `import M hiding (foo)`
+  --
+  | Hiding [DeclarationRef]
   deriving (Eq, Show, Generic, Serialise, NFData)
 
 isExplicit :: ImportDeclarationType -> Bool
@@ -299,11 +320,10 @@ isExplicit _ = False
 -- In this example, @T@ is the identifier and @[representational, phantom]@ is
 -- the list of roles (@T@ presumably having two parameters).
 data RoleDeclarationData = RoleDeclarationData
-  { rdeclSourceAnn :: !SourceAnn,
-    rdeclIdent :: !(ProperName 'TypeName),
-    rdeclRoles :: ![Role]
-  }
-  deriving (Show, Eq, Generic, Serialise, NFData)
+  { rdeclSourceAnn :: !SourceAnn
+  , rdeclIdent :: !(ProperName 'TypeName)
+  , rdeclRoles :: ![Role]
+  } deriving (Show, Eq, Generic, NFData)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -311,11 +331,10 @@ data RoleDeclarationData = RoleDeclarationData
 --
 -- In this example @identity@ is the identifier and @forall a. a -> a@ the type.
 data TypeDeclarationData = TypeDeclarationData
-  { tydeclSourceAnn :: !SourceAnn,
-    tydeclIdent :: !Ident,
-    tydeclType :: !SourceType
-  }
-  deriving (Show, Eq, Generic, Serialise, NFData)
+  { tydeclSourceAnn :: !SourceAnn
+  , tydeclIdent :: !Ident
+  , tydeclType :: !SourceType
+  } deriving (Show, Eq, Generic, NFData)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -330,97 +349,109 @@ unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td)
 --
 -- In this example @double@ is the identifier, @x@ is a binder and @x + x@ is the expression.
 data ValueDeclarationData a = ValueDeclarationData
-  { valdeclSourceAnn :: !SourceAnn,
-    -- | The declared value's name
-    valdeclIdent :: !Ident,
-    -- | Whether or not this value is exported/visible
-    valdeclName :: !NameKind,
-    valdeclBinders :: ![Binder],
-    valdeclExpression :: !a
-  }
-  deriving (Show, Functor, Generic, Serialise, NFData, Foldable, Traversable)
+  { valdeclSourceAnn :: !SourceAnn
+  , valdeclIdent :: !Ident
+  -- ^ The declared value's name
+  , valdeclName :: !NameKind
+  -- ^ Whether or not this value is exported/visible
+  , valdeclBinders :: ![Binder]
+  , valdeclExpression :: !a
+  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
 getValueDeclaration _ = Nothing
 
 pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
-pattern ValueDecl sann ident name binders expr =
-  ValueDeclaration (ValueDeclarationData sann ident name binders expr)
+pattern ValueDecl sann ident name binders expr
+  = ValueDeclaration (ValueDeclarationData sann ident name binders expr)
 
 data DataConstructorDeclaration = DataConstructorDeclaration
-  { dataCtorAnn :: !SourceAnn,
-    dataCtorName :: !(ProperName 'ConstructorName),
-    dataCtorFields :: ![(Ident, SourceType)]
-  }
-  deriving (Show, Eq, Generic, Serialise, NFData)
+  { dataCtorAnn :: !SourceAnn
+  , dataCtorName :: !(ProperName 'ConstructorName)
+  , dataCtorFields :: ![(Ident, SourceType)]
+  } deriving (Show, Eq, Generic, NFData)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
-mapDataCtorFields f DataConstructorDeclaration {..} = DataConstructorDeclaration {dataCtorFields = f dataCtorFields, ..}
+mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. }
 
-traverseDataCtorFields :: (Monad m) => ([(Ident, SourceType)] -> m [(Ident, SourceType)]) -> DataConstructorDeclaration -> m DataConstructorDeclaration
-traverseDataCtorFields f DataConstructorDeclaration {..} = DataConstructorDeclaration dataCtorAnn dataCtorName <$> f dataCtorFields
+traverseDataCtorFields :: Monad m => ([(Ident, SourceType)] -> m [(Ident, SourceType)]) -> DataConstructorDeclaration -> m DataConstructorDeclaration
+traverseDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration dataCtorAnn dataCtorName <$> f dataCtorFields
 
 -- |
 -- The data type of declarations
+--
 data Declaration
-  = -- |
-    -- A data type declaration (data or newtype, name, arguments, data constructors)
-    DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceType)] [DataConstructorDeclaration]
-  | -- |
-    -- A minimal mutually recursive set of data type declarations
-    DataBindingGroupDeclaration (NEL.NonEmpty Declaration)
-  | -- |
-    -- A type synonym declaration (name, arguments, type)
-    TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceType)] SourceType
-  | -- |
-    -- A kind signature declaration
-    KindDeclaration SourceAnn KindSignatureFor (ProperName 'TypeName) SourceType
-  | -- |
-    -- A role declaration (name, roles)
-    RoleDeclaration {-# UNPACK #-} !RoleDeclarationData
-  | -- |
-    -- A type declaration for a value (name, ty)
-    TypeDeclaration {-# UNPACK #-} !TypeDeclarationData
-  | -- |
-    -- A value declaration (name, top-level binders, optional guard, value)
-    ValueDeclaration {-# UNPACK #-} !(ValueDeclarationData [GuardedExpr])
-  | -- |
-    -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value)
-    BoundValueDeclaration SourceAnn Binder Expr
-  | -- |
-    -- A minimal mutually recursive set of value declarations
-    BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr))
-  | -- |
-    -- A foreign import declaration (name, type)
-    ExternDeclaration SourceAnn Ident SourceType
-  | -- |
-    -- A data type foreign import (name, kind)
-    ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceType
-  | -- |
-    -- A fixity declaration
-    FixityDeclaration SourceAnn (Either ValueFixity TypeFixity)
-  | -- |
-    -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
-    ImportDeclaration SourceAnn ModuleName ImportDeclarationType (Maybe ModuleName)
-  | -- |
-    -- A type class declaration (name, argument, implies, member declarations)
-    TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceType)] [SourceConstraint] [FunctionalDependency] [Declaration]
-  | -- |
-    -- A type instance declaration (instance chain, chain index, name,
-    -- dependencies, class name, instance types, member declarations)
-    --
-    -- The first @SourceAnn@ serves as the annotation for the entire
-    -- declaration, while the second @SourceAnn@ serves as the
-    -- annotation for the type class and its arguments.
-    TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
-  deriving (Show, Generic, Serialise, NFData)
+  -- |
+  -- A data type declaration (data or newtype, name, arguments, data constructors)
+  --
+  = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceType)] [DataConstructorDeclaration]
+  -- |
+  -- A minimal mutually recursive set of data type declarations
+  --
+  | DataBindingGroupDeclaration (NEL.NonEmpty Declaration)
+  -- |
+  -- A type synonym declaration (name, arguments, type)
+  --
+  | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceType)] SourceType
+  -- |
+  -- A kind signature declaration
+  --
+  | KindDeclaration SourceAnn KindSignatureFor (ProperName 'TypeName) SourceType
+  -- |
+  -- A role declaration (name, roles)
+  --
+  | RoleDeclaration {-# UNPACK #-} !RoleDeclarationData
+  -- |
+  -- A type declaration for a value (name, ty)
+  --
+  | TypeDeclaration {-# UNPACK #-} !TypeDeclarationData
+  -- |
+  -- A value declaration (name, top-level binders, optional guard, value)
+  --
+  | ValueDeclaration {-# UNPACK #-} !(ValueDeclarationData [GuardedExpr])
+  -- |
+  -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value)
+  | BoundValueDeclaration SourceAnn Binder Expr
+  -- |
+  -- A minimal mutually recursive set of value declarations
+  --
+  | BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr))
+  -- |
+  -- A foreign import declaration (name, type)
+  --
+  | ExternDeclaration SourceAnn Ident SourceType
+  -- |
+  -- A data type foreign import (name, kind)
+  --
+  | ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceType
+  -- |
+  -- A fixity declaration
+  --
+  | FixityDeclaration SourceAnn (Either ValueFixity TypeFixity)
+  -- |
+  -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
+  --
+  | ImportDeclaration SourceAnn ModuleName ImportDeclarationType (Maybe ModuleName)
+  -- |
+  -- A type class declaration (name, argument, implies, member declarations)
+  --
+  | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceType)] [SourceConstraint] [FunctionalDependency] [Declaration]
+  -- |
+  -- A type instance declaration (instance chain, chain index, name,
+  -- dependencies, class name, instance types, member declarations)
+  --
+  -- The first @SourceAnn@ serves as the annotation for the entire
+  -- declaration, while the second @SourceAnn@ serves as the
+  -- annotation for the type class and its arguments.
+  | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
+  deriving (Show, Generic, NFData)
 
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
-  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData)
 
 data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
-  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData)
 
 pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
 pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))
@@ -431,17 +462,17 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, NFData)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
-  = -- | This is a derived instance
-    DerivedInstance
-  | -- | This is an instance derived from a newtype
-    NewtypeInstance
-  | -- | This is a regular (explicit) instance
-    ExplicitInstance [Declaration]
-  deriving (Show, Generic, Serialise, NFData)
+  = DerivedInstance
+  -- ^ This is a derived instance
+  | NewtypeInstance
+  -- ^ This is an instance derived from a newtype
+  | ExplicitInstance [Declaration]
+  -- ^ This is a regular (explicit) instance
+  deriving (Show, Generic, NFData)
 
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -457,7 +488,7 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, NFData)
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -492,54 +523,61 @@ declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n)
 declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n)
 declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n)
 declName (TypeInstanceDeclaration _ _ _ _ n _ _ _ _) = IdentName <$> hush n
-declName (RoleDeclaration RoleDeclarationData {..}) = Just (TyName rdeclIdent)
-declName ImportDeclaration {} = Nothing
-declName BindingGroupDeclaration {} = Nothing
-declName DataBindingGroupDeclaration {} = Nothing
-declName BoundValueDeclaration {} = Nothing
-declName KindDeclaration {} = Nothing
-declName TypeDeclaration {} = Nothing
+declName (RoleDeclaration RoleDeclarationData{..}) = Just (TyName rdeclIdent)
+declName ImportDeclaration{} = Nothing
+declName BindingGroupDeclaration{} = Nothing
+declName DataBindingGroupDeclaration{} = Nothing
+declName BoundValueDeclaration{} = Nothing
+declName KindDeclaration{} = Nothing
+declName TypeDeclaration{} = Nothing
 
 -- |
 -- Test if a declaration is a value declaration
+--
 isValueDecl :: Declaration -> Bool
-isValueDecl ValueDeclaration {} = True
+isValueDecl ValueDeclaration{} = True
 isValueDecl _ = False
 
 -- |
 -- Test if a declaration is a data type declaration
+--
 isDataDecl :: Declaration -> Bool
-isDataDecl DataDeclaration {} = True
+isDataDecl DataDeclaration{} = True
 isDataDecl _ = False
 
 -- |
 -- Test if a declaration is a type synonym declaration
+--
 isTypeSynonymDecl :: Declaration -> Bool
-isTypeSynonymDecl TypeSynonymDeclaration {} = True
+isTypeSynonymDecl TypeSynonymDeclaration{} = True
 isTypeSynonymDecl _ = False
 
 -- |
 -- Test if a declaration is a module import
+--
 isImportDecl :: Declaration -> Bool
-isImportDecl ImportDeclaration {} = True
+isImportDecl ImportDeclaration{} = True
 isImportDecl _ = False
 
 -- |
 -- Test if a declaration is a role declaration
+--
 isRoleDecl :: Declaration -> Bool
-isRoleDecl RoleDeclaration {} = True
+isRoleDecl RoleDeclaration{} = True
 isRoleDecl _ = False
 
 -- |
 -- Test if a declaration is a data type foreign import
+--
 isExternDataDecl :: Declaration -> Bool
-isExternDataDecl ExternDataDeclaration {} = True
+isExternDataDecl ExternDataDeclaration{} = True
 isExternDataDecl _ = False
 
 -- |
 -- Test if a declaration is a fixity declaration
+--
 isFixityDecl :: Declaration -> Bool
-isFixityDecl FixityDeclaration {} = True
+isFixityDecl FixityDeclaration{} = True
 isFixityDecl _ = False
 
 getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity)
@@ -548,195 +586,234 @@ getFixityDecl _ = Nothing
 
 -- |
 -- Test if a declaration is a foreign import
+--
 isExternDecl :: Declaration -> Bool
-isExternDecl ExternDeclaration {} = True
+isExternDecl ExternDeclaration{} = True
 isExternDecl _ = False
 
 -- |
 -- Test if a declaration is a type class instance declaration
+--
 isTypeClassInstanceDecl :: Declaration -> Bool
-isTypeClassInstanceDecl TypeInstanceDeclaration {} = True
+isTypeClassInstanceDecl TypeInstanceDeclaration{} = True
 isTypeClassInstanceDecl _ = False
 
 -- |
 -- Test if a declaration is a type class declaration
+--
 isTypeClassDecl :: Declaration -> Bool
-isTypeClassDecl TypeClassDeclaration {} = True
+isTypeClassDecl TypeClassDeclaration{} = True
 isTypeClassDecl _ = False
 
 -- |
 -- Test if a declaration is a kind signature declaration.
+--
 isKindDecl :: Declaration -> Bool
-isKindDecl KindDeclaration {} = True
+isKindDecl KindDeclaration{} = True
 isKindDecl _ = False
 
 -- |
 -- Recursively flatten data binding groups in the list of declarations
 flattenDecls :: [Declaration] -> [Declaration]
 flattenDecls = concatMap flattenOne
-  where
-    flattenOne :: Declaration -> [Declaration]
-    flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
-    flattenOne d = [d]
+    where flattenOne :: Declaration -> [Declaration]
+          flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
+          flattenOne d = [d]
 
 -- |
 -- A guard is just a boolean-valued expression that appears alongside a set of binders
-data Guard
-  = ConditionGuard Expr
-  | PatternGuard Binder Expr
-  deriving (Show, Generic, Serialise, NFData)
+--
+data Guard = ConditionGuard Expr
+           | PatternGuard Binder Expr
+           deriving (Show, Generic, NFData)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-  deriving (Show, Generic, Serialise, NFData)
+                 deriving (Show, Generic, NFData)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
 
 -- |
 -- Data type for expressions and terms
+--
 data Expr
-  = -- |
-    -- A literal value
-    Literal SourceSpan (Literal Expr)
-  | -- |
-    -- A prefix -, will be desugared
-    UnaryMinus SourceSpan Expr
-  | -- |
-    -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
-    -- will be removed.
-    BinaryNoParens Expr Expr Expr
-  | -- |
-    -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
-    -- will be removed.
-    --
-    -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents
-    -- certain traversals from matching.
-    Parens Expr
-  | -- |
-    -- An record property accessor expression (e.g. `obj.x` or `_.x`).
-    -- Anonymous arguments will be removed during desugaring and expanded
-    -- into a lambda that reads a property from a record.
-    Accessor PSString Expr
-  | -- |
-    -- Partial record update
-    ObjectUpdate Expr [(PSString, Expr)]
-  | -- |
-    -- Object updates with nested support: `x { foo { bar = e } }`
-    -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s
-    ObjectUpdateNested Expr (PathTree Expr)
-  | -- |
-    -- Function introduction
-    Abs Binder Expr
-  | -- |
-    -- Function application
-    App Expr Expr
-  | -- |
-    -- A type application (e.g. `f @Int`)
-    VisibleTypeApp Expr SourceType
-  | -- |
-    -- Hint that an expression is unused.
-    -- This is used to ignore type class dictionaries that are necessarily empty.
-    -- The inner expression lets us solve subgoals before eliminating the whole expression.
-    -- The code gen will render this as `undefined`, regardless of what the inner expression is.
-    Unused Expr
-  | -- |
-    -- Variable
-    Var SourceSpan (Qualified Ident)
-  | -- |
-    -- An operator. This will be desugared into a function during the "operators"
-    -- phase of desugaring.
-    Op SourceSpan (Qualified (OpName 'ValueOpName))
-  | -- |
-    -- Conditional (if-then-else expression)
-    IfThenElse Expr Expr Expr
-  | -- |
-    -- A data constructor
-    Constructor SourceSpan (Qualified (ProperName 'ConstructorName))
-  | -- |
-    -- A case expression. During the case expansion phase of desugaring, top-level binders will get
-    -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
-    Case [Expr] [CaseAlternative]
-  | -- |
-    -- A value with a type annotation
-    TypedValue Bool Expr SourceType
-  | -- |
-    -- A let binding
-    Let WhereProvenance [Declaration] Expr
-  | -- |
-    -- A do-notation block
-    Do (Maybe ModuleName) [DoNotationElement]
-  | -- |
-    -- An ado-notation block
-    Ado (Maybe ModuleName) [DoNotationElement] Expr
-  | -- |
-    -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
-    -- placeholders will be replaced with actual expressions representing type classes dictionaries which
-    -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
-    -- at superclass implementations when searching for a dictionary, the type class name and
-    -- instance type, and the type class dictionaries in scope.
-    TypeClassDictionary
-      SourceConstraint
-      (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-      [ErrorMessageHint]
-  | -- |
-    -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
-    DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType]
-  | -- |
-    -- A placeholder for a type class instance to be derived during typechecking
-    DerivedInstancePlaceholder (Qualified (ProperName 'ClassName)) InstanceDerivationStrategy
-  | -- |
-    -- A placeholder for an anonymous function argument
-    AnonymousArgument
-  | -- |
-    -- A typed hole that will be turned into a hint/error during typechecking
-    Hole Text
-  | -- |
-    -- A value with source position information
-    PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, Serialise, NFData)
+  -- |
+  -- A literal value
+  --
+  = Literal SourceSpan (Literal Expr)
+  -- |
+  -- A prefix -, will be desugared
+  --
+  | UnaryMinus SourceSpan Expr
+  -- |
+  -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
+  -- will be removed.
+  --
+  | BinaryNoParens Expr Expr Expr
+  -- |
+  -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
+  -- will be removed.
+  --
+  -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents
+  -- certain traversals from matching.
+  --
+  | Parens Expr
+  -- |
+  -- An record property accessor expression (e.g. `obj.x` or `_.x`).
+  -- Anonymous arguments will be removed during desugaring and expanded
+  -- into a lambda that reads a property from a record.
+  --
+  | Accessor PSString Expr
+  -- |
+  -- Partial record update
+  --
+  | ObjectUpdate Expr [(PSString, Expr)]
+  -- |
+  -- Object updates with nested support: `x { foo { bar = e } }`
+  -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s
+  --
+  | ObjectUpdateNested Expr (PathTree Expr)
+  -- |
+  -- Function introduction
+  --
+  | Abs Binder Expr
+  -- |
+  -- Function application
+  --
+  | App Expr Expr
+  -- |
+  -- A type application (e.g. `f @Int`)
+  --
+  | VisibleTypeApp Expr SourceType
+  -- |
+  -- Hint that an expression is unused.
+  -- This is used to ignore type class dictionaries that are necessarily empty.
+  -- The inner expression lets us solve subgoals before eliminating the whole expression.
+  -- The code gen will render this as `undefined`, regardless of what the inner expression is.
+  | Unused Expr
+  -- |
+  -- Variable
+  --
+  | Var SourceSpan (Qualified Ident)
+  -- |
+  -- An operator. This will be desugared into a function during the "operators"
+  -- phase of desugaring.
+  --
+  | Op SourceSpan (Qualified (OpName 'ValueOpName))
+  -- |
+  -- Conditional (if-then-else expression)
+  --
+  | IfThenElse Expr Expr Expr
+  -- |
+  -- A data constructor
+  --
+  | Constructor SourceSpan (Qualified (ProperName 'ConstructorName))
+  -- |
+  -- A case expression. During the case expansion phase of desugaring, top-level binders will get
+  -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
+  --
+  | Case [Expr] [CaseAlternative]
+  -- |
+  -- A value with a type annotation
+  --
+  | TypedValue Bool Expr SourceType
+  -- |
+  -- A let binding
+  --
+  | Let WhereProvenance [Declaration] Expr
+  -- |
+  -- A do-notation block
+  --
+  | Do (Maybe ModuleName) [DoNotationElement]
+  -- |
+  -- An ado-notation block
+  --
+  | Ado (Maybe ModuleName) [DoNotationElement] Expr
+  -- |
+  -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
+  -- placeholders will be replaced with actual expressions representing type classes dictionaries which
+  -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
+  -- at superclass implementations when searching for a dictionary, the type class name and
+  -- instance type, and the type class dictionaries in scope.
+  --
+  | TypeClassDictionary SourceConstraint
+                        (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
+                        [ErrorMessageHint]
+  -- |
+  -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
+  --
+  | DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType]
+  -- |
+  -- A placeholder for a type class instance to be derived during typechecking
+  --
+  | DerivedInstancePlaceholder (Qualified (ProperName 'ClassName)) InstanceDerivationStrategy
+  -- |
+  -- A placeholder for an anonymous function argument
+  --
+  | AnonymousArgument
+  -- |
+  -- A typed hole that will be turned into a hint/error during typechecking
+  --
+  | Hole Text
+  -- |
+  -- A value with source position information
+  --
+  | PositionedValue SourceSpan [Comment] Expr
+  deriving (Show, Generic, NFData)
 
 -- |
 -- Metadata that tells where a let binding originated
+--
 data WhereProvenance
-  = -- |
-    -- The let binding was originally a where clause
-    FromWhere
-  | -- |
-    -- The let binding was always a let binding
-    FromLet
-  deriving (Show, Generic, Serialise, NFData)
+  -- |
+  -- The let binding was originally a where clause
+  --
+  = FromWhere
+  -- |
+  -- The let binding was always a let binding
+  --
+  | FromLet
+  deriving (Show, Generic, NFData)
 
 -- |
 -- An alternative in a case statement
+--
 data CaseAlternative = CaseAlternative
   { -- |
     -- A collection of binders with which to match the inputs
-    caseAlternativeBinders :: [Binder],
+    --
+    caseAlternativeBinders :: [Binder]
     -- |
     -- The result expression or a collect of guarded expressions
-    caseAlternativeResult :: [GuardedExpr]
-  }
-  deriving (Show, Generic, Serialise, NFData)
+    --
+  , caseAlternativeResult :: [GuardedExpr]
+  } deriving (Show, Generic, NFData)
 
 -- |
 -- A statement in a do-notation block
+--
 data DoNotationElement
-  = -- |
-    -- A monadic value without a binder
-    DoNotationValue Expr
-  | -- |
-    -- A monadic value with a binder
-    DoNotationBind Binder Expr
-  | -- |
-    -- A let statement, i.e. a pure value with a binder
-    DoNotationLet [Declaration]
-  | -- |
-    -- A do notation element with source position information
-    PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
-  deriving (Show, Generic, Serialise, NFData)
+  -- |
+  -- A monadic value without a binder
+  --
+  = DoNotationValue Expr
+  -- |
+  -- A monadic value with a binder
+  --
+  | DoNotationBind Binder Expr
+  -- |
+  -- A let statement, i.e. a pure value with a binder
+  --
+  | DoNotationLet [Declaration]
+  -- |
+  -- A do notation element with source position information
+  --
+  | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
+  deriving (Show, Generic, NFData)
+
 
 -- For a record update such as:
 --
@@ -762,24 +839,20 @@ data DoNotationElement
 --
 
 newtype PathTree t = PathTree (AssocList PSString (PathNode t))
-  deriving (Show, Eq, Ord, Functor, Foldable, Generic, Traversable)
-  deriving newtype (NFData)
-
-instance (Serialise t) => Serialise (PathTree t)
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+  deriving newtype NFData
 
 data PathNode t = Leaf t | Branch (PathTree t)
-  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable, Serialise)
-
-newtype AssocList k t = AssocList {runAssocList :: [(k, t)]}
-  deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic)
-  deriving newtype (NFData)
+  deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)
 
-instance (Serialise t, Serialise k) => Serialise (AssocList k t)
+newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
+  deriving (Show, Eq, Ord, Foldable, Functor, Traversable)
+  deriving newtype NFData
 
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''NameSource)
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ExportSource)
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''DeclarationRef)
-$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''ImportDeclarationType)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
 
 isTrueExpr :: Expr -> Bool
 isTrueExpr (Literal _ (BooleanLiteral True)) = True
diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index c723fbd219..05e06ab8f9 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -8,7 +8,6 @@ import Prelude
 import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 import Language.PureScript.PSString (PSString)
-import Codec.Serialise.Class qualified as S
 
 -- |
 -- Data type for literal values. Parameterised so it can be used for Exprs and
@@ -39,4 +38,4 @@ data Literal a
   -- An object literal
   --
   | ObjectLiteral [(PSString, a)]
-  deriving (Eq, Ord, Show, Functor, Generic, S.Serialise, NFData)
+  deriving (Eq, Ord, Show, Functor, Generic, NFData)
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index a5705e2f96..f40cc44e9f 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -1,38 +1,39 @@
-{-# LANGUAGE DeriveAnyClass #-}
-
 -- |
 -- Bundles compiled PureScript modules for the browser.
 --
 -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
 -- performs dead code elimination, filters empty modules,
 -- and generates the final JavaScript bundle.
+{-# LANGUAGE DeriveAnyClass #-}
 module Language.PureScript.Bundle
-  ( ModuleIdentifier (..),
-    ModuleType (..),
-    ErrorMessage (..),
-    printErrorMessage,
-    ForeignModuleExports (..),
-    getExportedIdentifiers,
-    ForeignModuleImports (..),
-    getImportedModules,
-    Module,
-  )
-where
-
-import Codec.Serialise qualified as S
+  ( ModuleIdentifier(..)
+  , ModuleType(..)
+  , ErrorMessage(..)
+  , printErrorMessage
+  , ForeignModuleExports(..)
+  , getExportedIdentifiers
+  , ForeignModuleImports(..)
+  , getImportedModules
+  , Module
+  ) where
+
+import Prelude
+
 import Control.DeepSeq (NFData)
-import Control.Monad.Error.Class (MonadError (..))
+import Control.Monad.Error.Class (MonadError(..))
+
 import Data.Aeson ((.=))
-import Data.Aeson qualified as A
 import Data.Char (chr, digitToInt)
 import Data.Foldable (fold)
 import Data.Maybe (mapMaybe, maybeToList)
+import Data.Aeson qualified as A
 import Data.Text.Lazy qualified as LT
+
 import GHC.Generics (Generic)
-import Language.JavaScript.Parser (JSAST (..), JSAnnot (..), JSAssignOp (..), JSExpression (..), JSStatement (..), renderToText)
-import Language.JavaScript.Parser.AST (JSCommaList (..), JSCommaTrailingList (..), JSExportClause (..), JSExportDeclaration (..), JSExportSpecifier (..), JSFromClause (..), JSIdent (..), JSImportDeclaration (..), JSModuleItem (..), JSObjectProperty (..), JSObjectPropertyList, JSPropertyName (..), JSVarInitializer (..))
+
+import Language.JavaScript.Parser (JSAST(..), JSAnnot(..), JSAssignOp(..), JSExpression(..), JSStatement(..), renderToText)
+import Language.JavaScript.Parser.AST (JSCommaList(..), JSCommaTrailingList(..), JSExportClause(..), JSExportDeclaration(..), JSExportSpecifier(..), JSFromClause(..), JSIdent(..), JSImportDeclaration(..), JSModuleItem(..), JSObjectProperty(..), JSObjectPropertyList, JSPropertyName(..), JSVarInitializer(..))
 import Language.JavaScript.Process.Minify (minifyJS)
-import Prelude
 
 -- | The type of error messages. We separate generation and rendering of errors using a data
 -- type, in case we need to match on error types later.
@@ -45,14 +46,14 @@ data ErrorMessage
   | ErrorInModule ModuleIdentifier ErrorMessage
   | MissingEntryPoint String
   | MissingMainModule String
-  deriving (Show, Generic, S.Serialise, NFData)
+  deriving (Show, Generic, NFData)
 
 -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
 -- foreign modules.
 data ModuleType
   = Regular
   | Foreign
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 showModuleType :: ModuleType -> String
 showModuleType Regular = "Regular"
@@ -60,14 +61,13 @@ showModuleType Foreign = "Foreign"
 
 -- | A module is identified by its module name and its type.
 data ModuleIdentifier = ModuleIdentifier String ModuleType
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 instance A.ToJSON ModuleIdentifier where
   toJSON (ModuleIdentifier name mt) =
-    A.object
-      [ "name" .= name,
-        "type" .= show mt
-      ]
+    A.object [ "name" .= name
+             , "type" .= show mt
+             ]
 
 data Visibility
   = Public
@@ -107,115 +107,107 @@ data ModuleElement
 instance A.ToJSON ModuleElement where
   toJSON = \case
     (Import _ name (Right target)) ->
-      A.object
-        [ "type" .= A.String "Import",
-          "name" .= name,
-          "target" .= target
-        ]
+      A.object [ "type"   .= A.String "Import"
+               , "name"   .= name
+               , "target" .= target
+               ]
     (Import _ name (Left targetPath)) ->
-      A.object
-        [ "type" .= A.String "Import",
-          "name" .= name,
-          "targetPath" .= targetPath
-        ]
+      A.object [ "type"       .= A.String "Import"
+               , "name"       .= name
+               , "targetPath" .= targetPath
+               ]
     (Member _ visibility name _ dependsOn) ->
-      A.object
-        [ "type" .= A.String "Member",
-          "name" .= name,
-          "visibility" .= show visibility,
-          "dependsOn" .= map keyToJSON dependsOn
-        ]
+      A.object [ "type"       .= A.String "Member"
+               , "name"       .= name
+               , "visibility" .= show visibility
+               , "dependsOn"  .= map keyToJSON dependsOn
+               ]
     (ExportsList exports) ->
-      A.object
-        [ "type" .= A.String "ExportsList",
-          "exports" .= map exportToJSON exports
-        ]
+      A.object [ "type"    .= A.String "ExportsList"
+               , "exports" .= map exportToJSON exports
+               ]
     (Other stmt) ->
-      A.object
-        [ "type" .= A.String "Other",
-          "js" .= getFragment (JSAstStatement stmt JSNoAnnot)
-        ]
+      A.object [ "type" .= A.String "Other"
+               , "js"   .= getFragment (JSAstStatement stmt JSNoAnnot)
+               ]
     (Skip item) ->
-      A.object
-        [ "type" .= A.String "Skip",
-          "js" .= getFragment (JSAstModule [item] JSNoAnnot)
-        ]
+      A.object [ "type" .= A.String "Skip"
+               , "js"   .= getFragment (JSAstModule [item] JSNoAnnot)
+               ]
+
     where
-      keyToJSON (mid, member, visibility) =
-        A.object
-          [ "module" .= mid,
-            "member" .= member,
-            "visibility" .= show visibility
-          ]
-
-      exportToJSON (RegularExport sourceName, name, _, dependsOn) =
-        A.object
-          [ "type" .= A.String "RegularExport",
-            "name" .= name,
-            "sourceName" .= sourceName,
-            "dependsOn" .= map keyToJSON dependsOn
-          ]
-      exportToJSON (ForeignReexport, name, _, dependsOn) =
-        A.object
-          [ "type" .= A.String "ForeignReexport",
-            "name" .= name,
-            "dependsOn" .= map keyToJSON dependsOn
-          ]
-
-      getFragment = ellipsize . renderToText . minifyJS
-        where
-          ellipsize text = if LT.compareLength text 20 == GT then LT.take 19 text `LT.snoc` ellipsis else text
-          ellipsis = '\x2026'
+
+    keyToJSON (mid, member, visibility) =
+      A.object [ "module"     .= mid
+               , "member"     .= member
+               , "visibility" .= show visibility
+               ]
+
+    exportToJSON (RegularExport sourceName, name, _, dependsOn) =
+      A.object [ "type"       .= A.String "RegularExport"
+               , "name"       .= name
+               , "sourceName" .= sourceName
+               , "dependsOn"  .= map keyToJSON dependsOn
+               ]
+    exportToJSON (ForeignReexport, name, _, dependsOn) =
+      A.object [ "type"      .= A.String "ForeignReexport"
+               , "name"      .= name
+               , "dependsOn" .= map keyToJSON dependsOn
+               ]
+
+    getFragment = ellipsize . renderToText . minifyJS
+      where
+      ellipsize text = if LT.compareLength text 20 == GT then LT.take 19 text `LT.snoc` ellipsis else text
+      ellipsis = '\x2026'
 
 -- | A module is just a list of elements of the types listed above.
 data Module = Module ModuleIdentifier (Maybe FilePath) [ModuleElement] deriving (Show)
 
 instance A.ToJSON Module where
   toJSON (Module moduleId filePath elements) =
-    A.object
-      [ "moduleId" .= moduleId,
-        "filePath" .= filePath,
-        "elements" .= elements
-      ]
+    A.object [ "moduleId" .= moduleId
+             , "filePath" .= filePath
+             , "elements" .= elements
+             ]
 
 -- | Prepare an error message for consumption by humans.
 printErrorMessage :: ErrorMessage -> [String]
 printErrorMessage (UnsupportedModulePath s) =
-  [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ").",
-    "The following file names are supported:",
-    "  1) index.js (PureScript native modules)",
-    "  2) foreign.js (PureScript ES foreign modules)",
-    "  3) foreign.cjs (PureScript CommonJS foreign modules)"
+  [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ")."
+  , "The following file names are supported:"
+  , "  1) index.js (PureScript native modules)"
+  , "  2) foreign.js (PureScript ES foreign modules)"
+  , "  3) foreign.cjs (PureScript CommonJS foreign modules)"
   ]
 printErrorMessage InvalidTopLevel =
-  ["Expected a list of source elements at the top level."]
+  [ "Expected a list of source elements at the top level." ]
 printErrorMessage (UnableToParseModule err) =
-  [ "The module could not be parsed:",
-    err
+  [ "The module could not be parsed:"
+  , err
   ]
 printErrorMessage UnsupportedImport =
-  [ "An import was unsupported.",
-    "Modules can be imported with ES namespace imports declarations:",
-    "  import * as module from \"Module.Name\"",
-    "Alternatively, they can be also be imported with the CommonJS require function:",
-    "  var module = require(\"Module.Name\")"
+  [ "An import was unsupported."
+  , "Modules can be imported with ES namespace imports declarations:"
+  , "  import * as module from \"Module.Name\""
+  , "Alternatively, they can be also be imported with the CommonJS require function:"
+  , "  var module = require(\"Module.Name\")"
   ]
 printErrorMessage UnsupportedExport =
-  [ "An export was unsupported.",
-    "Declarations can be exported as ES named exports:",
-    "  export var decl",
-    "Existing identifiers can be exported as well:",
-    "  export { name }",
-    "They can also be renamed on export:",
-    "  export { name as alias }",
-    "Alternatively, CommonJS exports can be defined in one of two ways:",
-    "  1) exports.name = value",
-    "  2) exports = { name: value }"
+  [ "An export was unsupported."
+  , "Declarations can be exported as ES named exports:"
+  , "  export var decl"
+  , "Existing identifiers can be exported as well:"
+  , "  export { name }"
+  , "They can also be renamed on export:"
+  , "  export { name as alias }"
+  , "Alternatively, CommonJS exports can be defined in one of two ways:"
+  , "  1) exports.name = value"
+  , "  2) exports = { name: value }"
   ]
 printErrorMessage (ErrorInModule mid e) =
   ("Error in module " ++ displayIdentifier mid ++ ":")
-    : ""
-    : map ("  " ++) (printErrorMessage e)
+  : ""
+  : map ("  " ++) (printErrorMessage e)
   where
     displayIdentifier (ModuleIdentifier name ty) =
       name ++ " (" ++ showModuleType ty ++ ")"
@@ -234,28 +226,28 @@ fromStringLiteral _ = Nothing
 strValue :: String -> String
 strValue str = go $ drop 1 str
   where
-    go ('\\' : 'b' : xs) = '\b' : go xs
-    go ('\\' : 'f' : xs) = '\f' : go xs
-    go ('\\' : 'n' : xs) = '\n' : go xs
-    go ('\\' : 'r' : xs) = '\r' : go xs
-    go ('\\' : 't' : xs) = '\t' : go xs
-    go ('\\' : 'v' : xs) = '\v' : go xs
-    go ('\\' : '0' : xs) = '\0' : go xs
-    go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs
-      where
-        a' = 16 * digitToInt a
-        b' = digitToInt b
-    go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs
-      where
-        a' = 16 * 16 * 16 * digitToInt a
-        b' = 16 * 16 * digitToInt b
-        c' = 16 * digitToInt c
-        d' = digitToInt d
-    go ('\\' : x : xs) = x : go xs
-    go "\"" = ""
-    go "'" = ""
-    go (x : xs) = x : go xs
-    go "" = ""
+  go ('\\' : 'b' : xs) = '\b' : go xs
+  go ('\\' : 'f' : xs) = '\f' : go xs
+  go ('\\' : 'n' : xs) = '\n' : go xs
+  go ('\\' : 'r' : xs) = '\r' : go xs
+  go ('\\' : 't' : xs) = '\t' : go xs
+  go ('\\' : 'v' : xs) = '\v' : go xs
+  go ('\\' : '0' : xs) = '\0' : go xs
+  go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs
+    where
+    a' = 16 * digitToInt a
+    b' = digitToInt b
+  go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs
+    where
+    a' = 16 * 16 * 16 * digitToInt a
+    b' = 16 * 16 * digitToInt b
+    c' = 16 * digitToInt c
+    d' = digitToInt d
+  go ('\\' : x : xs) = x : go xs
+  go "\"" = ""
+  go "'" = ""
+  go (x : xs) = x : go xs
+  go "" = ""
 
 commaList :: JSCommaList a -> [a]
 commaList JSLNil = []
@@ -288,19 +280,18 @@ exportStatementIdentifiers _ = []
 varNames :: JSCommaList JSExpression -> [String]
 varNames = mapMaybe varName . commaList
   where
-    varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident
-    varName _ = Nothing
+  varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident
+  varName _ = Nothing
 
-data ForeignModuleExports = ForeignModuleExports
-  { cjsExports :: [String],
-    esExports :: [String]
-  }
-  deriving (Show)
+data ForeignModuleExports =
+  ForeignModuleExports
+    { cjsExports :: [String]
+    , esExports :: [String]
+    } deriving (Show)
 
 instance Semigroup ForeignModuleExports where
   (ForeignModuleExports cjsExports esExports) <> (ForeignModuleExports cjsExports' esExports') =
     ForeignModuleExports (cjsExports <> cjsExports') (esExports <> esExports')
-
 instance Monoid ForeignModuleExports where
   mempty = ForeignModuleExports [] []
 
@@ -308,155 +299,149 @@ instance Monoid ForeignModuleExports where
 --
 -- TODO: what if we assign to exports.foo and then later assign to
 -- module.exports (presumably overwriting exports.foo)?
-getExportedIdentifiers ::
-  forall m.
-  (MonadError ErrorMessage m) =>
-  String ->
-  JSAST ->
-  m ForeignModuleExports
+getExportedIdentifiers :: forall m. (MonadError ErrorMessage m)
+                          => String
+                          -> JSAST
+                          -> m ForeignModuleExports
 getExportedIdentifiers mname top
   | JSAstModule jsModuleItems _ <- top = fold <$> traverse go jsModuleItems
   | otherwise = err InvalidTopLevel
   where
-    err :: ErrorMessage -> m a
-    err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
-
-    go (JSModuleStatementListItem jsStatement)
-      | Just props <- matchExportsAssignment jsStatement =
-          do
-            cjsExports <- traverse toIdent (trailingCommaList props)
-            pure ForeignModuleExports {cjsExports, esExports = []}
-      | Just (Public, name, _) <- matchMember jsStatement =
-          pure ForeignModuleExports {cjsExports = [name], esExports = []}
-      | otherwise =
-          pure mempty
-    go (JSModuleExportDeclaration _ jsExportDeclaration) =
-      pure ForeignModuleExports {cjsExports = [], esExports = exportDeclarationIdentifiers jsExportDeclaration}
-    go _ = pure mempty
-
-    toIdent (JSPropertyNameandValue name _ [_]) =
-      extractLabel' name
-    toIdent _ =
-      err UnsupportedExport
-
-    extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
-
-    exportDeclarationIdentifiers (JSExportFrom jsExportClause _ _) =
-      exportClauseIdentifiers jsExportClause
-    exportDeclarationIdentifiers (JSExportLocals jsExportClause _) =
-      exportClauseIdentifiers jsExportClause
-    exportDeclarationIdentifiers (JSExport jsStatement _) =
-      exportStatementIdentifiers jsStatement
-
-    exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) =
-      mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers
-
-    exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent
-    exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs
-
-data ForeignModuleImports = ForeignModuleImports
-  { cjsImports :: [String],
-    esImports :: [String]
-  }
-  deriving (Show)
+  err :: ErrorMessage -> m a
+  err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
+
+  go (JSModuleStatementListItem jsStatement)
+    | Just props <- matchExportsAssignment jsStatement
+    = do cjsExports <- traverse toIdent (trailingCommaList props)
+         pure ForeignModuleExports{ cjsExports, esExports = [] }
+    | Just (Public, name, _) <- matchMember jsStatement
+    = pure ForeignModuleExports{ cjsExports = [name], esExports = [] }
+    | otherwise
+    = pure mempty
+  go (JSModuleExportDeclaration _ jsExportDeclaration) =
+    pure ForeignModuleExports{ cjsExports = [], esExports = exportDeclarationIdentifiers jsExportDeclaration }
+  go _ = pure mempty
+
+  toIdent (JSPropertyNameandValue name _ [_]) =
+    extractLabel' name
+  toIdent _ =
+    err UnsupportedExport
+
+  extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
+
+  exportDeclarationIdentifiers (JSExportFrom jsExportClause _ _) =
+    exportClauseIdentifiers jsExportClause
+  exportDeclarationIdentifiers (JSExportLocals jsExportClause _) =
+    exportClauseIdentifiers jsExportClause
+  exportDeclarationIdentifiers (JSExport jsStatement _) =
+    exportStatementIdentifiers jsStatement
+
+  exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) =
+    mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers
+
+  exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent
+  exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs
+
+data ForeignModuleImports =
+  ForeignModuleImports
+    { cjsImports :: [String]
+    , esImports :: [String]
+    } deriving (Show)
 
 instance Semigroup ForeignModuleImports where
   (ForeignModuleImports cjsImports esImports) <> (ForeignModuleImports cjsImports' esImports') =
     ForeignModuleImports (cjsImports <> cjsImports') (esImports <> esImports')
-
 instance Monoid ForeignModuleImports where
   mempty = ForeignModuleImports [] []
 
 -- Get a list of all the imported module identifiers from a foreign module.
-getImportedModules ::
-  forall m.
-  (MonadError ErrorMessage m) =>
-  String ->
-  JSAST ->
-  m ForeignModuleImports
+getImportedModules :: forall m. (MonadError ErrorMessage m)
+                          => String
+                          -> JSAST
+                          -> m ForeignModuleImports
 getImportedModules mname top
   | JSAstModule jsModuleItems _ <- top = pure $ foldMap go jsModuleItems
   | otherwise = err InvalidTopLevel
   where
-    err :: ErrorMessage -> m a
-    err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
+  err :: ErrorMessage -> m a
+  err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)
 
-    go (JSModuleStatementListItem jsStatement)
-      | Just (_, mid) <- matchRequire jsStatement =
-          ForeignModuleImports {cjsImports = [mid], esImports = []}
-    go (JSModuleImportDeclaration _ jsImportDeclaration) =
-      ForeignModuleImports {cjsImports = [], esImports = [importDeclarationModuleId jsImportDeclaration]}
-    go _ = mempty
+  go (JSModuleStatementListItem jsStatement)
+    | Just (_, mid) <- matchRequire jsStatement
+    = ForeignModuleImports{ cjsImports = [mid], esImports = [] }
+  go (JSModuleImportDeclaration _ jsImportDeclaration) =
+    ForeignModuleImports{ cjsImports = [], esImports = [importDeclarationModuleId jsImportDeclaration] }
+  go _ = mempty
 
-    importDeclarationModuleId (JSImportDeclaration _ (JSFromClause _ _ mid) _) = mid
-    importDeclarationModuleId (JSImportDeclarationBare _ mid _) = mid
+  importDeclarationModuleId (JSImportDeclaration _ (JSFromClause _ _ mid) _) = mid
+  importDeclarationModuleId (JSImportDeclarationBare _ mid _) = mid
 
 -- Matches JS statements like this:
 -- var ModuleName = require("file");
 matchRequire :: JSStatement -> Maybe (String, String)
 matchRequire stmt
-  | JSVariable _ jsInit _ <- stmt,
-    [JSVarInitExpression var varInit] <- commaList jsInit,
-    JSIdentifier _ importName <- var,
-    JSVarInit _ jsInitEx <- varInit,
-    JSMemberExpression req _ argsE _ <- jsInitEx,
-    JSIdentifier _ "require" <- req,
-    [Just importPath] <- map fromStringLiteral (commaList argsE) =
-      Just (importName, importPath)
-  | otherwise =
-      Nothing
+  | JSVariable _ jsInit _ <- stmt
+  , [JSVarInitExpression var varInit] <- commaList jsInit
+  , JSIdentifier _ importName <- var
+  , JSVarInit _ jsInitEx <- varInit
+  , JSMemberExpression req _ argsE _ <- jsInitEx
+  , JSIdentifier _ "require" <- req
+  , [ Just importPath ] <- map fromStringLiteral (commaList argsE)
+  = Just (importName, importPath)
+  | otherwise
+  = Nothing
 
 -- Matches JS member declarations.
 matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression)
 matchMember stmt
-  | Just (name, decl) <- matchInternalMember stmt =
-      pure (Internal, name, decl)
+  | Just (name, decl) <- matchInternalMember stmt
+  = pure (Internal, name, decl)
   -- exports.foo = expr; exports["foo"] = expr;
-  | JSAssignStatement e (JSAssign _) decl _ <- stmt,
-    Just name <- exportsAccessor e =
-      Just (Public, name, decl)
-  | otherwise =
-      Nothing
+  | JSAssignStatement e (JSAssign _) decl _ <- stmt
+  , Just name <- exportsAccessor e
+  = Just (Public, name, decl)
+  | otherwise
+  = Nothing
 
 matchInternalMember :: JSStatement -> Maybe (String, JSExpression)
 matchInternalMember stmt
   -- var foo = expr;
-  | JSVariable _ jsInit _ <- stmt,
-    [JSVarInitExpression var varInit] <- commaList jsInit,
-    JSIdentifier _ name <- var,
-    JSVarInit _ decl <- varInit =
-      pure (name, decl)
+  | JSVariable _ jsInit _ <- stmt
+  , [JSVarInitExpression var varInit] <- commaList jsInit
+  , JSIdentifier _ name <- var
+  , JSVarInit _ decl <- varInit
+  = pure (name, decl)
   -- function foo(...args) { body }
-  | JSFunction a0 jsIdent a1 args a2 body _ <- stmt,
-    JSIdentName _ name <- jsIdent =
-      pure (name, JSFunctionExpression a0 jsIdent a1 args a2 body)
-  | otherwise =
-      Nothing
+  | JSFunction a0 jsIdent a1 args a2 body _ <- stmt
+  , JSIdentName _ name <- jsIdent
+  = pure (name, JSFunctionExpression a0 jsIdent a1 args a2 body)
+  | otherwise
+  = Nothing
 
 -- Matches exports.* or exports["*"] expressions and returns the property name.
 exportsAccessor :: JSExpression -> Maybe String
 exportsAccessor (JSMemberDot exports _ nm)
-  | JSIdentifier _ "exports" <- exports,
-    JSIdentifier _ name <- nm =
-      Just name
+  | JSIdentifier _ "exports" <- exports
+  , JSIdentifier _ name <- nm
+  = Just name
 exportsAccessor (JSMemberSquare exports _ nm _)
-  | JSIdentifier _ "exports" <- exports,
-    Just name <- fromStringLiteral nm =
-      Just name
+  | JSIdentifier _ "exports" <- exports
+  , Just name <- fromStringLiteral nm
+  = Just name
 exportsAccessor _ = Nothing
 
 -- Matches assignments to module.exports, like this:
 -- module.exports = { ... }
 matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList
 matchExportsAssignment stmt
-  | JSAssignStatement e (JSAssign _) decl _ <- stmt,
-    JSMemberDot module' _ exports <- e,
-    JSIdentifier _ "module" <- module',
-    JSIdentifier _ "exports" <- exports,
-    JSObjectLiteral _ props _ <- decl =
-      Just props
-  | otherwise =
-      Nothing
+  | JSAssignStatement e (JSAssign _) decl _ <- stmt
+  , JSMemberDot module' _ exports <- e
+  , JSIdentifier _ "module" <- module'
+  , JSIdentifier _ "exports" <- exports
+  , JSObjectLiteral _ props _ <- decl
+  = Just props
+  | otherwise
+  = Nothing
 
 extractLabel :: JSPropertyName -> Maybe String
 extractLabel (JSPropertyString _ nm) = Just $ strValue nm
diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs
index 9ef54eb37a..3682f2f0a5 100644
--- a/src/Language/PureScript/CST/Errors.hs
+++ b/src/Language/PureScript/CST/Errors.hs
@@ -20,8 +20,6 @@ import Language.PureScript.CST.Layout (LayoutStack)
 import Language.PureScript.CST.Print (printToken)
 import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToken(..), Token(..))
 import Text.Printf (printf)
-import Codec.Serialise (Serialise)
-import Codec.Serialise qualified as S
 
 data ParserErrorType
   = ErrWildcardInType
@@ -61,7 +59,7 @@ data ParserErrorType
   | ErrConstraintInForeignImportSyntax
   | ErrEof
   | ErrCustom String
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 data ParserWarningType
   = WarnDeprecatedRowSyntax
@@ -69,7 +67,7 @@ data ParserWarningType
   | WarnDeprecatedKindImportSyntax
   | WarnDeprecatedKindExportSyntax
   | WarnDeprecatedCaseOfOffsideSyntax
-  deriving (Show, Eq, Ord, Generic, Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 data ParserErrorInfo a = ParserErrorInfo
   { errRange :: SourceRange
@@ -78,8 +76,6 @@ data ParserErrorInfo a = ParserErrorInfo
   , errType :: a
   } deriving (Show, Eq, Generic, NFData)
 
-instance Serialise a => Serialise (ParserErrorInfo a)
-
 type ParserError = ParserErrorInfo ParserErrorType
 type ParserWarning = ParserErrorInfo ParserWarningType
 
diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs
index d52fba78f9..2f41df6b4f 100644
--- a/src/Language/PureScript/CST/Layout.hs
+++ b/src/Language/PureScript/CST/Layout.hs
@@ -178,7 +178,6 @@ import Data.Foldable (find)
 import Data.Function ((&))
 import GHC.Generics (Generic)
 import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..))
-import Codec.Serialise qualified as S
 
 type LayoutStack = [(SourcePos, LayoutDelim)]
 
@@ -205,7 +204,7 @@ data LayoutDelim
   | LytOf
   | LytDo
   | LytAdo
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 isIndented :: LayoutDelim -> Bool
 isIndented = \case
diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs
index 084fb6f3c4..ba90f7e95b 100644
--- a/src/Language/PureScript/CST/Types.hs
+++ b/src/Language/PureScript/CST/Types.hs
@@ -1,54 +1,51 @@
 {-# LANGUAGE DeriveAnyClass #-}
-
 -- | This module contains data types for the entire PureScript surface language. Every
 -- token is represented in the tree, and every token is annotated with
 -- whitespace and comments (both leading and trailing). This means one can write
 -- an exact printer so that `print . parse = id`. Every constructor is laid out
 -- with tokens in left-to-right order. The core productions are given a slot for
 -- arbitrary annotations, however this is not used by the parser.
+
 module Language.PureScript.CST.Types where
 
-import Codec.Serialise qualified as S
+import Prelude
+
 import Control.DeepSeq (NFData)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
 import Data.Void (Void)
 import GHC.Generics (Generic)
 import Language.PureScript.Names qualified as N
-import Language.PureScript.PSString (PSString)
 import Language.PureScript.Roles qualified as R
-import Prelude
+import Language.PureScript.PSString (PSString)
 
 data SourcePos = SourcePos
-  { srcLine :: {-# UNPACK #-} !Int,
-    srcColumn :: {-# UNPACK #-} !Int
-  }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  { srcLine :: {-# UNPACK #-} !Int
+  , srcColumn :: {-# UNPACK #-} !Int
+  } deriving (Show, Eq, Ord, Generic, NFData)
 
 data SourceRange = SourceRange
-  { srcStart :: !SourcePos,
-    srcEnd :: !SourcePos
-  }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  { srcStart :: !SourcePos
+  , srcEnd :: !SourcePos
+  } deriving (Show, Eq, Ord, Generic, NFData)
 
 data Comment l
   = Comment !Text
   | Space {-# UNPACK #-} !Int
   | Line !l
-  deriving (Show, Eq, Ord, Generic, Functor, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, Functor, NFData)
 
 data LineFeed = LF | CRLF
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 data TokenAnn = TokenAnn
-  { tokRange :: !SourceRange,
-    tokLeadingComments :: ![Comment LineFeed],
-    tokTrailingComments :: ![Comment Void]
-  }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  { tokRange :: !SourceRange
+  , tokLeadingComments :: ![Comment LineFeed]
+  , tokTrailingComments :: ![Comment Void]
+  } deriving (Show, Eq, Ord, Generic, NFData)
 
 data SourceStyle = ASCII | Unicode
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 data Token
   = TokLeftParen
@@ -84,60 +81,51 @@ data Token
   | TokLayoutSep
   | TokLayoutEnd
   | TokEof
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 data SourceToken = SourceToken
-  { tokAnn :: !TokenAnn,
-    tokValue :: !Token
-  }
-  deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
+  { tokAnn :: !TokenAnn
+  , tokValue :: !Token
+  } deriving (Show, Eq, Ord, Generic, NFData)
 
 data Ident = Ident
   { getIdent :: Text
-  }
-  deriving (Show, Eq, Ord, Generic)
+  } deriving (Show, Eq, Ord, Generic)
 
 data Name a = Name
-  { nameTok :: SourceToken,
-    nameValue :: a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { nameTok :: SourceToken
+  , nameValue :: a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data QualifiedName a = QualifiedName
-  { qualTok :: SourceToken,
-    qualModule :: Maybe N.ModuleName,
-    qualName :: a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { qualTok :: SourceToken
+  , qualModule :: Maybe N.ModuleName
+  , qualName :: a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Label = Label
-  { lblTok :: SourceToken,
-    lblName :: PSString
-  }
-  deriving (Show, Eq, Ord, Generic)
+  { lblTok :: SourceToken
+  , lblName :: PSString
+  } deriving (Show, Eq, Ord, Generic)
 
 data Wrapped a = Wrapped
-  { wrpOpen :: SourceToken,
-    wrpValue :: a,
-    wrpClose :: SourceToken
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { wrpOpen :: SourceToken
+  , wrpValue :: a
+  , wrpClose :: SourceToken
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Separated a = Separated
-  { sepHead :: a,
-    sepTail :: [(SourceToken, a)]
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { sepHead :: a
+  , sepTail :: [(SourceToken, a)]
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Labeled a b = Labeled
-  { lblLabel :: a,
-    lblSep :: SourceToken,
-    lblValue :: b
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { lblLabel :: a
+  , lblSep :: SourceToken
+  , lblValue  :: b
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 type Delimited a = Wrapped (Maybe (Separated a))
-
 type DelimitedNonEmpty a = Wrapped (Separated a)
 
 data OneOrDelimited a
@@ -177,22 +165,20 @@ data Constraint a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Row a = Row
-  { rowLabels :: Maybe (Separated (Labeled Label (Type a))),
-    rowTail :: Maybe (SourceToken, Type a)
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { rowLabels :: Maybe (Separated (Labeled Label (Type a)))
+  , rowTail :: Maybe (SourceToken, Type a)
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Module a = Module
-  { modAnn :: a,
-    modKeyword :: SourceToken,
-    modNamespace :: Name N.ModuleName,
-    modExports :: Maybe (DelimitedNonEmpty (Export a)),
-    modWhere :: SourceToken,
-    modImports :: [ImportDecl a],
-    modDecls :: [Declaration a],
-    modTrailingComments :: [Comment LineFeed]
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { modAnn :: a
+  , modKeyword :: SourceToken
+  , modNamespace :: Name N.ModuleName
+  , modExports :: Maybe (DelimitedNonEmpty (Export a))
+  , modWhere :: SourceToken
+  , modImports :: [ImportDecl a]
+  , modDecls :: [Declaration a]
+  , modTrailingComments :: [Comment LineFeed]
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Export a
   = ExportValue a (Name Ident)
@@ -224,10 +210,9 @@ data Declaration a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Instance a = Instance
-  { instHead :: InstanceHead a,
-    instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a))
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { instHead :: InstanceHead a
+  , instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a))
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data InstanceBinding a
   = InstanceBindingSignature a (Labeled (Name Ident) (Type a))
@@ -235,13 +220,12 @@ data InstanceBinding a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data ImportDecl a = ImportDecl
-  { impAnn :: a,
-    impKeyword :: SourceToken,
-    impModule :: Name N.ModuleName,
-    impNames :: Maybe (Maybe SourceToken, DelimitedNonEmpty (Import a)),
-    impQual :: Maybe (SourceToken, Name N.ModuleName)
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { impAnn :: a
+  , impKeyword :: SourceToken
+  , impModule :: Name N.ModuleName
+  , impNames :: Maybe (Maybe SourceToken, DelimitedNonEmpty (Import a))
+  , impQual :: Maybe (SourceToken, Name N.ModuleName)
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Import a
   = ImportValue a (Name Ident)
@@ -252,27 +236,24 @@ data Import a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DataHead a = DataHead
-  { dataHdKeyword :: SourceToken,
-    dataHdName :: Name (N.ProperName 'N.TypeName),
-    dataHdVars :: [TypeVarBinding a]
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { dataHdKeyword :: SourceToken
+  , dataHdName :: Name (N.ProperName 'N.TypeName)
+  , dataHdVars :: [TypeVarBinding a]
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DataCtor a = DataCtor
-  { dataCtorAnn :: a,
-    dataCtorName :: Name (N.ProperName 'N.ConstructorName),
-    dataCtorFields :: [Type a]
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { dataCtorAnn :: a
+  , dataCtorName :: Name (N.ProperName 'N.ConstructorName)
+  , dataCtorFields :: [Type a]
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data ClassHead a = ClassHead
-  { clsKeyword :: SourceToken,
-    clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken),
-    clsName :: Name (N.ProperName 'N.ClassName),
-    clsVars :: [TypeVarBinding a],
-    clsFundeps :: Maybe (SourceToken, Separated ClassFundep)
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { clsKeyword :: SourceToken
+  , clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken)
+  , clsName :: Name (N.ProperName 'N.ClassName)
+  , clsVars :: [TypeVarBinding a]
+  , clsFundeps :: Maybe (SourceToken, Separated ClassFundep)
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data ClassFundep
   = FundepDetermined SourceToken (NonEmpty (Name Ident))
@@ -280,13 +261,12 @@ data ClassFundep
   deriving (Show, Eq, Ord, Generic)
 
 data InstanceHead a = InstanceHead
-  { instKeyword :: SourceToken,
-    instNameSep :: Maybe (Name Ident, SourceToken),
-    instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken),
-    instClass :: QualifiedName (N.ProperName 'N.ClassName),
-    instTypes :: [Type a]
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { instKeyword :: SourceToken
+  , instNameSep :: Maybe (Name Ident, SourceToken)
+  , instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken)
+  , instClass :: QualifiedName (N.ProperName 'N.ClassName)
+  , instTypes :: [Type a]
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Fixity
   = Infix
@@ -300,18 +280,16 @@ data FixityOp
   deriving (Show, Eq, Ord, Generic)
 
 data FixityFields = FixityFields
-  { fxtKeyword :: (SourceToken, Fixity),
-    fxtPrec :: (SourceToken, Integer),
-    fxtOp :: FixityOp
-  }
-  deriving (Show, Eq, Ord, Generic)
+  { fxtKeyword :: (SourceToken, Fixity)
+  , fxtPrec :: (SourceToken, Integer)
+  , fxtOp :: FixityOp
+  } deriving (Show, Eq, Ord, Generic)
 
 data ValueBindingFields a = ValueBindingFields
-  { valName :: Name Ident,
-    valBinders :: [Binder a],
-    valGuarded :: Guarded a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { valName :: Name Ident
+  , valBinders :: [Binder a]
+  , valGuarded :: Guarded a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Guarded a
   = Unconditional SourceToken (Where a)
@@ -319,18 +297,16 @@ data Guarded a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data GuardedExpr a = GuardedExpr
-  { grdBar :: SourceToken,
-    grdPatterns :: Separated (PatternGuard a),
-    grdSep :: SourceToken,
-    grdWhere :: Where a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { grdBar :: SourceToken
+  , grdPatterns :: Separated (PatternGuard a)
+  , grdSep :: SourceToken
+  , grdWhere :: Where a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data PatternGuard a = PatternGuard
-  { patBinder :: Maybe (Binder a, SourceToken),
-    patExpr :: Expr a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { patBinder :: Maybe (Binder a, SourceToken)
+  , patExpr :: Expr a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Foreign a
   = ForeignValue (Labeled (Name Ident) (Type a))
@@ -339,10 +315,9 @@ data Foreign a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Role = Role
-  { roleTok :: SourceToken,
-    roleValue :: R.Role
-  }
-  deriving (Show, Eq, Ord, Generic)
+  { roleTok :: SourceToken
+  , roleValue :: R.Role
+  } deriving (Show, Eq, Ord, Generic)
 
 data Expr a
   = ExprHole a (Name Ident)
@@ -384,51 +359,45 @@ data RecordUpdate a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data RecordAccessor a = RecordAccessor
-  { recExpr :: Expr a,
-    recDot :: SourceToken,
-    recPath :: Separated Label
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { recExpr :: Expr a
+  , recDot :: SourceToken
+  , recPath :: Separated Label
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Lambda a = Lambda
-  { lmbSymbol :: SourceToken,
-    lmbBinders :: NonEmpty (Binder a),
-    lmbArr :: SourceToken,
-    lmbBody :: Expr a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { lmbSymbol :: SourceToken
+  , lmbBinders :: NonEmpty (Binder a)
+  , lmbArr :: SourceToken
+  , lmbBody :: Expr a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data IfThenElse a = IfThenElse
-  { iteIf :: SourceToken,
-    iteCond :: Expr a,
-    iteThen :: SourceToken,
-    iteTrue :: Expr a,
-    iteElse :: SourceToken,
-    iteFalse :: Expr a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { iteIf :: SourceToken
+  , iteCond :: Expr a
+  , iteThen :: SourceToken
+  , iteTrue :: Expr a
+  , iteElse :: SourceToken
+  , iteFalse :: Expr a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data CaseOf a = CaseOf
-  { caseKeyword :: SourceToken,
-    caseHead :: Separated (Expr a),
-    caseOf :: SourceToken,
-    caseBranches :: NonEmpty (Separated (Binder a), Guarded a)
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { caseKeyword :: SourceToken
+  , caseHead :: Separated (Expr a)
+  , caseOf :: SourceToken
+  , caseBranches :: NonEmpty (Separated (Binder a), Guarded a)
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data LetIn a = LetIn
-  { letKeyword :: SourceToken,
-    letBindings :: NonEmpty (LetBinding a),
-    letIn :: SourceToken,
-    letBody :: Expr a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { letKeyword :: SourceToken
+  , letBindings :: NonEmpty (LetBinding a)
+  , letIn :: SourceToken
+  , letBody :: Expr a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Where a = Where
-  { whereExpr :: Expr a,
-    whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a))
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { whereExpr :: Expr a
+  , whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a))
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data LetBinding a
   = LetBindingSignature a (Labeled (Name Ident) (Type a))
@@ -437,10 +406,9 @@ data LetBinding a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DoBlock a = DoBlock
-  { doKeyword :: SourceToken,
-    doStatements :: NonEmpty (DoStatement a)
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { doKeyword :: SourceToken
+  , doStatements :: NonEmpty (DoStatement a)
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data DoStatement a
   = DoLet SourceToken (NonEmpty (LetBinding a))
@@ -449,12 +417,11 @@ data DoStatement a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data AdoBlock a = AdoBlock
-  { adoKeyword :: SourceToken,
-    adoStatements :: [DoStatement a],
-    adoIn :: SourceToken,
-    adoResult :: Expr a
-  }
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+  { adoKeyword :: SourceToken
+  , adoStatements :: [DoStatement a]
+  , adoIn :: SourceToken
+  , adoResult :: Expr a
+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 data Binder a
   = BinderWildcard a SourceToken
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 49b6a935a5..e1f857031f 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 module Language.PureScript.Environment where
 
 import Prelude
@@ -46,7 +45,7 @@ data Environment = Environment
   -- scope (ie dictionaries brought in by a constrained type).
   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
   -- ^ Type classes
-  } deriving (Show, Generic, Serialise)
+  } deriving (Show, Generic)
 
 instance NFData Environment
 
@@ -72,7 +71,7 @@ data TypeClassData = TypeClassData
   -- ^ A sets of arguments that can be used to infer all other arguments.
   , typeClassIsEmpty :: Bool
   -- ^ Whether or not dictionaries for this type class are necessarily empty.
-  } deriving (Show, Generic, Serialise)
+  } deriving (Show, Generic)
 
 instance NFData TypeClassData
 
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index fb374a7737..96b5061c7e 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -56,7 +56,6 @@ import System.Console.ANSI qualified as ANSI
 import System.FilePath (makeRelative)
 import Text.PrettyPrint.Boxes qualified as Box
 import Witherable (wither)
-import Codec.Serialise (Serialise)
 
 -- | A type of error messages
 data SimpleErrorMessage
@@ -200,12 +199,12 @@ data SimpleErrorMessage
   | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool
   | CannotSkipTypeApplication SourceType
   | CannotApplyExpressionOfTypeOnType SourceType SourceType
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, NFData)
 
 data ErrorMessage = ErrorMessage
   [ErrorMessageHint]
   SimpleErrorMessage
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Show, Generic, NFData)
 
 newtype ErrorSuggestion = ErrorSuggestion Text
 
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 51c8b76aa5..d9542e0cd1 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -12,19 +12,14 @@
 
 module Language.PureScript.LspSimple (main) where
 
-import Codec.Serialise (deserialise, serialise)
 import Control.Lens ((^.))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
-import Data.Aeson qualified as A
-import Data.ByteArray qualified as B
-import Data.ByteString.Lazy qualified as BL
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Data.Text.Encoding qualified as TE
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
@@ -140,7 +135,7 @@ handlers diagErrs =
                             Types.WorkspaceEdit
                               (Just $ Map.singleton uri textEdits)
                               Nothing
-                              (Just _)
+                              Nothing
                         )
                         Nothing
                         Nothing
@@ -221,16 +216,6 @@ rebuildFile file = do
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
 
-encodeErrorMessage :: ErrorMessage -> A.Value
-encodeErrorMessage msg = A.toJSON $ TE.decodeUtf8 $ B.concat $ BL.toChunks $ serialise msg
-
-decodeErrorMessage :: A.Value -> Either Text ErrorMessage
-decodeErrorMessage json = do
-  fromJson :: Text <- case A.fromJSON json of
-    A.Success a -> Right a
-    A.Error err -> Left $ T.pack err
-  deserialise $ toUtf8Lazy fromJson
-
 main :: IdeEnvironment -> IO Int
 main ideEnv = do
   diagErrs <- newIORef Map.empty
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index a26a2b24cf..593e8c1a8d 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -9,7 +9,6 @@ import Data.Text (Text, pack)
 import Language.PureScript.AST.Declarations.ChainId (ChainId)
 import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify)
 import Language.PureScript.Types (SourceConstraint, SourceType)
-import Codec.Serialise (Serialise)
 
 --
 -- Data representing a type class dictionary which is in scope
@@ -41,7 +40,6 @@ data TypeClassDictionaryInScope v
     deriving (Show, Functor, Foldable, Traversable, Generic)
 
 instance NFData v => NFData (TypeClassDictionaryInScope v)
-instance Serialise v => Serialise (TypeClassDictionaryInScope v)
 
 type NamedDict = TypeClassDictionaryInScope (Qualified Ident)
 

From 3c008849cf5245653dbd5b63264926aaac5eab5a Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 20 Sep 2024 01:15:01 +0200
Subject: [PATCH 034/297] add suggested type annotation in correct position

---
 src/Language/PureScript/Errors.hs    |  2 +-
 src/Language/PureScript/LspSimple.hs | 40 +++++++++++++++-------------
 2 files changed, 23 insertions(+), 19 deletions(-)

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 96b5061c7e..40cd90afbe 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -520,7 +520,7 @@ errorSuggestion err =
       ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
       ImplicitQualifiedImportReExport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule)
       HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing
-      MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedTypeSimplified ty) <> "\n"
+      MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedTypeSimplified ty)
       MissingKindDeclaration sig name ty -> suggest $ prettyPrintKindSignatureFor sig <> " " <> runProperName name <> " :: " <> T.pack (prettyPrintSuggestedTypeSimplified ty) <> "\n"
       WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedTypeSimplified ty)
       WarningParsingCSTModule pe -> do
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index d9542e0cd1..eff1947bda 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -6,9 +6,9 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
-{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 
 module Language.PureScript.LspSimple (main) where
 
@@ -20,6 +20,8 @@ import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
+import Data.Time (getCurrentTime)
+import GHC.IO (unsafePerformIO)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
@@ -36,6 +38,7 @@ import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
 import Language.PureScript.Ide.Types (IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
 import Language.PureScript.Ide.Util (runLogger)
 import Protolude
+import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
 
@@ -97,15 +100,6 @@ handlers diagErrs =
 
         errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
 
-        -- let getRanges :: [Types.Command Types.|? Types.CodeAction] -> [Types.Range]
-        --     getRanges = foldMap \case
-        --       Types.InL _ -> []
-        --       Types.InR (Types.CodeAction _ _ _ _ _ (Just (Types.WorkspaceEdit (Just edits) _ _)) _ _) ->
-        --         (getEditRange =<< Map.toList edits) : []
-        --       _ -> []
-
-        --     getEditRange :: (Uri, [Types.TextEdit]) -> [Types.Range]
-        --     getEditRange (_, edits) = edits 
         res $
           Right $
             Types.InL $
@@ -114,16 +108,15 @@ handlers diagErrs =
                     textEdits =
                       toSuggestion err
                         & maybeToList
+                        & spy "suggestion"
                           >>= suggestionToEdit
 
                     suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
+                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just errorPos@JsonErrors.ErrorPosition {..})) =
                       let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
-                          end = Types.Position (fromIntegral $ endLine) (fromIntegral $ endColumn)
-                          range = Types.Range start end
+                          end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
                        in pure $ Types.TextEdit (Types.Range start end) replacement
                     suggestionToEdit _ = []
-
                  in Types.InR $
                       Types.CodeAction
                         "Apply suggestion"
@@ -239,11 +232,22 @@ main ideEnv = do
         options = Server.defaultOptions
       }
 
+spy :: (Show a) => Text -> a -> a
+spy msg a = unsafePerformIO $ do
+  logT $ msg <> ": " <> show a
+  pure a
+
+unsafeLog :: (Show a) => a -> ()
+unsafeLog a = unsafePerformIO $ log_ a
+
 log_ :: (MonadIO m, Show a) => a -> m ()
-log_ = logToFile "log.txt" . show
+log_ = logToFile . show
 
 logT :: (MonadIO m) => Text -> m ()
-logT = logToFile "log.txt"
+logT = logToFile
 
-logToFile :: (MonadIO m) => FilePath -> Text -> m ()
-logToFile path txt = liftIO $ appendFile path $ txt <> "\n"
\ No newline at end of file
+logToFile :: (MonadIO m) => Text -> m ()
+logToFile txt = liftIO $ do
+  createDirectoryIfMissing True "logs"
+  time <- show <$> getCurrentTime
+  writeFile ("logs/" <> time <> "-----" <> T.unpack txt) $ txt <> "\n"

From 2b8b87602fd19fe33403eb72753c4a35412f88a0 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 20 Sep 2024 01:21:56 +0200
Subject: [PATCH 035/297] adds file rebuild log

---
 src/Language/PureScript/LspSimple.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index eff1947bda..232fd672a7 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -139,6 +139,7 @@ handlers diagErrs =
       let uri :: Uri
           uri = getMsgUri msg
           fileName = Types.uriToFilePath uri
+      logT $ "Rebuilding file: " <> show (uri, fileName)
       case fileName of
         Just file -> do
           res <- liftIde $ rebuildFile file

From 75ee800148fd3f4b3541be666c410f61e3309318 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 20 Sep 2024 11:41:27 +0200
Subject: [PATCH 036/297] start find completions

---
 src/Language/PureScript/Ide.hs       | 179 +++++++++++++++------------
 src/Language/PureScript/LspSimple.hs |  66 +++++++++-
 2 files changed, 160 insertions(+), 85 deletions(-)

diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 76b558755d..d0a7df6447 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -8,31 +8,28 @@
 -- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
 -- Stability   : experimental
 --
--- |
--- Interface for the psc-ide-server
 -----------------------------------------------------------------------------
-
 {-# LANGUAGE PackageImports #-}
 
+-- |
+-- Interface for the psc-ide-server
 module Language.PureScript.Ide
-       ( handleCommand
-       , loadModulesAsync
-       , findAvailableExterns
-       ) where
-
-import Protolude hiding (moduleName)
+  ( handleCommand,
+    loadModulesAsync,
+    findAvailableExterns,
+  )
+where
 
 import Control.Concurrent.Async.Lifted (mapConcurrently_)
-import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Language.PureScript qualified as P
-import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..))
+import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs)
 import Language.PureScript.Ide.CaseSplit qualified as CS
-import Language.PureScript.Ide.Command (Command(..), ImportCommand(..), ListType(..))
+import Language.PureScript.Ide.Command (Command (..), ImportCommand (..), ListType (..))
 import Language.PureScript.Ide.Completion (CompletionOptions, completionFromMatch, getCompletions, getExactCompletions, simpleExport)
-import Language.PureScript.Ide.Error (IdeError(..))
+import Language.PureScript.Ide.Error (IdeError (..))
 import Language.PureScript.Ide.Externs (readExternFile)
 import Language.PureScript.Ide.Filter (Filter)
 import Language.PureScript.Ide.Imports (parseImportsFromFile)
@@ -41,19 +38,21 @@ import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync, rebuildFileSync)
 import Language.PureScript.Ide.SourceFile (parseModulesFromFiles)
-import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState, setFocusedModules, getFocusedModules)
-import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..))
-import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn)
+import Language.PureScript.Ide.State (getAllModules, getFocusedModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState, setFocusedModules)
+import Language.PureScript.Ide.Types (Annotation (..), Ide, IdeConfiguration (..), IdeDeclarationAnn (..), IdeEnvironment (..), Success (..))
 import Language.PureScript.Ide.Usage (findUsages)
-import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist)
-import System.FilePath ((</>), normalise)
+import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn)
+import Protolude hiding (moduleName)
+import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, getDirectoryContents)
+import System.FilePath (normalise, (</>))
+import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 
 -- | Accepts a Command and runs it against psc-ide's State. This is the main
 -- entry point for the server.
-handleCommand
-  :: (Ide m, MonadLogger m, MonadError IdeError m)
-  => Command
-  -> m Success
+handleCommand ::
+  (Ide m, MonadLogger m, MonadError IdeError m) =>
+  Command ->
+  m Success
 handleCommand c = case c of
   Load [] ->
     -- Clearing the State before populating it to avoid a space leak
@@ -81,15 +80,20 @@ handleCommand c = case c of
   AddClause l wca ->
     MultilineTextResult <$> CS.addClause l wca
   FindUsages moduleName ident namespace -> do
-    Map.lookup moduleName <$> getAllModules Nothing >>= \case
-      Nothing -> throwError (GeneralError "Module not found")
-      Just decls -> do
-        case find (\d -> namespaceForDeclaration (discardAnn d) == namespace
-                    && identifierFromIdeDeclaration (discardAnn d) == ident) decls of
-          Nothing -> throwError (GeneralError "Declaration not found")
-          Just declaration -> do
-            let sourceModule = fromMaybe moduleName (declaration & _idaAnnotation & _annExportedFrom)
-            UsagesResult . foldMap toList <$> findUsages (discardAnn declaration) sourceModule
+    Map.lookup moduleName
+      <$> getAllModules Nothing >>= \case
+        Nothing -> throwError (GeneralError "Module not found")
+        Just decls -> do
+          case find
+            ( \d ->
+                namespaceForDeclaration (discardAnn d) == namespace
+                  && identifierFromIdeDeclaration (discardAnn d) == ident
+            )
+            decls of
+            Nothing -> throwError (GeneralError "Declaration not found")
+            Just declaration -> do
+              let sourceModule = fromMaybe moduleName (declaration & _idaAnnotation & _annExportedFrom)
+              UsagesResult . foldMap toList <$> findUsages (discardAnn declaration) sourceModule
   Import fp outfp _ (AddImplicitImport mn) -> do
     rs <- addImplicitImport fp mn
     answerRequest outfp rs
@@ -115,39 +119,39 @@ handleCommand c = case c of
   Quit ->
     liftIO exitSuccess
 
-findCompletions
-  :: Ide m
-  => [Filter]
-  -> Matcher IdeDeclarationAnn
-  -> Maybe P.ModuleName
-  -> CompletionOptions
-  -> m Success
+findCompletions ::
+  (Ide m) =>
+  [Filter] ->
+  Matcher IdeDeclarationAnn ->
+  Maybe P.ModuleName ->
+  CompletionOptions ->
+  m Success
 findCompletions filters matcher currentModule complOptions = do
   modules <- getAllModules currentModule
   let insertPrim = Map.union idePrimDeclarations
   pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules)))
 
-findType
-  :: Ide m
-  => Text
-  -> [Filter]
-  -> Maybe P.ModuleName
-  -> m Success
+findType ::
+  (Ide m) =>
+  Text ->
+  [Filter] ->
+  Maybe P.ModuleName ->
+  m Success
 findType search filters currentModule = do
   modules <- getAllModules currentModule
   let insertPrim = Map.union idePrimDeclarations
   pure (CompletionResult (getExactCompletions search filters (insertPrim modules)))
 
-printModules :: Ide m => m Success
+printModules :: (Ide m) => m Success
 printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames
 
-outputDirectory :: Ide m => m FilePath
+outputDirectory :: (Ide m) => m FilePath
 outputDirectory = do
   outputPath <- confOutputPath . ideConfiguration <$> ask
   cwd <- liftIO getCurrentDirectory
   pure (cwd </> outputPath)
 
-listAvailableModules :: Ide m => m Success
+listAvailableModules :: (Ide m) => m Success
 listAvailableModules = do
   oDir <- outputDirectory
   liftIO $ do
@@ -155,8 +159,14 @@ listAvailableModules = do
     let cleaned = filter (`notElem` [".", ".."]) contents
     return (ModuleList (map toS cleaned))
 
-caseSplit :: (Ide m, MonadError IdeError m) =>
-  Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success
+caseSplit ::
+  (Ide m, MonadError IdeError m) =>
+  Text ->
+  Int ->
+  Int ->
+  CS.WildcardAnnotations ->
+  Text ->
+  m Success
 caseSplit l b e csa t = do
   patterns <- CS.makePattern l b e csa <$> CS.caseSplit t
   pure (MultilineTextResult patterns)
@@ -166,7 +176,8 @@ caseSplit l b e csa t = do
 findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName]
 findAvailableExterns = do
   oDir <- outputDirectory
-  unlessM (liftIO (doesDirectoryExist oDir))
+  unlessM
+    (liftIO (doesDirectoryExist oDir))
     (throwError (GeneralError $ "Couldn't locate your output directory at: " <> T.pack (normalise oDir)))
   liftIO $ do
     directories <- getDirectoryContents oDir
@@ -183,55 +194,54 @@ findAvailableExterns = do
           doesFileExist file
 
 -- | Finds all matches for the globs specified at the commandline
-findAllSourceFiles :: Ide m => m [FilePath]
+findAllSourceFiles :: (Ide m) => m [FilePath]
 findAllSourceFiles = do
-  IdeConfiguration{..} <- ideConfiguration <$> ask
-  liftIO $ toInputGlobs $ PSCGlobs
-    { pscInputGlobs = confGlobs
-    , pscInputGlobsFromFile = confGlobsFromFile
-    , pscExcludeGlobs = confGlobsExclude
-    , pscWarnFileTypeNotFound = const $ pure ()
-    }
-
+  IdeConfiguration {..} <- ideConfiguration <$> ask
+  liftIO $
+    toInputGlobs $
+      PSCGlobs
+        { pscInputGlobs = confGlobs,
+          pscInputGlobsFromFile = confGlobsFromFile,
+          pscExcludeGlobs = confGlobsExclude,
+          pscWarnFileTypeNotFound = const $ pure ()
+        }
 
 -- | Looks up the ExternsFiles for the given Modulenames and loads them into the
 -- server state. Then proceeds to parse all the specified sourcefiles and
 -- inserts their ASTs into the state. Finally kicks off an async worker, which
 -- populates the VolatileState.
-loadModulesAsync
-  :: (Ide m, MonadError IdeError m, MonadLogger m)
-  => [P.ModuleName]
-  -> m Success
+loadModulesAsync ::
+  (Ide m, MonadError IdeError m, MonadLogger m) =>
+  [P.ModuleName] ->
+  m Success
 loadModulesAsync moduleNames = do
   tr <- loadModules moduleNames
   _ <- populateVolatileState
   pure tr
 
-loadModulesSync
-  :: (Ide m, MonadError IdeError m, MonadLogger m)
-  => [P.ModuleName]
-  -> m Success
+loadModulesSync ::
+  (Ide m, MonadError IdeError m, MonadLogger m) =>
+  [P.ModuleName] ->
+  m Success
 loadModulesSync moduleNames = do
   tr <- loadModules moduleNames
   populateVolatileStateSync
   pure tr
 
-loadModules
-  :: (Ide m, MonadError IdeError m, MonadLogger m)
-  => [P.ModuleName]
-  -> m Success
+loadModules ::
+  (Ide m, MonadError IdeError m, MonadLogger m) =>
+  [P.ModuleName] ->
+  m Success
 loadModules moduleNames = do
   focusedModules <- getFocusedModules
   -- We resolve all the modulenames to externs files and load these into memory.
   oDir <- outputDirectory
-  let
-    -- But we only load the externs files that are in the focusedModules.
-    efModules = 
-        if Set.null focusedModules then 
-          moduleNames
-        else 
-          Set.toList $ Set.fromList moduleNames `Set.intersection` focusedModules
-    efPaths =
+  let -- But we only load the externs files that are in the focusedModules.
+      efModules =
+        if Set.null focusedModules
+          then moduleNames
+          else Set.toList $ Set.fromList moduleNames `Set.intersection` focusedModules
+      efPaths =
         map (\mn -> oDir </> toS (P.runModuleName mn) </> P.externsFileName) efModules
   efiles <- traverse readExternFile efPaths
   mapConcurrently_ insertExterns efiles
@@ -244,5 +254,12 @@ loadModules moduleNames = do
     logWarnN ("Failed to parse: " <> show failures)
   mapConcurrently_ insertModule allModules
 
-  pure (TextResult ("Loaded " <> show (length efiles) <> " modules and "
-                    <> show (length allModules) <> " source files."))
+  pure
+    ( TextResult
+        ( "Loaded "
+            <> show (length efiles)
+            <> " modules and "
+            <> show (length allModules)
+            <> " source files."
+        )
+    )
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 232fd672a7..eae70749da 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -35,12 +35,19 @@ import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Ide (findAvailableExterns, loadModulesAsync)
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
-import Language.PureScript.Ide.Types (IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
+import Language.PureScript.Ide.Types (Completion, IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult), IdeDeclarationAnn, Ide)
 import Language.PureScript.Ide.Util (runLogger)
 import Protolude
 import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
+import Language.PureScript.Ide.Matcher (Matcher)
+import Language.PureScript qualified as P
+import Language.PureScript.Ide.Filter (Filter)
+import Language.PureScript.Ide.Completion (getExactCompletions, getCompletions)
+import Language.PureScript.Ide.Prim (idePrimDeclarations)
+import Language.PureScript.Ide.State (getAllModules)
+import Language.PureScript.Ide.Completion qualified as Purs.Completion
 
 type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
 
@@ -82,9 +89,9 @@ handlers diagErrs =
         sendInfoMsg $ "Config changed: " <> show cfg,
       Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
         sendInfoMsg "SMethod_SetTrace",
-      Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \msg res -> do
+      Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDiagnostic"
-        (errs, diagnostics) <- getFileDiagnotics msg
+        (errs, diagnostics) <- getFileDiagnotics req
         insertDiagnosticErrors diagErrs errs diagnostics
         res $
           Right $
@@ -131,9 +138,37 @@ handlers diagErrs =
                               Nothing
                         )
                         Nothing
-                        Nothing
+                        Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+        sendInfoMsg "SMethod_TextDocumentHover"
+        let Types.HoverParams _doc pos _workDone = req ^. LSP.params
+            Types.Position _l _c' = pos
+            -- LSP.at
+        res $
+          Right $
+            Types.InL $
+              Types.Hover
+                ( Types.InL $
+                    Types.MarkupContent Types.MarkupKind_PlainText "Hello!"
+                )
+                Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentDocumentSymbol $ \req res -> do
+        sendInfoMsg "SMethod_TextDocumentDocumentSymbol"
+        -- getCompletionsWithPrim
+        res $
+          Right $
+            Types.InL
+              []
     ]
   where
+    -- Types.DocumentSymbol
+    --   "symbol"
+    --   Nothing
+    --   Types.SymbolKind_Array
+    --   (Types.Range (Types.Position 0 0) (Types.Position 0 0))
+    --   (Types.Range (Types.Position 0 0) (Types.Position 0 0))
+    --   []
+
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
     getFileDiagnotics msg = do
       let uri :: Uri
@@ -252,3 +287,26 @@ logToFile txt = liftIO $ do
   createDirectoryIfMissing True "logs"
   time <- show <$> getCurrentTime
   writeFile ("logs/" <> time <> "-----" <> T.unpack txt) $ txt <> "\n"
+
+getCompletionsWithPrim ::
+  (Ide m) =>
+  [Filter] ->
+  Matcher IdeDeclarationAnn ->
+  Maybe P.ModuleName ->
+  Purs.Completion.CompletionOptions ->
+  m [Completion]
+getCompletionsWithPrim filters matcher currentModule complOptions = do
+  modules <- getAllModules currentModule
+  let insertPrim = Map.union idePrimDeclarations
+  pure (getCompletions filters matcher complOptions (insertPrim modules))
+
+getExactCompletionsWithPrim ::
+  (Ide m) =>
+  Text ->
+  [Filter] ->
+  Maybe P.ModuleName ->
+  m [Completion]
+getExactCompletionsWithPrim search filters currentModule = do
+  modules <- getAllModules currentModule
+  let insertPrim = Map.union idePrimDeclarations
+  pure (getExactCompletions search filters (insertPrim modules))
\ No newline at end of file

From 5ae5a27a03dea4a5a941b7501126db24a1ded0cd Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 22 Sep 2024 05:39:30 +0200
Subject: [PATCH 037/297] hover value showing

---
 purescript.cabal                     |   3 +-
 src/Language/PureScript/LSP.hs       |   5 +-
 src/Language/PureScript/LspSimple.hs | 133 +++++++++++++++++++++------
 3 files changed, 109 insertions(+), 32 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index c2fda4afa9..6e56bd0ef9 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -213,7 +213,8 @@ common defaults
     lsp-types >=2.2.0 && <3.0,
     co-log-core >= 0.3.2.0 && < 0.4,
     prettyprinter >= 1.7.0 && < 2.0,
-    unliftio-core >= 0.2.0.0 && < 0.3
+    unliftio-core >= 0.2.0.0 && < 0.3,
+    text-rope >= 0.2 && < 1.0
 
 library
   import: defaults
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index d6d1560718..82c14205fe 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -19,7 +19,8 @@ import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Server as LSP.Server
-import Language.LSP.VFS
+-- import Language.LSP.VFS  (VirtualFile(..))
+import Language.LSP.VFS  qualified as VFS
 import Prettyprinter
 import Protolude hiding (to)
 import System.IO as IO
@@ -222,7 +223,7 @@ handlers logger =
         logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info
         mdoc <- getVirtualFile doc
         case mdoc of
-          Just (VirtualFile _version str _) -> do
+          Just (VFS.VirtualFile _version str _) -> do
             logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info
           Nothing -> do
             logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info,
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index eae70749da..076d4be155 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -13,6 +13,7 @@
 module Language.PureScript.LspSimple (main) where
 
 import Control.Lens ((^.))
+import Control.Lens.Getter (to)
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
@@ -20,34 +21,38 @@ import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
+import Data.Text.Utf16.Rope.Mixed as Rope
 import Data.Time (getCurrentTime)
 import GHC.IO (unsafePerformIO)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
-import Language.LSP.Protocol.Types (Diagnostic, Uri)
+import Language.LSP.Protocol.Types (Diagnostic, UInt, Uri)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
+import Language.LSP.VFS qualified as VFS
+import Language.PureScript qualified as P
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Ide (findAvailableExterns, loadModulesAsync)
+import Language.PureScript.Ide.Completion (getCompletions, getExactCompletions)
+import Language.PureScript.Ide.Completion qualified as Purs.Completion
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
+import Language.PureScript.Ide.Filter (Filter)
+import Language.PureScript.Ide.Matcher (Matcher)
+import Language.PureScript.Ide.Prim (idePrimDeclarations)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
-import Language.PureScript.Ide.Types (Completion, IdeConfiguration (confLogLevel), IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult), IdeDeclarationAnn, Ide)
+import Language.PureScript.Ide.State (cachedRebuild, getAllModules)
+import Language.PureScript.Ide.Types (Completion (complIdentifier, complModule, complType), Ide, IdeConfiguration (confLogLevel), IdeDeclarationAnn, IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
 import Language.PureScript.Ide.Util (runLogger)
-import Protolude
+import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
-import Language.PureScript.Ide.Matcher (Matcher)
-import Language.PureScript qualified as P
-import Language.PureScript.Ide.Filter (Filter)
-import Language.PureScript.Ide.Completion (getExactCompletions, getCompletions)
-import Language.PureScript.Ide.Prim (idePrimDeclarations)
-import Language.PureScript.Ide.State (getAllModules)
-import Language.PureScript.Ide.Completion qualified as Purs.Completion
+
+-- import Language.Haskell.LSP.VFS qualified as VFS
 
 type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
 
@@ -75,6 +80,7 @@ handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
+        sendInfoMsg "SMethod_Initialized"
         void $ liftIde $ findAvailableExterns >>= loadModulesAsync
         log_ ("OA purs lsp server initialized" :: T.Text)
         sendInfoMsg "OA purs lsp server initialized",
@@ -101,7 +107,6 @@ handlers diagErrs =
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentCodeAction"
         let params = req ^. LSP.params
-            -- doc = params ^. LSP.textDocument
             diags = params ^. LSP.context . LSP.diagnostics
             uri = getMsgUri req
 
@@ -115,7 +120,6 @@ handlers diagErrs =
                     textEdits =
                       toSuggestion err
                         & maybeToList
-                        & spy "suggestion"
                           >>= suggestionToEdit
 
                     suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
@@ -141,17 +145,43 @@ handlers diagErrs =
                         Nothing,
       Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentHover"
-        let Types.HoverParams _doc pos _workDone = req ^. LSP.params
-            Types.Position _l _c' = pos
-            -- LSP.at
-        res $
-          Right $
-            Types.InL $
-              Types.Hover
-                ( Types.InL $
-                    Types.MarkupContent Types.MarkupKind_PlainText "Hello!"
-                )
-                Nothing,
+        let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
+
+        let doc =
+              docIdent
+                ^. LSP.uri
+                  . to Types.toNormalizedUri
+
+        vfMb <- Server.getVirtualFile doc
+
+        for_ vfMb \vf -> do
+          let word = getWordAt (VFS._file_text vf) pos
+          cache <- liftIde cachedRebuild
+          let moduleName' = case cache of
+                Right (Just (mName, _)) -> Just mName
+                _ -> Nothing
+
+          completions <- liftIde $ getExactCompletionsWithPrim word [] moduleName'
+          sendInfoMsg $ "Completions: " <> show (length completions)
+
+          let pursValue = case head <$> completions of
+                Right (Just completion) ->
+                  complType completion
+                    <> "\n"
+                    <> complModule completion
+                    <> "."
+                    <> complIdentifier completion
+                _ -> word
+
+          res $
+            Right $
+              Types.InL $
+                Types.Hover
+                  ( Types.InL $
+                      Types.MarkupContent Types.MarkupKind_Markdown $
+                        pursMarkdown pursValue
+                  )
+                  Nothing,
       Server.requestHandler Message.SMethod_TextDocumentDocumentSymbol $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDocumentSymbol"
         -- getCompletionsWithPrim
@@ -265,9 +295,26 @@ main ideEnv = do
                 . Server.runLspT env
             )
             liftIO,
-        options = Server.defaultOptions
+        options = lspOptions
       }
 
+syncOptions :: Types.TextDocumentSyncOptions
+syncOptions =
+  Types.TextDocumentSyncOptions
+    { Types._openClose = Just True,
+      Types._change = Just Types.TextDocumentSyncKind_Incremental,
+      Types._willSave = Just False,
+      Types._willSaveWaitUntil = Just False,
+      Types._save = Just $ Types.InR $ Types.SaveOptions $ Just False
+    }
+
+lspOptions :: Server.Options
+lspOptions =
+  Server.defaultOptions
+    { Server.optTextDocumentSync = Just syncOptions,
+      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
+    }
+
 spy :: (Show a) => Text -> a -> a
 spy msg a = unsafePerformIO $ do
   logT $ msg <> ": " <> show a
@@ -283,10 +330,15 @@ logT :: (MonadIO m) => Text -> m ()
 logT = logToFile
 
 logToFile :: (MonadIO m) => Text -> m ()
-logToFile txt = liftIO $ do
-  createDirectoryIfMissing True "logs"
-  time <- show <$> getCurrentTime
-  writeFile ("logs/" <> time <> "-----" <> T.unpack txt) $ txt <> "\n"
+logToFile txt =
+  liftIO $
+    catchError
+      ( do
+          createDirectoryIfMissing True "logs"
+          time <- show <$> getCurrentTime
+          writeFile ("logs/" <> time <> "-----" <> T.unpack txt) $ txt <> "\n"
+      )
+      (const $ pure ())
 
 getCompletionsWithPrim ::
   (Ide m) =>
@@ -309,4 +361,27 @@ getExactCompletionsWithPrim ::
 getExactCompletionsWithPrim search filters currentModule = do
   modules <- getAllModules currentModule
   let insertPrim = Map.union idePrimDeclarations
-  pure (getExactCompletions search filters (insertPrim modules))
\ No newline at end of file
+  pure (getExactCompletions search filters (insertPrim modules))
+
+getWordAt :: Rope -> Types.Position -> Text
+getWordAt file Types.Position {..} =
+  let (_, after) = splitAtLine (fromIntegral _line) file
+      (ropeLine, _) = splitAtLine 1 after
+      line' = Rope.toText ropeLine
+   in getWordOnLine line' _character
+
+getWordOnLine :: Text -> UInt -> Text
+getWordOnLine line' col =
+  let start = getWsIdx (subtract 1) (fromIntegral col) line'
+      end = getWsIdx (+ 1) (fromIntegral col) line'
+   in T.take (end - start) $ T.drop start line'
+  where
+    getWsIdx :: (Int -> Int) -> Int -> Text -> Int
+    getWsIdx _ 0 _ = 0
+    getWsIdx _ idx txt | idx >= T.length txt = idx
+    getWsIdx fn idx txt = case T.index txt idx of
+      ch | isSpace ch -> idx
+      _ -> getWsIdx fn (fn idx) txt
+
+pursMarkdown :: Text -> Text
+pursMarkdown txt = "```pureScript\n" <> txt <> "```"
\ No newline at end of file

From 461e4c23b94b60a2accf4ecbd92308c991cf7cb1 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 22 Sep 2024 06:52:44 +0200
Subject: [PATCH 038/297] types displaying on hover

---
 src/Language/PureScript/LspSimple.hs | 91 ++++++++++++++++++----------
 1 file changed, 59 insertions(+), 32 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 076d4be155..976a239dc6 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -40,12 +40,13 @@ import Language.PureScript.Ide (findAvailableExterns, loadModulesAsync)
 import Language.PureScript.Ide.Completion (getCompletions, getExactCompletions)
 import Language.PureScript.Ide.Completion qualified as Purs.Completion
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
-import Language.PureScript.Ide.Filter (Filter)
+import Language.PureScript.Ide.Filter (Filter, moduleFilter)
+import Language.PureScript.Ide.Imports (parseImportsFromFile)
 import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
 import Language.PureScript.Ide.State (cachedRebuild, getAllModules)
-import Language.PureScript.Ide.Types (Completion (complIdentifier, complModule, complType), Ide, IdeConfiguration (confLogLevel), IdeDeclarationAnn, IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
+import Language.PureScript.Ide.Types (Completion (..), Ide, IdeConfiguration (confLogLevel), IdeDeclarationAnn, IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
 import Language.PureScript.Ide.Util (runLogger)
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
@@ -144,10 +145,10 @@ handlers diagErrs =
                         Nothing
                         Nothing,
       Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentHover"
         let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
 
-        let doc =
+        let filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            doc =
               docIdent
                 ^. LSP.uri
                   . to Types.toNormalizedUri
@@ -161,16 +162,34 @@ handlers diagErrs =
                 Right (Just (mName, _)) -> Just mName
                 _ -> Nothing
 
-          completions <- liftIde $ getExactCompletionsWithPrim word [] moduleName'
-          sendInfoMsg $ "Completions: " <> show (length completions)
+          imports <-
+            filePathMb
+              & maybe (pure Nothing) (fmap hush . liftIde . parseImportsFromFile)
 
-          let pursValue = case head <$> completions of
-                Right (Just completion) ->
-                  complType completion
-                    <> "\n"
-                    <> complModule completion
-                    <> "."
-                    <> complIdentifier completion
+          let filters :: [Filter]
+              filters =
+                imports
+                  & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+              getInputModName (n, _, _) = n
+
+              insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+              insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+          sendInfoMsg $ "word: " <> show word
+          sendInfoMsg $ "word: " <> show word
+
+          completions <- liftIde $ getExactCompletionsWithPrim word filters moduleName'
+          sendInfoMsg $ "Completions: " <> show completions
+
+          completions1 <- liftIde $ getExactCompletionsWithPrim word [] moduleName'
+          sendInfoMsg $ "completions1: " <> show completions1
+
+          completions2 <- liftIde $ getExactCompletionsWithPrim "log" [] moduleName'
+          sendInfoMsg $ "completions2: " <> show completions2
+
+          let hoverInfo = case head <$> completions of
+                Right (Just completion) -> completionToHoverInfo word completion
                 _ -> word
 
           res $
@@ -178,27 +197,17 @@ handlers diagErrs =
               Types.InL $
                 Types.Hover
                   ( Types.InL $
-                      Types.MarkupContent Types.MarkupKind_Markdown $
-                        pursMarkdown pursValue
+                      Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
                   )
                   Nothing,
       Server.requestHandler Message.SMethod_TextDocumentDocumentSymbol $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDocumentSymbol"
-        -- getCompletionsWithPrim
         res $
           Right $
             Types.InL
               []
     ]
   where
-    -- Types.DocumentSymbol
-    --   "symbol"
-    --   Nothing
-    --   Types.SymbolKind_Array
-    --   (Types.Range (Types.Position 0 0) (Types.Position 0 0))
-    --   (Types.Range (Types.Position 0 0) (Types.Position 0 0))
-    --   []
-
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
     getFileDiagnotics msg = do
       let uri :: Uri
@@ -372,16 +381,34 @@ getWordAt file Types.Position {..} =
 
 getWordOnLine :: Text -> UInt -> Text
 getWordOnLine line' col =
-  let start = getWsIdx (subtract 1) (fromIntegral col) line'
-      end = getWsIdx (+ 1) (fromIntegral col) line'
+  let start = getPrevWs (fromIntegral col) line'
+      end = getNextWs (fromIntegral col) line'
    in T.take (end - start) $ T.drop start line'
   where
-    getWsIdx :: (Int -> Int) -> Int -> Text -> Int
-    getWsIdx _ 0 _ = 0
-    getWsIdx _ idx txt | idx >= T.length txt = idx
-    getWsIdx fn idx txt = case T.index txt idx of
+    getNextWs :: Int -> Text -> Int
+    getNextWs idx txt | idx >= T.length txt = idx
+    getNextWs idx txt = case T.index txt idx of
       ch | isSpace ch -> idx
-      _ -> getWsIdx fn (fn idx) txt
+      _ -> getNextWs (idx + 1) txt
+
+    getPrevWs :: Int -> Text -> Int
+    getPrevWs 0 _ = 0
+    getPrevWs idx txt = case T.index txt idx of
+      ch | isSpace ch -> idx + 1
+      _ -> getPrevWs (idx - 1) txt
 
 pursMarkdown :: Text -> Text
-pursMarkdown txt = "```pureScript\n" <> txt <> "```"
\ No newline at end of file
+pursMarkdown txt = "```pureScript\n" <> txt <> "```"
+
+completionToHoverInfo :: Text -> Completion -> Text
+completionToHoverInfo word Completion {..} =
+  typeStr <> "\n" <> fromMaybe "" complDocumentation
+  where
+    typeStr =
+      "```purescript\n"
+        <> compactTypeStr
+        <> (if showExpanded then "\n" <> expandedTypeStr else "")
+        <> "\n```"
+    showExpanded = complExpandedType /= "" && (complExpandedType /= complType)
+    compactTypeStr = word <> " :: " <> complType
+    expandedTypeStr = word <> " :: " <> complExpandedType

From 8ec5801f346b816bd2c471c71412b85c1b2bbab4 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 22 Sep 2024 07:08:08 +0200
Subject: [PATCH 039/297] remove logs

---
 src/Language/PureScript/LspSimple.hs | 10 ----------
 1 file changed, 10 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 976a239dc6..87ba23237e 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -176,17 +176,7 @@ handlers diagErrs =
               insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
               insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
 
-          sendInfoMsg $ "word: " <> show word
-          sendInfoMsg $ "word: " <> show word
-
           completions <- liftIde $ getExactCompletionsWithPrim word filters moduleName'
-          sendInfoMsg $ "Completions: " <> show completions
-
-          completions1 <- liftIde $ getExactCompletionsWithPrim word [] moduleName'
-          sendInfoMsg $ "completions1: " <> show completions1
-
-          completions2 <- liftIde $ getExactCompletionsWithPrim "log" [] moduleName'
-          sendInfoMsg $ "completions2: " <> show completions2
 
           let hoverInfo = case head <$> completions of
                 Right (Just completion) -> completionToHoverInfo word completion

From 85b1dd5ecaf2e15baef0f07eeb61809bed47236b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 23 Sep 2024 16:06:18 +0200
Subject: [PATCH 040/297] adds SMethod_TextDocumentDefinition handler but
 locations not loading

---
 src/Language/PureScript/LspSimple.hs | 92 ++++++++++++++++++++++++----
 1 file changed, 81 insertions(+), 11 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 87ba23237e..36e66842c9 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -45,8 +45,8 @@ import Language.PureScript.Ide.Imports (parseImportsFromFile)
 import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
 import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
-import Language.PureScript.Ide.State (cachedRebuild, getAllModules)
-import Language.PureScript.Ide.Types (Completion (..), Ide, IdeConfiguration (confLogLevel), IdeDeclarationAnn, IdeEnvironment (ideConfiguration), Success (RebuildSuccess, TextResult))
+import Language.PureScript.Ide.State (cachedRebuild, getAllModules, getFileState)
+import Language.PureScript.Ide.Types (Completion (..), Ide, IdeConfiguration (confLogLevel), IdeDeclarationAnn, IdeEnvironment (ideConfiguration), IdeFileState (fsModules), Success (RebuildSuccess, TextResult))
 import Language.PureScript.Ide.Util (runLogger)
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
@@ -76,7 +76,6 @@ getDiagnosticError diagErrs diags = liftIO $ Map.lookup diags <$> readIORef diag
 getDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [k] -> m (Map k a)
 getDiagnosticErrors diagErrs diags = liftIO $ flip Map.restrictKeys (Set.fromList diags) <$> readIORef diagErrs
 
--- z = combin
 handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
@@ -148,12 +147,12 @@ handlers diagErrs =
         let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
 
         let filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            doc =
+            docUri =
               docIdent
                 ^. LSP.uri
                   . to Types.toNormalizedUri
 
-        vfMb <- Server.getVirtualFile doc
+        vfMb <- Server.getVirtualFile docUri
 
         for_ vfMb \vf -> do
           let word = getWordAt (VFS._file_text vf) pos
@@ -190,12 +189,77 @@ handlers diagErrs =
                       Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
                   )
                   Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentDocumentSymbol $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentDocumentSymbol"
-        res $
-          Right $
-            Types.InL
-              []
+      Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+        sendInfoMsg "SMethod_TextDocumentDefinition"
+        let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            uri =
+              req
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to Types.toNormalizedUri
+
+            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+        vfMb <- Server.getVirtualFile uri
+
+        for_ vfMb \vf -> do
+          let word = getWordAt (VFS._file_text vf) pos
+          cache <- liftIde cachedRebuild
+          let moduleName' = case cache of
+                Right (Just (mName, _)) -> Just mName
+                _ -> Nothing
+
+          imports <-
+            filePathMb
+              & maybe (pure Nothing) (fmap hush . liftIde . parseImportsFromFile)
+
+          let filters :: [Filter]
+              filters =
+                imports
+                  & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+              getInputModName (n, _, _) = n
+
+              insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+              insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+          completions :: Either IdeError [Completion] <- liftIde $ getExactCompletionsWithPrim word filters moduleName'
+
+          sendInfoMsg $ "Completions: " <> show completions
+          let withLocation =
+                fold completions
+                  & mapMaybe
+                    ( \c -> case complLocation c of
+                        Just loc -> Just (c, loc)
+                        Nothing -> Nothing
+                    )
+                  & head
+
+          paths <- liftIde $ Map.map snd . fsModules <$> getFileState
+
+          case withLocation of
+            Just (completion, location) -> do
+              let fpMb =
+                    Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
+
+              case fpMb of
+                Nothing -> do
+                  sendInfoMsg "No file path for module"
+                  nullRes
+                Just fp ->
+                  res $
+                    Right $
+                      Types.InL $
+                        Types.Definition $
+                          Types.InL $
+                            Types.Location
+                              (Types.filePathToUri fp)
+                              (spanToRange location)
+            _ -> do
+              sendInfoMsg "No location for completion"
+              nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -259,6 +323,12 @@ handlers diagErrs =
                     Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
                   )
 
+spanToRange :: Errors.SourceSpan -> Types.Range
+spanToRange (Errors.SourceSpan _ (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+  Types.Range
+    (Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1))
+    (Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1))
+
 sendError :: IdeError -> HandlerM config ()
 sendError err =
   Server.sendNotification

From 5bbfdf13249c66e3c08a0c3d918a6afc5109aa2f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 23 Sep 2024 16:06:26 +0200
Subject: [PATCH 041/297] add Lsp files

---
 purescript.cabal                     | 2 ++
 src/Language/PureScript/Lsp/Cache.hs | 5 +++++
 src/Language/PureScript/Lsp/Types.hs | 7 +++++++
 3 files changed, 14 insertions(+)
 create mode 100644 src/Language/PureScript/Lsp/Cache.hs
 create mode 100644 src/Language/PureScript/Lsp/Types.hs

diff --git a/purescript.cabal b/purescript.cabal
index 6e56bd0ef9..1a86517bcb 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -339,6 +339,8 @@ library
     Language.PureScript.Linter.Imports
     Language.PureScript.Linter.Wildcards
     Language.PureScript.Lsp
+    Language.PureScript.Lsp.Cache
+    Language.PureScript.Lsp.Types
     Language.PureScript.LspSimple
     Language.PureScript.Make
     Language.PureScript.Make.Actions
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
new file mode 100644
index 0000000000..903b4d9281
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -0,0 +1,5 @@
+module Language.PureScript.Lsp.Cache where 
+import Language.PureScript.AST (Module)
+
+
+type Module__ = Module
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
new file mode 100644
index 0000000000..cf10eb71eb
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -0,0 +1,7 @@
+module Language.PureScript.Lsp.Types where 
+
+import Protolude 
+
+type LspM = ()
+
+x = 1
\ No newline at end of file

From 4678bd0da9b38719f2e9f52a431dd680b7836a28 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 24 Sep 2024 06:19:55 +0200
Subject: [PATCH 042/297] adds start of cache inserts

---
 purescript.cabal                     |  2 ++
 src/Language/PureScript/Ide/Types.hs | 23 +++++++------
 src/Language/PureScript/Lsp/Cache.hs | 50 ++++++++++++++++++++++++++--
 src/Language/PureScript/Lsp/DB.hs    | 25 ++++++++++++++
 src/Language/PureScript/Lsp/Types.hs | 33 +++++++++++++++---
 5 files changed, 115 insertions(+), 18 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/DB.hs

diff --git a/purescript.cabal b/purescript.cabal
index 1a86517bcb..7926d6a6b8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -198,6 +198,7 @@ common defaults
     semigroups ==0.20.*,
     semialign >=1.2.0.1 && <1.3,
     sourcemap >=0.1.7 && <0.2,
+    sqlite-simple >=0.4.18 && <0.5,
     stm >=2.5.0.2 && <2.6,
     stringsearch >=0.3.6.6 && <0.4,
     template-haskell >=2.18.0.0 && <2.19,
@@ -339,6 +340,7 @@ library
     Language.PureScript.Linter.Imports
     Language.PureScript.Linter.Wildcards
     Language.PureScript.Lsp
+    Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Types
     Language.PureScript.LspSimple
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index b9120713f5..5e96e77b7f 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -20,6 +20,7 @@ import Data.Set qualified as S
 import Language.PureScript qualified as P
 import Language.PureScript.Errors.JSON qualified as P
 import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..))
+import Codec.Serialise (Serialise)
 
 type ModuleIdent = Text
 type ModuleMap a = Map P.ModuleName a
@@ -33,43 +34,43 @@ data IdeDeclaration
   | IdeDeclValueOperator IdeValueOperator
   | IdeDeclTypeOperator IdeTypeOperator
   | IdeDeclModule P.ModuleName
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeValue = IdeValue
   { _ideValueIdent :: P.Ident
   , _ideValueType :: P.SourceType
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeType = IdeType
  { _ideTypeName :: P.ProperName 'P.TypeName
  , _ideTypeKind :: P.SourceType
  , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.SourceType)]
- } deriving (Show, Eq, Ord)
+ } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeTypeSynonym = IdeTypeSynonym
   { _ideSynonymName :: P.ProperName 'P.TypeName
   , _ideSynonymType :: P.SourceType
   , _ideSynonymKind :: P.SourceType
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeDataConstructor = IdeDataConstructor
   { _ideDtorName :: P.ProperName 'P.ConstructorName
   , _ideDtorTypeName :: P.ProperName 'P.TypeName
   , _ideDtorType :: P.SourceType
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeTypeClass = IdeTypeClass
   { _ideTCName :: P.ProperName 'P.ClassName
   , _ideTCKind :: P.SourceType
   , _ideTCInstances :: [IdeInstance]
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeInstance = IdeInstance
   { _ideInstanceModule :: P.ModuleName
   , _ideInstanceName :: P.Ident
   , _ideInstanceTypes :: [P.SourceType]
   , _ideInstanceConstraints :: Maybe [P.SourceConstraint]
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeValueOperator = IdeValueOperator
   { _ideValueOpName :: P.OpName 'P.ValueOpName
@@ -77,7 +78,7 @@ data IdeValueOperator = IdeValueOperator
   , _ideValueOpPrecedence :: P.Precedence
   , _ideValueOpAssociativity :: P.Associativity
   , _ideValueOpType :: Maybe P.SourceType
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data IdeTypeOperator = IdeTypeOperator
   { _ideTypeOpName :: P.OpName 'P.TypeOpName
@@ -85,7 +86,7 @@ data IdeTypeOperator = IdeTypeOperator
   , _ideTypeOpPrecedence :: P.Precedence
   , _ideTypeOpAssociativity :: P.Associativity
   , _ideTypeOpKind :: Maybe P.SourceType
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 _IdeDeclValue :: Traversal' IdeDeclaration IdeValue
 _IdeDeclValue f (IdeDeclValue x) = map IdeDeclValue (f x)
@@ -133,7 +134,7 @@ makeLenses ''IdeTypeOperator
 data IdeDeclarationAnn = IdeDeclarationAnn
   { _idaAnnotation :: Annotation
   , _idaDeclaration :: IdeDeclaration
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 data Annotation
   = Annotation
@@ -141,7 +142,7 @@ data Annotation
   , _annExportedFrom :: Maybe P.ModuleName
   , _annTypeAnnotation :: Maybe P.SourceType
   , _annDocumentation :: Maybe Text
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 makeLenses ''Annotation
 makeLenses ''IdeDeclarationAnn
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 903b4d9281..33b613f71f 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -1,5 +1,49 @@
-module Language.PureScript.Lsp.Cache where 
-import Language.PureScript.AST (Module)
+module Language.PureScript.Lsp.Cache where
 
+import Codec.Serialise (serialise)
+import Data.Aeson (encode)
+import Database.SQLite.Simple
+import Language.PureScript qualified as P
+import Language.PureScript.AST (Module (..))
+import Language.PureScript.Externs (ExternsFile)
+import Language.PureScript.Lsp.DB (executeNamed')
+import Language.PureScript.Lsp.Types (LspEnvironment)
+import Protolude
 
-type Module__ = Module
\ No newline at end of file
+loadModules :: (MonadIO m, MonadReader LspEnvironment m) => m ()
+loadModules = pure ()
+
+insertModule :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> ExternsFile -> Module -> m ()
+insertModule fp extern (Module P.SourceSpan {..} comments name declarations exports) = do
+  executeNamed'
+    (Query "INSERT INTO modules (name, path) VALUES (:path, :name)")
+    [ ":path" := fp,
+      "ef_version" := P.efVersion extern,
+      ":name" := P.runModuleName name,
+      ":src" := spanName,
+      ":start_col" := P.sourcePosColumn spanStart,
+      ":start_line" := P.sourcePosLine spanStart,
+      ":end_col" := P.sourcePosColumn spanEnd,
+      ":end_line" := P.sourcePosLine spanEnd,
+      "comments" := encode comments
+    ]
+
+  forM_ (P.efImports extern) $ insertEfImport name
+  forM_ declarations $ insertDeclaration name
+
+insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
+insertEfImport moduleName' ei = do
+  executeNamed'
+    (Query "INSERT INTO ef_imports (module_name, import_name) VALUES (:module_name, :import_name)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":imported_module_name" := P.runModuleName (P.eiModule ei),
+      "import_type" := serialise (P.eiImportType ei),
+      "imported_as" := fmap P.runModuleName (P.eiImportedAs ei)
+    ]
+
+insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.Declaration -> m ()
+insertDeclaration moduleName' decl = do
+  executeNamed'
+    (Query "INSERT INTO declarations (module_name, declaration) VALUES (:module_name, :declaration)")
+    [ ":module_name" := P.runModuleName moduleName',
+    ]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/DB.hs b/src/Language/PureScript/Lsp/DB.hs
new file mode 100644
index 0000000000..8fb892b58b
--- /dev/null
+++ b/src/Language/PureScript/Lsp/DB.hs
@@ -0,0 +1,25 @@
+module Language.PureScript.Lsp.DB where
+
+import Database.SQLite.Simple qualified as SQL
+import Database.SQLite.Simple.FromRow (FromRow)
+import Database.SQLite.Simple.Types (Query)
+import Language.PureScript.Lsp.Types (LspEnvironment (lspDbConnection))
+import Protolude
+
+queryNamed' ::
+  (MonadIO m, MonadReader LspEnvironment m, FromRow r) =>
+  Query ->
+  [SQL.NamedParam] ->
+  m [r]
+queryNamed' q params = do
+  conn <- asks lspDbConnection
+  liftIO $ SQL.queryNamed conn q params
+  
+executeNamed' ::
+  (MonadIO m, MonadReader LspEnvironment m) =>
+  Query ->
+  [SQL.NamedParam] ->
+  m ()
+executeNamed' q params = do
+  conn <- asks lspDbConnection
+  liftIO $ SQL.executeNamed conn q params
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index cf10eb71eb..a4226e95dc 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -1,7 +1,32 @@
-module Language.PureScript.Lsp.Types where 
+module Language.PureScript.Lsp.Types where
 
-import Protolude 
+import Protolude
+import Database.SQLite.Simple (Connection)
+import Control.Concurrent.STM (TVar)
+import Language.PureScript.Ide.Types (IdeDeclarationAnn)
+import Language.PureScript qualified as P
 
-type LspM = ()
+data LspEnvironment = LspEnvironment
+  { lspConfig :: LspConfig,
+    lspDbConnection :: Connection,
+    lspStateVar :: TVar LspState
+  }
 
-x = 1
\ No newline at end of file
+data LspConfig = LspConfig
+  { configOutputPath :: FilePath,
+    confRootDir :: FilePath,
+    confGlobs :: [FilePath]
+  }
+  deriving (Show)
+
+data LspState = LspState
+  { currentFile :: Maybe CurrentFile
+  }
+  deriving (Show)
+
+data CurrentFile = CurrentFile
+  { currentModuleName :: P.ModuleName,
+    currentExternsFile :: P.ExternsFile,
+    currentDeclarations :: [IdeDeclarationAnn]
+  }
+  deriving (Show)
\ No newline at end of file

From 382d3cd5c0d9b0d961d4d54670a216b3bb954ce8 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 24 Sep 2024 18:10:08 +0200
Subject: [PATCH 043/297] add serialise to declarations

---
 src/Language/PureScript/AST/Binders.hs      |  3 +-
 src/Language/PureScript/AST/Declarations.hs | 47 ++++++++++++---------
 src/Language/PureScript/AST/Literals.hs     |  3 +-
 3 files changed, 31 insertions(+), 22 deletions(-)

diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 1f427755f0..6ea7e1ae4c 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -13,6 +13,7 @@ import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified)
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Types (SourceType)
+import Codec.Serialise qualified as S
 
 -- |
 -- Data type for binders
@@ -64,7 +65,7 @@ data Binder
   -- A binder with a type annotation
   --
   | TypedBinder SourceType Binder
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, S.Serialise, NFData)
 
 -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing
 -- the `SourceSpan` values embedded in some of the data constructors of `Binder`
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index cf0c83a42d..f9949fdaaf 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -33,6 +33,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict)
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
 import Language.PureScript.Constants.Prim qualified as C
+import Codec.Serialise qualified as S
 
 -- | A map of locally-bound names in scope.
 type Context = [(Ident, SourceType)]
@@ -90,7 +91,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- | Categories of hints
 data HintCategory
@@ -112,7 +113,7 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
@@ -323,7 +324,7 @@ data RoleDeclarationData = RoleDeclarationData
   { rdeclSourceAnn :: !SourceAnn
   , rdeclIdent :: !(ProperName 'TypeName)
   , rdeclRoles :: ![Role]
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic,  S.Serialise, NFData)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -334,7 +335,7 @@ data TypeDeclarationData = TypeDeclarationData
   { tydeclSourceAnn :: !SourceAnn
   , tydeclIdent :: !Ident
   , tydeclType :: !SourceType
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, S.Serialise, NFData)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -356,7 +357,7 @@ data ValueDeclarationData a = ValueDeclarationData
   -- ^ Whether or not this value is exported/visible
   , valdeclBinders :: ![Binder]
   , valdeclExpression :: !a
-  } deriving (Show, Functor, Generic, NFData, Foldable, Traversable)
+  } deriving (Show, Functor, Generic, S.Serialise, NFData, Foldable, Traversable)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
@@ -370,7 +371,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration
   { dataCtorAnn :: !SourceAnn
   , dataCtorName :: !(ProperName 'ConstructorName)
   , dataCtorFields :: ![(Ident, SourceType)]
-  } deriving (Show, Eq, Generic, NFData)
+  } deriving (Show, Eq, Generic, S.Serialise, NFData)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
 mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. }
@@ -445,13 +446,13 @@ data Declaration
   -- declaration, while the second @SourceAnn@ serves as the
   -- annotation for the type class and its arguments.
   | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName)
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration
 pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op))
@@ -462,7 +463,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
@@ -472,7 +473,7 @@ data TypeInstanceBody
   -- ^ This is an instance derived from a newtype
   | ExplicitInstance [Declaration]
   -- ^ This is a regular (explicit) instance
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -488,7 +489,7 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show, Generic, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -625,13 +626,13 @@ flattenDecls = concatMap flattenOne
 --
 data Guard = ConditionGuard Expr
            | PatternGuard Binder Expr
-           deriving (Show, Generic, NFData)
+           deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-                 deriving (Show, Generic, NFData)
+                 deriving (Show, Generic, Serialise, NFData)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
@@ -762,7 +763,7 @@ data Expr
   -- A value with source position information
   --
   | PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- Metadata that tells where a let binding originated
@@ -776,7 +777,7 @@ data WhereProvenance
   -- The let binding was always a let binding
   --
   | FromLet
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- An alternative in a case statement
@@ -790,7 +791,7 @@ data CaseAlternative = CaseAlternative
     -- The result expression or a collect of guarded expressions
     --
   , caseAlternativeResult :: [GuardedExpr]
-  } deriving (Show, Generic, NFData)
+  } deriving (Show, Generic, Serialise, NFData)
 
 -- |
 -- A statement in a do-notation block
@@ -812,7 +813,7 @@ data DoNotationElement
   -- A do notation element with source position information
   --
   | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
-  deriving (Show, Generic, NFData)
+  deriving (Show, Generic, Serialise, NFData)
 
 
 -- For a record update such as:
@@ -839,16 +840,22 @@ data DoNotationElement
 --
 
 newtype PathTree t = PathTree (AssocList PSString (PathNode t))
-  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
   deriving newtype NFData
 
+instance  S.Serialise t => S.Serialise (PathTree t)
+
 data PathNode t = Leaf t | Branch (PathTree t)
   deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)
 
+instance S.Serialise t => S.Serialise (PathNode t)
+
 newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
-  deriving (Show, Eq, Ord, Foldable, Functor, Traversable)
+  deriving (Show, Eq, Ord, Foldable, Functor, Traversable, Generic)
   deriving newtype NFData
 
+instance (S.Serialise k, S.Serialise t) => S.Serialise (AssocList k t)
+
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource)
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource)
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index 05e06ab8f9..5d4db34d5c 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -8,6 +8,7 @@ import Prelude
 import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 import Language.PureScript.PSString (PSString)
+import Codec.Serialise qualified as S
 
 -- |
 -- Data type for literal values. Parameterised so it can be used for Exprs and
@@ -38,4 +39,4 @@ data Literal a
   -- An object literal
   --
   | ObjectLiteral [(PSString, a)]
-  deriving (Eq, Ord, Show, Functor, Generic, NFData)
+  deriving (Eq, Ord, Show, Functor, Generic,  S.Serialise, NFData)

From 0ca955e054e4b5561379af4dcc241551a456571b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 25 Sep 2024 11:26:42 +0200
Subject: [PATCH 044/297] add Ord instance to Declarations

---
 src/Language/PureScript/AST/Declarations.hs   | 43 +++++++++++--------
 src/Language/PureScript/Environment.hs        |  4 +-
 .../PureScript/TypeClassDictionaries.hs       |  4 +-
 3 files changed, 30 insertions(+), 21 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index f9949fdaaf..448775abee 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -91,7 +91,7 @@ data ErrorMessageHint
   | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName))
   | PositionedError (NEL.NonEmpty SourceSpan)
   | RelatedPositions (NEL.NonEmpty SourceSpan)
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 -- | Categories of hints
 data HintCategory
@@ -102,7 +102,7 @@ data HintCategory
   | SolverHint
   | DeclarationHint
   | OtherHint
-  deriving (Show, Eq)
+  deriving (Show, Eq, Ord)
 
 -- |
 -- In constraint solving, indicates whether there were `TypeUnknown`s that prevented
@@ -113,7 +113,7 @@ data UnknownsHint
   = NoUnknowns
   | Unknowns
   | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]]))
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 -- |
 -- A module declaration, consisting of comments about the module, a module name,
@@ -166,7 +166,7 @@ importPrim =
       . addDefaultImport (Qualified ByNullSourcePos primModName)
 
 data NameSource = UserNamed | CompilerNamed
-  deriving (Show, Generic, NFData, Serialise)
+  deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
 -- |
 -- An item in a list of explicit imports or exports
@@ -307,7 +307,7 @@ data ImportDeclarationType
   -- An import with a list of references to hide: `import M hiding (foo)`
   --
   | Hiding [DeclarationRef]
-  deriving (Eq, Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 isExplicit :: ImportDeclarationType -> Bool
 isExplicit (Explicit _) = True
@@ -324,7 +324,7 @@ data RoleDeclarationData = RoleDeclarationData
   { rdeclSourceAnn :: !SourceAnn
   , rdeclIdent :: !(ProperName 'TypeName)
   , rdeclRoles :: ![Role]
-  } deriving (Show, Eq, Generic,  S.Serialise, NFData)
+  } deriving (Show, Eq, Ord, Generic,  S.Serialise, NFData)
 
 -- | A type declaration assigns a type to an identifier, eg:
 --
@@ -335,7 +335,7 @@ data TypeDeclarationData = TypeDeclarationData
   { tydeclSourceAnn :: !SourceAnn
   , tydeclIdent :: !Ident
   , tydeclType :: !SourceType
-  } deriving (Show, Eq, Generic, S.Serialise, NFData)
+  } deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData
 getTypeDeclaration (TypeDeclaration d) = Just d
@@ -357,7 +357,7 @@ data ValueDeclarationData a = ValueDeclarationData
   -- ^ Whether or not this value is exported/visible
   , valdeclBinders :: ![Binder]
   , valdeclExpression :: !a
-  } deriving (Show, Functor, Generic, S.Serialise, NFData, Foldable, Traversable)
+  } deriving (Eq, Ord, Show, Functor, Generic, S.Serialise, NFData, Foldable, Traversable)
 
 getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr])
 getValueDeclaration (ValueDeclaration d) = Just d
@@ -371,7 +371,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration
   { dataCtorAnn :: !SourceAnn
   , dataCtorName :: !(ProperName 'ConstructorName)
   , dataCtorFields :: ![(Ident, SourceType)]
-  } deriving (Show, Eq, Generic, S.Serialise, NFData)
+  } deriving (Show, Eq, Ord, Generic, S.Serialise, NFData)
 
 mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration
 mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. }
@@ -446,7 +446,7 @@ data Declaration
   -- declaration, while the second @SourceAnn@ serves as the
   -- annotation for the type class and its arguments.
   | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
   deriving (Eq, Ord, Show, Generic, Serialise, NFData)
@@ -463,7 +463,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T
 data InstanceDerivationStrategy
   = KnownClassStrategy
   | NewtypeStrategy
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
@@ -473,7 +473,7 @@ data TypeInstanceBody
   -- ^ This is an instance derived from a newtype
   | ExplicitInstance [Declaration]
   -- ^ This is a regular (explicit) instance
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
@@ -508,6 +508,13 @@ declSourceAnn (ImportDeclaration sa _ _ _) = sa
 declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa
 declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _ _ _ _) = sa
 
+-- declSourceType :: Declaration -> SourceType
+-- declSourceType (DataDeclaration td _ _ _) = tydeclType td
+-- declSourceType (TypeDeclaration td) = tydeclType td
+-- declSourceType (KindDeclaration _ _ _ ty) = ty
+-- declSourceType (RoleDeclaration RoleDeclarationData{..}) = foldr (\_ ty -> SourceTypeApp ty C.TyType) C.TyType rdeclRoles
+
+
 declSourceSpan :: Declaration -> SourceSpan
 declSourceSpan = fst . declSourceAnn
 
@@ -626,13 +633,13 @@ flattenDecls = concatMap flattenOne
 --
 data Guard = ConditionGuard Expr
            | PatternGuard Binder Expr
-           deriving (Show, Generic, Serialise, NFData)
+           deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 -- |
 -- The right hand side of a binder in value declarations
 -- and case expressions.
 data GuardedExpr = GuardedExpr [Guard] Expr
-                 deriving (Show, Generic, Serialise, NFData)
+                 deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 pattern MkUnguarded :: Expr -> GuardedExpr
 pattern MkUnguarded e = GuardedExpr [] e
@@ -763,7 +770,7 @@ data Expr
   -- A value with source position information
   --
   | PositionedValue SourceSpan [Comment] Expr
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 -- |
 -- Metadata that tells where a let binding originated
@@ -777,7 +784,7 @@ data WhereProvenance
   -- The let binding was always a let binding
   --
   | FromLet
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 -- |
 -- An alternative in a case statement
@@ -791,7 +798,7 @@ data CaseAlternative = CaseAlternative
     -- The result expression or a collect of guarded expressions
     --
   , caseAlternativeResult :: [GuardedExpr]
-  } deriving (Show, Generic, Serialise, NFData)
+  } deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 -- |
 -- A statement in a do-notation block
@@ -813,7 +820,7 @@ data DoNotationElement
   -- A do notation element with source position information
   --
   | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement
-  deriving (Show, Generic, Serialise, NFData)
+  deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
 
 -- For a record update such as:
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index e1f857031f..f0595ce8aa 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -82,7 +82,7 @@ data FunctionalDependency = FunctionalDependency
   -- ^ the type arguments which determine the determined type arguments
   , fdDetermined  :: [Int]
   -- ^ the determined type arguments
-  } deriving (Show, Generic)
+  } deriving (Show, Eq, Ord, Generic)
 
 instance NFData FunctionalDependency
 instance Serialise FunctionalDependency
@@ -248,7 +248,7 @@ data NameKind
   -- ^ A public value for a module member or foreign import declaration
   | External
   -- ^ A name for member introduced by foreign import
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq, Ord, Generic)
 
 instance NFData NameKind
 instance Serialise NameKind
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 593e8c1a8d..79393ba004 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -9,6 +9,7 @@ import Data.Text (Text, pack)
 import Language.PureScript.AST.Declarations.ChainId (ChainId)
 import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify)
 import Language.PureScript.Types (SourceConstraint, SourceType)
+import Codec.Serialise (Serialise)
 
 --
 -- Data representing a type class dictionary which is in scope
@@ -37,9 +38,10 @@ data TypeClassDictionaryInScope v
     -- error messages
     , tcdDescription :: Maybe SourceType
     }
-    deriving (Show, Functor, Foldable, Traversable, Generic)
+    deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
 instance NFData v => NFData (TypeClassDictionaryInScope v)
+instance Serialise v => Serialise (TypeClassDictionaryInScope v)
 
 type NamedDict = TypeClassDictionaryInScope (Qualified Ident)
 

From 86e28651e7d1df6c7320918db81d2ca855ad7871 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 25 Sep 2024 16:01:32 +0200
Subject: [PATCH 045/297] adds rebuild for lsp

---
 purescript.cabal                              |   1 +
 src/Language/PureScript/Ide/Rebuild.hs        |   3 +-
 src/Language/PureScript/Ide/State.hs          | 466 ++++++++++--------
 src/Language/PureScript/Ide/Types.hs          |   4 +-
 src/Language/PureScript/Lsp/Cache copy        | 233 +++++++++
 src/Language/PureScript/Lsp/Cache.hs          | 266 ++++++++--
 src/Language/PureScript/Lsp/DB.hs             |  25 +-
 src/Language/PureScript/Lsp/Rebuild.hs        | 134 +++++
 src/Language/PureScript/Lsp/Types.hs          |  10 +-
 .../PureScript/Sugar/BindingGroups.hs         |   1 +
 10 files changed, 886 insertions(+), 257 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Cache copy
 create mode 100644 src/Language/PureScript/Lsp/Rebuild.hs

diff --git a/purescript.cabal b/purescript.cabal
index 7926d6a6b8..012eaadcbf 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -343,6 +343,7 @@ library
     Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Types
+    Language.PureScript.Lsp.Rebuild
     Language.PureScript.LspSimple
     Language.PureScript.Make
     Language.PureScript.Make.Actions
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index ebc34339eb..57a800d686 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -4,6 +4,7 @@ module Language.PureScript.Ide.Rebuild
   ( rebuildFileSync
   , rebuildFileAsync
   , rebuildFile
+  , updateCacheDb
   ) where
 
 import Protolude hiding (moduleName)
@@ -201,7 +202,7 @@ enableForeignCheck foreigns codegenTargets ma =
 -- module. Throws an error if there is a cyclic dependency within the
 -- ExternsFiles
 sortExterns
-  :: (Ide m, MonadError IdeError m)
+  :: (MonadError IdeError m)
   => P.Module
   -> ModuleMap P.ExternsFile
   -> m [P.ExternsFile]
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
index f11f00ad81..f4893845dd 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -8,43 +8,44 @@
 -- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
 -- Stability   : experimental
 --
--- |
--- Functions to access psc-ide's state
 -----------------------------------------------------------------------------
-
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeApplications #-}
 
+-- |
+-- Functions to access psc-ide's state
 module Language.PureScript.Ide.State
-  ( getLoadedModulenames
-  , getExternFiles
-  , getFileState
-  , resetIdeState
-  , cacheRebuild
-  , cachedRebuild
-  , insertExterns
-  , insertModule
-  , insertExternsSTM
-  , getAllModules
-  , populateVolatileState
-  , populateVolatileStateSync
-  , populateVolatileStateSTM
-  , getOutputDirectory
-  , updateCacheTimestamp
-  , getFocusedModules
-  , setFocusedModules
-  , setFocusedModulesSTM
-  -- for tests
-  , resolveOperatorsForModule
-  , resolveInstances
-  , resolveDataConstructorsForModule
-  ) where
-
-import Protolude hiding (moduleName, unzip)
+  ( getLoadedModulenames,
+    getExternFiles,
+    getFileState,
+    resetIdeState,
+    cacheRebuild,
+    cachedRebuild,
+    convertDeclaration',
+    insertExterns,
+    insertModule,
+    insertExternsSTM,
+    getAllModules,
+    populateVolatileState,
+    populateVolatileStateSync,
+    populateVolatileStateSTM,
+    getOutputDirectory,
+    updateCacheTimestamp,
+    getFocusedModules,
+    setFocusedModules,
+    setFocusedModulesSTM,
+    resolveDocumentationForModule,
+    resolveLocations,
+    resolveLocationsForModule,
+    -- for tests
+    resolveOperatorsForModule,
+    resolveInstances,
+    resolveDataConstructorsForModule,
+  )
+where
 
 import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar)
-import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.))
-import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
+import Control.Lens (Ixed (..), preview, view, (%~), (.~), (^.))
 import Data.IORef (readIORef, writeIORef)
 import Data.Map.Lazy qualified as Map
 import Data.Set qualified as Set
@@ -52,37 +53,39 @@ import Data.Time.Clock (UTCTime)
 import Data.Zip (unzip)
 import Language.PureScript qualified as P
 import Language.PureScript.Docs.Convert.Single (convertComments)
-import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..))
-import Language.PureScript.Make.Actions (cacheDbFile)
+import Language.PureScript.Externs (ExternsDeclaration (..), ExternsFile (..))
 import Language.PureScript.Ide.Externs (convertExterns)
-import Language.PureScript.Ide.Reexports (ReexportResult(..), prettyPrintReexportResult, reexportHasFailures, resolveReexports)
+import Language.PureScript.Ide.Reexports (ReexportResult (..), prettyPrintReexportResult, reexportHasFailures, resolveReexports)
 import Language.PureScript.Ide.SourceFile (extractAstInformation)
 import Language.PureScript.Ide.Types
 import Language.PureScript.Ide.Util (discardAnn, opNameT, properNameT, runLogger)
+import Language.PureScript.Make.Actions (cacheDbFile)
+import Protolude hiding (moduleName, unzip)
 import System.Directory (getModificationTime)
+import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN)
 
 -- | Resets all State inside psc-ide
-resetIdeState :: Ide m => m ()
+resetIdeState :: (Ide m) => m ()
 resetIdeState = do
   ideVar <- ideStateVar <$> ask
   durableState <- getDurableState
-  liftIO (atomically (writeTVar ideVar (emptyIdeState { ideDurableState = durableState })))
+  liftIO (atomically (writeTVar ideVar (emptyIdeState {ideDurableState = durableState})))
 
-getOutputDirectory :: Ide m => m FilePath
+getOutputDirectory :: (Ide m) => m FilePath
 getOutputDirectory = do
   confOutputPath . ideConfiguration <$> ask
 
-getCacheTimestamp :: Ide m => m (Maybe UTCTime)
+getCacheTimestamp :: (Ide m) => m (Maybe UTCTime)
 getCacheTimestamp = do
   x <- ideCacheDbTimestamp <$> ask
   liftIO (readIORef x)
 
-readCacheTimestamp :: Ide m => m (Maybe UTCTime)
+readCacheTimestamp :: (Ide m) => m (Maybe UTCTime)
 readCacheTimestamp = do
   cacheDb <- cacheDbFile <$> getOutputDirectory
   liftIO (hush <$> try @SomeException (getModificationTime cacheDb))
 
-updateCacheTimestamp :: Ide m => m (Maybe (Maybe UTCTime, Maybe UTCTime))
+updateCacheTimestamp :: (Ide m) => m (Maybe (Maybe UTCTime, Maybe UTCTime))
 updateCacheTimestamp = do
   old <- getCacheTimestamp
   new <- readCacheTimestamp
@@ -94,15 +97,15 @@ updateCacheTimestamp = do
       pure (Just (old, new))
 
 -- | Gets the loaded Modulenames
-getLoadedModulenames :: Ide m => m [P.ModuleName]
+getLoadedModulenames :: (Ide m) => m [P.ModuleName]
 getLoadedModulenames = Map.keys <$> getExternFiles
 
 -- | Gets all loaded ExternFiles
-getExternFiles :: Ide m => m (ModuleMap ExternsFile)
+getExternFiles :: (Ide m) => m (ModuleMap ExternsFile)
 getExternFiles = fsExterns <$> getFileState
 
 -- | Insert a Module into Stage1 of the State
-insertModule :: Ide m => (FilePath, P.Module) -> m ()
+insertModule :: (Ide m) => (FilePath, P.Module) -> m ()
 insertModule module' = do
   stateVar <- ideStateVar <$> ask
   liftIO . atomically $ insertModuleSTM stateVar module'
@@ -111,15 +114,20 @@ insertModule module' = do
 insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM ()
 insertModuleSTM ref (fp, module') =
   modifyTVar ref $ \x ->
-    x { ideFileState = (ideFileState x) {
-          fsModules = Map.insert
-            (P.getModuleName module')
-            (module', fp)
-            (fsModules (ideFileState x))}}
+    x
+      { ideFileState =
+          (ideFileState x)
+            { fsModules =
+                Map.insert
+                  (P.getModuleName module')
+                  (module', fp)
+                  (fsModules (ideFileState x))
+            }
+      }
 
 -- | Retrieves the FileState from the State. This includes loaded Externfiles
 -- and parsed Modules
-getFileState :: Ide m => m IdeFileState
+getFileState :: (Ide m) => m IdeFileState
 getFileState = do
   st <- ideStateVar <$> ask
   ideFileState <$> liftIO (readTVarIO st)
@@ -130,7 +138,7 @@ getFileStateSTM ref = ideFileState <$> readTVar ref
 
 -- | Retrieves VolatileState from the State.
 -- This includes the denormalized Declarations and cached rebuilds
-getVolatileState :: Ide m => m IdeVolatileState
+getVolatileState :: (Ide m) => m IdeVolatileState
 getVolatileState = do
   st <- ideStateVar <$> ask
   liftIO (atomically (getVolatileStateSTM st))
@@ -147,7 +155,7 @@ setVolatileStateSTM ref vs = do
   pure ()
 
 -- | Retrieves the DurableState from the State.
-getDurableState :: Ide m => m IdeDurableState
+getDurableState :: (Ide m) => m IdeDurableState
 getDurableState = do
   st <- ideStateVar <$> ask
   liftIO (atomically (getDurableStateSTM st))
@@ -166,7 +174,7 @@ setDurableStateSTM ref md = do
 -- | Checks if the given ModuleName matches the last rebuild cache and if it
 -- does returns all loaded definitions + the definitions inside the rebuild
 -- cache
-getAllModules :: Ide m => Maybe P.ModuleName -> m (ModuleMap [IdeDeclarationAnn])
+getAllModules :: (Ide m) => Maybe P.ModuleName -> m (ModuleMap [IdeDeclarationAnn])
 getAllModules mmoduleName = do
   declarations <- vsDeclarations <$> getVolatileState
   rebuild <- cachedRebuild
@@ -177,15 +185,14 @@ getAllModules mmoduleName = do
         Just (cachedModulename, ef)
           | cachedModulename == moduleName -> do
               AstData asts <- vsAstData <$> getVolatileState
-              let
-                ast =
-                  fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
-                cachedModule =
-                  resolveLocationsForModule ast (fst (convertExterns ef))
-                tmp =
-                  Map.insert moduleName cachedModule declarations
-                resolved =
-                  Map.adjust (resolveOperatorsForModule tmp) moduleName tmp
+              let ast =
+                    fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts)
+                  cachedModule =
+                    resolveLocationsForModule ast (fst (convertExterns ef))
+                  tmp =
+                    Map.insert moduleName cachedModule declarations
+                  resolved =
+                    Map.adjust (resolveOperatorsForModule tmp) moduleName tmp
 
               pure resolved
         _ -> pure declarations
@@ -193,7 +200,7 @@ getAllModules mmoduleName = do
 -- | Adds an ExternsFile into psc-ide's FileState. This does not populate the
 -- VolatileState, which needs to be done after all the necessary Externs and
 -- SourceFiles have been loaded.
-insertExterns :: Ide m => ExternsFile -> m ()
+insertExterns :: (Ide m) => ExternsFile -> m ()
 insertExterns ef = do
   st <- ideStateVar <$> ask
   liftIO (atomically (insertExternsSTM st ef))
@@ -202,19 +209,27 @@ insertExterns ef = do
 insertExternsSTM :: TVar IdeState -> ExternsFile -> STM ()
 insertExternsSTM ref ef =
   modifyTVar ref $ \x ->
-    x { ideFileState = (ideFileState x) {
-          fsExterns = Map.insert (efModuleName ef) ef (fsExterns (ideFileState x))}}
+    x
+      { ideFileState =
+          (ideFileState x)
+            { fsExterns = Map.insert (efModuleName ef) ef (fsExterns (ideFileState x))
+            }
+      }
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: Ide m => ExternsFile -> m ()
+cacheRebuild :: (Ide m) => ExternsFile -> m ()
 cacheRebuild ef = do
   st <- ideStateVar <$> ask
   liftIO . atomically . modifyTVar st $ \x ->
-    x { ideVolatileState = (ideVolatileState x) {
-          vsCachedRebuild = Just (efModuleName ef, ef)}}
+    x
+      { ideVolatileState =
+          (ideVolatileState x)
+            { vsCachedRebuild = Just (efModuleName ef, ef)
+            }
+      }
 
 -- | Retrieves the rebuild cache
-cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile))
+cachedRebuild :: (Ide m) => m (Maybe (P.ModuleName, ExternsFile))
 cachedRebuild = vsCachedRebuild <$> getVolatileState
 
 -- | Resolves reexports and populates VolatileState with data to be used in queries.
@@ -222,11 +237,12 @@ populateVolatileStateSync :: (Ide m, MonadLogger m) => m ()
 populateVolatileStateSync = do
   st <- ideStateVar <$> ask
   results <- liftIO (atomically (populateVolatileStateSTM st))
-  void $ Map.traverseWithKey
-    (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
-    (Map.filter reexportHasFailures results)
+  void $
+    Map.traverseWithKey
+      (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn)))
+      (Map.filter reexportHasFailures results)
 
-populateVolatileState :: Ide m => m (Async ())
+populateVolatileState :: (Ide m) => m (Async ())
 populateVolatileState = do
   env <- ask
   let ll = confLogLevel (ideConfiguration env)
@@ -235,11 +251,11 @@ populateVolatileState = do
   liftIO (async (runLogger ll (runReaderT populateVolatileStateSync env)))
 
 -- | STM version of populateVolatileState
-populateVolatileStateSTM
-  :: TVar IdeState
-  -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn]))
+populateVolatileStateSTM ::
+  TVar IdeState ->
+  STM (ModuleMap (ReexportResult [IdeDeclarationAnn]))
 populateVolatileStateSTM ref = do
-  IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref
+  IdeFileState {fsExterns = externs, fsModules = modules} <- getFileStateSTM ref
   -- We're not using the cached rebuild for anything other than preserving it
   -- through the repopulation
   rebuildCache <- vsCachedRebuild <$> getVolatileStateSTM ref
@@ -247,57 +263,64 @@ populateVolatileStateSTM ref = do
   let (moduleDeclarations, reexportRefs) = unzip (Map.map convertExterns externs)
       results =
         moduleDeclarations
-        & map resolveDataConstructorsForModule
-        & resolveLocations asts
-        & resolveDocumentation (map fst modules)
-        & resolveInstances externs
-        & resolveOperators
-        & resolveReexports reexportRefs
+          & map resolveDataConstructorsForModule
+          & resolveLocations asts
+          & resolveDocumentation (map fst modules)
+          & resolveInstances externs
+          & resolveOperators
+          & resolveReexports reexportRefs
   setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache)
   pure results
 
-resolveLocations
-  :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
-  -> ModuleMap [IdeDeclarationAnn]
-  -> ModuleMap [IdeDeclarationAnn]
+resolveLocations ::
+  ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) ->
+  ModuleMap [IdeDeclarationAnn] ->
+  ModuleMap [IdeDeclarationAnn]
 resolveLocations asts =
-  Map.mapWithKey (\mn decls ->
-                    maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts))
-
-resolveLocationsForModule
-  :: (DefinitionSites P.SourceSpan, TypeAnnotations)
-  -> [IdeDeclarationAnn]
-  -> [IdeDeclarationAnn]
+  Map.mapWithKey
+    ( \mn decls ->
+        maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts)
+    )
+
+resolveLocationsForModule ::
+  (DefinitionSites P.SourceSpan, TypeAnnotations) ->
+  [IdeDeclarationAnn] ->
+  [IdeDeclarationAnn]
 resolveLocationsForModule (defs, types) =
   map convertDeclaration
   where
     convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
-    convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration'
-      annotateFunction
-      annotateValue
-      annotateDataConstructor
-      annotateType
-      annotateType -- type classes live in the type namespace
-      annotateModule
-      d
+    convertDeclaration (IdeDeclarationAnn ann d) =
+      convertDeclaration'
+        annotateFunction
+        annotateValue
+        annotateDataConstructor
+        annotateType
+        annotateType -- type classes live in the type namespace
+        annotateModule
+        d
       where
-        annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
-                                                    , _annTypeAnnotation = Map.lookup x types
-                                                    })
+        annotateFunction x =
+          IdeDeclarationAnn
+            ( ann
+                { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs,
+                  _annTypeAnnotation = Map.lookup x types
+                }
+            )
         annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
         annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
         annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs})
         annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs})
 
-convertDeclaration'
-  :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn)
-  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
-  -> IdeDeclaration
-  -> IdeDeclarationAnn
+convertDeclaration' ::
+  (P.Ident -> IdeDeclaration -> t) ->
+  (Text -> IdeDeclaration -> t) ->
+  (Text -> IdeDeclaration -> t) ->
+  (Text -> IdeDeclaration -> t) ->
+  (Text -> IdeDeclaration -> t) ->
+  (Text -> IdeDeclaration -> t) ->
+  IdeDeclaration ->
+  t
 convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d =
   case d of
     IdeDeclValue v ->
@@ -317,143 +340,155 @@ convertDeclaration' annotateFunction annotateValue annotateDataConstructor annot
     IdeDeclModule mn ->
       annotateModule (P.runModuleName mn) d
 
-resolveDocumentation
-  :: ModuleMap P.Module
-  -> ModuleMap [IdeDeclarationAnn]
-  -> ModuleMap [IdeDeclarationAnn]
+resolveDocumentation ::
+  ModuleMap P.Module ->
+  ModuleMap [IdeDeclarationAnn] ->
+  ModuleMap [IdeDeclarationAnn]
 resolveDocumentation modules =
-  Map.mapWithKey (\mn decls ->
-    maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules))
-
-resolveDocumentationForModule
-  :: P.Module
-    -> [IdeDeclarationAnn]
-    -> [IdeDeclarationAnn]
+  Map.mapWithKey
+    ( \mn decls ->
+        maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules)
+    )
+
+resolveDocumentationForModule ::
+  P.Module ->
+  [IdeDeclarationAnn] ->
+  [IdeDeclarationAnn]
 resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) =
   map convertDecl
   where
-  extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])]
-  extractDeclComments = \case
-    P.DataDeclaration (_, cs) _ ctorName _ ctors ->
-      (P.TyName ctorName, cs) : map dtorComments ctors
-    P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members ->
-      (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members
-    decl ->
-      maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl)
-
-  comments :: Map P.Name [P.Comment]
-  comments = Map.insert (P.ModName moduleName) moduleComments $
-    Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls
-
-  dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment])
-  dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd))
-
-  name :: P.Declaration -> Maybe P.Name
-  name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d
-  name decl = P.declName decl
-
-  convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn
-  convertDecl (IdeDeclarationAnn ann d) =
-    convertDeclaration'
-      (annotateValue . P.IdentName)
-      (annotateValue . P.IdentName . P.Ident)
-      (annotateValue . P.DctorName . P.ProperName)
-      (annotateValue . P.TyName . P.ProperName)
-      (annotateValue . P.TyClassName . P.ProperName)
-      (annotateValue . P.ModName . P.moduleNameFromString)
-      d
-    where
-      docs :: P.Name -> Text
-      docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments
-
-      annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident })
-
-resolveInstances
-  :: ModuleMap P.ExternsFile
-  -> ModuleMap [IdeDeclarationAnn]
-  -> ModuleMap [IdeDeclarationAnn]
+    extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])]
+    extractDeclComments = \case
+      P.DataDeclaration (_, cs) _ ctorName _ ctors ->
+        (P.TyName ctorName, cs) : map dtorComments ctors
+      P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members ->
+        (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members
+      decl ->
+        maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl)
+
+    comments :: Map P.Name [P.Comment]
+    comments =
+      Map.insert (P.ModName moduleName) moduleComments $
+        Map.fromListWith (flip (<>)) $
+          concatMap extractDeclComments sdecls
+
+    dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment])
+    dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd))
+
+    name :: P.Declaration -> Maybe P.Name
+    name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d
+    name decl = P.declName decl
+
+    convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn
+    convertDecl (IdeDeclarationAnn ann d) =
+      convertDeclaration'
+        (annotateValue . P.IdentName)
+        (annotateValue . P.IdentName . P.Ident)
+        (annotateValue . P.DctorName . P.ProperName)
+        (annotateValue . P.TyName . P.ProperName)
+        (annotateValue . P.TyClassName . P.ProperName)
+        (annotateValue . P.ModName . P.moduleNameFromString)
+        d
+      where
+        docs :: P.Name -> Text
+        docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments
+
+        annotateValue ident = IdeDeclarationAnn (ann {_annDocumentation = Just $ docs ident})
+
+resolveInstances ::
+  ModuleMap P.ExternsFile ->
+  ModuleMap [IdeDeclarationAnn] ->
+  ModuleMap [IdeDeclarationAnn]
 resolveInstances externs declarations =
   Map.foldr (flip (foldr go)) declarations
-  . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef))
-  $ externs
+    . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef))
+    $ externs
   where
-    extractInstances mn P.EDInstance{..} =
+    extractInstances mn P.EDInstance {..} =
       case edInstanceClassName of
-          P.Qualified (P.ByModuleName classModule) className ->
-            Just (IdeInstance mn
-                  edInstanceName
-                  edInstanceTypes
-                  edInstanceConstraints, classModule, className)
-          _ -> Nothing
+        P.Qualified (P.ByModuleName classModule) className ->
+          Just
+            ( IdeInstance
+                mn
+                edInstanceName
+                edInstanceTypes
+                edInstanceConstraints,
+              classModule,
+              className
+            )
+        _ -> Nothing
     extractInstances _ _ = Nothing
 
-    go
-      :: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName)
-      -> ModuleMap [IdeDeclarationAnn]
-      -> ModuleMap [IdeDeclarationAnn]
+    go ::
+      (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) ->
+      ModuleMap [IdeDeclarationAnn] ->
+      ModuleMap [IdeDeclarationAnn]
     go (ideInstance, classModule, className) acc' =
-      let
-        matchTC =
-          anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className)
-        updateDeclaration =
-          mapIf matchTC (idaDeclaration
-                         . _IdeDeclTypeClass
-                         . ideTCInstances
-                         %~ (ideInstance :))
-      in
-        acc' & ix classModule %~ updateDeclaration
-
-resolveOperators
-  :: ModuleMap [IdeDeclarationAnn]
-  -> ModuleMap [IdeDeclarationAnn]
+      let matchTC =
+            anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className)
+          updateDeclaration =
+            mapIf
+              matchTC
+              ( idaDeclaration
+                  . _IdeDeclTypeClass
+                  . ideTCInstances
+                  %~ (ideInstance :)
+              )
+       in acc' & ix classModule %~ updateDeclaration
+
+resolveOperators ::
+  ModuleMap [IdeDeclarationAnn] ->
+  ModuleMap [IdeDeclarationAnn]
 resolveOperators modules =
   map (resolveOperatorsForModule modules) modules
 
 -- | Looks up the types and kinds for operators and assigns them to their
 -- declarations
-resolveOperatorsForModule
-  :: ModuleMap [IdeDeclarationAnn]
-  -> [IdeDeclarationAnn]
-  -> [IdeDeclarationAnn]
+resolveOperatorsForModule ::
+  ModuleMap [IdeDeclarationAnn] ->
+  [IdeDeclarationAnn] ->
+  [IdeDeclarationAnn]
 resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator)
   where
     getDeclarations :: P.ModuleName -> [IdeDeclaration]
     getDeclarations moduleName =
       Map.lookup moduleName modules
-      & foldMap (map discardAnn)
+        & foldMap (map discardAnn)
 
     resolveOperator (IdeDeclValueOperator op)
       | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias =
-          let t = getDeclarations mn
+          let t =
+                getDeclarations mn
                   & mapMaybe (preview _IdeDeclValue)
                   & filter (anyOf ideValueIdent (== ident))
                   & map (view ideValueType)
                   & listToMaybe
-          in IdeDeclValueOperator (op & ideValueOpType .~ t)
+           in IdeDeclValueOperator (op & ideValueOpType .~ t)
       | (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias =
-          let t = getDeclarations mn
+          let t =
+                getDeclarations mn
                   & mapMaybe (preview _IdeDeclDataConstructor)
                   & filter (anyOf ideDtorName (== dtor))
                   & map (view ideDtorType)
                   & listToMaybe
-          in IdeDeclValueOperator (op & ideValueOpType .~ t)
+           in IdeDeclValueOperator (op & ideValueOpType .~ t)
     resolveOperator (IdeDeclTypeOperator op)
       | P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias =
-          let k = getDeclarations mn
+          let k =
+                getDeclarations mn
                   & mapMaybe (preview _IdeDeclType)
                   & filter (anyOf ideTypeName (== properName))
                   & map (view ideTypeKind)
                   & listToMaybe
-          in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
+           in IdeDeclTypeOperator (op & ideTypeOpKind .~ k)
     resolveOperator x = x
 
-
-mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b
+mapIf :: (Functor f) => (b -> Bool) -> (b -> b) -> f b -> f b
 mapIf p f = map (\x -> if p x then f x else x)
 
-resolveDataConstructorsForModule
-  :: [IdeDeclarationAnn]
-  -> [IdeDeclarationAnn]
+resolveDataConstructorsForModule ::
+  [IdeDeclarationAnn] ->
+  [IdeDeclarationAnn]
 resolveDataConstructorsForModule decls =
   map (idaDeclaration %~ resolveDataConstructors) decls
   where
@@ -466,19 +501,22 @@ resolveDataConstructorsForModule decls =
 
     dtors =
       decls
-      & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor))
-      & foldr (\(IdeDataConstructor name typeName type') ->
-                  Map.insertWith (<>) typeName [(name, type')]) Map.empty
-
-getFocusedModules :: Ide m => m (Set P.ModuleName)
+        & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor))
+        & foldr
+          ( \(IdeDataConstructor name typeName type') ->
+              Map.insertWith (<>) typeName [(name, type')]
+          )
+          Map.empty
+
+getFocusedModules :: (Ide m) => m (Set P.ModuleName)
 getFocusedModules = do
-  IdeDurableState{drFocusedModules = focusedModules} <- getDurableState
+  IdeDurableState {drFocusedModules = focusedModules} <- getDurableState
   pure focusedModules
 
-setFocusedModules :: Ide m => [P.ModuleName] -> m ()
+setFocusedModules :: (Ide m) => [P.ModuleName] -> m ()
 setFocusedModules modulesToFocus = do
   st <- ideStateVar <$> ask
-  liftIO (atomically (setFocusedModulesSTM st modulesToFocus)) 
+  liftIO (atomically (setFocusedModulesSTM st modulesToFocus))
 
 setFocusedModulesSTM :: TVar IdeState -> [P.ModuleName] -> STM ()
 setFocusedModulesSTM ref modulesToFocus = do
diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
index 5e96e77b7f..010a7b668d 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -36,6 +36,8 @@ data IdeDeclaration
   | IdeDeclModule P.ModuleName
   deriving (Show, Eq, Ord, Generic, Serialise)
 
+
+
 data IdeValue = IdeValue
   { _ideValueIdent :: P.Ident
   , _ideValueType :: P.SourceType
@@ -328,7 +330,7 @@ encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifie
 
 -- | Denotes the different namespaces a name in PureScript can reside in.
 data IdeNamespace = IdeNSValue | IdeNSType | IdeNSModule
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic, Serialise)
 
 instance FromJSON IdeNamespace where
   parseJSON = Aeson.withText "Namespace" $ \case
diff --git a/src/Language/PureScript/Lsp/Cache copy b/src/Language/PureScript/Lsp/Cache copy
new file mode 100644
index 0000000000..4b0ae1447d
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Cache copy	
@@ -0,0 +1,233 @@
+{-# LANGUAGE PackageImports #-}
+
+module Language.PureScript.Lsp.CacheCopy where
+
+import Codec.Serialise (deserialise, serialise)
+import Control.Lens ((^.))
+import Data.Aeson (encode)
+import Data.List qualified as List
+import Data.Text qualified as T
+import Database.SQLite.Simple
+import Language.PureScript qualified as P
+import Language.PureScript.CST qualified as CST
+import Language.PureScript.Externs (ExternsFile (efModuleName))
+import Language.PureScript.Ide.Error (IdeError (RebuildError))
+import Language.PureScript.Ide.Externs (convertExterns, readExternFile)
+import Language.PureScript.Ide.State (convertDeclaration', resolveDataConstructorsForModule, resolveDocumentationForModule)
+import Language.PureScript.Ide.Types (Annotation (_annDocumentation, _annExportedFrom, _annLocation, _annTypeAnnotation), IdeDeclaration (..), IdeDeclarationAnn (IdeDeclarationAnn, _idaAnnotation, _idaDeclaration), IdeNamespace (IdeNSModule, IdeNSType, IdeNSValue), ideDtorType, ideSynonymKind, ideTCKind, ideTypeKind, ideTypeOpKind, ideValueOpType, ideValueType)
+import Language.PureScript.Ide.Util (ideReadFile)
+import Language.PureScript.Lsp.DB qualified as DB
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Protolude
+import System.FilePath ((</>))
+import System.FilePath.Glob (glob)
+import "monad-logger" Control.Monad.Logger (MonadLogger)
+
+initCache ::
+  (MonadIO m, MonadReader LspEnvironment m) =>
+  m ()
+initCache = do
+  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS externs (name TEXT PRIMARY KEY, path TEXT, version TEXT, externs BLOB)"
+  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS ident_source_spans (ident TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, name_space BLOB)"
+  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, import_type BLOB, imported_as TEXT)"
+  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, declaration BLOB, ann_start_col INTEGER, ann_start_line INTEGER, ann_end_col INTEGER, ann_end_line INTEGER, ann_exported_from TEXT, ann_type_annotation BLOB, ann_documentation BLOB, decl_start_col INTEGER, decl_start_line INTEGER, decl_end_col INTEGER, decl_end_line INTEGER, decl_comments TEXT, ann BLOB, decl BLOB)"
+
+
+loadCache ::
+  ( MonadIO m,
+    MonadLogger m,
+    MonadError IdeError m,
+    MonadReader LspEnvironment m
+  ) =>
+  m [(FilePath, [CST.ParserWarning])]
+loadCache = do
+  globs <- asks (confGlobs . lspConfig)
+  files <- liftIO $ concat <$> traverse glob globs
+  traverse rebuildFile files
+
+rebuildFile ::
+  ( MonadIO m,
+    MonadLogger m,
+    MonadError IdeError m,
+    MonadReader LspEnvironment m
+  ) =>
+  FilePath ->
+  m (FilePath, [CST.ParserWarning])
+rebuildFile srcPath = do
+  outputDir <- asks (confOutputPath . lspConfig)
+  (fp, input) <-
+    case List.stripPrefix "data:" srcPath of
+      Just source -> pure ("", T.pack source)
+      _ -> ideReadFile srcPath -- todo replace with VFS
+  (pwarnings, module') <- case sequence $ CST.parseFromFile fp input of
+    Left parseError ->
+      throwError $ RebuildError [(fp, input)] $ CST.toMultipleErrors fp parseError
+    Right m -> pure m
+  let externsPath = outputDir </> T.unpack (P.runModuleName $ P.getModuleName module') </> P.externsFileName
+  externs <- readExternFile externsPath
+  let (moduleDeclarations, _) = convertExterns externs
+  decls <-
+    moduleDeclarations
+      & resolveDataConstructorsForModule
+      & resolveLocations
+      <&> resolveDocumentationForModule module'
+  -- & resolveInstances externs
+  -- & resolveOperatorsForModule
+  -- & resolveReexports reexportRefs
+
+  insertExtern srcPath externsPath externs decls
+  pure (srcPath, pwarnings)
+
+insertExtern ::
+  (MonadIO m, MonadReader LspEnvironment m) =>
+  FilePath ->
+  FilePath ->
+  ExternsFile ->
+  [IdeDeclarationAnn] ->
+  m ()
+insertExtern srcPath externsPath extern annotatedDecls = do
+  DB.executeNamed
+    (Query "INSERT INTO externs (name, path) VALUES (:path, :name)")
+    [ ":src_path" := srcPath,
+      ":externs_path" := externsPath,
+      ":ef_version" := P.efVersion extern,
+      ":externs" := serialise extern,
+      ":name" := P.runModuleName name
+    ]
+
+  forM_ (P.efImports extern) $ insertEfImport name
+  forM_ annotatedDecls $ insertDeclaration name
+  where
+    name = efModuleName extern
+
+insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
+insertEfImport moduleName' ei = do
+  DB.executeNamed
+    (Query "INSERT INTO ef_imports (module_name, import_name) VALUES (:module_name, :import_name)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":imported_module_name" := P.runModuleName (P.eiModule ei),
+      ":import_type" := serialise (P.eiImportType ei),
+      ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei)
+    ]
+
+insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> IdeDeclarationAnn -> m ()
+insertDeclaration moduleName' declAnn = do
+  DB.executeNamed
+    (Query "INSERT INTO declarations (module_name, declaration) VALUES (:module_name, :declaration)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":ann_start_col" := map (P.sourcePosColumn . P.spanStart) annLocation,
+      ":ann_start_line" := map (P.sourcePosLine . P.spanStart) annLocation,
+      ":ann_end_col" := map (P.sourcePosColumn . P.spanEnd) annLocation,
+      ":ann_end_line" := map (P.sourcePosLine . P.spanEnd) annLocation,
+      ":ann_exported_from" := map P.runModuleName (_annExportedFrom ann),
+      ":ann_type_annotation" := serialise (_annTypeAnnotation ann),
+      ":ann_documentation" := serialise (_annDocumentation ann),
+      ":decl_start_col" := (P.sourcePosColumn . P.spanStart) declLocation,
+      ":decl_start_line" := (P.sourcePosLine . P.spanStart) declLocation,
+      ":decl_end_col" := (P.sourcePosColumn . P.spanEnd) declLocation,
+      ":decl_end_line" := (P.sourcePosLine . P.spanEnd) declLocation,
+      ":decl_comments" := encode comments,
+      ":ann" := serialise ann,
+      ":decl" := serialise decl
+    ]
+  where
+    ann = _idaAnnotation declAnn
+    annLocation = _annLocation ann
+
+    decl = _idaDeclaration declAnn
+
+    (declLocation, comments) =
+      decl
+        & declSourceType
+        & maybe P.nullSourceAnn P.getAnnForType
+
+declSourceType :: IdeDeclaration -> Maybe P.SourceType
+declSourceType = \case
+  IdeDeclValue x -> Just (x ^. ideValueType)
+  IdeDeclType x -> Just (x ^. ideTypeKind)
+  IdeDeclTypeSynonym x -> Just (x ^. ideSynonymKind)
+  IdeDeclDataConstructor x -> Just (x ^. ideDtorType)
+  IdeDeclTypeClass x -> Just (x ^. ideTCKind)
+  IdeDeclValueOperator x -> x ^. ideValueOpType
+  IdeDeclTypeOperator x -> x ^. ideTypeOpKind
+  IdeDeclModule _ -> Nothing
+
+resolveLocations :: (MonadIO m, MonadReader LspEnvironment m) => [IdeDeclarationAnn] -> m [IdeDeclarationAnn]
+resolveLocations = traverse resolveLocation
+
+resolveLocation :: (MonadIO m, MonadReader LspEnvironment m) => IdeDeclarationAnn -> m IdeDeclarationAnn
+resolveLocation (IdeDeclarationAnn ann d) =
+  convertDeclaration'
+    annotateFunction
+    annotateValue
+    annotateDataConstructor
+    annotateType
+    annotateType -- type classes live in the type namespace
+    annotateModule
+    d
+  where
+    -- annotateFunction :: _
+    annotateFunction x d' = do
+      def <- selectIdentSourceSpan IdeNSValue $ P.runIdent x
+      type' <- selectIdentSourceType x
+      pure $
+        IdeDeclarationAnn
+          ( ann
+              { _annLocation = def,
+                _annTypeAnnotation = type'
+              }
+          )
+          d'
+    annotateValue x d' = do
+      def <- selectIdentSourceSpan IdeNSValue x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+    annotateDataConstructor x d' = do
+      def <- selectIdentSourceSpan IdeNSValue x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+    annotateType x d' = do
+      def <- selectIdentSourceSpan IdeNSType x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+    annotateModule x d' = do
+      def <- selectIdentSourceSpan IdeNSModule x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+
+insertIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> P.SourceSpan -> m ()
+insertIdentSourceSpan nameSpace ident span =
+  DB.executeNamed
+    (Query "INSERT INTO ident_source_spans (ident, start_col, start_line, end_col, end_line) VALUES (:ident, :start_col, :start_line, :end_col, :end_line :name_space)")
+    [ ":ident" := ident,
+      ":start_col" := P.sourcePosColumn (P.spanStart span),
+      ":start_line" := P.sourcePosLine (P.spanStart span),
+      ":end_col" := P.sourcePosColumn (P.spanEnd span),
+      ":end_line" := P.sourcePosLine (P.spanEnd span),
+      ":name_space" := serialise nameSpace
+    ]
+
+selectIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> m (Maybe P.SourceSpan)
+selectIdentSourceSpan name_space ident =
+  fmap toSpan . head
+    <$> DB.queryNamed
+      (Query "SELECT start_col, start_line, end_col, end_line FROM ident_source_spans WHERE ident = :ident and name_space = :name_space")
+      [ ":ident" := ident,
+        ":name_space" := serialise name_space
+      ]
+  where
+    toSpan :: (Int, Int, Int, Int) -> P.SourceSpan
+    toSpan (startCol, startLine, endCol, endLine) =
+      P.SourceSpan
+        (T.unpack ident)
+        (P.SourcePos startLine startCol)
+        (P.SourcePos endLine endCol)
+
+insertIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> P.SourceType -> m ()
+insertIdentSourceType ident ty =
+  DB.executeNamed
+    (Query "INSERT INTO ident_source_types (ident, type) VALUES (:ident, :type)")
+    [":ident" := P.runIdent ident, ":type" := serialise ty]
+
+selectIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> m (Maybe P.SourceType)
+selectIdentSourceType ident =
+  fmap (deserialise . fromOnly) . head
+    <$> DB.queryNamed
+      (Query "SELECT type FROM ident_source_types WHERE ident = :ident")
+      [":ident" := P.runIdent ident]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 33b613f71f..9497d21b29 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -1,49 +1,251 @@
+{-# LANGUAGE PackageImports #-}
+
 module Language.PureScript.Lsp.Cache where
 
-import Codec.Serialise (serialise)
+import Codec.Serialise (deserialise, serialise)
+import Control.Lens (Field1 (_1), (^.), _1, _2, _3)
+import Control.Monad.RWS (asks)
 import Data.Aeson (encode)
+import Data.ByteString.Lazy qualified as LB
+import Data.List qualified as List
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+import Data.Text qualified as T
 import Database.SQLite.Simple
+import Language.PureScript (prettyPrintBinder)
 import Language.PureScript qualified as P
-import Language.PureScript.AST (Module (..))
-import Language.PureScript.Externs (ExternsFile)
-import Language.PureScript.Lsp.DB (executeNamed')
-import Language.PureScript.Lsp.Types (LspEnvironment)
+import Language.PureScript.AST.Declarations (declSourceAnn)
+import Language.PureScript.AST.Exported (isExported)
+import Language.PureScript.AST.Traversals (accumTypes)
+import Language.PureScript.CST qualified as CST
+import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
+import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
+import Language.PureScript.Ide.Externs (convertExterns, readExternFile)
+import Language.PureScript.Ide.State (convertDeclaration', resolveDataConstructorsForModule, resolveDocumentationForModule)
+import Language.PureScript.Ide.Types (Annotation (_annDocumentation, _annExportedFrom, _annLocation, _annTypeAnnotation), IdeDeclaration (..), IdeDeclarationAnn (IdeDeclarationAnn, _idaAnnotation, _idaDeclaration), IdeNamespace (IdeNSModule, IdeNSType, IdeNSValue), ideDtorType, ideSynonymKind, ideTCKind, ideTypeKind, ideTypeOpKind, ideValueOpType, ideValueType, ModuleMap)
+import Language.PureScript.Ide.Util (ideReadFile)
+import Language.PureScript.Lsp.DB qualified as DB
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Pretty.Types (prettyPrintType)
+import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
 import Protolude
+import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, getDirectoryContents)
+import System.FilePath (normalise, (</>))
+import System.FilePath.Glob (glob)
+import "monad-logger" Control.Monad.Logger (MonadLogger)
 
-loadModules :: (MonadIO m, MonadReader LspEnvironment m) => m ()
-loadModules = pure ()
-
-insertModule :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> ExternsFile -> Module -> m ()
-insertModule fp extern (Module P.SourceSpan {..} comments name declarations exports) = do
-  executeNamed'
-    (Query "INSERT INTO modules (name, path) VALUES (:path, :name)")
-    [ ":path" := fp,
-      "ef_version" := P.efVersion extern,
-      ":name" := P.runModuleName name,
-      ":src" := spanName,
-      ":start_col" := P.sourcePosColumn spanStart,
-      ":start_line" := P.sourcePosLine spanStart,
-      ":end_col" := P.sourcePosColumn spanEnd,
-      ":end_line" := P.sourcePosLine spanEnd,
-      "comments" := encode comments
-    ]
+-- loadCache ::
+--   ( MonadIO m,
+--     MonadLogger m,
+--     MonadError IdeError m,
+--     MonadReader LspEnvironment m
+--   ) =>
+--   m [(FilePath, [CST.ParserWarning])]
+-- loadCache = do
+--   globs <- asks (confGlobs . lspConfig)
+--   files <- liftIO $ concat <$> traverse glob globs
+--   traverse rebuildFile files
+
+selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
+selectAllExternsMap = do
+  Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectAllExterns
+
+selectAllExterns :: (MonadIO m, MonadReader LspEnvironment m) => m [ExternsFile]
+selectAllExterns = do
+  DB.query_ (Query "SELECT value FROM externs") <&> fmap (deserialise . fromOnly)
+
+insertAllExterns ::
+  ( MonadIO m,
+    MonadReader LspEnvironment m,
+    MonadError IdeError m,
+    MonadLogger m
+  ) =>
+  m ()
+insertAllExterns = do
+  oDir <- asks (confOutputPath . lspConfig)
+  externPaths <- findAvailableExterns
+  forM_ externPaths $ \name -> do
+    extern <- readExternFile (oDir </> T.unpack (P.runModuleName name) <> externsFileName)
+    insertExtern oDir extern
+
+-- | Finds all the externs inside the output folder and returns the
+-- corresponding module names
+findAvailableExterns :: (MonadIO m, MonadReader LspEnvironment m, MonadError IdeError m) => m [P.ModuleName]
+findAvailableExterns = do
+  oDir <- asks (confOutputPath . lspConfig)
+  unlessM
+    (liftIO (doesDirectoryExist oDir))
+    (throwError (GeneralError $ "Couldn't locate your output directory at: " <> T.pack (normalise oDir)))
+  liftIO $ do
+    directories <- getDirectoryContents oDir
+    moduleNames <- filterM (containsExterns oDir) directories
+    pure (P.moduleNameFromString . toS <$> moduleNames)
+  where
+    -- Takes the output directory and a filepath like "Data.Array" and
+    -- looks up, whether that folder contains an externs file
+    containsExterns :: FilePath -> FilePath -> IO Bool
+    containsExterns oDir d
+      | d `elem` [".", ".."] = pure False
+      | otherwise = do
+          let file = oDir </> d </> P.externsFileName
+          doesFileExist file
 
+insertExtern ::
+  (MonadIO m, MonadReader LspEnvironment m) =>
+  FilePath ->
+  ExternsFile ->
+  m ()
+insertExtern outDir extern = do
+  DB.executeNamed
+    (Query "INSERT INTO externs (name, path) VALUES (:path, :name)")
+    [ ":path" := externsPath,
+      ":ef_version" := P.efVersion extern,
+      ":value" := serialise extern,
+      ":module_name" := P.runModuleName name
+    ]
   forM_ (P.efImports extern) $ insertEfImport name
-  forM_ declarations $ insertDeclaration name
+  forM_ (P.efExports extern) $ insertEfExport name
+  where
+    externsPath = outDir </> T.unpack (P.runModuleName name) <> externsFileName
+    name = efModuleName extern
 
 insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
 insertEfImport moduleName' ei = do
-  executeNamed'
+  DB.executeNamed
     (Query "INSERT INTO ef_imports (module_name, import_name) VALUES (:module_name, :import_name)")
     [ ":module_name" := P.runModuleName moduleName',
-      ":imported_module_name" := P.runModuleName (P.eiModule ei),
-      "import_type" := serialise (P.eiImportType ei),
-      "imported_as" := fmap P.runModuleName (P.eiImportedAs ei)
+      ":imported_module" := P.runModuleName (P.eiModule ei),
+      ":import_type" := serialise (P.eiImportType ei),
+      ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei)
+    ]
+
+insertEfExport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.DeclarationRef -> m ()
+insertEfExport moduleName' dr = do
+  DB.executeNamed
+    (Query "INSERT INTO ef_exports (module_name, export_name) VALUES (:module_name, :export_name)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":value" := serialise dr,
+      ":span_name" := P.spanName span,
+      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
+      ":start_line" := (P.sourcePosLine . P.spanStart) span,
+      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
+      ":end_line" := (P.sourcePosLine . P.spanEnd) span
+    ]
+  where
+    span = P.declRefSourceSpan dr
+
+insertModule :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> P.Module -> m ()
+insertModule srcPath m = do
+  let moduleName' = P.getModuleName m
+  DB.executeNamed
+    (Query "INSERT INTO modules (module_name, module) VALUES (:module_name, :module)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":path" := srcPath
     ]
 
-insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.Declaration -> m ()
-insertDeclaration moduleName' decl = do
-  executeNamed'
-    (Query "INSERT INTO declarations (module_name, declaration) VALUES (:module_name, :declaration)")
+  let exported = Set.fromList $ P.exportedDeclarations m
+  traverse_ (insertDeclaration moduleName' exported) (P.getModuleDeclarations m)
+
+insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Set P.Declaration -> P.Declaration -> m ()
+insertDeclaration moduleName' exportedDecls decl = do
+  DB.executeNamed
+    (Query "INSERT INTO declarations (module_name, declaration) VALUES (:module_name, :name, :value)")
     [ ":module_name" := P.runModuleName moduleName',
-    ]
\ No newline at end of file
+      ":name" := P.spanName declLocation,
+      ":type_printed" := typeName,
+      ":start_col" := (P.sourcePosColumn . P.spanStart) declLocation,
+      ":start_line" := (P.sourcePosLine . P.spanStart) declLocation,
+      ":end_col" := (P.sourcePosColumn . P.spanEnd) declLocation,
+      ":end_line" := (P.sourcePosLine . P.spanEnd) declLocation,
+      ":comments" := encode comments,
+      ":exported" := exported,
+      ":value" := serialise decl
+    ]
+  where
+    typeName = Protolude.fold $ head typeNames
+
+    typeNames :: [Text]
+    typeNames = accumTypes (pure . T.pack . prettyPrintType maxBound) ^. _1 $ decl
+
+    exported = Set.member decl exportedDecls
+    (declLocation, comments) = declSourceAnn decl
+
+resolveLocations :: (MonadIO m, MonadReader LspEnvironment m) => [IdeDeclarationAnn] -> m [IdeDeclarationAnn]
+resolveLocations = traverse resolveLocation
+
+resolveLocation :: (MonadIO m, MonadReader LspEnvironment m) => IdeDeclarationAnn -> m IdeDeclarationAnn
+resolveLocation (IdeDeclarationAnn ann d) =
+  convertDeclaration'
+    annotateFunction
+    annotateValue
+    annotateDataConstructor
+    annotateType
+    annotateType -- type classes live in the type namespace
+    annotateModule
+    d
+  where
+    -- annotateFunction :: _
+    annotateFunction x d' = do
+      def <- selectIdentSourceSpan IdeNSValue $ P.runIdent x
+      type' <- selectIdentSourceType x
+      pure $
+        IdeDeclarationAnn
+          ( ann
+              { _annLocation = def,
+                _annTypeAnnotation = type'
+              }
+          )
+          d'
+    annotateValue x d' = do
+      def <- selectIdentSourceSpan IdeNSValue x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+    annotateDataConstructor x d' = do
+      def <- selectIdentSourceSpan IdeNSValue x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+    annotateType x d' = do
+      def <- selectIdentSourceSpan IdeNSType x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+    annotateModule x d' = do
+      def <- selectIdentSourceSpan IdeNSModule x
+      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
+
+insertIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> P.SourceSpan -> m ()
+insertIdentSourceSpan nameSpace ident span =
+  DB.executeNamed
+    (Query "INSERT INTO ident_source_spans (ident, start_col, start_line, end_col, end_line) VALUES (:ident, :start_col, :start_line, :end_col, :end_line :name_space)")
+    [ ":ident" := ident,
+      ":start_col" := P.sourcePosColumn (P.spanStart span),
+      ":start_line" := P.sourcePosLine (P.spanStart span),
+      ":end_col" := P.sourcePosColumn (P.spanEnd span),
+      ":end_line" := P.sourcePosLine (P.spanEnd span),
+      ":name_space" := serialise nameSpace
+    ]
+
+selectIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> m (Maybe P.SourceSpan)
+selectIdentSourceSpan name_space ident =
+  fmap toSpan . head
+    <$> DB.queryNamed
+      (Query "SELECT start_col, start_line, end_col, end_line FROM ident_source_spans WHERE ident = :ident and name_space = :name_space")
+      [ ":ident" := ident,
+        ":name_space" := serialise name_space
+      ]
+  where
+    toSpan :: (Int, Int, Int, Int) -> P.SourceSpan
+    toSpan (startCol, startLine, endCol, endLine) =
+      P.SourceSpan
+        (T.unpack ident)
+        (P.SourcePos startLine startCol)
+        (P.SourcePos endLine endCol)
+
+insertIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> P.SourceType -> m ()
+insertIdentSourceType ident ty =
+  DB.executeNamed
+    (Query "INSERT INTO ident_source_types (ident, type) VALUES (:ident, :type)")
+    [":ident" := P.runIdent ident, ":type" := serialise ty]
+
+selectIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> m (Maybe P.SourceType)
+selectIdentSourceType ident =
+  fmap (deserialise . fromOnly) . head
+    <$> DB.queryNamed
+      (Query "SELECT type FROM ident_source_types WHERE ident = :ident")
+      [":ident" := P.runIdent ident]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/DB.hs b/src/Language/PureScript/Lsp/DB.hs
index 8fb892b58b..3972c1e680 100644
--- a/src/Language/PureScript/Lsp/DB.hs
+++ b/src/Language/PureScript/Lsp/DB.hs
@@ -6,20 +6,37 @@ import Database.SQLite.Simple.Types (Query)
 import Language.PureScript.Lsp.Types (LspEnvironment (lspDbConnection))
 import Protolude
 
-queryNamed' ::
+
+-- initDb :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> m ()
+
+queryNamed ::
   (MonadIO m, MonadReader LspEnvironment m, FromRow r) =>
   Query ->
   [SQL.NamedParam] ->
   m [r]
-queryNamed' q params = do
+queryNamed q params = do
   conn <- asks lspDbConnection
   liftIO $ SQL.queryNamed conn q params
   
-executeNamed' ::
+query_ ::
+  (MonadIO m, MonadReader LspEnvironment m, FromRow r) =>
+  Query ->
+  m [r]
+query_ q  = do
+  conn <- asks lspDbConnection
+  liftIO $ SQL.query_ conn q 
+  
+executeNamed ::
   (MonadIO m, MonadReader LspEnvironment m) =>
   Query ->
   [SQL.NamedParam] ->
   m ()
-executeNamed' q params = do
+executeNamed q params = do
   conn <- asks lspDbConnection
   liftIO $ SQL.executeNamed conn q params
+
+execute_ :: (MonadReader LspEnvironment m, MonadIO m) => Query -> m ()
+execute_ q  = do
+  conn <- asks lspDbConnection
+  liftIO $ SQL.execute_ conn q 
+  
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
new file mode 100644
index 0000000000..37da2f37bd
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE PackageImports #-}
+
+module Language.PureScript.Lsp.Rebuild where
+
+import Data.List qualified as List
+import Data.Map.Lazy qualified as M
+import Data.Maybe (fromJust)
+import Data.Set qualified as S
+import Data.Set qualified as Set
+import Data.Text qualified as T
+import Language.PureScript qualified as P
+import Language.PureScript.CST qualified as CST
+import Language.PureScript.Externs (ExternsFile (efModuleName))
+import Language.PureScript.Ide.Error (IdeError (RebuildError))
+import Language.PureScript.Ide.Rebuild (updateCacheDb)
+import Language.PureScript.Ide.Types (ModuleMap)
+import Language.PureScript.Ide.Util (ideReadFile)
+import Language.PureScript.Lsp.Cache
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Make (ffiCodegen')
+import Protolude  hiding (moduleName)
+import System.FilePath.Glob (glob)
+
+rebuildAllFiles ::
+  ( MonadIO m,
+    MonadError IdeError m,
+    MonadReader LspEnvironment m
+  ) =>
+  m [(FilePath, P.MultipleErrors)]
+rebuildAllFiles = do
+  globs <- asks (confGlobs . lspConfig)
+  files <- liftIO $ concat <$> traverse glob globs
+  traverse rebuildFile files
+
+rebuildFile ::
+  ( MonadIO m,
+    MonadError IdeError m,
+    MonadReader LspEnvironment m
+  ) =>
+  FilePath ->
+  m (FilePath, P.MultipleErrors)
+rebuildFile srcPath = do
+  (fp, input) <-
+    case List.stripPrefix "data:" srcPath of
+      Just source -> pure ("", T.pack source)
+      _ -> ideReadFile srcPath -- todo replace with VFS
+  (pwarnings, m) <- case sequence $ CST.parseFromFile fp input of
+    Left parseError ->
+      throwError $ RebuildError [(fp, input)] $ CST.toMultipleErrors fp parseError
+    Right m -> pure m
+  let moduleName = P.getModuleName m
+  externs <- sortExterns m =<< selectAllExternsMap
+  outputDirectory <- asks (confOutputPath . lspConfig)
+  let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+  let pureRebuild = fp == ""
+  let modulePath = if pureRebuild then fp else srcPath
+  foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
+  let makeEnv =
+        P.buildMakeActions outputDirectory filePathMap foreigns False
+          & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
+          & shushProgress
+  (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+    newExterns <- P.rebuildModule makeEnv externs m
+    unless pureRebuild $
+      updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
+    pure newExterns
+  case result of
+    Left errors ->
+      throwError (RebuildError [(fp, input)] errors)
+    Right newExterns -> do
+      insertModule fp m
+      insertExtern outputDirectory newExterns
+      -- void populateVolatileState
+      -- _ <- updateCacheTimestamp
+      -- runOpenBuild (rebuildModuleOpen makeEnv externs m)
+      pure (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
+  where
+    codegenTargets = Set.singleton P.JS
+
+-- | Shuts the compiler up about progress messages
+shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
+shushProgress ma =
+  ma {P.progress = \_ -> pure ()}
+
+-- | Stops any kind of codegen
+shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
+shushCodegen ma =
+  ma { P.codegen = \_ _ _ -> pure ()
+     , P.ffiCodegen = \_ -> pure ()
+     }
+
+enableForeignCheck ::
+  M.Map P.ModuleName FilePath ->
+  S.Set P.CodegenTarget ->
+  P.MakeActions P.Make ->
+  P.MakeActions P.Make
+enableForeignCheck foreigns codegenTargets ma =
+  ma
+    { P.ffiCodegen = ffiCodegen' foreigns codegenTargets Nothing
+    }
+
+-- | Returns a topologically sorted list of dependent ExternsFiles for the given
+-- module. Throws an error if there is a cyclic dependency within the
+-- ExternsFiles
+sortExterns ::
+  (MonadError IdeError m) =>
+  P.Module ->
+  ModuleMap P.ExternsFile ->
+  m [P.ExternsFile]
+sortExterns m ex = do
+  sorted' <-
+    runExceptT
+      . P.sortModules P.Transitive P.moduleSignature
+      . (:) m
+      . map mkShallowModule
+      . M.elems
+      . M.delete (P.getModuleName m)
+      $ ex
+  case sorted' of
+    Left err ->
+      throwError (RebuildError [] err)
+    Right (sorted, graph) -> do
+      let deps = fromJust (List.lookup (P.getModuleName m) graph)
+      pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
+  where
+    mkShallowModule P.ExternsFile {..} =
+      P.Module (P.internalModuleSourceSpan "<rebuild>") [] efModuleName (map mkImport efImports) Nothing
+    mkImport (P.ExternsImport mn it iq) =
+      P.ImportDeclaration (P.internalModuleSourceSpan "<rebuild>", []) mn it iq
+    getExtern mn = M.lookup mn ex
+    -- Sort a list so its elements appear in the same order as in another list.
+    inOrderOf :: (Ord a) => [a] -> [a] -> [a]
+    inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index a4226e95dc..e238863a77 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -1,10 +1,10 @@
 module Language.PureScript.Lsp.Types where
 
-import Protolude
-import Database.SQLite.Simple (Connection)
 import Control.Concurrent.STM (TVar)
-import Language.PureScript.Ide.Types (IdeDeclarationAnn)
+import Database.SQLite.Simple (Connection)
 import Language.PureScript qualified as P
+import Language.PureScript.Ide.Types (IdeDeclarationAnn)
+import Protolude
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -13,7 +13,7 @@ data LspEnvironment = LspEnvironment
   }
 
 data LspConfig = LspConfig
-  { configOutputPath :: FilePath,
+  { confOutputPath :: FilePath,
     confRootDir :: FilePath,
     confGlobs :: [FilePath]
   }
@@ -29,4 +29,4 @@ data CurrentFile = CurrentFile
     currentExternsFile :: P.ExternsFile,
     currentDeclarations :: [IdeDeclarationAnn]
   }
-  deriving (Show)
\ No newline at end of file
+  deriving (Show)
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index d2f9aebf2b..730c1ef80a 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -6,6 +6,7 @@ module Language.PureScript.Sugar.BindingGroups
   ( createBindingGroups
   , createBindingGroupsModule
   , collapseBindingGroups
+  , usedTypeNames
   ) where
 
 import Prelude

From d9f749afdc3586e60179e2d619e36819dd5992cc Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 25 Sep 2024 22:47:37 +0200
Subject: [PATCH 046/297] first attempt using sqlite

---
 app/Command/Lsp.hs                     |  24 +-
 purescript.cabal                       |   1 +
 src/Language/PureScript/Ide/Error.hs   |   3 +-
 src/Language/PureScript/Ide/Logging.hs |  14 +-
 src/Language/PureScript/Lsp/Cache copy | 233 --------------
 src/Language/PureScript/Lsp/Cache.hs   | 112 +------
 src/Language/PureScript/Lsp/Rebuild.hs |  43 ++-
 src/Language/PureScript/Lsp/State.hs   |  17 +
 src/Language/PureScript/Lsp/Types.hs   |  21 +-
 src/Language/PureScript/LspSimple.hs   | 429 +++++++++++++------------
 10 files changed, 317 insertions(+), 580 deletions(-)
 delete mode 100644 src/Language/PureScript/Lsp/Cache copy
 create mode 100644 src/Language/PureScript/Lsp/State.hs

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index 04f0935607..c36bb6022e 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -1,8 +1,7 @@
 module Command.Lsp (command) where
 
-import Control.Concurrent.STM (newTVarIO)
-import Data.IORef (newIORef)
-import Language.PureScript.Ide.Types (IdeConfiguration (..), IdeEnvironment (..), IdeLogLevel (..), emptyIdeState)
+import Language.PureScript.Ide.Types (IdeLogLevel (..))
+import Language.PureScript.Lsp.Types (LspConfig (..), mkEnv)
 import Language.PureScript.LspSimple as Lsp
 import Options.Applicative qualified as Opts
 import Protolude
@@ -34,27 +33,18 @@ command = Opts.helper <*> subcommands
         ]
 
     server :: ServerOptions -> IO ()
-    server opts'@(ServerOptions dir globs globsFromFile globsExcluded outputPath logLevel) = do
+    server opts'@(ServerOptions dir globs _globsFromFile _globsExcluded outputPath logLevel) = do
       when
         (logLevel == LogDebug || logLevel == LogAll)
         (putText "Parsed Options:" *> print opts')
       maybe (pure ()) setCurrentDirectory dir
-      ideState <- newTVarIO emptyIdeState
       let conf =
-            IdeConfiguration
-              { confLogLevel = logLevel,
-                confOutputPath = outputPath,
+            LspConfig
+              { confOutputPath = outputPath,
                 confGlobs = globs,
-                confGlobsFromFile = globsFromFile,
-                confGlobsExclude = globsExcluded
-              }
-      ts <- newIORef Nothing
-      let env =
-            IdeEnvironment
-              { ideStateVar = ideState,
-                ideConfiguration = conf,
-                ideCacheDbTimestamp = ts
+                confLogLevel = logLevel
               }
+      env <- mkEnv conf
       startServer env
 
     serverOptions :: Opts.Parser ServerOptions
diff --git a/purescript.cabal b/purescript.cabal
index 012eaadcbf..3fbb1c3013 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -342,6 +342,7 @@ library
     Language.PureScript.Lsp
     Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Cache
+    Language.PureScript.Lsp.State
     Language.PureScript.Lsp.Types
     Language.PureScript.Lsp.Rebuild
     Language.PureScript.LspSimple
diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs
index 535af939dc..1b7097bac9 100644
--- a/src/Language/PureScript/Ide/Error.hs
+++ b/src/Language/PureScript/Ide/Error.hs
@@ -11,6 +11,7 @@
 -- |
 -- Error types for psc-ide
 -----------------------------------------------------------------------------
+{-# LANGUAGE DeriveAnyClass #-}
 
 module Language.PureScript.Ide.Error
        ( IdeError(..)
@@ -33,7 +34,7 @@ data IdeError
     | ModuleNotFound ModuleIdent
     | ModuleFileNotFound ModuleIdent
     | RebuildError [(FilePath, Text)] P.MultipleErrors
-    deriving (Show)
+    deriving (Show, Exception)
 
 instance ToJSON IdeError where
   toJSON (RebuildError files errs) = object
diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs
index 925881b2d0..5451dca3ae 100644
--- a/src/Language/PureScript/Ide/Logging.hs
+++ b/src/Language/PureScript/Ide/Logging.hs
@@ -2,6 +2,7 @@
 
 module Language.PureScript.Ide.Logging
        ( runLogger
+       , runFileLogger
        , logPerf
        , displayTimeSpec
        , labelTimespec
@@ -9,11 +10,12 @@ module Language.PureScript.Ide.Logging
 
 import Protolude
 
-import "monad-logger" Control.Monad.Logger (LogLevel(..), LoggingT, MonadLogger, filterLogger, logOtherN, runStdoutLoggingT)
+import "monad-logger" Control.Monad.Logger (LogLevel(..), LoggingT, MonadLogger, filterLogger, logOtherN, runStdoutLoggingT, runFileLoggingT)
 import Data.Text qualified as T
 import Language.PureScript.Ide.Types (IdeLogLevel(..))
 import System.Clock (Clock(..), TimeSpec, diffTimeSpec, getTime, toNanoSecs)
 import Text.Printf (printf)
+import Control.Monad.Trans.Control (MonadBaseControl)
 
 runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a
 runLogger logLevel' =
@@ -25,6 +27,16 @@ runLogger logLevel' =
                                          LogDebug -> logLevel /= LevelOther "perf"
                                          LogPerf -> logLevel == LevelOther "perf")
 
+runFileLogger :: MonadBaseControl IO m => FilePath -> IdeLogLevel -> LoggingT m a -> m a
+runFileLogger fp logLevel' =
+  runFileLoggingT fp . filterLogger (\_ logLevel ->
+                                        case logLevel' of
+                                          LogAll -> True
+                                          LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)
+                                          LogNone -> False
+                                          LogDebug -> logLevel /= LevelOther "perf"
+                                          LogPerf -> logLevel == LevelOther "perf")
+
 labelTimespec :: Text -> TimeSpec -> Text
 labelTimespec label duration = label <> ": " <> displayTimeSpec duration
 
diff --git a/src/Language/PureScript/Lsp/Cache copy b/src/Language/PureScript/Lsp/Cache copy
deleted file mode 100644
index 4b0ae1447d..0000000000
--- a/src/Language/PureScript/Lsp/Cache copy	
+++ /dev/null
@@ -1,233 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-
-module Language.PureScript.Lsp.CacheCopy where
-
-import Codec.Serialise (deserialise, serialise)
-import Control.Lens ((^.))
-import Data.Aeson (encode)
-import Data.List qualified as List
-import Data.Text qualified as T
-import Database.SQLite.Simple
-import Language.PureScript qualified as P
-import Language.PureScript.CST qualified as CST
-import Language.PureScript.Externs (ExternsFile (efModuleName))
-import Language.PureScript.Ide.Error (IdeError (RebuildError))
-import Language.PureScript.Ide.Externs (convertExterns, readExternFile)
-import Language.PureScript.Ide.State (convertDeclaration', resolveDataConstructorsForModule, resolveDocumentationForModule)
-import Language.PureScript.Ide.Types (Annotation (_annDocumentation, _annExportedFrom, _annLocation, _annTypeAnnotation), IdeDeclaration (..), IdeDeclarationAnn (IdeDeclarationAnn, _idaAnnotation, _idaDeclaration), IdeNamespace (IdeNSModule, IdeNSType, IdeNSValue), ideDtorType, ideSynonymKind, ideTCKind, ideTypeKind, ideTypeOpKind, ideValueOpType, ideValueType)
-import Language.PureScript.Ide.Util (ideReadFile)
-import Language.PureScript.Lsp.DB qualified as DB
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
-import Protolude
-import System.FilePath ((</>))
-import System.FilePath.Glob (glob)
-import "monad-logger" Control.Monad.Logger (MonadLogger)
-
-initCache ::
-  (MonadIO m, MonadReader LspEnvironment m) =>
-  m ()
-initCache = do
-  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS externs (name TEXT PRIMARY KEY, path TEXT, version TEXT, externs BLOB)"
-  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS ident_source_spans (ident TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, name_space BLOB)"
-  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, import_type BLOB, imported_as TEXT)"
-  DB.execute_ $ Query "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, declaration BLOB, ann_start_col INTEGER, ann_start_line INTEGER, ann_end_col INTEGER, ann_end_line INTEGER, ann_exported_from TEXT, ann_type_annotation BLOB, ann_documentation BLOB, decl_start_col INTEGER, decl_start_line INTEGER, decl_end_col INTEGER, decl_end_line INTEGER, decl_comments TEXT, ann BLOB, decl BLOB)"
-
-
-loadCache ::
-  ( MonadIO m,
-    MonadLogger m,
-    MonadError IdeError m,
-    MonadReader LspEnvironment m
-  ) =>
-  m [(FilePath, [CST.ParserWarning])]
-loadCache = do
-  globs <- asks (confGlobs . lspConfig)
-  files <- liftIO $ concat <$> traverse glob globs
-  traverse rebuildFile files
-
-rebuildFile ::
-  ( MonadIO m,
-    MonadLogger m,
-    MonadError IdeError m,
-    MonadReader LspEnvironment m
-  ) =>
-  FilePath ->
-  m (FilePath, [CST.ParserWarning])
-rebuildFile srcPath = do
-  outputDir <- asks (confOutputPath . lspConfig)
-  (fp, input) <-
-    case List.stripPrefix "data:" srcPath of
-      Just source -> pure ("", T.pack source)
-      _ -> ideReadFile srcPath -- todo replace with VFS
-  (pwarnings, module') <- case sequence $ CST.parseFromFile fp input of
-    Left parseError ->
-      throwError $ RebuildError [(fp, input)] $ CST.toMultipleErrors fp parseError
-    Right m -> pure m
-  let externsPath = outputDir </> T.unpack (P.runModuleName $ P.getModuleName module') </> P.externsFileName
-  externs <- readExternFile externsPath
-  let (moduleDeclarations, _) = convertExterns externs
-  decls <-
-    moduleDeclarations
-      & resolveDataConstructorsForModule
-      & resolveLocations
-      <&> resolveDocumentationForModule module'
-  -- & resolveInstances externs
-  -- & resolveOperatorsForModule
-  -- & resolveReexports reexportRefs
-
-  insertExtern srcPath externsPath externs decls
-  pure (srcPath, pwarnings)
-
-insertExtern ::
-  (MonadIO m, MonadReader LspEnvironment m) =>
-  FilePath ->
-  FilePath ->
-  ExternsFile ->
-  [IdeDeclarationAnn] ->
-  m ()
-insertExtern srcPath externsPath extern annotatedDecls = do
-  DB.executeNamed
-    (Query "INSERT INTO externs (name, path) VALUES (:path, :name)")
-    [ ":src_path" := srcPath,
-      ":externs_path" := externsPath,
-      ":ef_version" := P.efVersion extern,
-      ":externs" := serialise extern,
-      ":name" := P.runModuleName name
-    ]
-
-  forM_ (P.efImports extern) $ insertEfImport name
-  forM_ annotatedDecls $ insertDeclaration name
-  where
-    name = efModuleName extern
-
-insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
-insertEfImport moduleName' ei = do
-  DB.executeNamed
-    (Query "INSERT INTO ef_imports (module_name, import_name) VALUES (:module_name, :import_name)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":imported_module_name" := P.runModuleName (P.eiModule ei),
-      ":import_type" := serialise (P.eiImportType ei),
-      ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei)
-    ]
-
-insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> IdeDeclarationAnn -> m ()
-insertDeclaration moduleName' declAnn = do
-  DB.executeNamed
-    (Query "INSERT INTO declarations (module_name, declaration) VALUES (:module_name, :declaration)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":ann_start_col" := map (P.sourcePosColumn . P.spanStart) annLocation,
-      ":ann_start_line" := map (P.sourcePosLine . P.spanStart) annLocation,
-      ":ann_end_col" := map (P.sourcePosColumn . P.spanEnd) annLocation,
-      ":ann_end_line" := map (P.sourcePosLine . P.spanEnd) annLocation,
-      ":ann_exported_from" := map P.runModuleName (_annExportedFrom ann),
-      ":ann_type_annotation" := serialise (_annTypeAnnotation ann),
-      ":ann_documentation" := serialise (_annDocumentation ann),
-      ":decl_start_col" := (P.sourcePosColumn . P.spanStart) declLocation,
-      ":decl_start_line" := (P.sourcePosLine . P.spanStart) declLocation,
-      ":decl_end_col" := (P.sourcePosColumn . P.spanEnd) declLocation,
-      ":decl_end_line" := (P.sourcePosLine . P.spanEnd) declLocation,
-      ":decl_comments" := encode comments,
-      ":ann" := serialise ann,
-      ":decl" := serialise decl
-    ]
-  where
-    ann = _idaAnnotation declAnn
-    annLocation = _annLocation ann
-
-    decl = _idaDeclaration declAnn
-
-    (declLocation, comments) =
-      decl
-        & declSourceType
-        & maybe P.nullSourceAnn P.getAnnForType
-
-declSourceType :: IdeDeclaration -> Maybe P.SourceType
-declSourceType = \case
-  IdeDeclValue x -> Just (x ^. ideValueType)
-  IdeDeclType x -> Just (x ^. ideTypeKind)
-  IdeDeclTypeSynonym x -> Just (x ^. ideSynonymKind)
-  IdeDeclDataConstructor x -> Just (x ^. ideDtorType)
-  IdeDeclTypeClass x -> Just (x ^. ideTCKind)
-  IdeDeclValueOperator x -> x ^. ideValueOpType
-  IdeDeclTypeOperator x -> x ^. ideTypeOpKind
-  IdeDeclModule _ -> Nothing
-
-resolveLocations :: (MonadIO m, MonadReader LspEnvironment m) => [IdeDeclarationAnn] -> m [IdeDeclarationAnn]
-resolveLocations = traverse resolveLocation
-
-resolveLocation :: (MonadIO m, MonadReader LspEnvironment m) => IdeDeclarationAnn -> m IdeDeclarationAnn
-resolveLocation (IdeDeclarationAnn ann d) =
-  convertDeclaration'
-    annotateFunction
-    annotateValue
-    annotateDataConstructor
-    annotateType
-    annotateType -- type classes live in the type namespace
-    annotateModule
-    d
-  where
-    -- annotateFunction :: _
-    annotateFunction x d' = do
-      def <- selectIdentSourceSpan IdeNSValue $ P.runIdent x
-      type' <- selectIdentSourceType x
-      pure $
-        IdeDeclarationAnn
-          ( ann
-              { _annLocation = def,
-                _annTypeAnnotation = type'
-              }
-          )
-          d'
-    annotateValue x d' = do
-      def <- selectIdentSourceSpan IdeNSValue x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-    annotateDataConstructor x d' = do
-      def <- selectIdentSourceSpan IdeNSValue x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-    annotateType x d' = do
-      def <- selectIdentSourceSpan IdeNSType x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-    annotateModule x d' = do
-      def <- selectIdentSourceSpan IdeNSModule x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-
-insertIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> P.SourceSpan -> m ()
-insertIdentSourceSpan nameSpace ident span =
-  DB.executeNamed
-    (Query "INSERT INTO ident_source_spans (ident, start_col, start_line, end_col, end_line) VALUES (:ident, :start_col, :start_line, :end_col, :end_line :name_space)")
-    [ ":ident" := ident,
-      ":start_col" := P.sourcePosColumn (P.spanStart span),
-      ":start_line" := P.sourcePosLine (P.spanStart span),
-      ":end_col" := P.sourcePosColumn (P.spanEnd span),
-      ":end_line" := P.sourcePosLine (P.spanEnd span),
-      ":name_space" := serialise nameSpace
-    ]
-
-selectIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> m (Maybe P.SourceSpan)
-selectIdentSourceSpan name_space ident =
-  fmap toSpan . head
-    <$> DB.queryNamed
-      (Query "SELECT start_col, start_line, end_col, end_line FROM ident_source_spans WHERE ident = :ident and name_space = :name_space")
-      [ ":ident" := ident,
-        ":name_space" := serialise name_space
-      ]
-  where
-    toSpan :: (Int, Int, Int, Int) -> P.SourceSpan
-    toSpan (startCol, startLine, endCol, endLine) =
-      P.SourceSpan
-        (T.unpack ident)
-        (P.SourcePos startLine startCol)
-        (P.SourcePos endLine endCol)
-
-insertIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> P.SourceType -> m ()
-insertIdentSourceType ident ty =
-  DB.executeNamed
-    (Query "INSERT INTO ident_source_types (ident, type) VALUES (:ident, :type)")
-    [":ident" := P.runIdent ident, ":type" := serialise ty]
-
-selectIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> m (Maybe P.SourceType)
-selectIdentSourceType ident =
-  fmap (deserialise . fromOnly) . head
-    <$> DB.queryNamed
-      (Query "SELECT type FROM ident_source_types WHERE ident = :ident")
-      [":ident" := P.runIdent ident]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 9497d21b29..bc4e1a4654 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -3,49 +3,27 @@
 module Language.PureScript.Lsp.Cache where
 
 import Codec.Serialise (deserialise, serialise)
-import Control.Lens (Field1 (_1), (^.), _1, _2, _3)
-import Control.Monad.RWS (asks)
+import Control.Lens (Field1 (_1), (^.), _1)
 import Data.Aeson (encode)
-import Data.ByteString.Lazy qualified as LB
-import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple
-import Language.PureScript (prettyPrintBinder)
 import Language.PureScript qualified as P
 import Language.PureScript.AST.Declarations (declSourceAnn)
-import Language.PureScript.AST.Exported (isExported)
 import Language.PureScript.AST.Traversals (accumTypes)
-import Language.PureScript.CST qualified as CST
 import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
-import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
-import Language.PureScript.Ide.Externs (convertExterns, readExternFile)
-import Language.PureScript.Ide.State (convertDeclaration', resolveDataConstructorsForModule, resolveDocumentationForModule)
-import Language.PureScript.Ide.Types (Annotation (_annDocumentation, _annExportedFrom, _annLocation, _annTypeAnnotation), IdeDeclaration (..), IdeDeclarationAnn (IdeDeclarationAnn, _idaAnnotation, _idaDeclaration), IdeNamespace (IdeNSModule, IdeNSType, IdeNSValue), ideDtorType, ideSynonymKind, ideTCKind, ideTypeKind, ideTypeOpKind, ideValueOpType, ideValueType, ModuleMap)
-import Language.PureScript.Ide.Util (ideReadFile)
+import Language.PureScript.Ide.Error (IdeError (GeneralError))
+import Language.PureScript.Ide.Externs (readExternFile)
+import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Pretty.Types (prettyPrintType)
-import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
 import Protolude
-import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, getDirectoryContents)
+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
 import System.FilePath (normalise, (</>))
-import System.FilePath.Glob (glob)
 import "monad-logger" Control.Monad.Logger (MonadLogger)
 
--- loadCache ::
---   ( MonadIO m,
---     MonadLogger m,
---     MonadError IdeError m,
---     MonadReader LspEnvironment m
---   ) =>
---   m [(FilePath, [CST.ParserWarning])]
--- loadCache = do
---   globs <- asks (confGlobs . lspConfig)
---   files <- liftIO $ concat <$> traverse glob globs
---   traverse rebuildFile files
-
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
 selectAllExternsMap = do
   Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectAllExterns
@@ -169,83 +147,3 @@ insertDeclaration moduleName' exportedDecls decl = do
 
     exported = Set.member decl exportedDecls
     (declLocation, comments) = declSourceAnn decl
-
-resolveLocations :: (MonadIO m, MonadReader LspEnvironment m) => [IdeDeclarationAnn] -> m [IdeDeclarationAnn]
-resolveLocations = traverse resolveLocation
-
-resolveLocation :: (MonadIO m, MonadReader LspEnvironment m) => IdeDeclarationAnn -> m IdeDeclarationAnn
-resolveLocation (IdeDeclarationAnn ann d) =
-  convertDeclaration'
-    annotateFunction
-    annotateValue
-    annotateDataConstructor
-    annotateType
-    annotateType -- type classes live in the type namespace
-    annotateModule
-    d
-  where
-    -- annotateFunction :: _
-    annotateFunction x d' = do
-      def <- selectIdentSourceSpan IdeNSValue $ P.runIdent x
-      type' <- selectIdentSourceType x
-      pure $
-        IdeDeclarationAnn
-          ( ann
-              { _annLocation = def,
-                _annTypeAnnotation = type'
-              }
-          )
-          d'
-    annotateValue x d' = do
-      def <- selectIdentSourceSpan IdeNSValue x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-    annotateDataConstructor x d' = do
-      def <- selectIdentSourceSpan IdeNSValue x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-    annotateType x d' = do
-      def <- selectIdentSourceSpan IdeNSType x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-    annotateModule x d' = do
-      def <- selectIdentSourceSpan IdeNSModule x
-      pure $ IdeDeclarationAnn (ann {_annLocation = def}) d'
-
-insertIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> P.SourceSpan -> m ()
-insertIdentSourceSpan nameSpace ident span =
-  DB.executeNamed
-    (Query "INSERT INTO ident_source_spans (ident, start_col, start_line, end_col, end_line) VALUES (:ident, :start_col, :start_line, :end_col, :end_line :name_space)")
-    [ ":ident" := ident,
-      ":start_col" := P.sourcePosColumn (P.spanStart span),
-      ":start_line" := P.sourcePosLine (P.spanStart span),
-      ":end_col" := P.sourcePosColumn (P.spanEnd span),
-      ":end_line" := P.sourcePosLine (P.spanEnd span),
-      ":name_space" := serialise nameSpace
-    ]
-
-selectIdentSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => IdeNamespace -> Text -> m (Maybe P.SourceSpan)
-selectIdentSourceSpan name_space ident =
-  fmap toSpan . head
-    <$> DB.queryNamed
-      (Query "SELECT start_col, start_line, end_col, end_line FROM ident_source_spans WHERE ident = :ident and name_space = :name_space")
-      [ ":ident" := ident,
-        ":name_space" := serialise name_space
-      ]
-  where
-    toSpan :: (Int, Int, Int, Int) -> P.SourceSpan
-    toSpan (startCol, startLine, endCol, endLine) =
-      P.SourceSpan
-        (T.unpack ident)
-        (P.SourcePos startLine startCol)
-        (P.SourcePos endLine endCol)
-
-insertIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> P.SourceType -> m ()
-insertIdentSourceType ident ty =
-  DB.executeNamed
-    (Query "INSERT INTO ident_source_types (ident, type) VALUES (:ident, :type)")
-    [":ident" := P.runIdent ident, ":type" := serialise ty]
-
-selectIdentSourceType :: (MonadIO m, MonadReader LspEnvironment m) => P.Ident -> m (Maybe P.SourceType)
-selectIdentSourceType ident =
-  fmap (deserialise . fromOnly) . head
-    <$> DB.queryNamed
-      (Query "SELECT type FROM ident_source_types WHERE ident = :ident")
-      [":ident" := P.runIdent ident]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 37da2f37bd..edd788b310 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -12,15 +12,16 @@ import Data.Text qualified as T
 import Language.PureScript qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Externs (ExternsFile (efModuleName))
-import Language.PureScript.Ide.Error (IdeError (RebuildError))
+import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
 import Language.PureScript.Lsp.Cache
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Make (ffiCodegen')
-import Protolude  hiding (moduleName)
+import Protolude hiding (moduleName)
 import System.FilePath.Glob (glob)
+import Language.PureScript.Lsp.State (cacheRebuild)
 
 rebuildAllFiles ::
   ( MonadIO m,
@@ -71,24 +72,43 @@ rebuildFile srcPath = do
     Right newExterns -> do
       insertModule fp m
       insertExtern outputDirectory newExterns
-      -- void populateVolatileState
-      -- _ <- updateCacheTimestamp
-      -- runOpenBuild (rebuildModuleOpen makeEnv externs m)
+      rebuildModuleOpen makeEnv externs m
       pure (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
   where
     codegenTargets = Set.singleton P.JS
 
+-- | Rebuilds a module but opens up its export list first and stores the result
+-- inside the rebuild cache
+rebuildModuleOpen ::
+  ( MonadReader LspEnvironment m,
+    MonadIO m
+  ) =>
+  P.MakeActions P.Make ->
+  [P.ExternsFile] ->
+  P.Module ->
+  m ()
+rebuildModuleOpen makeEnv externs m = void $ runExceptT do
+  (openResult, _) <-
+    liftIO $
+      P.runMake P.defaultOptions $
+        P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
+  case openResult of
+    Left _ ->
+      throwError (GeneralError "Failed when rebuilding with open exports")
+    Right result -> cacheRebuild result
+
 -- | Shuts the compiler up about progress messages
 shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushProgress ma =
   ma {P.progress = \_ -> pure ()}
 
 -- | Stops any kind of codegen
-shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
+shushCodegen :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
-  ma { P.codegen = \_ _ _ -> pure ()
-     , P.ffiCodegen = \_ -> pure ()
-     }
+  ma
+    { P.codegen = \_ _ _ -> pure (),
+      P.ffiCodegen = \_ -> pure ()
+    }
 
 enableForeignCheck ::
   M.Map P.ModuleName FilePath ->
@@ -132,3 +152,8 @@ sortExterns m ex = do
     -- Sort a list so its elements appear in the same order as in another list.
     inOrderOf :: (Ord a) => [a] -> [a] -> [a]
     inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
+
+
+-- | Removes a modules export list.
+openModuleExports :: P.Module -> P.Module
+openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
new file mode 100644
index 0000000000..b7be627317
--- /dev/null
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE PackageImports #-}
+module Language.PureScript.Lsp.State where
+
+
+import Control.Concurrent.STM (modifyTVar)
+import Language.PureScript.Externs (ExternsFile (..))
+import Language.PureScript.Lsp.Types
+import Protolude hiding (moduleName, unzip)
+
+-- | Sets rebuild cache to the given ExternsFile
+cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> m ()
+cacheRebuild ef = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically . modifyTVar st $ \x ->
+    x
+      { currentFile = Just $ CurrentFile (efModuleName ef) ef
+      }
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index e238863a77..eeefc5fb07 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -1,9 +1,11 @@
+{-# LANGUAGE PackageImports #-}
+
 module Language.PureScript.Lsp.Types where
 
-import Control.Concurrent.STM (TVar)
-import Database.SQLite.Simple (Connection)
+import Control.Concurrent.STM (TVar, newTVarIO)
+import Database.SQLite.Simple (Connection, open)
 import Language.PureScript qualified as P
-import Language.PureScript.Ide.Types (IdeDeclarationAnn)
+import Language.PureScript.Ide.Types (IdeLogLevel)
 import Protolude
 
 data LspEnvironment = LspEnvironment
@@ -12,10 +14,16 @@ data LspEnvironment = LspEnvironment
     lspStateVar :: TVar LspState
   }
 
+mkEnv :: LspConfig -> IO LspEnvironment
+mkEnv conf = do 
+   connection <- open (confOutputPath conf <> "lsp.db") 
+   st <- newTVarIO (LspState Nothing)
+   pure $ LspEnvironment conf connection st
+
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
-    confRootDir :: FilePath,
-    confGlobs :: [FilePath]
+    confGlobs :: [FilePath],
+    confLogLevel :: IdeLogLevel
   }
   deriving (Show)
 
@@ -26,7 +34,6 @@ data LspState = LspState
 
 data CurrentFile = CurrentFile
   { currentModuleName :: P.ModuleName,
-    currentExternsFile :: P.ExternsFile,
-    currentDeclarations :: [IdeDeclarationAnn]
+    currentExternsFile :: P.ExternsFile
   }
   deriving (Show)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 36e66842c9..b48e75c0d1 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
@@ -42,25 +43,36 @@ import Language.PureScript.Ide.Completion qualified as Purs.Completion
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
 import Language.PureScript.Ide.Filter (Filter, moduleFilter)
 import Language.PureScript.Ide.Imports (parseImportsFromFile)
+import Language.PureScript.Ide.Logging (runFileLogger)
 import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
-import Language.PureScript.Ide.Rebuild (rebuildFileAsync)
 import Language.PureScript.Ide.State (cachedRebuild, getAllModules, getFileState)
-import Language.PureScript.Ide.Types (Completion (..), Ide, IdeConfiguration (confLogLevel), IdeDeclarationAnn, IdeEnvironment (ideConfiguration), IdeFileState (fsModules), Success (RebuildSuccess, TextResult))
+import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeDeclarationAnn)
 import Language.PureScript.Ide.Util (runLogger)
+import Language.PureScript.Lsp.Cache (insertAllExterns)
+import Language.PureScript.Lsp.Rebuild (rebuildAllFiles, rebuildFile)
+import Language.PureScript.Lsp.Types (LspConfig (confLogLevel, confOutputPath), LspEnvironment (lspConfig))
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
+import System.FilePath (takeDirectory, (</>))
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
 
 -- import Language.Haskell.LSP.VFS qualified as VFS
 
-type HandlerM config = Server.LspT config (ReaderT IdeEnvironment (LoggingT IO))
+type HandlerM config = Server.LspT config (ReaderT LspEnvironment (LoggingT IO))
 
-type IdeM = ReaderT IdeEnvironment (LoggingT (ExceptT IdeError IO))
+type LspM = ReaderT LspEnvironment (LoggingT (ExceptT IdeError IO))
 
-liftIde :: IdeM a -> HandlerM config (Either IdeError a)
-liftIde = lift . mapReaderT (mapLoggingT runExceptT)
+fromLsp :: LspM a -> HandlerM config a
+fromLsp = lift . mapReaderT (mapLoggingT (throwIdeError <=< runExceptT))
+  where
+    throwIdeError = \case
+      Left err -> liftIO $ throwIO err
+      Right a -> pure a
+
+fromLspWithErr :: LspM a -> HandlerM config (Either IdeError a)
+fromLspWithErr = lift . mapReaderT (mapLoggingT runExceptT)
 
 type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
 
@@ -80,10 +92,18 @@ handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
-        sendInfoMsg "SMethod_Initialized"
-        void $ liftIde $ findAvailableExterns >>= loadModulesAsync
+        logT "SMethod_Initialized"
+        res <- fromLspWithErr do
+          logT "insertAllExterns"
+          insertAllExterns
+          logT "rebuildAllFiles"
+          rebuildAllFiles
+
         log_ ("OA purs lsp server initialized" :: T.Text)
-        sendInfoMsg "OA purs lsp server initialized",
+        sendInfoMsg $
+          "OA purs lsp server initialized: " <> case res of
+            Left err -> show err
+            Right _ -> "Rebuild successful",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
         sendInfoMsg "TextDocumentDidOpen",
       Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
@@ -103,163 +123,163 @@ handlers diagErrs =
           Right $
             Types.DocumentDiagnosticReport $
               Types.InL $
-                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentCodeAction"
-        let params = req ^. LSP.params
-            diags = params ^. LSP.context . LSP.diagnostics
-            uri = getMsgUri req
-
-        errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
-
-        res $
-          Right $
-            Types.InL $
-              errs & fmap \(diag, err) ->
-                let textEdits :: [Types.TextEdit]
-                    textEdits =
-                      toSuggestion err
-                        & maybeToList
-                          >>= suggestionToEdit
-
-                    suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just errorPos@JsonErrors.ErrorPosition {..})) =
-                      let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
-                          end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
-                       in pure $ Types.TextEdit (Types.Range start end) replacement
-                    suggestionToEdit _ = []
-                 in Types.InR $
-                      Types.CodeAction
-                        "Apply suggestion"
-                        (Just Types.CodeActionKind_QuickFix)
-                        (Just diags)
-                        (Just True)
-                        Nothing -- disabled
-                        ( Just $
-                            Types.WorkspaceEdit
-                              (Just $ Map.singleton uri textEdits)
-                              Nothing
-                              Nothing
-                        )
-                        Nothing
-                        Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-        let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
-
-        let filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            docUri =
-              docIdent
-                ^. LSP.uri
-                  . to Types.toNormalizedUri
-
-        vfMb <- Server.getVirtualFile docUri
-
-        for_ vfMb \vf -> do
-          let word = getWordAt (VFS._file_text vf) pos
-          cache <- liftIde cachedRebuild
-          let moduleName' = case cache of
-                Right (Just (mName, _)) -> Just mName
-                _ -> Nothing
-
-          imports <-
-            filePathMb
-              & maybe (pure Nothing) (fmap hush . liftIde . parseImportsFromFile)
-
-          let filters :: [Filter]
-              filters =
-                imports
-                  & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-              getInputModName (n, _, _) = n
-
-              insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-              insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-          completions <- liftIde $ getExactCompletionsWithPrim word filters moduleName'
-
-          let hoverInfo = case head <$> completions of
-                Right (Just completion) -> completionToHoverInfo word completion
-                _ -> word
-
-          res $
-            Right $
-              Types.InL $
-                Types.Hover
-                  ( Types.InL $
-                      Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
-                  )
-                  Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentDefinition"
-        let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            uri =
-              req
-                ^. LSP.params
-                  . LSP.textDocument
-                  . LSP.uri
-                  . to Types.toNormalizedUri
-
-            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-        vfMb <- Server.getVirtualFile uri
-
-        for_ vfMb \vf -> do
-          let word = getWordAt (VFS._file_text vf) pos
-          cache <- liftIde cachedRebuild
-          let moduleName' = case cache of
-                Right (Just (mName, _)) -> Just mName
-                _ -> Nothing
-
-          imports <-
-            filePathMb
-              & maybe (pure Nothing) (fmap hush . liftIde . parseImportsFromFile)
-
-          let filters :: [Filter]
-              filters =
-                imports
-                  & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-              getInputModName (n, _, _) = n
-
-              insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-              insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-          completions :: Either IdeError [Completion] <- liftIde $ getExactCompletionsWithPrim word filters moduleName'
-
-          sendInfoMsg $ "Completions: " <> show completions
-          let withLocation =
-                fold completions
-                  & mapMaybe
-                    ( \c -> case complLocation c of
-                        Just loc -> Just (c, loc)
-                        Nothing -> Nothing
-                    )
-                  & head
-
-          paths <- liftIde $ Map.map snd . fsModules <$> getFileState
-
-          case withLocation of
-            Just (completion, location) -> do
-              let fpMb =
-                    Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
-
-              case fpMb of
-                Nothing -> do
-                  sendInfoMsg "No file path for module"
-                  nullRes
-                Just fp ->
-                  res $
-                    Right $
-                      Types.InL $
-                        Types.Definition $
-                          Types.InL $
-                            Types.Location
-                              (Types.filePathToUri fp)
-                              (spanToRange location)
-            _ -> do
-              sendInfoMsg "No location for completion"
-              nullRes
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing
+                -- Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
+                --   sendInfoMsg "SMethod_TextDocumentCodeAction"
+                --   let params = req ^. LSP.params
+                --       diags = params ^. LSP.context . LSP.diagnostics
+                --       uri = getMsgUri req
+
+                --   errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
+
+                --   res $
+                --     Right $
+                --       Types.InL $
+                --         errs & fmap \(diag, err) ->
+                --           let textEdits :: [Types.TextEdit]
+                --               textEdits =
+                --                 toSuggestion err
+                --                   & maybeToList
+                --                     >>= suggestionToEdit
+
+                --               suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
+                --               suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just errorPos@JsonErrors.ErrorPosition {..})) =
+                --                 let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
+                --                     end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
+                --                  in pure $ Types.TextEdit (Types.Range start end) replacement
+                --               suggestionToEdit _ = []
+                --            in Types.InR $
+                --                 Types.CodeAction
+                --                   "Apply suggestion"
+                --                   (Just Types.CodeActionKind_QuickFix)
+                --                   (Just diags)
+                --                   (Just True)
+                --                   Nothing -- disabled
+                --                   ( Just $
+                --                       Types.WorkspaceEdit
+                --                         (Just $ Map.singleton uri textEdits)
+                --                         Nothing
+                --                         Nothing
+                --                   )
+                --                   Nothing
+                --                   Nothing,
+                -- Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+                --   let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
+
+                --   let filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+                --       docUri =
+                --         docIdent
+                --           ^. LSP.uri
+                --             . to Types.toNormalizedUri
+
+                --   vfMb <- Server.getVirtualFile docUri
+
+                --   for_ vfMb \vf -> do
+                --     let word = getWordAt (VFS._file_text vf) pos
+                --     cache <- fromLsp cachedRebuild
+                --     let moduleName' = case cache of
+                --           Right (Just (mName, _)) -> Just mName
+                --           _ -> Nothing
+
+                --     imports <-
+                --       filePathMb
+                --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
+
+                --     let filters :: [Filter]
+                --         filters =
+                --           imports
+                --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                --         getInputModName (n, _, _) = n
+
+                --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                --     completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+                --     let hoverInfo = case head <$> completions of
+                --           Right (Just completion) -> completionToHoverInfo word completion
+                --           _ -> word
+
+                --     res $
+                --       Right $
+                --         Types.InL $
+                --           Types.Hover
+                --             ( Types.InL $
+                --                 Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
+                --             )
+                --             Nothing,
+                -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+                --   sendInfoMsg "SMethod_TextDocumentDefinition"
+                --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+                --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+                --       uri =
+                --         req
+                --           ^. LSP.params
+                --             . LSP.textDocument
+                --             . LSP.uri
+                --             . to Types.toNormalizedUri
+
+                --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+                --   vfMb <- Server.getVirtualFile uri
+
+                --   for_ vfMb \vf -> do
+                --     let word = getWordAt (VFS._file_text vf) pos
+                --     cache <- fromLsp cachedRebuild
+                --     let moduleName' = case cache of
+                --           Right (Just (mName, _)) -> Just mName
+                --           _ -> Nothing
+
+                --     imports <-
+                --       filePathMb
+                --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
+
+                --     let filters :: [Filter]
+                --         filters =
+                --           imports
+                --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                --         getInputModName (n, _, _) = n
+
+                --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+                --     sendInfoMsg $ "Completions: " <> show completions
+                --     let withLocation =
+                --           fold completions
+                --             & mapMaybe
+                --               ( \c -> case complLocation c of
+                --                   Just loc -> Just (c, loc)
+                --                   Nothing -> Nothing
+                --               )
+                --             & head
+
+                --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
+
+                --     case withLocation of
+                --       Just (completion, location) -> do
+                --         let fpMb =
+                --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
+
+                --         case fpMb of
+                --           Nothing -> do
+                --             sendInfoMsg "No file path for module"
+                --             nullRes
+                --           Just fp ->
+                --             res $
+                --               Right $
+                --                 Types.InL $
+                --                   Types.Definition $
+                --                     Types.InL $
+                --                       Types.Location
+                --                         (Types.filePathToUri fp)
+                --                         (spanToRange location)
+                --       _ -> do
+                --         sendInfoMsg "No location for completion"
+                --         nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -270,7 +290,7 @@ handlers diagErrs =
       logT $ "Rebuilding file: " <> show (uri, fileName)
       case fileName of
         Just file -> do
-          res <- liftIde $ rebuildFile file
+          res <- fmap snd <$> fromLspWithErr (rebuildFile file)
           getResultDiagnostics res
         Nothing -> do
           sendInfoMsg $ "No file path for uri: " <> show uri
@@ -279,16 +299,8 @@ handlers diagErrs =
     getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
     getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
 
-    getResultDiagnostics :: Either IdeError Success -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
+    getResultDiagnostics :: Either IdeError MultipleErrors -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
     getResultDiagnostics res = case res of
-      Right success ->
-        case success of
-          RebuildSuccess errs -> do
-            let errors = runMultipleErrors errs
-                diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
-            pure (errors, diags)
-          TextResult _ -> pure ([], [])
-          _ -> pure ([], [])
       Left (RebuildError _ errs) -> do
         let errors = runMultipleErrors errs
             diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
@@ -296,6 +308,11 @@ handlers diagErrs =
       Left err -> do
         sendError err
         pure ([], [])
+      Right errs | Errors.nonEmpty errs -> do
+        let errors = runMultipleErrors errs
+            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
+        pure (errors, diags)
+      _ -> pure ([], [])
       where
         errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
         errorMessageDiagnostic severity msg@((ErrorMessage hints _)) =
@@ -337,15 +354,15 @@ sendError err =
         "Something went wrong:\n" <> textError err
     )
 
-rebuildFile :: FilePath -> IdeM Success
-rebuildFile file = do
-  rebuildFileAsync file Nothing mempty
+-- rebuildFile :: FilePath -> LspM Success
+-- rebuildFile file = do
+--   rebuildFile file  mempty
 
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
 
-main :: IdeEnvironment -> IO Int
-main ideEnv = do
+main :: LspEnvironment -> IO Int
+main lspEnv = do
   diagErrs <- newIORef Map.empty
   Server.runServer $
     Server.ServerDefinition
@@ -359,13 +376,15 @@ main ideEnv = do
         staticHandlers = \_caps -> do handlers diagErrs,
         interpretHandler = \env ->
           Server.Iso
-            ( runLogger (confLogLevel (ideConfiguration ideEnv))
-                . flip runReaderT ideEnv
+            ( runFileLogger logPath (confLogLevel (lspConfig lspEnv))
+                . flip runReaderT lspEnv
                 . Server.runLspT env
             )
             liftIO,
         options = lspOptions
       }
+  where 
+    logPath = (</>) "logs.txt" $ takeDirectory $ confOutputPath $ lspConfig lspEnv
 
 syncOptions :: Types.TextDocumentSyncOptions
 syncOptions =
@@ -409,28 +428,28 @@ logToFile txt =
       )
       (const $ pure ())
 
-getCompletionsWithPrim ::
-  (Ide m) =>
-  [Filter] ->
-  Matcher IdeDeclarationAnn ->
-  Maybe P.ModuleName ->
-  Purs.Completion.CompletionOptions ->
-  m [Completion]
-getCompletionsWithPrim filters matcher currentModule complOptions = do
-  modules <- getAllModules currentModule
-  let insertPrim = Map.union idePrimDeclarations
-  pure (getCompletions filters matcher complOptions (insertPrim modules))
-
-getExactCompletionsWithPrim ::
-  (Ide m) =>
-  Text ->
-  [Filter] ->
-  Maybe P.ModuleName ->
-  m [Completion]
-getExactCompletionsWithPrim search filters currentModule = do
-  modules <- getAllModules currentModule
-  let insertPrim = Map.union idePrimDeclarations
-  pure (getExactCompletions search filters (insertPrim modules))
+-- getCompletionsWithPrim ::
+--   (Ide m) =>
+--   [Filter] ->
+--   Matcher IdeDeclarationAnn ->
+--   Maybe P.ModuleName ->
+--   Purs.Completion.CompletionOptions ->
+--   m [Completion]
+-- getCompletionsWithPrim filters matcher currentModule complOptions = do
+--   modules <- getAllModules currentModule
+--   let insertPrim = Map.union idePrimDeclarations
+--   pure (getCompletions filters matcher complOptions (insertPrim modules))
+
+-- getExactCompletionsWithPrim ::
+--   (Ide m) =>
+--   Text ->
+--   [Filter] ->
+--   Maybe P.ModuleName ->
+--   m [Completion]
+-- getExactCompletionsWithPrim search filters currentModule = do
+--   modules <- getAllModules currentModule
+--   let insertPrim = Map.union idePrimDeclarations
+--   pure (getExactCompletions search filters (insertPrim modules))
 
 getWordAt :: Rope -> Types.Position -> Text
 getWordAt file Types.Position {..} =

From 14fbfac45f23afed1f86d0be79c241bae814738f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 26 Sep 2024 01:00:54 +0200
Subject: [PATCH 047/297] initial lint working

---
 src/Language/PureScript/Ide/Logging.hs |  23 +-
 src/Language/PureScript/Lsp/Cache.hs   |  29 ++-
 src/Language/PureScript/LspSimple.hs   | 347 +++++++++++++------------
 3 files changed, 208 insertions(+), 191 deletions(-)

diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs
index 5451dca3ae..ce74b49ec6 100644
--- a/src/Language/PureScript/Ide/Logging.hs
+++ b/src/Language/PureScript/Ide/Logging.hs
@@ -2,7 +2,7 @@
 
 module Language.PureScript.Ide.Logging
        ( runLogger
-       , runFileLogger
+       , runErrLogger
        , logPerf
        , displayTimeSpec
        , labelTimespec
@@ -10,12 +10,11 @@ module Language.PureScript.Ide.Logging
 
 import Protolude
 
-import "monad-logger" Control.Monad.Logger (LogLevel(..), LoggingT, MonadLogger, filterLogger, logOtherN, runStdoutLoggingT, runFileLoggingT)
+import "monad-logger" Control.Monad.Logger (LogLevel(..), LoggingT, MonadLogger, filterLogger, logOtherN, runStdoutLoggingT, runStderrLoggingT)
 import Data.Text qualified as T
 import Language.PureScript.Ide.Types (IdeLogLevel(..))
 import System.Clock (Clock(..), TimeSpec, diffTimeSpec, getTime, toNanoSecs)
 import Text.Printf (printf)
-import Control.Monad.Trans.Control (MonadBaseControl)
 
 runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a
 runLogger logLevel' =
@@ -27,15 +26,15 @@ runLogger logLevel' =
                                          LogDebug -> logLevel /= LevelOther "perf"
                                          LogPerf -> logLevel == LevelOther "perf")
 
-runFileLogger :: MonadBaseControl IO m => FilePath -> IdeLogLevel -> LoggingT m a -> m a
-runFileLogger fp logLevel' =
-  runFileLoggingT fp . filterLogger (\_ logLevel ->
-                                        case logLevel' of
-                                          LogAll -> True
-                                          LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)
-                                          LogNone -> False
-                                          LogDebug -> logLevel /= LevelOther "perf"
-                                          LogPerf -> logLevel == LevelOther "perf")
+runErrLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a
+runErrLogger logLevel' =
+  runStderrLoggingT . filterLogger (\_ logLevel ->
+                                       case logLevel' of
+                                         LogAll -> True
+                                         LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug)
+                                         LogNone -> False
+                                         LogDebug -> logLevel /= LevelOther "perf"
+                                         LogPerf -> logLevel == LevelOther "perf")
 
 labelTimespec :: Text -> TimeSpec -> Text
 labelTimespec label duration = label <> ": " <> displayTimeSpec duration
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index bc4e1a4654..1d7876a64e 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -24,6 +24,22 @@ import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents
 import System.FilePath (normalise, (</>))
 import "monad-logger" Control.Monad.Logger (MonadLogger)
 
+dropTables :: (MonadIO m, MonadReader LspEnvironment m) => m ()
+dropTables = do
+  DB.execute_ "DROP TABLE IF EXISTS modules"
+  DB.execute_ "DROP TABLE IF EXISTS declarations"
+  DB.execute_ "DROP TABLE IF EXISTS externs"
+  DB.execute_ "DROP TABLE IF EXISTS ef_imports"
+  DB.execute_ "DROP TABLE IF EXISTS ef_exports"
+
+initDb :: (MonadReader LspEnvironment m, MonadIO m) => m ()
+initDb = do
+  DB.execute_ "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (name TEXT PRIMARY KEY, path TEXT, ef_version TEXT, value BLOB, module_name TEXT)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value TEXT, span_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
 selectAllExternsMap = do
   Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectAllExterns
@@ -43,7 +59,8 @@ insertAllExterns = do
   oDir <- asks (confOutputPath . lspConfig)
   externPaths <- findAvailableExterns
   forM_ externPaths $ \name -> do
-    extern <- readExternFile (oDir </> T.unpack (P.runModuleName name) <> externsFileName)
+    extern <- readExternFile (oDir </> toS (P.runModuleName name) </> P.externsFileName)
+
     insertExtern oDir extern
 
 -- | Finds all the externs inside the output folder and returns the
@@ -75,7 +92,7 @@ insertExtern ::
   m ()
 insertExtern outDir extern = do
   DB.executeNamed
-    (Query "INSERT INTO externs (name, path) VALUES (:path, :name)")
+    (Query "INSERT INTO externs (path, ef_version, value, module_name) VALUES (:path, :ef_version, :value, :module_name)")
     [ ":path" := externsPath,
       ":ef_version" := P.efVersion extern,
       ":value" := serialise extern,
@@ -90,7 +107,7 @@ insertExtern outDir extern = do
 insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
 insertEfImport moduleName' ei = do
   DB.executeNamed
-    (Query "INSERT INTO ef_imports (module_name, import_name) VALUES (:module_name, :import_name)")
+    (Query "INSERT INTO ef_imports (module_name, imported_module, import_type, imported_as) VALUES (:module_name, :imported_module, :import_type, :imported_as)")
     [ ":module_name" := P.runModuleName moduleName',
       ":imported_module" := P.runModuleName (P.eiModule ei),
       ":import_type" := serialise (P.eiImportType ei),
@@ -100,7 +117,7 @@ insertEfImport moduleName' ei = do
 insertEfExport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.DeclarationRef -> m ()
 insertEfExport moduleName' dr = do
   DB.executeNamed
-    (Query "INSERT INTO ef_exports (module_name, export_name) VALUES (:module_name, :export_name)")
+    (Query "INSERT INTO ef_exports (module_name, value, span_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :span_name, :start_col, :start_line, :end_col, :end_line)")
     [ ":module_name" := P.runModuleName moduleName',
       ":value" := serialise dr,
       ":span_name" := P.spanName span,
@@ -116,7 +133,7 @@ insertModule :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> P.Modul
 insertModule srcPath m = do
   let moduleName' = P.getModuleName m
   DB.executeNamed
-    (Query "INSERT INTO modules (module_name, module) VALUES (:module_name, :module)")
+    (Query "INSERT INTO modules (module_name, path) VALUES (:module_name, :path)")
     [ ":module_name" := P.runModuleName moduleName',
       ":path" := srcPath
     ]
@@ -127,7 +144,7 @@ insertModule srcPath m = do
 insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Set P.Declaration -> P.Declaration -> m ()
 insertDeclaration moduleName' exportedDecls decl = do
   DB.executeNamed
-    (Query "INSERT INTO declarations (module_name, declaration) VALUES (:module_name, :name, :value)")
+    (Query "INSERT INTO declarations (module_name, name, type_printed, start_col, start_line, end_col, end_line, comments, exported, value) VALUES (:module_name, :name, :type_printed, :start_col, :start_line, :end_col, :end_line, :comments, :exported, :value)")
     [ ":module_name" := P.runModuleName moduleName',
       ":name" := P.spanName declLocation,
       ":type_printed" := typeName,
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index b48e75c0d1..9d5904dbe8 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -43,13 +43,12 @@ import Language.PureScript.Ide.Completion qualified as Purs.Completion
 import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
 import Language.PureScript.Ide.Filter (Filter, moduleFilter)
 import Language.PureScript.Ide.Imports (parseImportsFromFile)
-import Language.PureScript.Ide.Logging (runFileLogger)
+import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
-import Language.PureScript.Ide.State (cachedRebuild, getAllModules, getFileState)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeDeclarationAnn)
 import Language.PureScript.Ide.Util (runLogger)
-import Language.PureScript.Lsp.Cache (insertAllExterns)
+import Language.PureScript.Lsp.Cache (dropTables, initDb, insertAllExterns)
 import Language.PureScript.Lsp.Rebuild (rebuildAllFiles, rebuildFile)
 import Language.PureScript.Lsp.Types (LspConfig (confLogLevel, confOutputPath), LspEnvironment (lspConfig))
 import Protolude hiding (to)
@@ -57,6 +56,8 @@ import System.Directory (createDirectoryIfMissing)
 import System.FilePath (takeDirectory, (</>))
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
+import GHC.Float (Floating(log))
+import Debug.Trace (traceM)
 
 -- import Language.Haskell.LSP.VFS qualified as VFS
 
@@ -92,18 +93,16 @@ handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
-        logT "SMethod_Initialized"
         res <- fromLspWithErr do
-          logT "insertAllExterns"
+          dropTables
+          initDb
           insertAllExterns
-          logT "rebuildAllFiles"
-          rebuildAllFiles
-
-        log_ ("OA purs lsp server initialized" :: T.Text)
-        sendInfoMsg $
-          "OA purs lsp server initialized: " <> case res of
-            Left err -> show err
-            Right _ -> "Rebuild successful",
+          -- rebuildAllFiles
+        case res of
+          Left err -> do
+            log_ err
+            sendInfoMsg $ show err
+          Right _ -> sendInfoMsg "OA purs lsp server initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
         sendInfoMsg "TextDocumentDidOpen",
       Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
@@ -118,168 +117,171 @@ handlers diagErrs =
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDiagnostic"
         (errs, diagnostics) <- getFileDiagnotics req
+        sendInfoMsg $ "Errors: " <> show errs
+        sendInfoMsg $ "diagnostics: " <> show diagnostics
         insertDiagnosticErrors diagErrs errs diagnostics
         res $
           Right $
             Types.DocumentDiagnosticReport $
               Types.InL $
-                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing
-                -- Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
-                --   sendInfoMsg "SMethod_TextDocumentCodeAction"
-                --   let params = req ^. LSP.params
-                --       diags = params ^. LSP.context . LSP.diagnostics
-                --       uri = getMsgUri req
-
-                --   errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
-
-                --   res $
-                --     Right $
-                --       Types.InL $
-                --         errs & fmap \(diag, err) ->
-                --           let textEdits :: [Types.TextEdit]
-                --               textEdits =
-                --                 toSuggestion err
-                --                   & maybeToList
-                --                     >>= suggestionToEdit
-
-                --               suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-                --               suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just errorPos@JsonErrors.ErrorPosition {..})) =
-                --                 let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
-                --                     end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
-                --                  in pure $ Types.TextEdit (Types.Range start end) replacement
-                --               suggestionToEdit _ = []
-                --            in Types.InR $
-                --                 Types.CodeAction
-                --                   "Apply suggestion"
-                --                   (Just Types.CodeActionKind_QuickFix)
-                --                   (Just diags)
-                --                   (Just True)
-                --                   Nothing -- disabled
-                --                   ( Just $
-                --                       Types.WorkspaceEdit
-                --                         (Just $ Map.singleton uri textEdits)
-                --                         Nothing
-                --                         Nothing
-                --                   )
-                --                   Nothing
-                --                   Nothing,
-                -- Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-                --   let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
-
-                --   let filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-                --       docUri =
-                --         docIdent
-                --           ^. LSP.uri
-                --             . to Types.toNormalizedUri
-
-                --   vfMb <- Server.getVirtualFile docUri
-
-                --   for_ vfMb \vf -> do
-                --     let word = getWordAt (VFS._file_text vf) pos
-                --     cache <- fromLsp cachedRebuild
-                --     let moduleName' = case cache of
-                --           Right (Just (mName, _)) -> Just mName
-                --           _ -> Nothing
-
-                --     imports <-
-                --       filePathMb
-                --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
-
-                --     let filters :: [Filter]
-                --         filters =
-                --           imports
-                --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                --         getInputModName (n, _, _) = n
-
-                --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                --     completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-                --     let hoverInfo = case head <$> completions of
-                --           Right (Just completion) -> completionToHoverInfo word completion
-                --           _ -> word
-
-                --     res $
-                --       Right $
-                --         Types.InL $
-                --           Types.Hover
-                --             ( Types.InL $
-                --                 Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
-                --             )
-                --             Nothing,
-                -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-                --   sendInfoMsg "SMethod_TextDocumentDefinition"
-                --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-                --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-                --       uri =
-                --         req
-                --           ^. LSP.params
-                --             . LSP.textDocument
-                --             . LSP.uri
-                --             . to Types.toNormalizedUri
-
-                --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-                --   vfMb <- Server.getVirtualFile uri
-
-                --   for_ vfMb \vf -> do
-                --     let word = getWordAt (VFS._file_text vf) pos
-                --     cache <- fromLsp cachedRebuild
-                --     let moduleName' = case cache of
-                --           Right (Just (mName, _)) -> Just mName
-                --           _ -> Nothing
-
-                --     imports <-
-                --       filePathMb
-                --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
-
-                --     let filters :: [Filter]
-                --         filters =
-                --           imports
-                --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                --         getInputModName (n, _, _) = n
-
-                --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-                --     sendInfoMsg $ "Completions: " <> show completions
-                --     let withLocation =
-                --           fold completions
-                --             & mapMaybe
-                --               ( \c -> case complLocation c of
-                --                   Just loc -> Just (c, loc)
-                --                   Nothing -> Nothing
-                --               )
-                --             & head
-
-                --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
-
-                --     case withLocation of
-                --       Just (completion, location) -> do
-                --         let fpMb =
-                --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
-
-                --         case fpMb of
-                --           Nothing -> do
-                --             sendInfoMsg "No file path for module"
-                --             nullRes
-                --           Just fp ->
-                --             res $
-                --               Right $
-                --                 Types.InL $
-                --                   Types.Definition $
-                --                     Types.InL $
-                --                       Types.Location
-                --                         (Types.filePathToUri fp)
-                --                         (spanToRange location)
-                --       _ -> do
-                --         sendInfoMsg "No location for completion"
-                --         nullRes
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
+        sendInfoMsg "SMethod_TextDocumentCodeAction"
+        let params = req ^. LSP.params
+            diags = params ^. LSP.context . LSP.diagnostics
+            uri = getMsgUri req
+
+        errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
+
+        res $
+          Right $
+            Types.InL $
+              errs & fmap \(diag, err) ->
+                let textEdits :: [Types.TextEdit]
+                    textEdits =
+                      toSuggestion err
+                        & maybeToList
+                          >>= suggestionToEdit
+
+                    suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
+                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just errorPos@JsonErrors.ErrorPosition {..})) =
+                      let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
+                          end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
+                       in pure $ Types.TextEdit (Types.Range start end) replacement
+                    suggestionToEdit _ = []
+                 in Types.InR $
+                      Types.CodeAction
+                        "Apply suggestion"
+                        (Just Types.CodeActionKind_QuickFix)
+                        (Just diags)
+                        (Just True)
+                        Nothing -- disabled
+                        ( Just $
+                            Types.WorkspaceEdit
+                              (Just $ Map.singleton uri textEdits)
+                              Nothing
+                              Nothing
+                        )
+                        Nothing
+                        Nothing
+                        -- Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+                        --   let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
+
+                        --   let filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+                        --       docUri =
+                        --         docIdent
+                        --           ^. LSP.uri
+                        --             . to Types.toNormalizedUri
+
+                        --   vfMb <- Server.getVirtualFile docUri
+
+                        --   for_ vfMb \vf -> do
+                        --     let word = getWordAt (VFS._file_text vf) pos
+                        --     cache <- fromLsp cachedRebuild
+                        --     let moduleName' = case cache of
+                        --           Right (Just (mName, _)) -> Just mName
+                        --           _ -> Nothing
+
+                        --     imports <-
+                        --       filePathMb
+                        --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
+
+                        --     let filters :: [Filter]
+                        --         filters =
+                        --           imports
+                        --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                        --         getInputModName (n, _, _) = n
+
+                        --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                        --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                        --     completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+                        --     let hoverInfo = case head <$> completions of
+                        --           Right (Just completion) -> completionToHoverInfo word completion
+                        --           _ -> word
+
+                        --     res $
+                        --       Right $
+                        --         Types.InL $
+                        --           Types.Hover
+                        --             ( Types.InL $
+                        --                 Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
+                        --             )
+                        --             Nothing
+                        --             ,
+                        -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+                        --   sendInfoMsg "SMethod_TextDocumentDefinition"
+                        --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+                        --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+                        --       uri =
+                        --         req
+                        --           ^. LSP.params
+                        --             . LSP.textDocument
+                        --             . LSP.uri
+                        --             . to Types.toNormalizedUri
+
+                        --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+                        --   vfMb <- Server.getVirtualFile uri
+
+                        --   for_ vfMb \vf -> do
+                        --     let word = getWordAt (VFS._file_text vf) pos
+                        --     cache <- fromLsp cachedRebuild
+                        --     let moduleName' = case cache of
+                        --           Right (Just (mName, _)) -> Just mName
+                        --           _ -> Nothing
+
+                        --     imports <-
+                        --       filePathMb
+                        --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
+
+                        --     let filters :: [Filter]
+                        --         filters =
+                        --           imports
+                        --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                        --         getInputModName (n, _, _) = n
+
+                        --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                        --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                        --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+                        --     sendInfoMsg $ "Completions: " <> show completions
+                        --     let withLocation =
+                        --           fold completions
+                        --             & mapMaybe
+                        --               ( \c -> case complLocation c of
+                        --                   Just loc -> Just (c, loc)
+                        --                   Nothing -> Nothing
+                        --               )
+                        --             & head
+
+                        --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
+
+                        --     case withLocation of
+                        --       Just (completion, location) -> do
+                        --         let fpMb =
+                        --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
+
+                        --         case fpMb of
+                        --           Nothing -> do
+                        --             sendInfoMsg "No file path for module"
+                        --             nullRes
+                        --           Just fp ->
+                        --             res $
+                        --               Right $
+                        --                 Types.InL $
+                        --                   Types.Definition $
+                        --                     Types.InL $
+                        --                       Types.Location
+                        --                         (Types.filePathToUri fp)
+                        --                         (spanToRange location)
+                        --       _ -> do
+                        --         sendInfoMsg "No location for completion"
+                        --         nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -291,6 +293,7 @@ handlers diagErrs =
       case fileName of
         Just file -> do
           res <- fmap snd <$> fromLspWithErr (rebuildFile file)
+          logT $ "Rebuild result: " <> show res
           getResultDiagnostics res
         Nothing -> do
           sendInfoMsg $ "No file path for uri: " <> show uri
@@ -376,15 +379,13 @@ main lspEnv = do
         staticHandlers = \_caps -> do handlers diagErrs,
         interpretHandler = \env ->
           Server.Iso
-            ( runFileLogger logPath (confLogLevel (lspConfig lspEnv))
+            ( runErrLogger (confLogLevel (lspConfig lspEnv))
                 . flip runReaderT lspEnv
                 . Server.runLspT env
             )
             liftIO,
         options = lspOptions
       }
-  where 
-    logPath = (</>) "logs.txt" $ takeDirectory $ confOutputPath $ lspConfig lspEnv
 
 syncOptions :: Types.TextDocumentSyncOptions
 syncOptions =

From 501a2455e805ca35c98e3ec1a7f27dd044753850 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 26 Sep 2024 01:16:33 +0200
Subject: [PATCH 048/297] multiple lints working

---
 src/Language/PureScript/Lsp/Cache.hs | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 1d7876a64e..bb3f50e66a 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -34,10 +34,10 @@ dropTables = do
 
 initDb :: (MonadReader LspEnvironment m, MonadIO m) => m ()
 initDb = do
-  DB.execute_ "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (name TEXT PRIMARY KEY, path TEXT, ef_version TEXT, value BLOB, module_name TEXT)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT, UNIQUE(module_name), UNIQUE(path))"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, PRIMARY KEY (module_name, name))"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY TEXT, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path), UNIQUE(module_name))"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, )"
   DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value TEXT, span_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
@@ -92,7 +92,7 @@ insertExtern ::
   m ()
 insertExtern outDir extern = do
   DB.executeNamed
-    (Query "INSERT INTO externs (path, ef_version, value, module_name) VALUES (:path, :ef_version, :value, :module_name)")
+    (Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name) VALUES (:path, :ef_version, :value, :module_name)")
     [ ":path" := externsPath,
       ":ef_version" := P.efVersion extern,
       ":value" := serialise extern,
@@ -107,7 +107,7 @@ insertExtern outDir extern = do
 insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
 insertEfImport moduleName' ei = do
   DB.executeNamed
-    (Query "INSERT INTO ef_imports (module_name, imported_module, import_type, imported_as) VALUES (:module_name, :imported_module, :import_type, :imported_as)")
+    (Query "INSERT OR REPLACE INTO ef_imports (module_name, imported_module, import_type, imported_as) VALUES (:module_name, :imported_module, :import_type, :imported_as)")
     [ ":module_name" := P.runModuleName moduleName',
       ":imported_module" := P.runModuleName (P.eiModule ei),
       ":import_type" := serialise (P.eiImportType ei),
@@ -117,7 +117,7 @@ insertEfImport moduleName' ei = do
 insertEfExport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.DeclarationRef -> m ()
 insertEfExport moduleName' dr = do
   DB.executeNamed
-    (Query "INSERT INTO ef_exports (module_name, value, span_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :span_name, :start_col, :start_line, :end_col, :end_line)")
+    (Query "INSERT OR REPLACE INTO ef_exports (module_name, value, span_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :span_name, :start_col, :start_line, :end_col, :end_line)")
     [ ":module_name" := P.runModuleName moduleName',
       ":value" := serialise dr,
       ":span_name" := P.spanName span,
@@ -133,7 +133,7 @@ insertModule :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> P.Modul
 insertModule srcPath m = do
   let moduleName' = P.getModuleName m
   DB.executeNamed
-    (Query "INSERT INTO modules (module_name, path) VALUES (:module_name, :path)")
+    (Query "INSERT OR REPLACE INTO modules (module_name, path) VALUES (:module_name, :path)")
     [ ":module_name" := P.runModuleName moduleName',
       ":path" := srcPath
     ]
@@ -144,7 +144,7 @@ insertModule srcPath m = do
 insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Set P.Declaration -> P.Declaration -> m ()
 insertDeclaration moduleName' exportedDecls decl = do
   DB.executeNamed
-    (Query "INSERT INTO declarations (module_name, name, type_printed, start_col, start_line, end_col, end_line, comments, exported, value) VALUES (:module_name, :name, :type_printed, :start_col, :start_line, :end_col, :end_line, :comments, :exported, :value)")
+    (Query "INSERT OR REPLACE INTO declarations (module_name, name, type_printed, start_col, start_line, end_col, end_line, comments, exported, value) VALUES (:module_name, :name, :type_printed, :start_col, :start_line, :end_col, :end_line, :comments, :exported, :value)")
     [ ":module_name" := P.runModuleName moduleName',
       ":name" := P.spanName declLocation,
       ":type_printed" := typeName,

From 888a5bc6a40e3f2d830cd643986133c5dd00b971 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 26 Sep 2024 03:05:19 +0200
Subject: [PATCH 049/297] buggy hover with filepath added

---
 purescript.cabal                       |   1 +
 src/Language/PureScript/Lsp/Cache.hs   |   4 +-
 src/Language/PureScript/Lsp/Rebuild.hs |   2 +-
 src/Language/PureScript/Lsp/State.hs   |  17 +-
 src/Language/PureScript/Lsp/Types.hs   |   2 +
 src/Language/PureScript/LspSimple.hs   | 303 ++++++++++++++-----------
 6 files changed, 195 insertions(+), 134 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index 3fbb1c3013..b1f5d8f588 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -342,6 +342,7 @@ library
     Language.PureScript.Lsp
     Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Cache
+    Language.PureScript.Lsp.Cache.Query
     Language.PureScript.Lsp.State
     Language.PureScript.Lsp.Types
     Language.PureScript.Lsp.Rebuild
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index bb3f50e66a..f2d8e31fe9 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -36,8 +36,8 @@ initDb :: (MonadReader LspEnvironment m, MonadIO m) => m ()
 initDb = do
   DB.execute_ "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT, UNIQUE(module_name), UNIQUE(path))"
   DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, PRIMARY KEY (module_name, name))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY TEXT, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path), UNIQUE(module_name))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, )"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path), UNIQUE(module_name))"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT)"
   DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value TEXT, span_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index edd788b310..d5d6cbfef3 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -95,7 +95,7 @@ rebuildModuleOpen makeEnv externs m = void $ runExceptT do
   case openResult of
     Left _ ->
       throwError (GeneralError "Failed when rebuilding with open exports")
-    Right result -> cacheRebuild result
+    Right result -> cacheRebuild result m
 
 -- | Shuts the compiler up about progress messages
 shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index b7be627317..aba6d58ce4 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -2,16 +2,25 @@
 module Language.PureScript.Lsp.State where
 
 
-import Control.Concurrent.STM (modifyTVar)
+import Control.Concurrent.STM (modifyTVar, readTVar)
 import Language.PureScript.Externs (ExternsFile (..))
 import Language.PureScript.Lsp.Types
 import Protolude hiding (moduleName, unzip)
+import Language.PureScript qualified as P
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> m ()
-cacheRebuild ef = do
+cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> P.Module -> m ()
+cacheRebuild ef module' = do
   st <- lspStateVar <$> ask
   liftIO . atomically . modifyTVar st $ \x ->
     x
-      { currentFile = Just $ CurrentFile (efModuleName ef) ef
+      { currentFile = Just $ CurrentFile (efModuleName ef) module' ef
       }
+
+
+cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => m (Maybe CurrentFile)
+cachedRebuild = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ do
+    st' <- readTVar st
+    pure $ currentFile st'
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index eeefc5fb07..7a70d7bc1a 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -34,6 +34,8 @@ data LspState = LspState
 
 data CurrentFile = CurrentFile
   { currentModuleName :: P.ModuleName,
+    currentModule :: P.Module,
     currentExternsFile :: P.ExternsFile
+    
   }
   deriving (Show)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 9d5904dbe8..d9834fc53d 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -13,7 +13,7 @@
 
 module Language.PureScript.LspSimple (main) where
 
-import Control.Lens ((^.))
+import Control.Lens ((^.), Field1 (_1))
 import Control.Lens.Getter (to)
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
@@ -24,6 +24,8 @@ import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed as Rope
 import Data.Time (getCurrentTime)
+import Debug.Trace (traceM)
+import GHC.Float (Floating (log))
 import GHC.IO (unsafePerformIO)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
@@ -32,7 +34,10 @@ import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
+import Language.PureScript (accumTypes, prettyPrintType)
 import Language.PureScript qualified as P
+import Language.PureScript.AST.Declarations (declSourceAnn, getModuleDeclarations)
+import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
@@ -46,18 +51,18 @@ import Language.PureScript.Ide.Imports (parseImportsFromFile)
 import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Matcher (Matcher)
 import Language.PureScript.Ide.Prim (idePrimDeclarations)
+import Language.PureScript.Ide.State (getAllModules)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeDeclarationAnn)
 import Language.PureScript.Ide.Util (runLogger)
 import Language.PureScript.Lsp.Cache (dropTables, initDb, insertAllExterns)
 import Language.PureScript.Lsp.Rebuild (rebuildAllFiles, rebuildFile)
-import Language.PureScript.Lsp.Types (LspConfig (confLogLevel, confOutputPath), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.State (cachedRebuild)
+import Language.PureScript.Lsp.Types (CurrentFile (CurrentFile), LspConfig (confLogLevel, confOutputPath), LspEnvironment (lspConfig, lspDbConnection))
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath (takeDirectory, (</>))
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
-import GHC.Float (Floating(log))
-import Debug.Trace (traceM)
 
 -- import Language.Haskell.LSP.VFS qualified as VFS
 
@@ -95,20 +100,28 @@ handlers diagErrs =
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
         res <- fromLspWithErr do
           dropTables
-          initDb
+          initDb 
           insertAllExterns
-          -- rebuildAllFiles
+        -- rebuildAllFiles
         case res of
           Left err -> do
             log_ err
             sendInfoMsg $ show err
           Right _ -> sendInfoMsg "OA purs lsp server initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        sendInfoMsg "TextDocumentDidOpen",
+        sendInfoMsg "TextDocumentDidOpen"
+        let uri :: Uri
+            uri = getMsgUri msg
+            fileName = Types.uriToFilePath uri
+        void $ fromLsp $ traverse rebuildFile fileName,
       Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
         sendInfoMsg "TextDocumentDidChange",
       Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
-        sendInfoMsg "SMethod_TextDocumentDidSave",
+        sendInfoMsg "SMethod_TextDocumentDidSave"
+        let uri :: Uri
+            uri = getMsgUri msg
+            fileName = Types.uriToFilePath uri
+        void $ fromLsp $ traverse rebuildFile fileName,
       Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
         cfg <- getConfig
         sendInfoMsg $ "Config changed: " <> show cfg,
@@ -163,125 +176,160 @@ handlers diagErrs =
                               Nothing
                         )
                         Nothing
+                        Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+        let Types.HoverParams docIdent pos@(Types.Position line col) _workDone = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            docUri =
+              docIdent
+                ^. LSP.uri
+                  . to Types.toNormalizedUri
+            nullRes = res $ Right $ Types.InR Types.Null
+            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp val f = maybe nullRes f val
+        vfMb <- Server.getVirtualFile docUri
+
+        for_ vfMb \vf -> do
+          let word = getWordAt (VFS._file_text vf) pos
+          cacheMb <- fromLsp cachedRebuild
+          forLsp cacheMb $ \(CurrentFile _ module' ex) -> do
+            let spanAtPos :: P.SourceSpan -> Bool
+                spanAtPos (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+                  startLine <= fromIntegral (line + 1)
+                    && endLine >= fromIntegral (line + 1)
+                    && startCol <= fromIntegral (col + 1)
+                    && endCol >= fromIntegral (col + 1)
+
+                declMb :: Maybe P.Declaration
+                declMb =
+                  getModuleDeclarations module'
+                    & find (spanAtPos . fst . declSourceAnn)
+            forLsp declMb $ \decl -> do
+              let (declSpan, _) = declSourceAnn decl
+                  declName = P.spanName declSpan
+                  declType = Protolude.fold $ (head :: [Text] -> Maybe Text) $ accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $ decl
+                  declComments = snd $ declSourceAnn decl
+                  hoverInfo =
+                    Types.InL $
+                      Types.Hover
+                        ( Types.InL $
+                            Types.MarkupContent
+                              Types.MarkupKind_Markdown
+                              ( "```purescript\n"
+                                  <> T.pack declName
+                                  <> " :: "
+                                  <> declType
+                                  <> "\n"
+                                  <> fold (convertComments declComments)
+                                  <> "\n```"
+                              )
+                        )
                         Nothing
-                        -- Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-                        --   let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
-
-                        --   let filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-                        --       docUri =
-                        --         docIdent
-                        --           ^. LSP.uri
-                        --             . to Types.toNormalizedUri
-
-                        --   vfMb <- Server.getVirtualFile docUri
-
-                        --   for_ vfMb \vf -> do
-                        --     let word = getWordAt (VFS._file_text vf) pos
-                        --     cache <- fromLsp cachedRebuild
-                        --     let moduleName' = case cache of
-                        --           Right (Just (mName, _)) -> Just mName
-                        --           _ -> Nothing
-
-                        --     imports <-
-                        --       filePathMb
-                        --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
-
-                        --     let filters :: [Filter]
-                        --         filters =
-                        --           imports
-                        --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                        --         getInputModName (n, _, _) = n
-
-                        --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                        --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                        --     completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-                        --     let hoverInfo = case head <$> completions of
-                        --           Right (Just completion) -> completionToHoverInfo word completion
-                        --           _ -> word
-
-                        --     res $
-                        --       Right $
-                        --         Types.InL $
-                        --           Types.Hover
-                        --             ( Types.InL $
-                        --                 Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
-                        --             )
-                        --             Nothing
-                        --             ,
-                        -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-                        --   sendInfoMsg "SMethod_TextDocumentDefinition"
-                        --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-                        --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-                        --       uri =
-                        --         req
-                        --           ^. LSP.params
-                        --             . LSP.textDocument
-                        --             . LSP.uri
-                        --             . to Types.toNormalizedUri
-
-                        --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-                        --   vfMb <- Server.getVirtualFile uri
-
-                        --   for_ vfMb \vf -> do
-                        --     let word = getWordAt (VFS._file_text vf) pos
-                        --     cache <- fromLsp cachedRebuild
-                        --     let moduleName' = case cache of
-                        --           Right (Just (mName, _)) -> Just mName
-                        --           _ -> Nothing
-
-                        --     imports <-
-                        --       filePathMb
-                        --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
-
-                        --     let filters :: [Filter]
-                        --         filters =
-                        --           imports
-                        --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                        --         getInputModName (n, _, _) = n
-
-                        --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                        --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                        --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-                        --     sendInfoMsg $ "Completions: " <> show completions
-                        --     let withLocation =
-                        --           fold completions
-                        --             & mapMaybe
-                        --               ( \c -> case complLocation c of
-                        --                   Just loc -> Just (c, loc)
-                        --                   Nothing -> Nothing
-                        --               )
-                        --             & head
-
-                        --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
-
-                        --     case withLocation of
-                        --       Just (completion, location) -> do
-                        --         let fpMb =
-                        --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
-
-                        --         case fpMb of
-                        --           Nothing -> do
-                        --             sendInfoMsg "No file path for module"
-                        --             nullRes
-                        --           Just fp ->
-                        --             res $
-                        --               Right $
-                        --                 Types.InL $
-                        --                   Types.Definition $
-                        --                     Types.InL $
-                        --                       Types.Location
-                        --                         (Types.filePathToUri fp)
-                        --                         (spanToRange location)
-                        --       _ -> do
-                        --         sendInfoMsg "No location for completion"
-                        --         nullRes
+              res $ Right hoverInfo
+            -- let moduleName' = case cache of
+            --       Just (CurrentFile mName _) -> Just mName
+            --       _ -> Nothing
+
+            -- imports <-
+            --   filePathMb
+            --     & maybe (pure Nothing) (fromLsp . parseImportsFromFile)
+
+            -- let filters :: [Filter]
+            --     filters =
+            --       imports
+            --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+            --     getInputModName (n, _, _) = n
+
+            --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+            --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+            -- completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+            -- let hoverInfo = case head <$> completions of
+            --       Right (Just completion) -> completionToHoverInfo word completion
+            --       _ -> word
+
+            -- res $
+            --   Right $
+            --     Types.InL $
+            --       Types.Hover
+            --         ( Types.InL $
+            --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
+            --         )
+            --         Nothing
+            --             ,
+            -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+            --   sendInfoMsg "SMethod_TextDocumentDefinition"
+            --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+            --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            --       uri =
+            --         req
+            --           ^. LSP.params
+            --             . LSP.textDocument
+            --             . LSP.uri
+            --             . to Types.toNormalizedUri
+
+            --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+            --   vfMb <- Server.getVirtualFile uri
+
+            --   for_ vfMb \vf -> do
+            --     let word = getWordAt (VFS._file_text vf) pos
+            --     cache <- fromLsp cachedRebuild
+            --     let moduleName' = case cache of
+            --           Right (Just (mName, _)) -> Just mName
+            --           _ -> Nothing
+
+            --     imports <-
+            --       filePathMb
+            --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
+
+            --     let filters :: [Filter]
+            --         filters =
+            --           imports
+            --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+            --         getInputModName (n, _, _) = n
+
+            --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+            --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+            --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+            --     sendInfoMsg $ "Completions: " <> show completions
+            --     let withLocation =
+            --           fold completions
+            --             & mapMaybe
+            --               ( \c -> case complLocation c of
+            --                   Just loc -> Just (c, loc)
+            --                   Nothing -> Nothing
+            --               )
+            --             & head
+
+            --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
+
+            --     case withLocation of
+            --       Just (completion, location) -> do
+            --         let fpMb =
+            --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
+
+            --         case fpMb of
+            --           Nothing -> do
+            --             sendInfoMsg "No file path for module"
+            --             nullRes
+            --           Just fp ->
+            --             res $
+            --               Right $
+            --                 Types.InL $
+            --                   Types.Definition $
+            --                     Types.InL $
+            --                       Types.Location
+            --                         (Types.filePathToUri fp)
+            --                         (spanToRange location)
+            --       _ -> do
+            --         sendInfoMsg "No location for completion"
+            --         nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -374,7 +422,7 @@ main lspEnv = do
         defaultConfig = (),
         configSection = "oa-purescript-simple",
         doInitialize = \env _req -> do
-          logT "Init OA purs lsp server"
+          logT "Init OA purs lsp server"   
           pure $ Right env,
         staticHandlers = \_caps -> do handlers diagErrs,
         interpretHandler = \env ->
@@ -451,6 +499,7 @@ logToFile txt =
 --   modules <- getAllModules currentModule
 --   let insertPrim = Map.union idePrimDeclarations
 --   pure (getExactCompletions search filters (insertPrim modules))
+-- z = getAllModules
 
 getWordAt :: Rope -> Types.Position -> Text
 getWordAt file Types.Position {..} =

From 8893f504e83e298c0c86a126a86fd490783c34fc Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 26 Sep 2024 04:26:13 +0200
Subject: [PATCH 050/297] readds build all on start

---
 purescript.cabal                       |   3 +-
 src/Language/PureScript/Lsp/Cache.hs   |  28 ++++---
 src/Language/PureScript/Lsp/Rebuild.hs |  12 ++-
 src/Language/PureScript/LspSimple.hs   | 106 ++++++++++---------------
 4 files changed, 67 insertions(+), 82 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index b1f5d8f588..25e9bc8d5f 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -343,9 +343,10 @@ library
     Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Cache.Query
+    Language.PureScript.Lsp.Rebuild
     Language.PureScript.Lsp.State
     Language.PureScript.Lsp.Types
-    Language.PureScript.Lsp.Rebuild
+    Language.PureScript.Lsp.Util
     Language.PureScript.LspSimple
     Language.PureScript.Make
     Language.PureScript.Make.Actions
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index f2d8e31fe9..a90bcb380e 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -3,22 +3,20 @@
 module Language.PureScript.Lsp.Cache where
 
 import Codec.Serialise (deserialise, serialise)
-import Control.Lens (Field1 (_1), (^.), _1)
 import Data.Aeson (encode)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple
 import Language.PureScript qualified as P
-import Language.PureScript.AST.Declarations (declSourceAnn)
-import Language.PureScript.AST.Traversals (accumTypes)
+import Language.PureScript.AST.Declarations (declName, declRefName, declSourceAnn)
 import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Ide.Externs (readExternFile)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
-import Language.PureScript.Pretty.Types (prettyPrintType)
+import Language.PureScript.Lsp.Util (printName, printDeclarationType)
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
 import System.FilePath (normalise, (</>))
@@ -38,7 +36,7 @@ initDb = do
   DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, PRIMARY KEY (module_name, name))"
   DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path), UNIQUE(module_name))"
   DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value TEXT, span_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value TEXT, name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
 selectAllExternsMap = do
@@ -114,13 +112,22 @@ insertEfImport moduleName' ei = do
       ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei)
     ]
 
+-- insertEfDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsDeclaration -> m ()
+-- insertEfDeclaration moduleName' decl = do
+--   DB.executeNamed
+--     (Query "INSERT OR REPLACE INTO ef_declarations (module_name, value) VALUES (:module_name, :value)")
+--     [ ":module_name" := P.runModuleName moduleName',
+--       ":value" := serialise decl
+--       -- ":name" :=
+--     ]
+
 insertEfExport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.DeclarationRef -> m ()
 insertEfExport moduleName' dr = do
   DB.executeNamed
-    (Query "INSERT OR REPLACE INTO ef_exports (module_name, value, span_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :span_name, :start_col, :start_line, :end_col, :end_line)")
+    (Query "INSERT OR REPLACE INTO ef_exports (module_name, value, name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :name, :start_col, :start_line, :end_col, :end_line)")
     [ ":module_name" := P.runModuleName moduleName',
       ":value" := serialise dr,
-      ":span_name" := P.spanName span,
+      ":name" := printName (declRefName dr),
       ":start_col" := (P.sourcePosColumn . P.spanStart) span,
       ":start_line" := (P.sourcePosLine . P.spanStart) span,
       ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
@@ -146,7 +153,7 @@ insertDeclaration moduleName' exportedDecls decl = do
   DB.executeNamed
     (Query "INSERT OR REPLACE INTO declarations (module_name, name, type_printed, start_col, start_line, end_col, end_line, comments, exported, value) VALUES (:module_name, :name, :type_printed, :start_col, :start_line, :end_col, :end_line, :comments, :exported, :value)")
     [ ":module_name" := P.runModuleName moduleName',
-      ":name" := P.spanName declLocation,
+      ":name" := maybe (show decl) printName (declName decl),
       ":type_printed" := typeName,
       ":start_col" := (P.sourcePosColumn . P.spanStart) declLocation,
       ":start_line" := (P.sourcePosLine . P.spanStart) declLocation,
@@ -157,10 +164,7 @@ insertDeclaration moduleName' exportedDecls decl = do
       ":value" := serialise decl
     ]
   where
-    typeName = Protolude.fold $ head typeNames
-
-    typeNames :: [Text]
-    typeNames = accumTypes (pure . T.pack . prettyPrintType maxBound) ^. _1 $ decl
+    typeName = printDeclarationType decl
 
     exported = Set.member decl exportedDecls
     (declLocation, comments) = declSourceAnn decl
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index d5d6cbfef3..4aed513d27 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -17,16 +17,18 @@ import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
 import Language.PureScript.Lsp.Cache
+import Language.PureScript.Lsp.State (cacheRebuild)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Make (ffiCodegen')
 import Protolude hiding (moduleName)
 import System.FilePath.Glob (glob)
-import Language.PureScript.Lsp.State (cacheRebuild)
+import "monad-logger" Control.Monad.Logger (logWarnN, MonadLogger)
 
 rebuildAllFiles ::
   ( MonadIO m,
     MonadError IdeError m,
-    MonadReader LspEnvironment m
+    MonadReader LspEnvironment m,
+    MonadLogger m
   ) =>
   m [(FilePath, P.MultipleErrors)]
 rebuildAllFiles = do
@@ -37,11 +39,13 @@ rebuildAllFiles = do
 rebuildFile ::
   ( MonadIO m,
     MonadError IdeError m,
-    MonadReader LspEnvironment m
+    MonadReader LspEnvironment m,
+    MonadLogger m
   ) =>
   FilePath ->
   m (FilePath, P.MultipleErrors)
 rebuildFile srcPath = do
+  logWarnN $ "Rebuilding file: " <> T.pack srcPath
   (fp, input) <-
     case List.stripPrefix "data:" srcPath of
       Just source -> pure ("", T.pack source)
@@ -66,6 +70,7 @@ rebuildFile srcPath = do
     unless pureRebuild $
       updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
     pure newExterns
+  logWarnN $ "Rebuilt file: " <> T.pack srcPath
   case result of
     Left errors ->
       throwError (RebuildError [(fp, input)] errors)
@@ -153,7 +158,6 @@ sortExterns m ex = do
     inOrderOf :: (Ord a) => [a] -> [a] -> [a]
     inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
 
-
 -- | Removes a modules export list.
 openModuleExports :: P.Module -> P.Module
 openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index d9834fc53d..6abfca069e 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -63,6 +63,7 @@ import System.Directory (createDirectoryIfMissing)
 import System.FilePath (takeDirectory, (</>))
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
+import Language.PureScript.Lsp.Util (getWordAt)
 
 -- import Language.Haskell.LSP.VFS qualified as VFS
 
@@ -102,7 +103,7 @@ handlers diagErrs =
           dropTables
           initDb 
           insertAllExterns
-        -- rebuildAllFiles
+          rebuildAllFiles
         case res of
           Left err -> do
             log_ err
@@ -189,43 +190,46 @@ handlers diagErrs =
             forLsp val f = maybe nullRes f val
         vfMb <- Server.getVirtualFile docUri
 
-        for_ vfMb \vf -> do
+        forLsp vfMb \vf -> do
           let word = getWordAt (VFS._file_text vf) pos
-          cacheMb <- fromLsp cachedRebuild
-          forLsp cacheMb $ \(CurrentFile _ module' ex) -> do
-            let spanAtPos :: P.SourceSpan -> Bool
-                spanAtPos (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
-                  startLine <= fromIntegral (line + 1)
-                    && endLine >= fromIntegral (line + 1)
-                    && startCol <= fromIntegral (col + 1)
-                    && endCol >= fromIntegral (col + 1)
-
-                declMb :: Maybe P.Declaration
-                declMb =
-                  getModuleDeclarations module'
-                    & find (spanAtPos . fst . declSourceAnn)
-            forLsp declMb $ \decl -> do
-              let (declSpan, _) = declSourceAnn decl
-                  declName = P.spanName declSpan
-                  declType = Protolude.fold $ (head :: [Text] -> Maybe Text) $ accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $ decl
-                  declComments = snd $ declSourceAnn decl
-                  hoverInfo =
-                    Types.InL $
-                      Types.Hover
-                        ( Types.InL $
-                            Types.MarkupContent
-                              Types.MarkupKind_Markdown
-                              ( "```purescript\n"
-                                  <> T.pack declName
-                                  <> " :: "
-                                  <> declType
-                                  <> "\n"
-                                  <> fold (convertComments declComments)
-                                  <> "\n```"
-                              )
-                        )
-                        Nothing
-              res $ Right hoverInfo
+          if word == ""
+            then nullRes
+            else do
+              cacheMb <- fromLsp cachedRebuild
+              forLsp cacheMb $ \(CurrentFile _ module' ex) -> do
+                let posInSpan :: P.SourceSpan -> Bool
+                    posInSpan (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+                      startLine <= fromIntegral (line + 1)
+                        && endLine >= fromIntegral (line + 1)
+                        && startCol <= fromIntegral (col + 1)
+                        && endCol >= fromIntegral (col + 1)
+
+                    declMb :: Maybe P.Declaration
+                    declMb =
+                      getModuleDeclarations module'
+                        & find (posInSpan . fst . declSourceAnn)
+                forLsp declMb $ \decl -> do
+                  let (declSpan, _) = declSourceAnn decl
+                      declName = P.spanName declSpan
+                      declType = Protolude.fold $ (head :: [Text] -> Maybe Text) $ accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $ decl
+                      declComments = snd $ declSourceAnn decl
+                      hoverInfo =
+                        Types.InL $
+                          Types.Hover
+                            ( Types.InL $
+                                Types.MarkupContent
+                                  Types.MarkupKind_Markdown
+                                  ( "```purescript\n"
+                                      <> word
+                                      <> " :: "
+                                      <> declType
+                                      <> "\n"
+                                      <> fold (convertComments declComments)
+                                      <> "\n```"
+                                  )
+                            )
+                            Nothing
+                  res $ Right hoverInfo
             -- let moduleName' = case cache of
             --       Just (CurrentFile mName _) -> Just mName
             --       _ -> Nothing
@@ -501,34 +505,6 @@ logToFile txt =
 --   pure (getExactCompletions search filters (insertPrim modules))
 -- z = getAllModules
 
-getWordAt :: Rope -> Types.Position -> Text
-getWordAt file Types.Position {..} =
-  let (_, after) = splitAtLine (fromIntegral _line) file
-      (ropeLine, _) = splitAtLine 1 after
-      line' = Rope.toText ropeLine
-   in getWordOnLine line' _character
-
-getWordOnLine :: Text -> UInt -> Text
-getWordOnLine line' col =
-  let start = getPrevWs (fromIntegral col) line'
-      end = getNextWs (fromIntegral col) line'
-   in T.take (end - start) $ T.drop start line'
-  where
-    getNextWs :: Int -> Text -> Int
-    getNextWs idx txt | idx >= T.length txt = idx
-    getNextWs idx txt = case T.index txt idx of
-      ch | isSpace ch -> idx
-      _ -> getNextWs (idx + 1) txt
-
-    getPrevWs :: Int -> Text -> Int
-    getPrevWs 0 _ = 0
-    getPrevWs idx txt = case T.index txt idx of
-      ch | isSpace ch -> idx + 1
-      _ -> getPrevWs (idx - 1) txt
-
-pursMarkdown :: Text -> Text
-pursMarkdown txt = "```pureScript\n" <> txt <> "```"
-
 completionToHoverInfo :: Text -> Completion -> Text
 completionToHoverInfo word Completion {..} =
   typeStr <> "\n" <> fromMaybe "" complDocumentation

From 2621a98382f9907f11ed60cb66cc3375afbface6 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 26 Sep 2024 12:50:37 +0200
Subject: [PATCH 051/297] types showing on hover

---
 src/Language/PureScript/Externs.hs           |   7 +-
 src/Language/PureScript/Lsp/Cache.hs         |  46 +++-
 src/Language/PureScript/Lsp/Cache/Query.hs   |  84 +++++++
 src/Language/PureScript/Lsp/Types.hs         |   2 +-
 src/Language/PureScript/Lsp/Util.hs          | 125 ++++++++++
 src/Language/PureScript/LspSimple.hs         | 241 +++++++++----------
 src/Language/PureScript/Sugar/TypeClasses.hs |   2 +-
 7 files changed, 364 insertions(+), 143 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Cache/Query.hs
 create mode 100644 src/Language/PureScript/Lsp/Util.hs

diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index a9669a9995..ad9d110281 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -143,6 +143,7 @@ data ExternsDeclaration =
       , edClassConstraints        :: [SourceConstraint]
       , edFunctionalDependencies  :: [FunctionalDependency]
       , edIsEmpty                 :: Bool
+      , edSourceSpan              :: SourceSpan 
       }
   -- | An instance declaration
   | EDInstance
@@ -176,7 +177,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
   applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
   applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
   applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (ByModuleName efModuleName) ident) (ty, External, Defined) (names env) }
-  applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) }
+  applyDecl env (EDClass pn args members cs deps tcIsEmpty _) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) }
   applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) =
     env { typeClassDictionaries =
             updateMap
@@ -247,7 +248,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF
   toExternsDeclaration (ValueRef _ ident)
     | Just (ty, _, _) <- Qualified (ByModuleName mn) ident `M.lookup` names env
     = [ EDValue (lookupRenamedIdent ident) ty ]
-  toExternsDeclaration (TypeClassRef _ className)
+  toExternsDeclaration (TypeClassRef ss' className)
     | let dictName = dictTypeName . coerceProperName $ className
     , Just TypeClassData{..} <- Qualified (ByModuleName mn) className `M.lookup` typeClasses env
     , Just (kind, tk) <- Qualified (ByModuleName mn) (coerceProperName className) `M.lookup` types env
@@ -256,7 +257,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF
     = [ EDType (coerceProperName className) kind tk
       , EDType dictName dictKind dictData
       , EDDataConstructor dctor dty dictName ty args
-      , EDClass className typeClassArguments ((\(a, b, _) -> (a, b)) <$> typeClassMembers) typeClassSuperclasses typeClassDependencies typeClassIsEmpty
+      , EDClass className typeClassArguments ((\(a, b, _) -> (a, b)) <$> typeClassMembers) typeClassSuperclasses typeClassDependencies typeClassIsEmpty ss'
       ]
   toExternsDeclaration (TypeInstanceRef ss' ident ns)
     = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss'
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index a90bcb380e..13be96ddea 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -16,7 +16,7 @@ import Language.PureScript.Ide.Externs (readExternFile)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
-import Language.PureScript.Lsp.Util (printName, printDeclarationType)
+import Language.PureScript.Lsp.Util (efDeclCategory, efDeclName, efDeclSourceSpan, printDeclarationType, printName)
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
 import System.FilePath (normalise, (</>))
@@ -29,14 +29,16 @@ dropTables = do
   DB.execute_ "DROP TABLE IF EXISTS externs"
   DB.execute_ "DROP TABLE IF EXISTS ef_imports"
   DB.execute_ "DROP TABLE IF EXISTS ef_exports"
+  DB.execute_ "DROP TABLE IF EXISTS ef_declarations"
 
 initDb :: (MonadReader LspEnvironment m, MonadIO m) => m ()
 initDb = do
   DB.execute_ "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT, UNIQUE(module_name), UNIQUE(path))"
   DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, PRIMARY KEY (module_name, name))"
   DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path), UNIQUE(module_name))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value TEXT, name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value BLOB, name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT)"
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
 selectAllExternsMap = do
@@ -96,8 +98,18 @@ insertExtern outDir extern = do
       ":value" := serialise extern,
       ":module_name" := P.runModuleName name
     ]
+  DB.executeNamed
+    (Query "DELETE FROM ef_imports WHERE module_name = :module_name")
+    [":module_name" := P.runModuleName name]
   forM_ (P.efImports extern) $ insertEfImport name
+  DB.executeNamed
+    (Query "DELETE FROM ef_exports WHERE module_name = :module_name")
+    [":module_name" := P.runModuleName name]
   forM_ (P.efExports extern) $ insertEfExport name
+  DB.executeNamed
+    (Query "DELETE FROM ef_declarations WHERE module_name = :module_name")
+    [":module_name" := P.runModuleName name]
+  forM_ (P.efDeclarations extern) $ insertEfDeclaration name
   where
     externsPath = outDir </> T.unpack (P.runModuleName name) <> externsFileName
     name = efModuleName extern
@@ -105,21 +117,29 @@ insertExtern outDir extern = do
 insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
 insertEfImport moduleName' ei = do
   DB.executeNamed
-    (Query "INSERT OR REPLACE INTO ef_imports (module_name, imported_module, import_type, imported_as) VALUES (:module_name, :imported_module, :import_type, :imported_as)")
+    (Query "INSERT OR REPLACE INTO ef_imports (module_name, imported_module, import_type, imported_as, value) VALUES (:module_name, :imported_module, :import_type, :imported_as, :value)")
     [ ":module_name" := P.runModuleName moduleName',
       ":imported_module" := P.runModuleName (P.eiModule ei),
       ":import_type" := serialise (P.eiImportType ei),
-      ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei)
+      ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei),
+      ":value" := serialise ei
     ]
 
--- insertEfDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsDeclaration -> m ()
--- insertEfDeclaration moduleName' decl = do
---   DB.executeNamed
---     (Query "INSERT OR REPLACE INTO ef_declarations (module_name, value) VALUES (:module_name, :value)")
---     [ ":module_name" := P.runModuleName moduleName',
---       ":value" := serialise decl
---       -- ":name" :=
---     ]
+insertEfDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsDeclaration -> m ()
+insertEfDeclaration moduleName' decl = do
+  DB.executeNamed
+    (Query "INSERT OR REPLACE INTO ef_declarations (module_name, value, name, start_col, start_line, end_col, end_line, category) VALUES (:module_name, :value, :name, :start_col, :start_line, :end_col, :end_line, :category)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":name" := efDeclName decl,
+      ":value" := serialise decl,
+      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
+      ":start_line" := (P.sourcePosLine . P.spanStart) span,
+      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
+      ":end_line" := (P.sourcePosLine . P.spanEnd) span,
+      ":category" := efDeclCategory decl
+    ]
+  where
+    span = efDeclSourceSpan decl
 
 insertEfExport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.DeclarationRef -> m ()
 insertEfExport moduleName' dr = do
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
new file mode 100644
index 0000000000..1f129ae174
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -0,0 +1,84 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+
+module Language.PureScript.Lsp.Cache.Query where
+
+-- import Language.PureScript.Bundle (getImportedModules)
+
+import Codec.Serialise (deserialise, serialise)
+import Control.Lens (Field1 (_1), (^.), _1)
+import Data.Aeson (encode)
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+import Data.Text qualified as T
+import Database.SQLite.Simple
+import Language.LSP.Protocol.Types (Position)
+import Language.PureScript qualified as P
+import Language.PureScript.AST.Declarations (declSourceAnn)
+import Language.PureScript.AST.Traversals (accumTypes)
+import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
+import Language.PureScript.Ide.Error (IdeError (GeneralError))
+import Language.PureScript.Ide.Externs (readExternFile)
+import Language.PureScript.Ide.Types (ModuleMap)
+import Language.PureScript.Lsp.DB qualified as DB
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.Util (printName)
+import Language.PureScript.Pretty.Types (prettyPrintType)
+import Protolude
+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
+import System.FilePath (normalise, (</>))
+
+-- getDeclarationAt :: (MonadIO m, MonadReader LspEnvironment m) => Position -> m (Maybe P.Declaration)
+-- getDeclarationAt pos = do
+--   decls <-
+--     DB.queryNamed
+--       "SELECT * FROM declarations WHERE startLine <= :line AND endLine >= :line AND startColumn <= :column AND endColumn >= :column"
+--       [":line" := line
+--       , ":column" := column
+--       ]
+--   pure $ listToMaybe decls
+
+-- getImportedModules
+
+
+getEfImports :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m [P.ExternsImport]
+getEfImports moduleName' = do
+  imports <-
+    DB.queryNamed
+      "SELECT value FROM ef_imports WHERE module_name = :module_name"
+      [":module_name" := P.runModuleName moduleName']
+  pure $ deserialise . fromOnly <$> imports
+
+importMightContainIdent :: Text -> P.ExternsImport -> Bool
+importMightContainIdent ident import' = case P.eiImportType import' of
+  P.Implicit -> True
+  P.Explicit refs -> any ((==) ident . printName . P.declRefName) refs
+  P.Hiding refs -> not $ any ((==) ident . printName . P.declRefName) refs
+
+getDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
+getDeclaration moduleName' name = do 
+  inModule <- getEfDeclarationOnlyInModule moduleName' name
+  case inModule of
+    Just decl -> pure $ Just decl
+    Nothing -> getImportedDeclaration moduleName' name
+
+
+getImportedDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
+getImportedDeclaration moduleName' name = do
+  imports <- filter (importMightContainIdent name) <$> getEfImports moduleName'
+  foldM go Nothing imports
+  where
+    go :: (MonadIO m, MonadReader LspEnvironment m) => Maybe P.ExternsDeclaration -> P.ExternsImport -> m (Maybe P.ExternsDeclaration)
+    go acc import' = do
+      case acc of
+        Just _ -> pure acc
+        Nothing -> getEfDeclarationOnlyInModule (P.eiModule import') name
+
+getEfDeclarationOnlyInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
+getEfDeclarationOnlyInModule moduleName' name = do
+  decls <-
+    DB.queryNamed
+      "SELECT value FROM ef_declarations WHERE module_name = :module_name AND name = :name"
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := name
+      ]
+  pure $ deserialise . fromOnly <$> listToMaybe decls
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 7a70d7bc1a..87f31178ac 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -16,7 +16,7 @@ data LspEnvironment = LspEnvironment
 
 mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do 
-   connection <- open (confOutputPath conf <> "lsp.db") 
+   connection <- open (confOutputPath conf <> "lsp.sqlite") 
    st <- newTVarIO (LspState Nothing)
    pure $ LspEnvironment conf connection st
 
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
new file mode 100644
index 0000000000..124e8b0398
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Language.PureScript.Lsp.Util where
+
+import Codec.Serialise qualified as S
+import Control.Lens (Field1 (_1), (^.))
+import Data.Text qualified as T
+import Data.Text.Utf16.Rope.Mixed as Rope
+import Database.SQLite.Simple.ToField (ToField (toField))
+import Language.LSP.Protocol.Types (UInt)
+import Language.LSP.Protocol.Types qualified as Types
+import Language.PureScript (accumTypes)
+import Language.PureScript qualified as P
+import Language.PureScript.AST.Declarations (declSourceAnn)
+import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
+import Protolude hiding (to)
+
+posInSpan :: Types.Position -> Errors.SourceSpan -> Bool
+posInSpan (Types.Position line col) (Errors.SourceSpan _ (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+  startLine <= fromIntegral (line + 1)
+    && endLine >= fromIntegral (line + 1)
+    && startCol <= fromIntegral (col + 1)
+    && endCol >= fromIntegral (col + 1)
+
+getDeclarationAtPos :: Types.Position -> [P.Declaration] -> Maybe P.Declaration
+getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn)
+
+printDeclarationType :: P.Declaration -> Text
+printDeclarationType decl =
+  Protolude.fold $
+    (head :: [Text] -> Maybe Text) $
+      accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
+        decl
+
+getWordAt :: Rope -> Types.Position -> Text
+getWordAt file Types.Position {..} =
+  let (_, after) = splitAtLine (fromIntegral _line) file
+      (ropeLine, _) = splitAtLine 1 after
+      line' = Rope.toText ropeLine
+   in getWordOnLine line' _character
+
+getWordOnLine :: Text -> UInt -> Text
+getWordOnLine line' col =
+  let start = getPrevWs (fromIntegral col) line'
+      end = getNextWs (fromIntegral col) line'
+   in T.strip $ T.take (end - start) $ T.drop start line'
+  where
+    getNextWs :: Int -> Text -> Int
+    getNextWs idx txt | idx >= T.length txt = idx
+    getNextWs idx txt = case T.index txt idx of
+      ch | isSpace ch -> idx
+      _ -> getNextWs (idx + 1) txt
+
+    getPrevWs :: Int -> Text -> Int
+    getPrevWs 0 _ = 0
+    getPrevWs idx txt = case T.index txt idx of
+      ch | isSpace ch -> idx + 1
+      _ -> getPrevWs (idx - 1) txt
+
+efDeclName :: P.ExternsDeclaration -> Text
+efDeclName = \case
+  P.EDType name _ _ -> P.runProperName name
+  P.EDTypeSynonym name _ _ -> P.runProperName name
+  P.EDDataConstructor name _ _ _ _ -> P.runProperName name
+  P.EDValue ident _ -> P.runIdent ident
+  P.EDClass name _ _ _ _ _ _ -> P.runProperName name
+  P.EDInstance name _ _ _ _ _ _ _ _ _ -> P.runProperName $ P.disqualify name
+
+data ExternsDeclarationCategory
+  = EDCType
+  | EDCTypeSynonym
+  | EDCDataConstructor
+  | EDCValue
+  | EDCClass
+  | EDCInstance
+  deriving (Eq, Show, Read, Generic, S.Serialise)
+
+instance ToField ExternsDeclarationCategory where
+  toField = toField . S.serialise
+
+efDeclCategory :: P.ExternsDeclaration -> ExternsDeclarationCategory
+efDeclCategory = \case
+  P.EDType {} -> EDCType
+  P.EDTypeSynonym {} -> EDCTypeSynonym
+  P.EDDataConstructor {} -> EDCDataConstructor
+  P.EDValue {} -> EDCValue
+  P.EDClass {} -> EDCClass
+  P.EDInstance {} -> EDCInstance
+
+efDeclSourceType :: P.ExternsDeclaration -> P.SourceType
+efDeclSourceType = \case
+  P.EDType _ ty _ -> ty
+  P.EDTypeSynonym _ _ ty -> ty
+  P.EDDataConstructor _ _ _ ty _ -> ty
+  P.EDValue _ ty -> ty
+  P.EDClass {} -> P.srcREmpty
+  P.EDInstance {} -> P.srcREmpty
+
+efDeclSourceSpan :: P.ExternsDeclaration -> P.SourceSpan
+efDeclSourceSpan = \case
+  P.EDClass _ _ _ _ _ _ span -> span
+  P.EDInstance _ _ _ _ _ _ _ _ _ span -> span
+  ed ->
+    fromMaybe P.nullSourceSpan $ foldr (\(ss, _) _ -> Just ss) Nothing (efDeclSourceType ed)
+
+efDeclComments :: P.ExternsDeclaration -> [P.Comment]
+efDeclComments = foldr getComments [] . efDeclSourceType
+  where
+    getComments :: Errors.SourceAnn -> [P.Comment] -> [P.Comment]
+    getComments (_, cs) acc = cs ++ acc
+
+printName :: P.Name -> Text
+printName = \case
+  P.IdentName ident -> P.runIdent ident
+  P.ValOpName op -> P.runOpName op
+  P.TyName name -> P.runProperName name
+  P.TyOpName op -> P.runOpName op
+  P.DctorName name -> P.runProperName name
+  P.TyClassName name -> P.runProperName name
+  P.ModName name -> P.runModuleName name
+
+printSourceType :: P.SourceType -> Text
+printSourceType = prettyPrintTypeSingleLine
\ No newline at end of file
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 6abfca069e..8a96780d58 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -13,7 +13,7 @@
 
 module Language.PureScript.LspSimple (main) where
 
-import Control.Lens ((^.), Field1 (_1))
+import Control.Lens (Field1 (_1), (^.))
 import Control.Lens.Getter (to)
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
@@ -36,16 +36,17 @@ import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript (accumTypes, prettyPrintType)
 import Language.PureScript qualified as P
-import Language.PureScript.AST.Declarations (declSourceAnn, getModuleDeclarations)
+import Language.PureScript.AST.Declarations (declSourceAnn, getModuleDeclarations, getModuleName)
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
+import Language.PureScript.Externs (ExternsFile (efSourceSpan))
 import Language.PureScript.Ide (findAvailableExterns, loadModulesAsync)
 import Language.PureScript.Ide.Completion (getCompletions, getExactCompletions)
 import Language.PureScript.Ide.Completion qualified as Purs.Completion
-import Language.PureScript.Ide.Error (IdeError (RebuildError), textError)
+import Language.PureScript.Ide.Error (IdeError (RebuildError), prettyPrintTypeSingleLine, textError)
 import Language.PureScript.Ide.Filter (Filter, moduleFilter)
 import Language.PureScript.Ide.Imports (parseImportsFromFile)
 import Language.PureScript.Ide.Logging (runErrLogger)
@@ -55,15 +56,16 @@ import Language.PureScript.Ide.State (getAllModules)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeDeclarationAnn)
 import Language.PureScript.Ide.Util (runLogger)
 import Language.PureScript.Lsp.Cache (dropTables, initDb, insertAllExterns)
+import Language.PureScript.Lsp.Cache.Query (getDeclaration)
 import Language.PureScript.Lsp.Rebuild (rebuildAllFiles, rebuildFile)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (CurrentFile (CurrentFile), LspConfig (confLogLevel, confOutputPath), LspEnvironment (lspConfig, lspDbConnection))
+import Language.PureScript.Lsp.Util (efDeclComments, efDeclSourceSpan, efDeclSourceType, getWordAt)
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath (takeDirectory, (</>))
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
-import Language.PureScript.Lsp.Util (getWordAt)
 
 -- import Language.Haskell.LSP.VFS qualified as VFS
 
@@ -101,7 +103,7 @@ handlers diagErrs =
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
         res <- fromLspWithErr do
           dropTables
-          initDb 
+          initDb
           insertAllExterns
           rebuildAllFiles
         case res of
@@ -197,22 +199,11 @@ handlers diagErrs =
             else do
               cacheMb <- fromLsp cachedRebuild
               forLsp cacheMb $ \(CurrentFile _ module' ex) -> do
-                let posInSpan :: P.SourceSpan -> Bool
-                    posInSpan (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
-                      startLine <= fromIntegral (line + 1)
-                        && endLine >= fromIntegral (line + 1)
-                        && startCol <= fromIntegral (col + 1)
-                        && endCol >= fromIntegral (col + 1)
-
-                    declMb :: Maybe P.Declaration
-                    declMb =
-                      getModuleDeclarations module'
-                        & find (posInSpan . fst . declSourceAnn)
+                declMb <- fromLsp $ getDeclaration (getModuleName module') word
                 forLsp declMb $ \decl -> do
-                  let (declSpan, _) = declSourceAnn decl
-                      declName = P.spanName declSpan
-                      declType = Protolude.fold $ (head :: [Text] -> Maybe Text) $ accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $ decl
-                      declComments = snd $ declSourceAnn decl
+                  let declSpan = efDeclSourceSpan decl
+                      declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
+                      declComments = efDeclComments decl
                       hoverInfo =
                         Types.InL $
                           Types.Hover
@@ -230,110 +221,110 @@ handlers diagErrs =
                             )
                             Nothing
                   res $ Right hoverInfo
-            -- let moduleName' = case cache of
-            --       Just (CurrentFile mName _) -> Just mName
-            --       _ -> Nothing
-
-            -- imports <-
-            --   filePathMb
-            --     & maybe (pure Nothing) (fromLsp . parseImportsFromFile)
-
-            -- let filters :: [Filter]
-            --     filters =
-            --       imports
-            --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-            --     getInputModName (n, _, _) = n
-
-            --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-            --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-            -- completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-            -- let hoverInfo = case head <$> completions of
-            --       Right (Just completion) -> completionToHoverInfo word completion
-            --       _ -> word
-
-            -- res $
-            --   Right $
-            --     Types.InL $
-            --       Types.Hover
-            --         ( Types.InL $
-            --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
-            --         )
-            --         Nothing
-            --             ,
-            -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-            --   sendInfoMsg "SMethod_TextDocumentDefinition"
-            --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-            --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            --       uri =
-            --         req
-            --           ^. LSP.params
-            --             . LSP.textDocument
-            --             . LSP.uri
-            --             . to Types.toNormalizedUri
-
-            --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-            --   vfMb <- Server.getVirtualFile uri
-
-            --   for_ vfMb \vf -> do
-            --     let word = getWordAt (VFS._file_text vf) pos
-            --     cache <- fromLsp cachedRebuild
-            --     let moduleName' = case cache of
-            --           Right (Just (mName, _)) -> Just mName
-            --           _ -> Nothing
-
-            --     imports <-
-            --       filePathMb
-            --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
-
-            --     let filters :: [Filter]
-            --         filters =
-            --           imports
-            --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-            --         getInputModName (n, _, _) = n
-
-            --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-            --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-            --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-            --     sendInfoMsg $ "Completions: " <> show completions
-            --     let withLocation =
-            --           fold completions
-            --             & mapMaybe
-            --               ( \c -> case complLocation c of
-            --                   Just loc -> Just (c, loc)
-            --                   Nothing -> Nothing
-            --               )
-            --             & head
-
-            --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
-
-            --     case withLocation of
-            --       Just (completion, location) -> do
-            --         let fpMb =
-            --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
-
-            --         case fpMb of
-            --           Nothing -> do
-            --             sendInfoMsg "No file path for module"
-            --             nullRes
-            --           Just fp ->
-            --             res $
-            --               Right $
-            --                 Types.InL $
-            --                   Types.Definition $
-            --                     Types.InL $
-            --                       Types.Location
-            --                         (Types.filePathToUri fp)
-            --                         (spanToRange location)
-            --       _ -> do
-            --         sendInfoMsg "No location for completion"
-            --         nullRes
+                  -- let moduleName' = case cache of
+                  --       Just (CurrentFile mName _) -> Just mName
+                  --       _ -> Nothing
+
+                  -- imports <-
+                  --   filePathMb
+                  --     & maybe (pure Nothing) (fromLsp . parseImportsFromFile)
+
+                  -- let filters :: [Filter]
+                  --     filters =
+                  --       imports
+                  --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                  --     getInputModName (n, _, _) = n
+
+                  --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                  --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                  -- completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+                  -- let hoverInfo = case head <$> completions of
+                  --       Right (Just completion) -> completionToHoverInfo word completion
+                  --       _ -> word
+
+                  -- res $
+                  --   Right $
+                  --     Types.InL $
+                  --       Types.Hover
+                  --         ( Types.InL $
+                  --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
+                  --         )
+                  --         Nothing
+                  --             ,
+                  -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+                  --   sendInfoMsg "SMethod_TextDocumentDefinition"
+                  --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+                  --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+                  --       uri =
+                  --         req
+                  --           ^. LSP.params
+                  --             . LSP.textDocument
+                  --             . LSP.uri
+                  --             . to Types.toNormalizedUri
+
+                  --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+                  --   vfMb <- Server.getVirtualFile uri
+
+                  --   for_ vfMb \vf -> do
+                  --     let word = getWordAt (VFS._file_text vf) pos
+                  --     cache <- fromLsp cachedRebuild
+                  --     let moduleName' = case cache of
+                  --           Right (Just (mName, _)) -> Just mName
+                  --           _ -> Nothing
+
+                  --     imports <-
+                  --       filePathMb
+                  --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
+
+                  --     let filters :: [Filter]
+                  --         filters =
+                  --           imports
+                  --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                  --         getInputModName (n, _, _) = n
+
+                  --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                  --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                  --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+                  --     sendInfoMsg $ "Completions: " <> show completions
+                  --     let withLocation =
+                  --           fold completions
+                  --             & mapMaybe
+                  --               ( \c -> case complLocation c of
+                  --                   Just loc -> Just (c, loc)
+                  --                   Nothing -> Nothing
+                  --               )
+                  --             & head
+
+                  --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
+
+                  --     case withLocation of
+                  --       Just (completion, location) -> do
+                  --         let fpMb =
+                  --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
+
+                  --         case fpMb of
+                  --           Nothing -> do
+                  --             sendInfoMsg "No file path for module"
+                  --             nullRes
+                  --           Just fp ->
+                  --             res $
+                  --               Right $
+                  --                 Types.InL $
+                  --                   Types.Definition $
+                  --                     Types.InL $
+                  --                       Types.Location
+                  --                         (Types.filePathToUri fp)
+                  --                         (spanToRange location)
+                  --       _ -> do
+                  --         sendInfoMsg "No location for completion"
+                  --         nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -426,7 +417,7 @@ main lspEnv = do
         defaultConfig = (),
         configSection = "oa-purescript-simple",
         doInitialize = \env _req -> do
-          logT "Init OA purs lsp server"   
+          logT "Init OA purs lsp server"
           pure $ Right env,
         staticHandlers = \_caps -> do handlers diagErrs,
         interpretHandler = \env ->
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 4f3129baf8..ad38217fef 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -68,7 +68,7 @@ desugarTypeClasses externs = flip evalStateT initialState . desugarModule
     :: ModuleName
     -> ExternsDeclaration
     -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
-  fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty) = Just ((mn, name), typeClass) where
+  fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty _) = Just ((mn, name), typeClass) where
     typeClass = makeTypeClassData args members implies deps tcIsEmpty
   fromExternsDecl _ _ = Nothing
 

From 376197f38cc3271984d06d757af2916d85573740 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 27 Sep 2024 12:59:37 +0200
Subject: [PATCH 052/297] hovering works

---
 app/Command/Lsp.hs                         |   8 +-
 purescript.cabal                           |   2 +
 src/Language/PureScript/Lsp/Cache.hs       | 103 +++---
 src/Language/PureScript/Lsp/Cache/IO.hs    |  23 ++
 src/Language/PureScript/Lsp/Cache/Query.hs |  57 ++-
 src/Language/PureScript/Lsp/Print.hs       |  43 +++
 src/Language/PureScript/Lsp/Rebuild.hs     |  47 ++-
 src/Language/PureScript/Lsp/State.hs       |  33 +-
 src/Language/PureScript/Lsp/Types.hs       |  12 +-
 src/Language/PureScript/Lsp/Util.hs        |  78 +++--
 src/Language/PureScript/LspSimple.hs       | 388 +++++++++++----------
 src/Language/PureScript/Make/Actions.hs    |   2 +
 12 files changed, 497 insertions(+), 299 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Cache/IO.hs
 create mode 100644 src/Language/PureScript/Lsp/Print.hs

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index c36bb6022e..c917da3fdd 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -28,7 +28,7 @@ command = Opts.helper <*> subcommands
             "server"
             ( Opts.info
                 (fmap server serverOptions <**> Opts.helper)
-                (Opts.progDesc "Start a server process")
+                (Opts.progDesc "Start a server LSP process")
             )
         ]
 
@@ -36,13 +36,13 @@ command = Opts.helper <*> subcommands
     server opts'@(ServerOptions dir globs _globsFromFile _globsExcluded outputPath logLevel) = do
       when
         (logLevel == LogDebug || logLevel == LogAll)
-        (putText "Parsed Options:" *> print opts')
+        (hPutStrLn stderr ("Parsed Options:" :: Text) *> hPutStrLn stderr (show opts' :: Text))
       maybe (pure ()) setCurrentDirectory dir
       let conf =
             LspConfig
               { confOutputPath = outputPath,
-                confGlobs = globs,
-                confLogLevel = logLevel
+                confGlobs = globs
+                -- confLogLevel = logLevel
               }
       env <- mkEnv conf
       startServer env
diff --git a/purescript.cabal b/purescript.cabal
index 25e9bc8d5f..3ab58cb1bd 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -342,7 +342,9 @@ library
     Language.PureScript.Lsp
     Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Cache
+    Language.PureScript.Lsp.Cache.IO
     Language.PureScript.Lsp.Cache.Query
+    Language.PureScript.Lsp.Print
     Language.PureScript.Lsp.Rebuild
     Language.PureScript.Lsp.State
     Language.PureScript.Lsp.Types
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 13be96ddea..8f201c2d61 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -8,17 +8,20 @@ import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple
-import Language.PureScript qualified as P
+import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.Declarations (declName, declRefName, declSourceAnn)
-import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
+import Language.PureScript.AST.SourcePos (SourceSpan (spanName))
+import Language.PureScript.Externs (ExternsFile (efModuleName, efSourceSpan))
+import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Ide.Externs (readExternFile)
-import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.DB qualified as DB
+import Language.PureScript.Lsp.Print (printEfDeclName, printName)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
-import Language.PureScript.Lsp.Util (efDeclCategory, efDeclName, efDeclSourceSpan, printDeclarationType, printName)
+import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
+import Language.PureScript.Names qualified as P
 import Protolude
-import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute)
 import System.FilePath (normalise, (</>))
 import "monad-logger" Control.Monad.Logger (MonadLogger)
 
@@ -34,13 +37,13 @@ dropTables = do
 initDb :: (MonadReader LspEnvironment m, MonadIO m) => m ()
 initDb = do
   DB.execute_ "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT, UNIQUE(module_name), UNIQUE(path))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, PRIMARY KEY (module_name, name))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path), UNIQUE(module_name))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, import_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value BLOB, name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name BLOB, printed_name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, shown TEXT, PRIMARY KEY (module_name, name))"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path), UNIQUE(module_name))"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
 
-selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (ModuleMap ExternsFile)
+selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName ExternsFile)
 selectAllExternsMap = do
   Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectAllExterns
 
@@ -48,6 +51,18 @@ selectAllExterns :: (MonadIO m, MonadReader LspEnvironment m) => m [ExternsFile]
 selectAllExterns = do
   DB.query_ (Query "SELECT value FROM externs") <&> fmap (deserialise . fromOnly)
 
+selectExternFromFilePath :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe ExternsFile)
+selectExternFromFilePath path = do
+  absPath <- liftIO $ makeAbsolute path
+  res <- DB.queryNamed (Query "SELECT value FROM externs WHERE path = :path") [":path" := absPath]
+  pure $ deserialise . fromOnly <$> listToMaybe res
+
+selectExternModuleNameFromFilePath :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe P.ModuleName)
+selectExternModuleNameFromFilePath path = do
+  absPath <- liftIO $ makeAbsolute path
+  res <- DB.queryNamed (Query "SELECT module_name FROM externs WHERE path = :path") [":path" := absPath]
+  pure $ P.ModuleName . fromOnly <$> listToMaybe res
+
 insertAllExterns ::
   ( MonadIO m,
     MonadReader LspEnvironment m,
@@ -59,9 +74,9 @@ insertAllExterns = do
   oDir <- asks (confOutputPath . lspConfig)
   externPaths <- findAvailableExterns
   forM_ externPaths $ \name -> do
-    extern <- readExternFile (oDir </> toS (P.runModuleName name) </> P.externsFileName)
-
-    insertExtern oDir extern
+    let externPath = oDir </> toS (P.runModuleName name) </> P.externsFileName
+    extern <- readExternFile externPath
+    insertExtern extern
 
 -- | Finds all the externs inside the output folder and returns the
 -- corresponding module names
@@ -87,17 +102,19 @@ findAvailableExterns = do
 
 insertExtern ::
   (MonadIO m, MonadReader LspEnvironment m) =>
-  FilePath ->
   ExternsFile ->
   m ()
-insertExtern outDir extern = do
+insertExtern extern = do
+  path <- liftIO $ makeAbsolute externPath
   DB.executeNamed
-    (Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name) VALUES (:path, :ef_version, :value, :module_name)")
-    [ ":path" := externsPath,
+    (Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name, shown) VALUES (:path, :ef_version, :value, :module_name, :shown)")
+    [ ":path" := path,
       ":ef_version" := P.efVersion extern,
       ":value" := serialise extern,
-      ":module_name" := P.runModuleName name
+      ":module_name" := P.runModuleName name,
+      ":shown" := (show extern :: Text)
     ]
+
   DB.executeNamed
     (Query "DELETE FROM ef_imports WHERE module_name = :module_name")
     [":module_name" := P.runModuleName name]
@@ -111,8 +128,8 @@ insertExtern outDir extern = do
     [":module_name" := P.runModuleName name]
   forM_ (P.efDeclarations extern) $ insertEfDeclaration name
   where
-    externsPath = outDir </> T.unpack (P.runModuleName name) <> externsFileName
     name = efModuleName extern
+    externPath = spanName (efSourceSpan extern)
 
 insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
 insertEfImport moduleName' ei = do
@@ -128,10 +145,11 @@ insertEfImport moduleName' ei = do
 insertEfDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsDeclaration -> m ()
 insertEfDeclaration moduleName' decl = do
   DB.executeNamed
-    (Query "INSERT OR REPLACE INTO ef_declarations (module_name, value, name, start_col, start_line, end_col, end_line, category) VALUES (:module_name, :value, :name, :start_col, :start_line, :end_col, :end_line, :category)")
+    (Query "INSERT OR REPLACE INTO ef_declarations (module_name, value, shown, name, start_col, start_line, end_col, end_line, category) VALUES (:module_name, :value, :shown, :name, :start_col, :start_line, :end_col, :end_line, :category)")
     [ ":module_name" := P.runModuleName moduleName',
-      ":name" := efDeclName decl,
+      ":name" := printEfDeclName decl,
       ":value" := serialise decl,
+      ":shown" := (show decl :: Text),
       ":start_col" := (P.sourcePosColumn . P.spanStart) span,
       ":start_line" := (P.sourcePosLine . P.spanStart) span,
       ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
@@ -144,10 +162,11 @@ insertEfDeclaration moduleName' decl = do
 insertEfExport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.DeclarationRef -> m ()
 insertEfExport moduleName' dr = do
   DB.executeNamed
-    (Query "INSERT OR REPLACE INTO ef_exports (module_name, value, name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :name, :start_col, :start_line, :end_col, :end_line)")
+    (Query "INSERT OR REPLACE INTO ef_exports (module_name, value, name, printed_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :name, :printed_name, :start_col, :start_line, :end_col, :end_line)")
     [ ":module_name" := P.runModuleName moduleName',
       ":value" := serialise dr,
-      ":name" := printName (declRefName dr),
+      ":name" := serialise (declRefName dr),
+      ":printed_name" := printName (declRefName dr),
       ":start_col" := (P.sourcePosColumn . P.spanStart) span,
       ":start_line" := (P.sourcePosLine . P.spanStart) span,
       ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
@@ -166,25 +185,31 @@ insertModule srcPath m = do
     ]
 
   let exported = Set.fromList $ P.exportedDeclarations m
+  DB.executeNamed "DELETE FROM declarations WHERE module_name = :module_name" [":module_name" := P.runModuleName moduleName']
   traverse_ (insertDeclaration moduleName' exported) (P.getModuleDeclarations m)
 
 insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Set P.Declaration -> P.Declaration -> m ()
 insertDeclaration moduleName' exportedDecls decl = do
-  DB.executeNamed
-    (Query "INSERT OR REPLACE INTO declarations (module_name, name, type_printed, start_col, start_line, end_col, end_line, comments, exported, value) VALUES (:module_name, :name, :type_printed, :start_col, :start_line, :end_col, :end_line, :comments, :exported, :value)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":name" := maybe (show decl) printName (declName decl),
-      ":type_printed" := typeName,
-      ":start_col" := (P.sourcePosColumn . P.spanStart) declLocation,
-      ":start_line" := (P.sourcePosLine . P.spanStart) declLocation,
-      ":end_col" := (P.sourcePosColumn . P.spanEnd) declLocation,
-      ":end_line" := (P.sourcePosLine . P.spanEnd) declLocation,
-      ":comments" := encode comments,
-      ":exported" := exported,
-      ":value" := serialise decl
-    ]
+  for_ (declName decl) $ \name -> do
+    DB.executeNamed
+      ( Query
+          "INSERT OR REPLACE INTO declarations \
+          \(module_name, name, printed_name, start_col, start_line, end_col, end_line, comments, exported, value, shown) \
+          \VALUES \
+          \(:module_name, :name, :printed_name, :start_col, :start_line, :end_col, :end_line, :comments, :exported, :value, :shown)"
+      )
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := serialise name,
+        ":printed_name" := printName name,
+        ":start_col" := (P.sourcePosColumn . P.spanStart) declLocation,
+        ":start_line" := (P.sourcePosLine . P.spanStart) declLocation,
+        ":end_col" := (P.sourcePosColumn . P.spanEnd) declLocation,
+        ":end_line" := (P.sourcePosLine . P.spanEnd) declLocation,
+        ":comments" := encode comments,
+        ":exported" := exported,
+        ":value" := serialise decl,
+        ":shown" := (show decl :: Text)
+      ]
   where
-    typeName = printDeclarationType decl
-
     exported = Set.member decl exportedDecls
     (declLocation, comments) = declSourceAnn decl
diff --git a/src/Language/PureScript/Lsp/Cache/IO.hs b/src/Language/PureScript/Lsp/Cache/IO.hs
new file mode 100644
index 0000000000..c40231e168
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Cache/IO.hs
@@ -0,0 +1,23 @@
+module Language.PureScript.Lsp.Cache.IO where
+
+import Protolude
+import Database.SQLite.Simple qualified as SQL
+
+
+dropTables :: SQL.Connection -> IO ()
+dropTables conn = do
+  SQL.execute_ conn "DROP TABLE IF EXISTS modules"
+  SQL.execute_ conn "DROP TABLE IF EXISTS declarations"
+  SQL.execute_ conn "DROP TABLE IF EXISTS externs"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ef_exports"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ef_declarations"
+
+initDb :: SQL.Connection -> IO ()
+initDb conn = do
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT, UNIQUE(module_name), UNIQUE(path))"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name BLOB, printed_name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, shown TEXT, PRIMARY KEY (module_name, name))"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path), UNIQUE(module_name))"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 1f129ae174..cd8d21ed3a 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -1,4 +1,6 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Language.PureScript.Lsp.Cache.Query where
 
@@ -12,7 +14,10 @@ import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple
 import Language.LSP.Protocol.Types (Position)
-import Language.PureScript qualified as P
+import Language.PureScript.AST qualified as P
+import Language.PureScript.Comments qualified as P
+import Language.PureScript.Externs qualified as P
+import Language.PureScript.Names qualified as P
 import Language.PureScript.AST.Declarations (declSourceAnn)
 import Language.PureScript.AST.Traversals (accumTypes)
 import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
@@ -21,14 +26,15 @@ import Language.PureScript.Ide.Externs (readExternFile)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
-import Language.PureScript.Lsp.Util (printName)
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
 import System.FilePath (normalise, (</>))
+import Control.Monad.Trans.Writer (execWriterT)
+import Language.PureScript.Lsp.Print (printName)
 
--- getDeclarationAt :: (MonadIO m, MonadReader LspEnvironment m) => Position -> m (Maybe P.Declaration)
--- getDeclarationAt pos = do
+-- getEfDeclarationAt :: (MonadIO m, MonadReader LspEnvironment m) => Position -> m (Maybe P.Declaration)
+-- getEfDeclarationAt pos = do
 --   decls <-
 --     DB.queryNamed
 --       "SELECT * FROM declarations WHERE startLine <= :line AND endLine >= :line AND startColumn <= :column AND endColumn >= :column"
@@ -36,10 +42,8 @@ import System.FilePath (normalise, (</>))
 --       , ":column" := column
 --       ]
 --   pure $ listToMaybe decls
-
 -- getImportedModules
 
-
 getEfImports :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m [P.ExternsImport]
 getEfImports moduleName' = do
   imports <-
@@ -54,24 +58,29 @@ importMightContainIdent ident import' = case P.eiImportType import' of
   P.Explicit refs -> any ((==) ident . printName . P.declRefName) refs
   P.Hiding refs -> not $ any ((==) ident . printName . P.declRefName) refs
 
-getDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
-getDeclaration moduleName' name = do 
+getEfDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
+getEfDeclaration moduleName' name = do
   inModule <- getEfDeclarationOnlyInModule moduleName' name
   case inModule of
-    Just decl -> pure $ Just decl
-    Nothing -> getImportedDeclaration moduleName' name
+    Just decl -> pure $ Just (moduleName', decl)
+    Nothing -> getEFImportedDeclaration moduleName' name
 
-
-getImportedDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
-getImportedDeclaration moduleName' name = do
+getEFImportedDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
+getEFImportedDeclaration moduleName' name = do
   imports <- filter (importMightContainIdent name) <$> getEfImports moduleName'
   foldM go Nothing imports
   where
-    go :: (MonadIO m, MonadReader LspEnvironment m) => Maybe P.ExternsDeclaration -> P.ExternsImport -> m (Maybe P.ExternsDeclaration)
+    go ::
+      (MonadIO m, MonadReader LspEnvironment m) =>
+      Maybe (P.ModuleName, P.ExternsDeclaration) ->
+      P.ExternsImport ->
+      m (Maybe (P.ModuleName, P.ExternsDeclaration))
     go acc import' = do
       case acc of
         Just _ -> pure acc
-        Nothing -> getEfDeclarationOnlyInModule (P.eiModule import') name
+        Nothing -> fmap (toTup $ P.eiModule import') <$> getEfDeclarationOnlyInModule (P.eiModule import') name
+
+    toTup a b = (a, b)
 
 getEfDeclarationOnlyInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
 getEfDeclarationOnlyInModule moduleName' name = do
@@ -82,3 +91,21 @@ getEfDeclarationOnlyInModule moduleName' name = do
         ":name" := name
       ]
   pure $ deserialise . fromOnly <$> listToMaybe decls
+
+getDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.Declaration)
+getDeclaration moduleName' name = do
+  decls <-
+    DB.queryNamed
+      "SELECT value FROM declarations WHERE module_name = :module_name AND name = :name"
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := name
+      ]
+  pure $ deserialise . fromOnly <$> listToMaybe decls
+
+
+getDeclarationDocumentation :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> P.Declaration -> m [P.Comment]
+getDeclarationDocumentation module' decl = 
+   execWriterT $ do 
+    P.everywhereOnValuesM handleDecl pure pure ^. _1 $ decl
+  where 
+    handleDecl = pure
diff --git a/src/Language/PureScript/Lsp/Print.hs b/src/Language/PureScript/Lsp/Print.hs
new file mode 100644
index 0000000000..860405265b
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Print.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Language.PureScript.Lsp.Print where
+
+import Control.Lens (Field1 (_1), (^.))
+import Data.Text qualified as T
+import Language.PureScript.AST.Traversals (accumTypes)
+import Language.PureScript.AST qualified as P
+import Language.PureScript.Externs qualified as P
+-- import Language.PureScript.Linter qualified as P
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Pretty qualified as P
+import Protolude hiding (to)
+
+printDeclarationType :: P.Declaration -> Text
+printDeclarationType decl =
+  Protolude.fold $
+    (head :: [Text] -> Maybe Text) $
+      accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
+        decl
+
+
+printName :: P.Name -> Text
+printName = \case
+  P.IdentName ident -> P.runIdent ident
+  P.ValOpName op -> P.runOpName op
+  P.TyName name -> P.runProperName name
+  P.TyOpName op -> P.runOpName op
+  P.DctorName name -> P.runProperName name
+  P.TyClassName name -> P.runProperName name
+  P.ModName name -> P.runModuleName name
+
+
+printEfDeclName :: P.ExternsDeclaration -> Text
+printEfDeclName = \case
+  P.EDType name _ _ -> P.runProperName name
+  P.EDTypeSynonym name _ _ -> P.runProperName name
+  P.EDDataConstructor name _ _ _ _ -> P.runProperName name
+  P.EDValue ident _ -> P.runIdent ident
+  P.EDClass name _ _ _ _ _ _ -> P.runProperName name
+  P.EDInstance name _ _ _ _ _ _ _ _ _ -> P.runProperName $ P.disqualify name
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 4aed513d27..a437087e96 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.Lsp.Rebuild where
 
@@ -9,9 +10,11 @@ import Data.Maybe (fromJust)
 import Data.Set qualified as S
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Language.PureScript qualified as P
+import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
+import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
+import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
@@ -20,21 +23,22 @@ import Language.PureScript.Lsp.Cache
 import Language.PureScript.Lsp.State (cacheRebuild)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Make (ffiCodegen')
+import Language.PureScript.Make qualified as P
+import Language.PureScript.ModuleDependencies qualified as P
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
-import System.FilePath.Glob (glob)
-import "monad-logger" Control.Monad.Logger (logWarnN, MonadLogger)
+import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
 
-rebuildAllFiles ::
+rebuildFileAndDeps ::
   ( MonadIO m,
     MonadError IdeError m,
     MonadReader LspEnvironment m,
     MonadLogger m
   ) =>
-  m [(FilePath, P.MultipleErrors)]
-rebuildAllFiles = do
-  globs <- asks (confGlobs . lspConfig)
-  files <- liftIO $ concat <$> traverse glob globs
-  traverse rebuildFile files
+  FilePath ->
+  m (FilePath, P.MultipleErrors)
+rebuildFileAndDeps = rebuildFile' True
 
 rebuildFile ::
   ( MonadIO m,
@@ -44,8 +48,19 @@ rebuildFile ::
   ) =>
   FilePath ->
   m (FilePath, P.MultipleErrors)
-rebuildFile srcPath = do
-  logWarnN $ "Rebuilding file: " <> T.pack srcPath
+rebuildFile = rebuildFile' False
+
+rebuildFile' ::
+  ( MonadIO m,
+    MonadError IdeError m,
+    MonadReader LspEnvironment m,
+    MonadLogger m
+  ) =>
+  Bool ->
+  FilePath ->
+  m (FilePath, P.MultipleErrors)
+rebuildFile' rebuildDeps srcPath = do
+  logDebugN $ "Rebuilding file: " <> T.pack srcPath
   (fp, input) <-
     case List.stripPrefix "data:" srcPath of
       Just source -> pure ("", T.pack source)
@@ -56,6 +71,12 @@ rebuildFile srcPath = do
     Right m -> pure m
   let moduleName = P.getModuleName m
   externs <- sortExterns m =<< selectAllExternsMap
+  logDebugN $ "Sorted externs: " <> T.pack (show $ map P.efModuleName externs)
+  when rebuildDeps do 
+    forM_ externs \ef -> do
+      let depSrcPath = P.spanName $ P.efSourceSpan ef
+      logDebugN $ "Rebuilding dependency: " <> T.pack depSrcPath
+      rebuildFile' False depSrcPath
   outputDirectory <- asks (confOutputPath . lspConfig)
   let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
   let pureRebuild = fp == ""
@@ -70,14 +91,14 @@ rebuildFile srcPath = do
     unless pureRebuild $
       updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
     pure newExterns
-  logWarnN $ "Rebuilt file: " <> T.pack srcPath
   case result of
     Left errors ->
       throwError (RebuildError [(fp, input)] errors)
     Right newExterns -> do
       insertModule fp m
-      insertExtern outputDirectory newExterns
+      insertExtern newExterns
       rebuildModuleOpen makeEnv externs m
+      logDebugN $ "Rebuilt file: " <> T.pack srcPath
       pure (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
   where
     codegenTargets = Set.singleton P.JS
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index aba6d58ce4..4aaf791f47 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -6,7 +6,7 @@ import Control.Concurrent.STM (modifyTVar, readTVar)
 import Language.PureScript.Externs (ExternsFile (..))
 import Language.PureScript.Lsp.Types
 import Protolude hiding (moduleName, unzip)
-import Language.PureScript qualified as P
+import Language.PureScript.AST.Declarations qualified as P
 
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> P.Module -> m ()
@@ -23,4 +23,33 @@ cachedRebuild = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ do
     st' <- readTVar st
-    pure $ currentFile st'
\ No newline at end of file
+    pure $ currentFile st'
+
+
+getInitialized :: (MonadIO m, MonadReader LspEnvironment m) => m Bool 
+getInitialized = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ do
+    st' <- readTVar st
+    pure $ lspInitalized st'
+
+
+initFinished :: (MonadIO m, MonadReader LspEnvironment m) => m ()
+initFinished = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically . modifyTVar st $ \x ->
+    x
+      { lspInitalized = True
+      }
+
+whenInitialized :: (MonadIO m, MonadReader LspEnvironment m) => m () -> m ()
+whenInitialized action = do
+  initialized <- getInitialized
+  when initialized action
+
+waitForInit :: (MonadIO m, MonadReader LspEnvironment m) => m ()
+waitForInit = do
+  initialized <- getInitialized
+  unless initialized $ do
+    liftIO $ threadDelay 100000
+    waitForInit
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 87f31178ac..d016b8fe3d 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -4,8 +4,10 @@ module Language.PureScript.Lsp.Types where
 
 import Control.Concurrent.STM (TVar, newTVarIO)
 import Database.SQLite.Simple (Connection, open)
-import Language.PureScript qualified as P
-import Language.PureScript.Ide.Types (IdeLogLevel)
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.Externs qualified as P
+import Language.PureScript.Names qualified as P
+-- import Language.PureScript.Ide.Types (IdeLogLevel)
 import Protolude
 
 data LspEnvironment = LspEnvironment
@@ -17,18 +19,18 @@ data LspEnvironment = LspEnvironment
 mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do 
    connection <- open (confOutputPath conf <> "lsp.sqlite") 
-   st <- newTVarIO (LspState Nothing)
+   st <- newTVarIO (LspState Nothing False)
    pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
-    confGlobs :: [FilePath],
-    confLogLevel :: IdeLogLevel
+    confGlobs :: [FilePath]
   }
   deriving (Show)
 
 data LspState = LspState
   { currentFile :: Maybe CurrentFile
+  , lspInitalized :: Bool
   }
   deriving (Show)
 
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 124e8b0398..d55ea87d53 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -1,20 +1,22 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Language.PureScript.Lsp.Util where
 
 import Codec.Serialise qualified as S
-import Control.Lens (Field1 (_1), (^.))
 import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed as Rope
 import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.LSP.Protocol.Types (UInt)
 import Language.LSP.Protocol.Types qualified as Types
-import Language.PureScript (accumTypes)
-import Language.PureScript qualified as P
+import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.Declarations (declSourceAnn)
+import Language.PureScript.Comments qualified as P
 import Language.PureScript.Errors qualified as Errors
-import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
+import Language.PureScript.Externs qualified as P
+-- import Language.PureScript.Linter qualified as P
+import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
 
 posInSpan :: Types.Position -> Errors.SourceSpan -> Bool
@@ -27,13 +29,6 @@ posInSpan (Types.Position line col) (Errors.SourceSpan _ (Errors.SourcePos start
 getDeclarationAtPos :: Types.Position -> [P.Declaration] -> Maybe P.Declaration
 getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn)
 
-printDeclarationType :: P.Declaration -> Text
-printDeclarationType decl =
-  Protolude.fold $
-    (head :: [Text] -> Maybe Text) $
-      accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
-        decl
-
 getWordAt :: Rope -> Types.Position -> Text
 getWordAt file Types.Position {..} =
   let (_, after) = splitAtLine (fromIntegral _line) file
@@ -50,23 +45,52 @@ getWordOnLine line' col =
     getNextWs :: Int -> Text -> Int
     getNextWs idx txt | idx >= T.length txt = idx
     getNextWs idx txt = case T.index txt idx of
-      ch | isSpace ch -> idx
+      ch | isWordBreak ch -> idx
       _ -> getNextWs (idx + 1) txt
 
     getPrevWs :: Int -> Text -> Int
     getPrevWs 0 _ = 0
     getPrevWs idx txt = case T.index txt idx of
-      ch | isSpace ch -> idx + 1
+      ch | isWordBreak ch -> idx + 1
       _ -> getPrevWs (idx - 1) txt
 
-efDeclName :: P.ExternsDeclaration -> Text
-efDeclName = \case
-  P.EDType name _ _ -> P.runProperName name
-  P.EDTypeSynonym name _ _ -> P.runProperName name
-  P.EDDataConstructor name _ _ _ _ -> P.runProperName name
-  P.EDValue ident _ -> P.runIdent ident
-  P.EDClass name _ _ _ _ _ _ -> P.runProperName name
-  P.EDInstance name _ _ _ _ _ _ _ _ _ -> P.runProperName $ P.disqualify name
+    isWordBreak :: Char -> Bool
+    isWordBreak = not . (isAlphaNum ||^ (== '_'))
+
+-- getNameAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> m (Maybe P.Name)
+-- getNameAtPosition pos = do
+--   cacheMb <- cachedRebuild
+--   case getDeclarationAtPos pos =<< P.getModuleDeclarations . currentModule <$> cacheMb of
+--     Nothing -> pure Nothing
+--     Just decl -> do
+--       let name :: Maybe P.Name
+--           name = P.everythingOnValues (<|>) getDeclarationName goDef goDef goDef goDef ^. _1 $ decl
+--           goDef _ = Nothing
+--           getDeclarationName :: P.Declaration -> Maybe P.Name
+--           getDeclarationName = \case
+--             _ -> Nothing
+
+--       pure name
+  -- where 
+  --   getExprName :: P.Expr -> Maybe P.Name
+  --   getExprName = \case
+  --     P.Var _ q -> Just $ P.IdentName $ P.disqualify q
+  --     _ -> Nothing
+
+-- cacheMb
+--   & maybe
+--     (pure _)
+--     \CurrentFile {..} -> do
+
+--       -- let module' = P.efModule currentExterns
+--       -- let decls = P.getModuleDeclarations module'
+--       -- let file = P.efSource currentExterns
+--       -- let word = getWordAt file Types.Position {..}
+--       -- let decl = getDeclarationAtPos Types.Position {..} decls
+--       -- let ident = P.Ident (P.IdentName $ P.Ident word)
+--       -- pure $ P.IdentName ident
+--       pure Nothing
+
 
 data ExternsDeclarationCategory
   = EDCType
@@ -111,15 +135,3 @@ efDeclComments = foldr getComments [] . efDeclSourceType
     getComments :: Errors.SourceAnn -> [P.Comment] -> [P.Comment]
     getComments (_, cs) acc = cs ++ acc
 
-printName :: P.Name -> Text
-printName = \case
-  P.IdentName ident -> P.runIdent ident
-  P.ValOpName op -> P.runOpName op
-  P.TyName name -> P.runProperName name
-  P.TyOpName op -> P.runOpName op
-  P.DctorName name -> P.runProperName name
-  P.TyClassName name -> P.runProperName name
-  P.ModName name -> P.runModuleName name
-
-printSourceType :: P.SourceType -> Text
-printSourceType = prettyPrintTypeSingleLine
\ No newline at end of file
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 8a96780d58..0ec3e2a436 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -6,14 +6,14 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
+-- {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.LspSimple (main) where
 
-import Control.Lens (Field1 (_1), (^.))
+import Control.Lens ((^.))
 import Control.Lens.Getter (to)
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
@@ -22,66 +22,55 @@ import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Data.Text.Utf16.Rope.Mixed as Rope
 import Data.Time (getCurrentTime)
-import Debug.Trace (traceM)
-import GHC.Float (Floating (log))
 import GHC.IO (unsafePerformIO)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
-import Language.LSP.Protocol.Types (Diagnostic, UInt, Uri)
+import Language.LSP.Protocol.Types (Diagnostic, Uri)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
-import Language.PureScript (accumTypes, prettyPrintType)
-import Language.PureScript qualified as P
-import Language.PureScript.AST.Declarations (declSourceAnn, getModuleDeclarations, getModuleName)
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
-import Language.PureScript.Externs (ExternsFile (efSourceSpan))
-import Language.PureScript.Ide (findAvailableExterns, loadModulesAsync)
-import Language.PureScript.Ide.Completion (getCompletions, getExactCompletions)
-import Language.PureScript.Ide.Completion qualified as Purs.Completion
-import Language.PureScript.Ide.Error (IdeError (RebuildError), prettyPrintTypeSingleLine, textError)
-import Language.PureScript.Ide.Filter (Filter, moduleFilter)
-import Language.PureScript.Ide.Imports (parseImportsFromFile)
+import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), prettyPrintTypeSingleLine, textError)
 import Language.PureScript.Ide.Logging (runErrLogger)
-import Language.PureScript.Ide.Matcher (Matcher)
-import Language.PureScript.Ide.Prim (idePrimDeclarations)
-import Language.PureScript.Ide.State (getAllModules)
-import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeDeclarationAnn)
-import Language.PureScript.Ide.Util (runLogger)
-import Language.PureScript.Lsp.Cache (dropTables, initDb, insertAllExterns)
-import Language.PureScript.Lsp.Cache.Query (getDeclaration)
-import Language.PureScript.Lsp.Rebuild (rebuildAllFiles, rebuildFile)
-import Language.PureScript.Lsp.State (cachedRebuild)
-import Language.PureScript.Lsp.Types (CurrentFile (CurrentFile), LspConfig (confLogLevel, confOutputPath), LspEnvironment (lspConfig, lspDbConnection))
+import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
+import Language.PureScript.Lsp.Cache (dropTables, initDb, insertAllExterns, selectExternModuleNameFromFilePath)
+import Language.PureScript.Lsp.Cache.Query (getDeclaration, getEfDeclaration)
+import Language.PureScript.Lsp.Print (printDeclarationType)
+import Language.PureScript.Lsp.Rebuild (rebuildFile, rebuildFileAndDeps)
+import Language.PureScript.Lsp.State (initFinished, waitForInit)
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Lsp.Util (efDeclComments, efDeclSourceSpan, efDeclSourceType, getWordAt)
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
-import System.FilePath (takeDirectory, (</>))
 import Text.PrettyPrint.Boxes (render)
-import "monad-logger" Control.Monad.Logger (LoggingT, mapLoggingT)
-
--- import Language.Haskell.LSP.VFS qualified as VFS
+import "monad-logger" Control.Monad.Logger (LoggingT, logDebugN, logErrorN, logWarnN, mapLoggingT)
 
 type HandlerM config = Server.LspT config (ReaderT LspEnvironment (LoggingT IO))
 
 type LspM = ReaderT LspEnvironment (LoggingT (ExceptT IdeError IO))
 
-fromLsp :: LspM a -> HandlerM config a
-fromLsp = lift . mapReaderT (mapLoggingT (throwIdeError <=< runExceptT))
+liftLsp :: LspM a -> HandlerM config a
+liftLsp = lift . mapReaderT (mapLoggingT (throwIdeError <=< runExceptT))
   where
     throwIdeError = \case
       Left err -> liftIO $ throwIO err
       Right a -> pure a
 
-fromLspWithErr :: LspM a -> HandlerM config (Either IdeError a)
-fromLspWithErr = lift . mapReaderT (mapLoggingT runExceptT)
+liftLspWithErr :: LspM a -> HandlerM config (Either IdeError a)
+liftLspWithErr = lift . flip catchError errorHandler . mapReaderT (mapLoggingT runExceptT)
+  where
+    errorHandler ::
+      IOException ->
+      ReaderT LspEnvironment (LoggingT IO) (Either IdeError a)
+    errorHandler err = do
+      logErrorN $ T.pack (show err)
+      pure $ Left $ GeneralError $ show err
 
 type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
 
@@ -101,40 +90,52 @@ handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
-        res <- fromLspWithErr do
+        res <- liftLspWithErr do
           dropTables
           initDb
           insertAllExterns
-          rebuildAllFiles
+          logDebugN "Externs inserted"
+          initFinished
+          logDebugN "Init finished"
+          void $ rebuildFileAndDeps "src/Main.purs"
+          logDebugN "Rebuilt Main.purs"
+
         case res of
           Left err -> do
-            log_ err
-            sendInfoMsg $ show err
+            liftLsp $ logErrorN $ "Initalise error: " <> show err
+            sendInfoMsg "Failed to initialise lsp server"
           Right _ -> sendInfoMsg "OA purs lsp server initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        sendInfoMsg "TextDocumentDidOpen"
+        liftLsp $ logDebugN "TextDocumentDidOpen"
         let uri :: Uri
             uri = getMsgUri msg
             fileName = Types.uriToFilePath uri
-        void $ fromLsp $ traverse rebuildFile fileName,
+        void $ liftLspWithErr do
+          waitForInit
+          logDebugN "Rebuilding file from open"
+          traverse rebuildFile fileName,
       Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
-        sendInfoMsg "TextDocumentDidChange",
+        liftLsp $ logDebugN "TextDocumentDidChange",
       Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
-        sendInfoMsg "SMethod_TextDocumentDidSave"
+        liftLsp $ logDebugN "SMethod_TextDocumentDidSave"
         let uri :: Uri
             uri = getMsgUri msg
             fileName = Types.uriToFilePath uri
-        void $ fromLsp $ traverse rebuildFile fileName,
+        void $ liftLspWithErr do
+          waitForInit
+          logDebugN "Rebuilding file from save"
+          traverse rebuildFile fileName,
       Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
         cfg <- getConfig
-        sendInfoMsg $ "Config changed: " <> show cfg,
+        liftLsp $ logDebugN $ "Config changed: " <> show cfg,
       Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
-        sendInfoMsg "SMethod_SetTrace",
+        liftLsp $ logDebugN "SMethod_SetTrace",
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentDiagnostic"
+        liftLsp $ logDebugN "SMethod_TextDocumentDiagnostic"
         (errs, diagnostics) <- getFileDiagnotics req
-        sendInfoMsg $ "Errors: " <> show errs
-        sendInfoMsg $ "diagnostics: " <> show diagnostics
+        unless (null errs) $ liftLsp do
+          logDebugN $ "Errors: " <> show errs
+          logDebugN $ "diagnostics: " <> show diagnostics
         insertDiagnosticErrors diagErrs errs diagnostics
         res $
           Right $
@@ -142,13 +143,14 @@ handlers diagErrs =
               Types.InL $
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentCodeAction"
+        liftLsp $ logDebugN "SMethod_TextDocumentCodeAction"
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
             uri = getMsgUri req
+        liftLsp $ logDebugN "SMethod_TextDocumentCodeAction 0"
 
         errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
-
+        liftLsp $ logDebugN "SMethod_TextDocumentCodeAction 1"
         res $
           Right $
             Types.InL $
@@ -181,6 +183,7 @@ handlers diagErrs =
                         Nothing
                         Nothing,
       Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+        liftLsp $ logDebugN "SMethod_TextDocumentHover"
         let Types.HoverParams docIdent pos@(Types.Position line col) _workDone = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             docUri =
@@ -190,141 +193,150 @@ handlers diagErrs =
             nullRes = res $ Right $ Types.InR Types.Null
             forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
             forLsp val f = maybe nullRes f val
-        vfMb <- Server.getVirtualFile docUri
-
-        forLsp vfMb \vf -> do
-          let word = getWordAt (VFS._file_text vf) pos
-          if word == ""
-            then nullRes
-            else do
-              cacheMb <- fromLsp cachedRebuild
-              forLsp cacheMb $ \(CurrentFile _ module' ex) -> do
-                declMb <- fromLsp $ getDeclaration (getModuleName module') word
-                forLsp declMb $ \decl -> do
-                  let declSpan = efDeclSourceSpan decl
-                      declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
-                      declComments = efDeclComments decl
-                      hoverInfo =
-                        Types.InL $
-                          Types.Hover
-                            ( Types.InL $
-                                Types.MarkupContent
-                                  Types.MarkupKind_Markdown
-                                  ( "```purescript\n"
-                                      <> word
-                                      <> " :: "
-                                      <> declType
-                                      <> "\n"
-                                      <> fold (convertComments declComments)
-                                      <> "\n```"
-                                  )
-                            )
-                            Nothing
-                  res $ Right hoverInfo
-                  -- let moduleName' = case cache of
-                  --       Just (CurrentFile mName _) -> Just mName
-                  --       _ -> Nothing
-
-                  -- imports <-
-                  --   filePathMb
-                  --     & maybe (pure Nothing) (fromLsp . parseImportsFromFile)
-
-                  -- let filters :: [Filter]
-                  --     filters =
-                  --       imports
-                  --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                  --     getInputModName (n, _, _) = n
-
-                  --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                  --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                  -- completions <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-                  -- let hoverInfo = case head <$> completions of
-                  --       Right (Just completion) -> completionToHoverInfo word completion
-                  --       _ -> word
-
-                  -- res $
-                  --   Right $
-                  --     Types.InL $
-                  --       Types.Hover
-                  --         ( Types.InL $
-                  --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
-                  --         )
-                  --         Nothing
-                  --             ,
-                  -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-                  --   sendInfoMsg "SMethod_TextDocumentDefinition"
-                  --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-                  --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-                  --       uri =
-                  --         req
-                  --           ^. LSP.params
-                  --             . LSP.textDocument
-                  --             . LSP.uri
-                  --             . to Types.toNormalizedUri
-
-                  --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-                  --   vfMb <- Server.getVirtualFile uri
-
-                  --   for_ vfMb \vf -> do
-                  --     let word = getWordAt (VFS._file_text vf) pos
-                  --     cache <- fromLsp cachedRebuild
-                  --     let moduleName' = case cache of
-                  --           Right (Just (mName, _)) -> Just mName
-                  --           _ -> Nothing
-
-                  --     imports <-
-                  --       filePathMb
-                  --         & maybe (pure Nothing) (fmap hush . fromLsp . parseImportsFromFile)
-
-                  --     let filters :: [Filter]
-                  --         filters =
-                  --           imports
-                  --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                  --         getInputModName (n, _, _) = n
-
-                  --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                  --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                  --     completions :: Either IdeError [Completion] <- fromLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-                  --     sendInfoMsg $ "Completions: " <> show completions
-                  --     let withLocation =
-                  --           fold completions
-                  --             & mapMaybe
-                  --               ( \c -> case complLocation c of
-                  --                   Just loc -> Just (c, loc)
-                  --                   Nothing -> Nothing
-                  --               )
-                  --             & head
-
-                  --     paths <- fromLsp $ Map.map snd . fsModules <$> getFileState
-
-                  --     case withLocation of
-                  --       Just (completion, location) -> do
-                  --         let fpMb =
-                  --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
-
-                  --         case fpMb of
-                  --           Nothing -> do
-                  --             sendInfoMsg "No file path for module"
-                  --             nullRes
-                  --           Just fp ->
-                  --             res $
-                  --               Right $
-                  --                 Types.InL $
-                  --                   Types.Definition $
-                  --                     Types.InL $
-                  --                       Types.Location
-                  --                         (Types.filePathToUri fp)
-                  --                         (spanToRange location)
-                  --       _ -> do
-                  --         sendInfoMsg "No location for completion"
-                  --         nullRes
+        liftLsp $ logDebugN $ "filePathMb: " <> show filePathMb
+        liftLsp $ logDebugN $ "docUri: " <> show docUri
+        forLsp filePathMb \filePath -> do
+          vfMb <- Server.getVirtualFile docUri
+          liftLsp $ logDebugN $ "vfMb exists: " <> show (isJust vfMb)
+          forLsp vfMb \vf -> do
+            let word = getWordAt (VFS._file_text vf) pos
+            liftLsp $ logWarnN $ "word: " <> show word
+            if word == ""
+              then nullRes
+              else do
+                mNameMb <- liftLspWithErr $ selectExternModuleNameFromFilePath filePath
+                liftLsp $ logDebugN $ "mNameMb: " <> show mNameMb
+                forLsp (join $ hush mNameMb) $ \mName -> do
+                  declMb <- liftLsp $ getEfDeclaration mName word
+                  forLsp declMb $ \(importedMod, decl) -> do
+                    liftLsp $ logWarnN $ "importedMod: " <> show importedMod
+                    astDeclMb <- liftLsp $ getDeclaration importedMod word
+                    liftLsp $ logWarnN $ "astDeclMb: " <> show astDeclMb
+                    let declSpan = efDeclSourceSpan decl
+                        declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
+                        declComments = maybe (convertComments $ efDeclComments decl) (Just . printDeclarationType) astDeclMb
+                        hoverInfo =
+                          Types.InL $
+                            Types.Hover
+                              ( Types.InL $
+                                  Types.MarkupContent
+                                    Types.MarkupKind_Markdown
+                                    ( "```purescript\n"
+                                        <> word
+                                        <> " :: "
+                                        <> declType
+                                        <> "\n"
+                                        <> fold declComments
+                                        <> "\n```"
+                                    )
+                              )
+                              Nothing
+                    liftLsp $ logWarnN $ "Comments: " <> show declComments
+                    res $ Right hoverInfo
+                    -- let moduleName' = case cache of
+                    --       Just (CurrentFile mName _ _ ) -> Just mName
+                    --       _ -> Nothing
+
+                    -- imports <-
+                    --   filePathMb
+                    --     & maybe (pure Nothing) (liftLsp . parseImportsFromFile)
+
+                    -- let filters :: [Filter]
+                    --     filters =
+                    --       imports
+                    --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                    --     getInputModName (n, _, _) = n
+
+                    --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                    --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                    -- completions <- liftLsp $ get_actCompletionsWithPrim word filters moduleName'
+
+                    -- let hoverInfo = case head <$> completions of
+                    --       Right (Just completion) -> completionToHoverInfo word completion
+                    --       _ -> word
+
+                    -- res $
+                    --   Right $
+                    --     Types.InL $
+                    --       Types.Hover
+                    --         ( Types.InL $
+                    --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
+                    --         )
+                    --         Nothing
+                    --             ,
+                    -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+                    --   sendInfoMsg "SMethod_TextDocumentDefinition"
+                    --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+                    --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+                    --       uri =
+                    --         req
+                    --           ^. LSP.params
+                    --             . LSP.textDocument
+                    --             . LSP.uri
+                    --             . to Types.toNormalizedUri
+
+                    --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+                    --   vfMb <- Server.getVirtualFile uri
+
+                    --   for_ vfMb \vf -> do
+                    --     let word = getWordAt (VFS._file_text vf) pos
+                    --     cache <- liftLsp cachedRebuild
+                    --     let moduleName' = case cache of
+                    --           Right (Just (mName, _)) -> Just mName
+                    --           _ -> Nothing
+
+                    --     imports <-
+                    --       filePathMb
+                    --         & maybe (pure Nothing) (fmap hush . liftLsp . parseImportsFromFile)
+
+                    --     let filters :: [Filter]
+                    --         filters =
+                    --           imports
+                    --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+                    --         getInputModName (n, _, _) = n
+
+                    --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+                    --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+                    --     completions :: Either IdeError [Completion] <- liftLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+                    --     sendInfoMsg $ "Completions: " <> show completions
+                    --     let withLocation =
+                    --           fold completions
+                    --             & mapMaybe
+                    --               ( \c -> case complLocation c of
+                    --                   Just loc -> Just (c, loc)
+                    --                   Nothing -> Nothing
+                    --               )
+                    --             & head
+
+                    --     paths <- liftLsp $ Map.map snd . fsModules <$> getFileState
+
+                    --     case withLocation of
+                    --       Just (completion, location) -> do
+                    --         let fpMb =
+                    --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
+
+                    --         case fpMb of
+                    --           Nothing -> do
+                    --             sendInfoMsg "No file path for module"
+                    --             nullRes
+                    --           Just fp ->
+                    --             res $
+                    --               Right $
+                    --                 Types.InL $
+                    --                   Types.Definition $
+                    --                     Types.InL $
+                    --                       Types.Location
+                    --                         (Types.filePathToUri fp)
+                    --                         (spanToRange location)
+                    --       _ -> do
+                    --         sendInfoMsg "No location for completion"
+                    --         nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -335,7 +347,7 @@ handlers diagErrs =
       logT $ "Rebuilding file: " <> show (uri, fileName)
       case fileName of
         Just file -> do
-          res <- fmap snd <$> fromLspWithErr (rebuildFile file)
+          res <- fmap snd <$> liftLspWithErr (waitForInit *> logWarnN "rebuilding for diagnostics" *> rebuildFile file)
           logT $ "Rebuild result: " <> show res
           getResultDiagnostics res
         Nothing -> do
@@ -352,7 +364,7 @@ handlers diagErrs =
             diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
         pure (errors, diags)
       Left err -> do
-        sendError err
+        liftLsp $ logErrorN $ "Rebuild error: " <> show err
         pure ([], [])
       Right errs | Errors.nonEmpty errs -> do
         let errors = runMultipleErrors errs
@@ -422,7 +434,7 @@ main lspEnv = do
         staticHandlers = \_caps -> do handlers diagErrs,
         interpretHandler = \env ->
           Server.Iso
-            ( runErrLogger (confLogLevel (lspConfig lspEnv))
+            ( runErrLogger LogAll
                 . flip runReaderT lspEnv
                 . Server.runLspT env
             )
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index f138327c8d..25c51d312f 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -249,6 +249,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   codegen m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
+    -- lift initDb
+
     codegenTargets <- lift $ asks optionsCodegenTargets
     when (S.member CoreFn codegenTargets) $ do
       let coreFnFile = targetFilename mn CoreFn

From 287fb336da2d9558f43e0bd8ff7c16a36e854d58 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 30 Sep 2024 11:56:55 +0200
Subject: [PATCH 053/297] remove ed instance extern changes

---
 purescript.cabal                             |   1 +
 src/Language/PureScript/Externs.hs           |   7 +-
 src/Language/PureScript/Lsp/Cache.hs         |   2 +
 src/Language/PureScript/Lsp/Cache/Query.hs   | 111 ++++++++++++-------
 src/Language/PureScript/Lsp/Print.hs         |   2 +-
 src/Language/PureScript/Lsp/Rebuild.hs       |  11 +-
 src/Language/PureScript/Lsp/Util.hs          |   2 +-
 src/Language/PureScript/Make.hs              |  32 +++++-
 src/Language/PureScript/Sugar/TypeClasses.hs |   2 +-
 9 files changed, 117 insertions(+), 53 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index 3ab58cb1bd..506dfa3a3e 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -344,6 +344,7 @@ library
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Cache.IO
     Language.PureScript.Lsp.Cache.Query
+    Language.PureScript.Lsp.Prim
     Language.PureScript.Lsp.Print
     Language.PureScript.Lsp.Rebuild
     Language.PureScript.Lsp.State
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index ad9d110281..6a67f0da46 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -143,7 +143,6 @@ data ExternsDeclaration =
       , edClassConstraints        :: [SourceConstraint]
       , edFunctionalDependencies  :: [FunctionalDependency]
       , edIsEmpty                 :: Bool
-      , edSourceSpan              :: SourceSpan 
       }
   -- | An instance declaration
   | EDInstance
@@ -177,7 +176,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar
   applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
   applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
   applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (ByModuleName efModuleName) ident) (ty, External, Defined) (names env) }
-  applyDecl env (EDClass pn args members cs deps tcIsEmpty _) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) }
+  applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) }
   applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) =
     env { typeClassDictionaries =
             updateMap
@@ -248,7 +247,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF
   toExternsDeclaration (ValueRef _ ident)
     | Just (ty, _, _) <- Qualified (ByModuleName mn) ident `M.lookup` names env
     = [ EDValue (lookupRenamedIdent ident) ty ]
-  toExternsDeclaration (TypeClassRef ss' className)
+  toExternsDeclaration (TypeClassRef _ss className)
     | let dictName = dictTypeName . coerceProperName $ className
     , Just TypeClassData{..} <- Qualified (ByModuleName mn) className `M.lookup` typeClasses env
     , Just (kind, tk) <- Qualified (ByModuleName mn) (coerceProperName className) `M.lookup` types env
@@ -257,7 +256,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF
     = [ EDType (coerceProperName className) kind tk
       , EDType dictName dictKind dictData
       , EDDataConstructor dctor dty dictName ty args
-      , EDClass className typeClassArguments ((\(a, b, _) -> (a, b)) <$> typeClassMembers) typeClassSuperclasses typeClassDependencies typeClassIsEmpty ss'
+      , EDClass className typeClassArguments ((\(a, b, _) -> (a, b)) <$> typeClassMembers) typeClassSuperclasses typeClassDependencies typeClassIsEmpty
       ]
   toExternsDeclaration (TypeInstanceRef ss' ident ns)
     = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss'
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 8f201c2d61..bf99ab00ac 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -24,6 +24,7 @@ import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute)
 import System.FilePath (normalise, (</>))
 import "monad-logger" Control.Monad.Logger (MonadLogger)
+-- import Language.PureScript.Lsp.Prim (primExterns)
 
 dropTables :: (MonadIO m, MonadReader LspEnvironment m) => m ()
 dropTables = do
@@ -42,6 +43,7 @@ initDb = do
   DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
   DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
   DB.execute_ "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
+  -- traverse_ insertExtern primExterns
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName ExternsFile)
 selectAllExternsMap = do
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index cd8d21ed3a..0d309c0631 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -1,6 +1,6 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# LANGUAGE PackageImports #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.Lsp.Cache.Query where
 
@@ -8,30 +8,35 @@ module Language.PureScript.Lsp.Cache.Query where
 
 import Codec.Serialise (deserialise, serialise)
 import Control.Lens (Field1 (_1), (^.), _1)
+import Control.Monad.Trans.Writer (execWriterT)
 import Data.Aeson (encode)
+import Data.ByteString.Lazy qualified as Lazy
+import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Database.SQLite.Simple
+import Database.SQLite.Simple (NamedParam ((:=)), fromOnly)
 import Language.LSP.Protocol.Types (Position)
 import Language.PureScript.AST qualified as P
-import Language.PureScript.Comments qualified as P
-import Language.PureScript.Externs qualified as P
-import Language.PureScript.Names qualified as P
-import Language.PureScript.AST.Declarations (declSourceAnn)
+import Language.PureScript.AST.Declarations (declRefName, declSourceAnn)
 import Language.PureScript.AST.Traversals (accumTypes)
+import Language.PureScript.Comments qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
+import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Ide.Externs (readExternFile)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.DB qualified as DB
+import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Names qualified as P
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
 import System.FilePath (normalise, (</>))
-import Control.Monad.Trans.Writer (execWriterT)
-import Language.PureScript.Lsp.Print (printName)
+import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebugN, logErrorN, logWarnN, mapLoggingT)
+
+-- import Control.Monad.Logger (logDebugN)
 
 -- getEfDeclarationAt :: (MonadIO m, MonadReader LspEnvironment m) => Position -> m (Maybe P.Declaration)
 -- getEfDeclarationAt pos = do
@@ -44,6 +49,9 @@ import Language.PureScript.Lsp.Print (printName)
 --   pure $ listToMaybe decls
 -- getImportedModules
 
+getEfImportsMap :: (MonadIO f, MonadReader LspEnvironment f) => [P.ModuleName] -> f (Map P.ModuleName [P.DeclarationRef])
+getEfImportsMap mNames = Map.fromListWith (++) . fmap (fmap List.singleton) <$> getEfExports mNames
+
 getEfImports :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m [P.ExternsImport]
 getEfImports moduleName' = do
   imports <-
@@ -52,37 +60,71 @@ getEfImports moduleName' = do
       [":module_name" := P.runModuleName moduleName']
   pure $ deserialise . fromOnly <$> imports
 
-importMightContainIdent :: Text -> P.ExternsImport -> Bool
-importMightContainIdent ident import' = case P.eiImportType import' of
-  P.Implicit -> True
-  P.Explicit refs -> any ((==) ident . printName . P.declRefName) refs
-  P.Hiding refs -> not $ any ((==) ident . printName . P.declRefName) refs
+getEfExports :: (MonadIO m, MonadReader LspEnvironment m) => [P.ModuleName] -> m [(P.ModuleName, P.DeclarationRef)]
+getEfExports moduleNames = do
+  exports :: [(Text, Lazy.ByteString)] <-
+    DB.queryNamed
+      "SELECT module_name, value FROM ef_exports WHERE module_name IN (SELECT value FROM json_each(:module_names))"
+      [ ":module_names" := encode (fmap P.runModuleName moduleNames)
+      ]
+  pure $ bimap P.ModuleName deserialise <$> exports
+
+importContainsIdent :: Text -> P.ExternsImport -> Maybe Bool
+importContainsIdent ident import' = case P.eiImportType import' of
+  P.Implicit -> Nothing
+  P.Explicit refs -> Just $ any ((==) ident . printName . P.declRefName) refs
+  P.Hiding refs ->
+    if any ((==) ident . printName . P.declRefName) refs
+      then Just False
+      else Nothing
 
-getEfDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
+getEfDeclaration :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
 getEfDeclaration moduleName' name = do
   inModule <- getEfDeclarationOnlyInModule moduleName' name
   case inModule of
     Just decl -> pure $ Just (moduleName', decl)
     Nothing -> getEFImportedDeclaration moduleName' name
 
-getEFImportedDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
+getEFImportedDeclaration :: forall m. (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
 getEFImportedDeclaration moduleName' name = do
-  imports <- filter (importMightContainIdent name) <$> getEfImports moduleName'
-  foldM go Nothing imports
+  imports <- getEfImports moduleName'
+  exported <- getEfImportsMap (fmap P.eiModule imports)
+  foldM (getFromModule exported) Nothing imports
   where
-    go ::
-      (MonadIO m, MonadReader LspEnvironment m) =>
-      Maybe (P.ModuleName, P.ExternsDeclaration) ->
-      P.ExternsImport ->
-      m (Maybe (P.ModuleName, P.ExternsDeclaration))
-    go acc import' = do
+    getFromModule exported acc import' = do
       case acc of
         Just _ -> pure acc
-        Nothing -> fmap (toTup $ P.eiModule import') <$> getEfDeclarationOnlyInModule (P.eiModule import') name
+        Nothing -> case importContainsIdent name import' of
+          Just False -> pure acc
+          _ -> do
+            inModule <- getEfDeclarationOnlyInModule importModName name
+            case inModule of
+              Just decl -> pure $ Just (importModName, decl)
+              Nothing -> getFromExports
+      where
+        importModName = P.eiModule import'
+        moduleExports = fromMaybe [] $ Map.lookup importModName exported
 
-    toTup a b = (a, b)
+        getFromExports :: m (Maybe (P.ModuleName, P.ExternsDeclaration))
+        getFromExports = foldM getFromExport Nothing moduleExports
 
-getEfDeclarationOnlyInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
+        getFromExport ::
+          Maybe (P.ModuleName, P.ExternsDeclaration) ->
+          P.DeclarationRef ->
+          m (Maybe (P.ModuleName, P.ExternsDeclaration))
+        getFromExport acc' export' = do
+          case acc of
+            Just _ -> pure acc'
+            Nothing -> do
+              case export' of
+                P.ModuleRef _ mName -> getEfDeclaration mName name
+                P.ReExportRef _ss (P.ExportSource _ definedIn) ref
+                  | printName (declRefName ref) == name ->
+                      fmap (definedIn,) <$> getEfDeclarationOnlyInModule definedIn name
+                _ -> pure acc'
+
+
+getEfDeclarationOnlyInModule :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
 getEfDeclarationOnlyInModule moduleName' name = do
   decls <-
     DB.queryNamed
@@ -90,22 +132,15 @@ getEfDeclarationOnlyInModule moduleName' name = do
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := name
       ]
+  logDebugN $ "getEfDeclarationOnlyInModule decls: " <> show moduleName' <> " . " <> show name <> " : " <> T.pack (show $ length decls)
   pure $ deserialise . fromOnly <$> listToMaybe decls
 
 getDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.Declaration)
-getDeclaration moduleName' name = do
+getDeclaration moduleName' printed_name = do
   decls <-
     DB.queryNamed
-      "SELECT value FROM declarations WHERE module_name = :module_name AND name = :name"
+      "SELECT value FROM declarations WHERE module_name = :module_name AND printed_name = :printed_name"
       [ ":module_name" := P.runModuleName moduleName',
-        ":name" := name
+        ":printed_name" := printed_name
       ]
   pure $ deserialise . fromOnly <$> listToMaybe decls
-
-
-getDeclarationDocumentation :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> P.Declaration -> m [P.Comment]
-getDeclarationDocumentation module' decl = 
-   execWriterT $ do 
-    P.everywhereOnValuesM handleDecl pure pure ^. _1 $ decl
-  where 
-    handleDecl = pure
diff --git a/src/Language/PureScript/Lsp/Print.hs b/src/Language/PureScript/Lsp/Print.hs
index 860405265b..221ff79c92 100644
--- a/src/Language/PureScript/Lsp/Print.hs
+++ b/src/Language/PureScript/Lsp/Print.hs
@@ -39,5 +39,5 @@ printEfDeclName = \case
   P.EDTypeSynonym name _ _ -> P.runProperName name
   P.EDDataConstructor name _ _ _ _ -> P.runProperName name
   P.EDValue ident _ -> P.runIdent ident
-  P.EDClass name _ _ _ _ _ _ -> P.runProperName name
+  P.EDClass name _ _ _ _ _ -> P.runProperName name
   P.EDInstance name _ _ _ _ _ _ _ _ _ -> P.runProperName $ P.disqualify name
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index a437087e96..5e79eefd06 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -72,11 +72,14 @@ rebuildFile' rebuildDeps srcPath = do
   let moduleName = P.getModuleName m
   externs <- sortExterns m =<< selectAllExternsMap
   logDebugN $ "Sorted externs: " <> T.pack (show $ map P.efModuleName externs)
-  when rebuildDeps do 
+  when rebuildDeps do
     forM_ externs \ef -> do
       let depSrcPath = P.spanName $ P.efSourceSpan ef
-      logDebugN $ "Rebuilding dependency: " <> T.pack depSrcPath
-      rebuildFile' False depSrcPath
+          modName = P.runModuleName $ P.efModuleName ef
+      when (modName /= "Prim" && T.take 5 modName /= "Prim.") do
+        logDebugN $ "Rebuilding dependency: " <> T.pack depSrcPath
+        void $ rebuildFile' False depSrcPath
+
   outputDirectory <- asks (confOutputPath . lspConfig)
   let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
   let pureRebuild = fp == ""
@@ -87,7 +90,7 @@ rebuildFile' rebuildDeps srcPath = do
           & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
           & shushProgress
   (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-    newExterns <- P.rebuildModule makeEnv externs m
+    (newExterns, coreFn, docs) <- P.rebuildModuleAndGetArtifacts makeEnv externs m
     unless pureRebuild $
       updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
     pure newExterns
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index d55ea87d53..be40f75b3a 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -124,7 +124,7 @@ efDeclSourceType = \case
 
 efDeclSourceSpan :: P.ExternsDeclaration -> P.SourceSpan
 efDeclSourceSpan = \case
-  P.EDClass _ _ _ _ _ _ span -> span
+  P.EDClass _ _ _ _ _ _ -> P.nullSourceSpan
   P.EDInstance _ _ _ _ _ _ _ _ _ span -> span
   ed ->
     fromMaybe P.nullSourceSpan $ foldr (\(ss, _) _ -> Just ss) Nothing (efDeclSourceType ed)
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 5228dc86e6..027c93834f 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -2,6 +2,7 @@ module Language.PureScript.Make
   (
   -- * Make API
   rebuildModule
+  , rebuildModuleAndGetArtifacts
   , rebuildModule'
   , make
   , inferForeignModules
@@ -23,6 +24,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..))
 import Control.Monad.Trans.State (runStateT)
 import Control.Monad.Writer.Class (MonadWriter(..), censor)
 import Control.Monad.Writer.Strict (runWriterT)
+import Language.PureScript.CoreFn.Module qualified as CoreFn
 import Data.Function (on)
 import Data.Foldable (fold, for_)
 import Data.List (foldl', sortOn)
@@ -36,6 +38,7 @@ import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..)
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Docs.Convert qualified as Docs
+import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (initEnvironment)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
 import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile)
@@ -53,6 +56,8 @@ import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.CoreFn qualified as CF
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
+import Language.PureScript.CoreFn.Ann (Ann)
+import Control.Lens (Field1(_1), view)
 
 -- | Rebuild a single module.
 --
@@ -68,6 +73,17 @@ rebuildModule actions externs m = do
   env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs
   rebuildModule' actions env externs m
 
+rebuildModuleAndGetArtifacts
+  :: forall m
+   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  => MakeActions m
+  -> [ExternsFile]
+  -> Module
+  -> m (ExternsFile, CoreFn.Module Ann, Docs.Module)
+rebuildModuleAndGetArtifacts actions externs m = do
+  env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs
+  rebuildModuleAndGetArtifacts' actions env externs m
+
 rebuildModule'
   :: forall m
    . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
@@ -76,7 +92,15 @@ rebuildModule'
   -> [ExternsFile]
   -> Module
   -> m ExternsFile
-rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
+rebuildModule' act env ext mdl = view _1 <$> rebuildModuleAndGetArtifacts' act env ext mdl 
+
+rebuildModuleAndGetArtifacts' :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  => MakeActions m
+  -> Env
+  -> [ExternsFile]
+  -> Module
+  -> m (ExternsFile, CoreFn.Module Ann, Docs.Module)
+rebuildModuleAndGetArtifacts' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
 
 rebuildModuleWithIndex
   :: forall m
@@ -86,7 +110,7 @@ rebuildModuleWithIndex
   -> [ExternsFile]
   -> Module
   -> Maybe (Int, Int)
-  -> m ExternsFile
+  -> m (ExternsFile,  CoreFn.Module Ann, Docs.Module)
 rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
@@ -133,7 +157,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
                Right d -> d
 
   evalSupplyT nextVar'' $ codegen renamed docs exts
-  return exts
+  return (exts, optimized, docs)
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
 --
@@ -274,7 +298,7 @@ make ma@MakeActions{..} ms = do
             -- Force the externs and warnings to avoid retaining excess module
             -- data after the module is finished compiling.
             extsAndWarnings <- evaluate . force <=< listen $ do
-              rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
+              view _1 <$>  rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
             liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
             return extsAndWarnings
           return $ BuildJobSucceeded (pwarnings' <> warnings) exts
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index ad38217fef..4f3129baf8 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -68,7 +68,7 @@ desugarTypeClasses externs = flip evalStateT initialState . desugarModule
     :: ModuleName
     -> ExternsDeclaration
     -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
-  fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty _) = Just ((mn, name), typeClass) where
+  fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty) = Just ((mn, name), typeClass) where
     typeClass = makeTypeClassData args members implies deps tcIsEmpty
   fromExternsDecl _ _ = Nothing
 

From 7eff2a9cdbea07ccf2c6b2395d252980b4c3e787 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 30 Sep 2024 15:31:10 +0200
Subject: [PATCH 054/297] adds corefn inserting

---
 app/Command/Compile.hs                   |   8 +-
 purescript.cabal                         |   2 +
 src/Language/PureScript/CoreFn/ToJSON.hs |   2 +
 src/Language/PureScript/DB.hs            |   9 ++
 src/Language/PureScript/Lsp/Prim.hs      | 170 +++++++++++++++++++++++
 src/Language/PureScript/Lsp/Rebuild.hs   |   8 +-
 src/Language/PureScript/Lsp/Types.hs     |  19 +--
 src/Language/PureScript/Make/Index.hs    | 128 +++++++++++++++++
 8 files changed, 335 insertions(+), 11 deletions(-)
 create mode 100644 src/Language/PureScript/DB.hs
 create mode 100644 src/Language/PureScript/Lsp/Prim.hs
 create mode 100644 src/Language/PureScript/Make/Index.hs

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index d81dd75c07..d59c5d7719 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -4,6 +4,7 @@ import Prelude
 
 import Control.Applicative (Alternative(..))
 import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
 import Data.Aeson qualified as A
 import Data.Bool (bool)
 import Data.ByteString.Lazy.UTF8 qualified as LBU8
@@ -24,6 +25,8 @@ import System.Exit (exitSuccess, exitFailure)
 import System.Directory (getCurrentDirectory)
 import System.IO (hPutStr, stderr, stdout)
 import System.IO.UTF8 (readUTF8FilesT)
+import Language.PureScript.Make.Index (addCoreFnIndexing, initDb)
+import Language.PureScript.DB (mkConnection)
 
 data PSCMakeOptions = PSCMakeOptions
   { pscmInput        :: [FilePath]
@@ -72,7 +75,10 @@ compile PSCMakeOptions{..} = do
     ms <- CST.parseModulesFromFiles id moduleFiles
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
     foreigns <- inferForeignModules filePathMap
-    let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
+    conn <- liftIO $ mkConnection pscmOutputDir
+    liftIO $ initDb conn
+    let makeActions 
+          = addCoreFnIndexing conn $ buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
     P.make makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
diff --git a/purescript.cabal b/purescript.cabal
index 506dfa3a3e..d78a75e519 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -281,6 +281,7 @@ library
     Language.PureScript.Comments
     Language.PureScript.Constants.Prim
     Language.PureScript.Crash
+    Language.PureScript.DB
     Language.PureScript.Docs
     Language.PureScript.Docs.AsHtml
     Language.PureScript.Docs.AsMarkdown
@@ -355,6 +356,7 @@ library
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
     Language.PureScript.Make.Cache
+    Language.PureScript.Make.Index
     Language.PureScript.Make.Monad
     Language.PureScript.ModuleDependencies
     Language.PureScript.Names
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
index 1b20ac4e65..9ead630b54 100644
--- a/src/Language/PureScript/CoreFn/ToJSON.hs
+++ b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -5,6 +5,8 @@
 --
 module Language.PureScript.CoreFn.ToJSON
   ( moduleToJSON
+  , bindToJSON
+  , exprToJSON
   ) where
 
 import Prelude
diff --git a/src/Language/PureScript/DB.hs b/src/Language/PureScript/DB.hs
new file mode 100644
index 0000000000..7915e2e903
--- /dev/null
+++ b/src/Language/PureScript/DB.hs
@@ -0,0 +1,9 @@
+module Language.PureScript.DB where 
+
+import Protolude
+import Database.SQLite.Simple (Connection, open)
+import System.FilePath ((</>))
+
+mkConnection :: FilePath -> IO Connection
+mkConnection outputDir =  
+  open (outputDir </> "purescript.sqlite")
diff --git a/src/Language/PureScript/Lsp/Prim.hs b/src/Language/PureScript/Lsp/Prim.hs
new file mode 100644
index 0000000000..85d7e8b770
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Prim.hs
@@ -0,0 +1,170 @@
+module Language.PureScript.Lsp.Prim where
+
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+import Data.Text qualified as T
+import Data.Version (showVersion)
+import Language.PureScript (primEnv)
+import Language.PureScript qualified as P
+import Language.PureScript.AST.SourcePos (nullSourceSpan)
+
+import Protolude
+
+-- primExternsMap :: Map P.ModuleName (P.SourceSpan, P.Imports, P.Exports)
+
+primExterns :: [P.ExternsFile]
+primExterns = Map.toList primEnv <&> toExtern
+  where
+    toExtern ::
+      (P.ModuleName, (P.SourceSpan, P.Imports, P.Exports)) ->
+      P.ExternsFile
+    toExtern (modName, (srcSpan, P.Imports {..}, P.Exports {..})) =
+      P.ExternsFile
+        { efVersion = T.pack $ showVersion P.version,
+          efModuleName = modName,
+          efExports = efExports,
+          efImports = efImports,
+          efFixities = [],
+          efTypeFixities = [],
+          efDeclarations = efDeclarations,
+          efSourceSpan = srcSpan
+        }
+      where
+        efExports =
+          (Map.toList exportedTypes <&> toEfExportType)
+            <> (Map.toList exportedTypeClasses <&> toEfExportTypeClass)
+            <> (Map.toList exportedValues <&> toEfExportValue)
+            <> (Map.toList exportedTypeOps <&> toEfExportTypeOp)
+            <> (Map.toList exportedValueOps <&> toEfExportValueOp)
+
+        toEfExportType ::
+          ( P.ProperName 'P.TypeName,
+            ([P.ProperName 'P.ConstructorName], P.ExportSource)
+          ) ->
+          P.DeclarationRef
+        toEfExportType (name, (ctrs, _src)) = P.TypeRef nullSourceSpan name (Just ctrs)
+
+        toEfExportTypeClass ::
+          (P.ProperName 'P.ClassName, P.ExportSource) ->
+          P.DeclarationRef
+        toEfExportTypeClass (name, _src) = P.TypeClassRef nullSourceSpan name
+
+        toEfExportValue :: (P.Ident, P.ExportSource) -> P.DeclarationRef
+        toEfExportValue (ident, _) = P.ValueRef nullSourceSpan ident
+
+        toEfExportTypeOp :: (P.OpName 'P.TypeOpName, P.ExportSource) -> P.DeclarationRef
+        toEfExportTypeOp (opName, _) = P.TypeOpRef nullSourceSpan opName
+
+        toEfExportValueOp :: (P.OpName 'P.ValueOpName, P.ExportSource) -> P.DeclarationRef
+        toEfExportValueOp (opName, _) = P.ValueOpRef nullSourceSpan opName
+
+        efImports =
+          (Map.toList importedTypes >>= toEfImportType)
+            <> (Map.toList importedTypeClasses >>= toEfImportTypeClass)
+            <> (Map.toList importedValues >>= toEfImportValue)
+            <> (Map.toList importedTypeOps >>= toEfImportTypeOp)
+            <> (Map.toList importedValueOps >>= toEfImportValueOp)
+            <> (Map.toList importedKinds >>= toEfImportKind)
+            <> (Set.toList importedModules <&> toEfImportModule)
+
+        toEfImportType ::
+          (P.Qualified (P.ProperName 'P.TypeName), [P.ImportRecord (P.ProperName 'P.TypeName)]) ->
+          [P.ExternsImport]
+        toEfImportType (P.Qualified (P.ByModuleName mn) name, _ctrs) =
+          [ P.ExternsImport
+              mn
+              (P.Explicit [P.TypeRef nullSourceSpan name Nothing])
+              Nothing
+          ]
+        toEfImportType _ = []
+
+        toEfImportTypeClass :: (P.Qualified (P.ProperName 'P.ClassName), [P.ImportRecord (P.ProperName 'P.ClassName)]) -> [P.ExternsImport]
+        toEfImportTypeClass (P.Qualified (P.ByModuleName mn) name, _ctrs) =
+          [ P.ExternsImport
+              mn
+              (P.Explicit [P.TypeClassRef nullSourceSpan name])
+              Nothing
+          ]
+        toEfImportTypeClass _ = []
+
+        toEfImportValue :: (P.Qualified P.Ident, [P.ImportRecord P.Ident]) -> [P.ExternsImport]
+        toEfImportValue = \case
+          (P.Qualified (P.ByModuleName mn) name, _ctrs) ->
+            [ P.ExternsImport
+                mn
+                (P.Explicit [P.ValueRef nullSourceSpan name])
+                Nothing
+            ]
+          _ -> []
+
+        toEfImportTypeOp :: (P.Qualified (P.OpName 'P.TypeOpName), [P.ImportRecord (P.OpName 'P.TypeOpName)]) -> [P.ExternsImport]
+        toEfImportTypeOp = \case
+          (P.Qualified (P.ByModuleName mn) name, _ctrs) ->
+            [ P.ExternsImport
+                mn
+                (P.Explicit [P.TypeOpRef nullSourceSpan name])
+                Nothing
+            ]
+          _ -> []
+
+        toEfImportValueOp :: (P.Qualified (P.OpName 'P.ValueOpName), [P.ImportRecord (P.OpName 'P.ValueOpName)]) -> [P.ExternsImport]
+        toEfImportValueOp = \case
+          (P.Qualified (P.ByModuleName mn) name, _ctrs) ->
+            [ P.ExternsImport
+                mn
+                (P.Explicit [P.ValueOpRef nullSourceSpan name])
+                Nothing
+            ]
+          _ -> []
+
+        toEfImportKind :: (P.Qualified (P.ProperName 'P.TypeName), [P.ImportRecord (P.ProperName 'P.TypeName)]) -> [P.ExternsImport]
+        toEfImportKind = \case
+          (P.Qualified (P.ByModuleName mn) name, _ctrs) ->
+            [ P.ExternsImport
+                mn
+                (P.Explicit [P.TypeRef nullSourceSpan name Nothing])
+                Nothing
+            ]
+          _ -> []
+
+        toEfImportModule :: P.ModuleName -> P.ExternsImport
+        toEfImportModule mn = P.ExternsImport mn P.Implicit Nothing
+
+        efDeclarations :: [P.ExternsDeclaration]
+        efDeclarations = efExports >>= \case 
+          P.TypeClassRef _ss name -> pure $ P.EDClass  name [] [] [] [] False
+          P.TypeOpRef _ss name -> pure $ P.EDValue (P.Ident $ P.runOpName name) P.srcREmpty
+          P.TypeRef _ss name _ctrs -> pure $ P.EDType name P.srcREmpty (P.DataType P.Data [] [])
+          P.ValueRef _ss name -> pure $ P.EDValue name P.srcREmpty
+          P.ValueOpRef _ss name -> pure $ P.EDValue (P.Ident $ P.runOpName name) P.srcREmpty
+          -- P.TypeInstanceRef _ss name source -> pure $ P.EDInstance (_ modName name) _ _ _ _ _ _ _ _ _
+          _ -> []
+          
+         
+            --  TypeClassRef SourceSpan (ProperName 'ClassName)
+            -- -- |
+            -- -- A type operator
+            -- --
+
+-- | The data which will be serialized to an externs file
+-- data ExternsFile = ExternsFile
+--   -- NOTE: Make sure to keep `efVersion` as the first field in this
+--   -- record, so the derived Serialise instance produces CBOR that can
+--   -- be checked for its version independent of the remaining format
+--   { efVersion :: Text
+--   -- ^ The externs version
+--   , efModuleName :: ModuleName
+--   -- ^ Module name
+--   , efExports :: [DeclarationRef]
+--   -- ^ List of module exports
+--   , efImports :: [ExternsImport]
+--   -- ^ List of module imports
+--   , efFixities :: [ExternsFixity]
+--   -- ^ List of operators and their fixities
+--   , efTypeFixities :: [ExternsTypeFixity]
+--   -- ^ List of type operators and their fixities
+--   , efDeclarations :: [ExternsDeclaration]
+--   -- ^ List of type and value declaration
+--   , efSourceSpan :: SourceSpan
+--   -- ^ Source span for error reporting
+--   } deriving (Show, Generic, NFData)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 5e79eefd06..dac3b8d311 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -21,7 +21,7 @@ import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
 import Language.PureScript.Lsp.Cache
 import Language.PureScript.Lsp.State (cacheRebuild)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
 import Language.PureScript.ModuleDependencies qualified as P
@@ -29,6 +29,7 @@ import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
+import Language.PureScript.Make.Index (addCoreFnIndexing)
 
 rebuildFileAndDeps ::
   ( MonadIO m,
@@ -85,12 +86,15 @@ rebuildFile' rebuildDeps srcPath = do
   let pureRebuild = fp == ""
   let modulePath = if pureRebuild then fp else srcPath
   foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
+  conn <- asks lspDbConnection
   let makeEnv =
         P.buildMakeActions outputDirectory filePathMap foreigns False
           & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
           & shushProgress
+          & addCoreFnIndexing conn
   (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
     (newExterns, coreFn, docs) <- P.rebuildModuleAndGetArtifacts makeEnv externs m
+    putErrLn $ "Rebuilt module: " <> T.pack (show coreFn)
     unless pureRebuild $
       updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
     pure newExterns
@@ -139,6 +143,8 @@ shushCodegen ma =
       P.ffiCodegen = \_ -> pure ()
     }
 
+-- add
+
 enableForeignCheck ::
   M.Map P.ModuleName FilePath ->
   S.Set P.CodegenTarget ->
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index d016b8fe3d..e8f6561a44 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -3,11 +3,13 @@
 module Language.PureScript.Lsp.Types where
 
 import Control.Concurrent.STM (TVar, newTVarIO)
-import Database.SQLite.Simple (Connection, open)
+import Database.SQLite.Simple (Connection)
 import Language.PureScript.AST.Declarations qualified as P
+-- import Language.PureScript.Ide.Types (IdeLogLevel)
+
+import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
--- import Language.PureScript.Ide.Types (IdeLogLevel)
 import Protolude
 
 data LspEnvironment = LspEnvironment
@@ -17,10 +19,10 @@ data LspEnvironment = LspEnvironment
   }
 
 mkEnv :: LspConfig -> IO LspEnvironment
-mkEnv conf = do 
-   connection <- open (confOutputPath conf <> "lsp.sqlite") 
-   st <- newTVarIO (LspState Nothing False)
-   pure $ LspEnvironment conf connection st
+mkEnv conf = do
+  connection <- mkConnection $ confOutputPath conf
+  st <- newTVarIO (LspState Nothing False)
+  pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
@@ -29,8 +31,8 @@ data LspConfig = LspConfig
   deriving (Show)
 
 data LspState = LspState
-  { currentFile :: Maybe CurrentFile
-  , lspInitalized :: Bool
+  { currentFile :: Maybe CurrentFile,
+    lspInitalized :: Bool
   }
   deriving (Show)
 
@@ -38,6 +40,5 @@ data CurrentFile = CurrentFile
   { currentModuleName :: P.ModuleName,
     currentModule :: P.Module,
     currentExternsFile :: P.ExternsFile
-    
   }
   deriving (Show)
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
new file mode 100644
index 0000000000..fde632cc31
--- /dev/null
+++ b/src/Language/PureScript/Make/Index.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+
+module Language.PureScript.Make.Index where
+
+import Control.Monad.Cont (MonadIO)
+import Control.Monad.Supply (SupplyT (SupplyT))
+import Data.Aeson qualified as A
+import Data.List qualified as List
+import Data.Map.Lazy qualified as M
+import Data.Maybe (fromJust)
+import Data.Set qualified as S
+import Data.Set qualified as Set
+import Data.Text qualified as T
+import Database.SQLite.Simple (Connection)
+import Database.SQLite.Simple qualified as SQL
+import Language.PureScript.AST qualified as P
+import Language.PureScript.CST qualified as CST
+import Language.PureScript.CoreFn qualified as CF
+import Language.PureScript.CoreFn.FromJSON qualified as CFJ
+import Language.PureScript.CoreFn.ToJSON qualified as CFJ
+import Language.PureScript.CoreFn.Traversals (traverseCoreFn)
+import Language.PureScript.Errors qualified as P
+import Language.PureScript.Externs (ExternsFile (efModuleName))
+import Language.PureScript.Externs qualified as P
+import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
+import Language.PureScript.Ide.Rebuild (updateCacheDb)
+import Language.PureScript.Ide.Types (ModuleMap)
+import Language.PureScript.Ide.Util (ideReadFile)
+import Language.PureScript.Lsp.Cache
+import Language.PureScript.Lsp.State (cacheRebuild)
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Make (ffiCodegen')
+import Language.PureScript.Make qualified as P
+import Language.PureScript.ModuleDependencies qualified as P
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Options qualified as P
+import Paths_purescript qualified as Paths
+import Protolude hiding (moduleName)
+import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
+
+initDb :: Connection -> IO ()
+initDb conn = do
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module TEXT, imported_module TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT, ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
+
+addCoreFnIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+addCoreFnIndexing getConn ma =
+  ma
+    { P.codegen = \m docs ext -> lift (indexCoreFn getConn m) <* P.codegen ma m docs ext
+    }
+
+indexCoreFn :: forall m. (MonadIO m) => Connection -> CF.Module CF.Ann -> m ()
+indexCoreFn conn m = do
+  liftIO do
+    let mName = P.runModuleName $ CF.moduleName m
+    SQL.execute
+      conn
+      (SQL.Query "INSERT INTO corefn_modules (name, path) VALUES (?, ?)")
+      ( mName,
+        T.pack $ CF.modulePath m
+      )
+
+    forM_ (CF.moduleImports m) \((span, _, _), importedModule) -> do
+      SQL.execute
+        conn
+        (SQL.Query "INSERT INTO corefn_imports (module, imported_module) VALUES (?, ?)")
+        ( mName,
+          P.runModuleName importedModule
+        )
+
+    forM_ (CF.moduleDecls m) \bind -> do
+      void $ insertBind mName True bind
+      let (insertBind', _, _, _) = traverseCoreFn (insertBind mName False) (insertExpr mName) pure pure
+      void $ insertBind' bind
+  where
+    insertBind :: Text -> Bool -> CF.Bind CF.Ann -> IO (CF.Bind CF.Ann)
+    insertBind mName topLevel bind = do
+      case bind of
+        CF.NonRec (ss, _comments, _meta) ident expr -> do
+          let
+          SQL.execute
+            conn
+            ( SQL.Query
+                "INSERT INTO corefn_declarations (module_name, ident, top_level, value, start_line, end_line, start_col, end_col) \
+                \VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
+            )
+            ( mName,
+              P.runIdent ident,
+              topLevel,
+              A.encode $ CFJ.bindToJSON bind,
+              P.sourcePosLine $ P.spanStart ss,
+              P.sourcePosLine $ P.spanEnd ss,
+              P.sourcePosColumn $ P.spanStart ss,
+              P.sourcePosColumn $ P.spanEnd ss
+            )
+        CF.Rec binds -> forM_ binds $ \((ann, ident), expr) ->
+          void $ insertBind mName topLevel (CF.NonRec ann ident expr)
+      pure bind
+
+    insertExpr :: Text -> CF.Expr CF.Ann -> IO (CF.Expr CF.Ann)
+    insertExpr mName expr = do
+      SQL.execute
+        conn
+        ( SQL.Query
+            "INSERT INTO corefn_expressions (module_name, value, start_line, end_line, start_col, end_col, lines, cols)\
+            \ VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
+        )
+        ( mName,
+          A.encode $ CFJ.exprToJSON expr,
+          P.sourcePosLine start,
+          P.sourcePosLine end,
+          P.sourcePosColumn start,
+          P.sourcePosColumn end,
+          lines',
+          cols
+        )
+      pure expr
+      where
+        (ss, _comments, _meta) = CF.extractAnn expr
+        start = P.spanStart ss
+        end = P.spanEnd ss
+        lines' = P.sourcePosLine end - P.sourcePosLine start
+        cols = P.sourcePosColumn end - P.sourcePosColumn start

From ce27550e69fddb8484b654c656a099dde7c28aa9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 05:34:39 +0200
Subject: [PATCH 055/297] clean up

---
 app/Command/Compile.hs                     | 161 +++++++------
 src/Language/PureScript/CoreFn/FromJSON.hs |   2 +
 src/Language/PureScript/Lsp/Cache.hs       | 160 +-----------
 src/Language/PureScript/Lsp/Cache/Query.hs |  67 +++++-
 src/Language/PureScript/Lsp/Rebuild.hs     |  12 +-
 src/Language/PureScript/LspSimple.hs       |   9 +-
 src/Language/PureScript/Make/Actions.hs    |   2 -
 src/Language/PureScript/Make/Index.hs      | 267 +++++++++++++++------
 8 files changed, 366 insertions(+), 314 deletions(-)

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index d59c5d7719..dc78776c58 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -1,8 +1,6 @@
 module Command.Compile (command) where
 
-import Prelude
-
-import Control.Applicative (Alternative(..))
+import Control.Applicative (Alternative (..))
 import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson qualified as A
@@ -15,27 +13,28 @@ import Data.Text qualified as T
 import Data.Traversable (for)
 import Language.PureScript qualified as P
 import Language.PureScript.CST qualified as CST
-import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors)
-import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..), warnFileTypeNotFound)
+import Language.PureScript.DB (mkConnection)
+import Language.PureScript.Errors.JSON (JSONResult (..), toJSONErrors)
+import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
+import Language.PureScript.Make.Index (addCoreFnIndexing, addExternIndexing, initDb)
 import Options.Applicative qualified as Opts
 import SharedCLI qualified
 import System.Console.ANSI qualified as ANSI
-import System.Exit (exitSuccess, exitFailure)
-import System.Directory (getCurrentDirectory)
+import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
+import System.Exit (exitFailure, exitSuccess)
 import System.IO (hPutStr, stderr, stdout)
 import System.IO.UTF8 (readUTF8FilesT)
-import Language.PureScript.Make.Index (addCoreFnIndexing, initDb)
-import Language.PureScript.DB (mkConnection)
+import Prelude
 
 data PSCMakeOptions = PSCMakeOptions
-  { pscmInput        :: [FilePath]
-  , pscmInputFromFile :: Maybe FilePath
-  , pscmExclude      :: [FilePath]
-  , pscmOutputDir    :: FilePath
-  , pscmOpts         :: P.Options
-  , pscmUsePrefix    :: Bool
-  , pscmJSONErrors   :: Bool
+  { pscmInput :: [FilePath],
+    pscmInputFromFile :: Maybe FilePath,
+    pscmExclude :: [FilePath],
+    pscmOutputDir :: FilePath,
+    pscmOpts :: P.Options,
+    pscmUsePrefix :: Bool,
+    pscmJSONErrors :: Bool
   }
 
 -- | Arguments: verbose, use JSON, warnings, errors
@@ -43,7 +42,7 @@ printWarningsAndErrors :: Bool -> Bool -> [(FilePath, T.Text)] -> P.MultipleErro
 printWarningsAndErrors verbose False files warnings errors = do
   pwd <- getCurrentDirectory
   cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stdout
-  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd, P.ppeFileContents = files }
+  let ppeOpts = P.defaultPPEOptions {P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd, P.ppeFileContents = files}
   when (P.nonEmpty warnings) $
     putStrLn (P.prettyPrintMultipleWarnings ppeOpts warnings)
   case errors of
@@ -53,77 +52,91 @@ printWarningsAndErrors verbose False files warnings errors = do
     Right _ -> return ()
 printWarningsAndErrors verbose True files warnings errors = do
   putStrLn . LBU8.toString . A.encode $
-    JSONResult (toJSONErrors verbose P.Warning files warnings)
-               (either (toJSONErrors verbose P.Error files) (const []) errors)
+    JSONResult
+      (toJSONErrors verbose P.Warning files warnings)
+      (either (toJSONErrors verbose P.Error files) (const []) errors)
   either (const exitFailure) (const (return ())) errors
 
 compile :: PSCMakeOptions -> IO ()
-compile PSCMakeOptions{..} = do
-  input <- toInputGlobs $ PSCGlobs
-    { pscInputGlobs = pscmInput
-    , pscInputGlobsFromFile = pscmInputFromFile
-    , pscExcludeGlobs = pscmExclude
-    , pscWarnFileTypeNotFound = warnFileTypeNotFound "compile"
-    }
+compile PSCMakeOptions {..} = do
+  input <-
+    toInputGlobs $
+      PSCGlobs
+        { pscInputGlobs = pscmInput,
+          pscInputGlobsFromFile = pscmInputFromFile,
+          pscExcludeGlobs = pscmExclude,
+          pscWarnFileTypeNotFound = warnFileTypeNotFound "compile"
+        }
   when (null input) $ do
-    hPutStr stderr $ unlines [ "purs compile: No input files."
-                             , "Usage: For basic information, try the `--help' option."
-                             ]
+    hPutStr stderr $
+      unlines
+        [ "purs compile: No input files.",
+          "Usage: For basic information, try the `--help' option."
+        ]
     exitFailure
   moduleFiles <- readUTF8FilesT input
   (makeErrors, makeWarnings) <- runMake pscmOpts $ do
     ms <- CST.parseModulesFromFiles id moduleFiles
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
     foreigns <- inferForeignModules filePathMap
+    liftIO $ createDirectoryIfMissing True pscmOutputDir
     conn <- liftIO $ mkConnection pscmOutputDir
     liftIO $ initDb conn
-    let makeActions 
-          = addCoreFnIndexing conn $ buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
+    let makeActions =
+          addCoreFnIndexing conn $
+            addExternIndexing conn $
+              buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
     P.make makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 
 outputDirectory :: Opts.Parser FilePath
-outputDirectory = Opts.strOption $
-     Opts.short 'o'
-  <> Opts.long "output"
-  <> Opts.value "output"
-  <> Opts.showDefault
-  <> Opts.help "The output directory"
+outputDirectory =
+  Opts.strOption $
+    Opts.short 'o'
+      <> Opts.long "output"
+      <> Opts.value "output"
+      <> Opts.showDefault
+      <> Opts.help "The output directory"
 
 comments :: Opts.Parser Bool
-comments = Opts.switch $
-     Opts.short 'c'
-  <> Opts.long "comments"
-  <> Opts.help "Include comments in the generated code"
+comments =
+  Opts.switch $
+    Opts.short 'c'
+      <> Opts.long "comments"
+      <> Opts.help "Include comments in the generated code"
 
 verboseErrors :: Opts.Parser Bool
-verboseErrors = Opts.switch $
-     Opts.short 'v'
-  <> Opts.long "verbose-errors"
-  <> Opts.help "Display verbose error messages"
+verboseErrors =
+  Opts.switch $
+    Opts.short 'v'
+      <> Opts.long "verbose-errors"
+      <> Opts.help "Display verbose error messages"
 
 noPrefix :: Opts.Parser Bool
-noPrefix = Opts.switch $
-     Opts.short 'p'
-  <> Opts.long "no-prefix"
-  <> Opts.help "Do not include comment header"
+noPrefix =
+  Opts.switch $
+    Opts.short 'p'
+      <> Opts.long "no-prefix"
+      <> Opts.help "Do not include comment header"
 
 jsonErrors :: Opts.Parser Bool
-jsonErrors = Opts.switch $
-     Opts.long "json-errors"
-  <> Opts.help "Print errors to stderr as JSON"
+jsonErrors =
+  Opts.switch $
+    Opts.long "json-errors"
+      <> Opts.help "Print errors to stderr as JSON"
 
 codegenTargets :: Opts.Parser [P.CodegenTarget]
-codegenTargets = Opts.option targetParser $
-     Opts.short 'g'
-  <> Opts.long "codegen"
-  <> Opts.value [P.JS]
-  <> Opts.help
-      ( "Specifies comma-separated codegen targets to include. "
-      <> targetsMessage
-      <> " The default target is 'js', but if this option is used only the targets specified will be used."
-      )
+codegenTargets =
+  Opts.option targetParser $
+    Opts.short 'g'
+      <> Opts.long "codegen"
+      <> Opts.value [P.JS]
+      <> Opts.help
+        ( "Specifies comma-separated codegen targets to include. "
+            <> targetsMessage
+            <> " The default target is 'js', but if this option is used only the targets specified will be used."
+        )
 
 targetsMessage :: String
 targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'."
@@ -131,11 +144,11 @@ targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys
 targetParser :: Opts.ReadM [P.CodegenTarget]
 targetParser =
   Opts.str >>= \s ->
-    for (T.split (== ',') s)
-      $ maybe (Opts.readerError targetsMessage) pure
-      . flip M.lookup P.codegenTargets
-      . T.unpack
-      . T.strip
+    for (T.split (== ',') s) $
+      maybe (Opts.readerError targetsMessage) pure
+        . flip M.lookup P.codegenTargets
+        . T.unpack
+        . T.strip
 
 options :: Opts.Parser P.Options
 options =
@@ -149,13 +162,15 @@ options =
     handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts)
 
 pscMakeOptions :: Opts.Parser PSCMakeOptions
-pscMakeOptions = PSCMakeOptions <$> many SharedCLI.inputFile
-                                <*> SharedCLI.globInputFile
-                                <*> many SharedCLI.excludeFiles
-                                <*> outputDirectory
-                                <*> options
-                                <*> (not <$> noPrefix)
-                                <*> jsonErrors
+pscMakeOptions =
+  PSCMakeOptions
+    <$> many SharedCLI.inputFile
+    <*> SharedCLI.globInputFile
+    <*> many SharedCLI.excludeFiles
+    <*> outputDirectory
+    <*> options
+    <*> (not <$> noPrefix)
+    <*> jsonErrors
 
 command :: Opts.Parser (IO ())
 command = compile <$> (Opts.helper <*> pscMakeOptions)
diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs
index d0426b6f8d..2bffe4c1e7 100644
--- a/src/Language/PureScript/CoreFn/FromJSON.hs
+++ b/src/Language/PureScript/CoreFn/FromJSON.hs
@@ -5,6 +5,8 @@
 module Language.PureScript.CoreFn.FromJSON
   ( moduleFromJSON
   , parseVersion'
+  , bindFromJSON
+  , exprFromJSON
   ) where
 
 import Prelude
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index bf99ab00ac..6a1ccc34ec 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -2,49 +2,21 @@
 
 module Language.PureScript.Lsp.Cache where
 
-import Codec.Serialise (deserialise, serialise)
-import Data.Aeson (encode)
+import Codec.Serialise (deserialise)
 import Data.Map qualified as Map
-import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple
-import Language.PureScript.AST qualified as P
-import Language.PureScript.AST.Declarations (declName, declRefName, declSourceAnn)
-import Language.PureScript.AST.SourcePos (SourceSpan (spanName))
-import Language.PureScript.Externs (ExternsFile (efModuleName, efSourceSpan))
+import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
-import Language.PureScript.Ide.Externs (readExternFile)
 import Language.PureScript.Lsp.DB qualified as DB
-import Language.PureScript.Lsp.Print (printEfDeclName, printName)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
-import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
 import Language.PureScript.Names qualified as P
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute)
 import System.FilePath (normalise, (</>))
-import "monad-logger" Control.Monad.Logger (MonadLogger)
 -- import Language.PureScript.Lsp.Prim (primExterns)
 
-dropTables :: (MonadIO m, MonadReader LspEnvironment m) => m ()
-dropTables = do
-  DB.execute_ "DROP TABLE IF EXISTS modules"
-  DB.execute_ "DROP TABLE IF EXISTS declarations"
-  DB.execute_ "DROP TABLE IF EXISTS externs"
-  DB.execute_ "DROP TABLE IF EXISTS ef_imports"
-  DB.execute_ "DROP TABLE IF EXISTS ef_exports"
-  DB.execute_ "DROP TABLE IF EXISTS ef_declarations"
-
-initDb :: (MonadReader LspEnvironment m, MonadIO m) => m ()
-initDb = do
-  DB.execute_ "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT, UNIQUE(module_name), UNIQUE(path))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name BLOB, printed_name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, shown TEXT, PRIMARY KEY (module_name, name))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path), UNIQUE(module_name))"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
-  DB.execute_ "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
-  -- traverse_ insertExtern primExterns
-
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName ExternsFile)
 selectAllExternsMap = do
   Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectAllExterns
@@ -65,20 +37,6 @@ selectExternModuleNameFromFilePath path = do
   res <- DB.queryNamed (Query "SELECT module_name FROM externs WHERE path = :path") [":path" := absPath]
   pure $ P.ModuleName . fromOnly <$> listToMaybe res
 
-insertAllExterns ::
-  ( MonadIO m,
-    MonadReader LspEnvironment m,
-    MonadError IdeError m,
-    MonadLogger m
-  ) =>
-  m ()
-insertAllExterns = do
-  oDir <- asks (confOutputPath . lspConfig)
-  externPaths <- findAvailableExterns
-  forM_ externPaths $ \name -> do
-    let externPath = oDir </> toS (P.runModuleName name) </> P.externsFileName
-    extern <- readExternFile externPath
-    insertExtern extern
 
 -- | Finds all the externs inside the output folder and returns the
 -- corresponding module names
@@ -101,117 +59,3 @@ findAvailableExterns = do
       | otherwise = do
           let file = oDir </> d </> P.externsFileName
           doesFileExist file
-
-insertExtern ::
-  (MonadIO m, MonadReader LspEnvironment m) =>
-  ExternsFile ->
-  m ()
-insertExtern extern = do
-  path <- liftIO $ makeAbsolute externPath
-  DB.executeNamed
-    (Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name, shown) VALUES (:path, :ef_version, :value, :module_name, :shown)")
-    [ ":path" := path,
-      ":ef_version" := P.efVersion extern,
-      ":value" := serialise extern,
-      ":module_name" := P.runModuleName name,
-      ":shown" := (show extern :: Text)
-    ]
-
-  DB.executeNamed
-    (Query "DELETE FROM ef_imports WHERE module_name = :module_name")
-    [":module_name" := P.runModuleName name]
-  forM_ (P.efImports extern) $ insertEfImport name
-  DB.executeNamed
-    (Query "DELETE FROM ef_exports WHERE module_name = :module_name")
-    [":module_name" := P.runModuleName name]
-  forM_ (P.efExports extern) $ insertEfExport name
-  DB.executeNamed
-    (Query "DELETE FROM ef_declarations WHERE module_name = :module_name")
-    [":module_name" := P.runModuleName name]
-  forM_ (P.efDeclarations extern) $ insertEfDeclaration name
-  where
-    name = efModuleName extern
-    externPath = spanName (efSourceSpan extern)
-
-insertEfImport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsImport -> m ()
-insertEfImport moduleName' ei = do
-  DB.executeNamed
-    (Query "INSERT OR REPLACE INTO ef_imports (module_name, imported_module, import_type, imported_as, value) VALUES (:module_name, :imported_module, :import_type, :imported_as, :value)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":imported_module" := P.runModuleName (P.eiModule ei),
-      ":import_type" := serialise (P.eiImportType ei),
-      ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei),
-      ":value" := serialise ei
-    ]
-
-insertEfDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.ExternsDeclaration -> m ()
-insertEfDeclaration moduleName' decl = do
-  DB.executeNamed
-    (Query "INSERT OR REPLACE INTO ef_declarations (module_name, value, shown, name, start_col, start_line, end_col, end_line, category) VALUES (:module_name, :value, :shown, :name, :start_col, :start_line, :end_col, :end_line, :category)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":name" := printEfDeclName decl,
-      ":value" := serialise decl,
-      ":shown" := (show decl :: Text),
-      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
-      ":start_line" := (P.sourcePosLine . P.spanStart) span,
-      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
-      ":end_line" := (P.sourcePosLine . P.spanEnd) span,
-      ":category" := efDeclCategory decl
-    ]
-  where
-    span = efDeclSourceSpan decl
-
-insertEfExport :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> P.DeclarationRef -> m ()
-insertEfExport moduleName' dr = do
-  DB.executeNamed
-    (Query "INSERT OR REPLACE INTO ef_exports (module_name, value, name, printed_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :name, :printed_name, :start_col, :start_line, :end_col, :end_line)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":value" := serialise dr,
-      ":name" := serialise (declRefName dr),
-      ":printed_name" := printName (declRefName dr),
-      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
-      ":start_line" := (P.sourcePosLine . P.spanStart) span,
-      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
-      ":end_line" := (P.sourcePosLine . P.spanEnd) span
-    ]
-  where
-    span = P.declRefSourceSpan dr
-
-insertModule :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> P.Module -> m ()
-insertModule srcPath m = do
-  let moduleName' = P.getModuleName m
-  DB.executeNamed
-    (Query "INSERT OR REPLACE INTO modules (module_name, path) VALUES (:module_name, :path)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":path" := srcPath
-    ]
-
-  let exported = Set.fromList $ P.exportedDeclarations m
-  DB.executeNamed "DELETE FROM declarations WHERE module_name = :module_name" [":module_name" := P.runModuleName moduleName']
-  traverse_ (insertDeclaration moduleName' exported) (P.getModuleDeclarations m)
-
-insertDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Set P.Declaration -> P.Declaration -> m ()
-insertDeclaration moduleName' exportedDecls decl = do
-  for_ (declName decl) $ \name -> do
-    DB.executeNamed
-      ( Query
-          "INSERT OR REPLACE INTO declarations \
-          \(module_name, name, printed_name, start_col, start_line, end_col, end_line, comments, exported, value, shown) \
-          \VALUES \
-          \(:module_name, :name, :printed_name, :start_col, :start_line, :end_col, :end_line, :comments, :exported, :value, :shown)"
-      )
-      [ ":module_name" := P.runModuleName moduleName',
-        ":name" := serialise name,
-        ":printed_name" := printName name,
-        ":start_col" := (P.sourcePosColumn . P.spanStart) declLocation,
-        ":start_line" := (P.sourcePosLine . P.spanStart) declLocation,
-        ":end_col" := (P.sourcePosColumn . P.spanEnd) declLocation,
-        ":end_line" := (P.sourcePosLine . P.spanEnd) declLocation,
-        ":comments" := encode comments,
-        ":exported" := exported,
-        ":value" := serialise decl,
-        ":shown" := (show decl :: Text)
-      ]
-  where
-    exported = Set.member decl exportedDecls
-    (declLocation, comments) = declSourceAnn decl
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 0d309c0631..a4453c2a88 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -10,17 +10,26 @@ import Codec.Serialise (deserialise, serialise)
 import Control.Lens (Field1 (_1), (^.), _1)
 import Control.Monad.Trans.Writer (execWriterT)
 import Data.Aeson (encode)
+import Data.Aeson.Types qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Set qualified as Set
+import Data.String (fromString)
 import Data.Text qualified as T
 import Database.SQLite.Simple (NamedParam ((:=)), fromOnly)
+import Database.SQLite.Simple qualified as SQL
+import GHC.Base (String)
+import GHC.Real (Integral (toInteger))
 import Language.LSP.Protocol.Types (Position)
+import Language.LSP.Protocol.Types qualified as LSP
 import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.Declarations (declRefName, declSourceAnn)
 import Language.PureScript.AST.Traversals (accumTypes)
 import Language.PureScript.Comments qualified as P
+import Language.PureScript.CoreFn qualified as CF
+import Language.PureScript.CoreFn.Expr as CF
+import Language.PureScript.CoreFn.FromJSON qualified as CF
 import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
@@ -32,9 +41,11 @@ import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Protolude
+import Protolude qualified as Either
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
 import System.FilePath (normalise, (</>))
 import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebugN, logErrorN, logWarnN, mapLoggingT)
+import Language.PureScript (Ident)
 
 -- import Control.Monad.Logger (logDebugN)
 
@@ -49,6 +60,61 @@ import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebugN, lo
 --   pure $ listToMaybe decls
 -- getImportedModules
 
+getCoreFnExprAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Expr CF.Ann))
+getCoreFnExprAt path (LSP.Position line col) = do
+  decls :: [SQL.Only String] <-
+    DB.queryNamed
+      "SELECT corefn_expressions.value FROM corefn_expressions \
+      \INNER JOIN corefn_modules on corefn_expressions.module_name = corefn_modules.name \
+      \WHERE startLine <= :line AND endLine >= :line \
+      \AND startColumn <= :column AND endColumn >= :column\
+      \AND path = :path\
+      \AND lines = 0\
+      \ORDER BY cols ASC\
+      \LIMIT 1"
+      [ ":line" := toInteger line,
+        ":column" := toInteger col,
+        ":path" := path
+      ]
+  pure $
+    A.parseMaybe (CF.exprFromJSON path)
+      =<< fromString
+      . fromOnly
+      <$> listToMaybe decls
+
+getCodeFnBindAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Bind CF.Ann))
+getCodeFnBindAt path (LSP.Position line col) = do
+  decls :: [SQL.Only String] <-
+    DB.queryNamed
+      "SELECT corefn_declarations.value FROM corefn_declarations \
+      \INNER JOIN corefn_modules on corefn_declarations.module_name = corefn_modules.name \
+      \WHERE startLine <= :line AND endLine >= :line \
+      \AND startColumn <= :column AND endColumn >= :column\
+      \AND path = :path\
+      \AND lines = 0\
+      \ORDER BY cols ASC\
+      \LIMIT 1"
+      [ ":line" := toInteger (line + 1),
+        ":column" := toInteger (col + 1),
+        ":path" := path
+      ]
+  pure $
+    A.parseMaybe (CF.bindFromJSON path)
+      =<< fromString
+      . fromOnly
+      <$> listToMaybe decls
+
+-- findLocalBinding :: (P.Ident -> Bool) -> Expr a -> Maybe (CF.Binder a)
+-- findLocalBinding f = go
+--   where
+--     go (Abs _ ident _) | f ident = Just (VarBinder nullSourceAnn ident)
+--     go (Let _ binds _) = asum (fmap (go . binder) binds)
+--     go _ = Nothing
+
+------------------------------------------------------------------------------------------------------------------------
+------------ Externs ---------------------------------------------------------------------------------------------------
+------------------------------------------------------------------------------------------------------------------------
+
 getEfImportsMap :: (MonadIO f, MonadReader LspEnvironment f) => [P.ModuleName] -> f (Map P.ModuleName [P.DeclarationRef])
 getEfImportsMap mNames = Map.fromListWith (++) . fmap (fmap List.singleton) <$> getEfExports mNames
 
@@ -123,7 +189,6 @@ getEFImportedDeclaration moduleName' name = do
                       fmap (definedIn,) <$> getEfDeclarationOnlyInModule definedIn name
                 _ -> pure acc'
 
-
 getEfDeclarationOnlyInModule :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
 getEfDeclarationOnlyInModule moduleName' name = do
   decls <-
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index dac3b8d311..5c0dc0048a 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -19,7 +19,6 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
-import Language.PureScript.Lsp.Cache
 import Language.PureScript.Lsp.State (cacheRebuild)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make (ffiCodegen')
@@ -29,7 +28,8 @@ import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
-import Language.PureScript.Make.Index (addCoreFnIndexing)
+import Language.PureScript.Make.Index (addCoreFnIndexing, addExternIndexing)
+import Language.PureScript.Lsp.Cache (selectAllExternsMap)
 
 rebuildFileAndDeps ::
   ( MonadIO m,
@@ -92,9 +92,9 @@ rebuildFile' rebuildDeps srcPath = do
           & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
           & shushProgress
           & addCoreFnIndexing conn
+          & addExternIndexing conn
   (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-    (newExterns, coreFn, docs) <- P.rebuildModuleAndGetArtifacts makeEnv externs m
-    putErrLn $ "Rebuilt module: " <> T.pack (show coreFn)
+    newExterns <- P.rebuildModule makeEnv externs m
     unless pureRebuild $
       updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
     pure newExterns
@@ -102,8 +102,6 @@ rebuildFile' rebuildDeps srcPath = do
     Left errors ->
       throwError (RebuildError [(fp, input)] errors)
     Right newExterns -> do
-      insertModule fp m
-      insertExtern newExterns
       rebuildModuleOpen makeEnv externs m
       logDebugN $ "Rebuilt file: " <> T.pack srcPath
       pure (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
@@ -124,7 +122,7 @@ rebuildModuleOpen makeEnv externs m = void $ runExceptT do
   (openResult, _) <-
     liftIO $
       P.runMake P.defaultOptions $
-        P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
+        P.rebuildModule ( shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
   case openResult of
     Left _ ->
       throwError (GeneralError "Failed when rebuilding with open exports")
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 0ec3e2a436..c43db4d052 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -39,10 +39,10 @@ import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), prettyPrintTypeSingleLine, textError)
 import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
-import Language.PureScript.Lsp.Cache (dropTables, initDb, insertAllExterns, selectExternModuleNameFromFilePath)
+import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
 import Language.PureScript.Lsp.Cache.Query (getDeclaration, getEfDeclaration)
 import Language.PureScript.Lsp.Print (printDeclarationType)
-import Language.PureScript.Lsp.Rebuild (rebuildFile, rebuildFileAndDeps)
+import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Lsp.Util (efDeclComments, efDeclSourceSpan, efDeclSourceType, getWordAt)
@@ -91,13 +91,10 @@ handlers diagErrs =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
         res <- liftLspWithErr do
-          dropTables
-          initDb
-          insertAllExterns
           logDebugN "Externs inserted"
           initFinished
           logDebugN "Init finished"
-          void $ rebuildFileAndDeps "src/Main.purs"
+          -- void $ rebuildFileAndDeps "src/Main.purs"
           logDebugN "Rebuilt Main.purs"
 
         case res of
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 25c51d312f..f138327c8d 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -249,8 +249,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   codegen m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
-    -- lift initDb
-
     codegenTargets <- lift $ asks optionsCodegenTargets
     when (S.member CoreFn codegenTargets) $ do
       let coreFnFile = targetFilename mn CoreFn
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index fde632cc31..0e770a3073 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -5,6 +5,7 @@
 
 module Language.PureScript.Make.Index where
 
+import Codec.Serialise (serialise)
 import Control.Monad.Cont (MonadIO)
 import Control.Monad.Supply (SupplyT (SupplyT))
 import Data.Aeson qualified as A
@@ -14,14 +15,16 @@ import Data.Maybe (fromJust)
 import Data.Set qualified as S
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Database.SQLite.Simple (Connection)
+import Database.SQLite.Simple (Connection, NamedParam ((:=)))
 import Database.SQLite.Simple qualified as SQL
+import Language.PureScript (declRefName)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.CoreFn.FromJSON qualified as CFJ
 import Language.PureScript.CoreFn.ToJSON qualified as CFJ
 import Language.PureScript.CoreFn.Traversals (traverseCoreFn)
+import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
@@ -29,9 +32,9 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
-import Language.PureScript.Lsp.Cache
-import Language.PureScript.Lsp.State (cacheRebuild)
+import Language.PureScript.Lsp.Print (printEfDeclName, printName)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
 import Language.PureScript.ModuleDependencies qualified as P
@@ -40,89 +43,219 @@ import Language.PureScript.Options qualified as P
 import Paths_purescript qualified as Paths
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
-
-initDb :: Connection -> IO ()
-initDb conn = do
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module TEXT, imported_module TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT, ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
+import Distribution.Compat.Directory (makeAbsolute)
+import Database.SQLite.Simple qualified as SQL
 
 addCoreFnIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
-addCoreFnIndexing getConn ma =
+addCoreFnIndexing conn ma =
   ma
-    { P.codegen = \m docs ext -> lift (indexCoreFn getConn m) <* P.codegen ma m docs ext
+    { P.codegen = \m docs ext -> lift (indexCoreFn conn m) <* P.codegen ma m docs ext
     }
 
 indexCoreFn :: forall m. (MonadIO m) => Connection -> CF.Module CF.Ann -> m ()
 indexCoreFn conn m = do
   liftIO do
     let mName = P.runModuleName $ CF.moduleName m
+    path <- makeAbsolute $ CF.modulePath m
+    SQL.execute conn "DELETE FROM corefn_modules WHERE name = ?" (SQL.Only mName)
     SQL.execute
       conn
-      (SQL.Query "INSERT INTO corefn_modules (name, path) VALUES (?, ?)")
+      (SQL.Query "INSERT INTO corefn_modules (name, path, value) VALUES (?, ?, ?)")
       ( mName,
-        T.pack $ CF.modulePath m
+        path,
+        A.encode $ CFJ.moduleToJSON Paths.version m
       )
 
     forM_ (CF.moduleImports m) \((span, _, _), importedModule) -> do
       SQL.execute
         conn
-        (SQL.Query "INSERT INTO corefn_imports (module, imported_module) VALUES (?, ?)")
+        (SQL.Query "INSERT INTO corefn_imports (module_name, imported_module) VALUES (?, ?)")
         ( mName,
           P.runModuleName importedModule
         )
 
-    forM_ (CF.moduleDecls m) \bind -> do
-      void $ insertBind mName True bind
-      let (insertBind', _, _, _) = traverseCoreFn (insertBind mName False) (insertExpr mName) pure pure
-      void $ insertBind' bind
+    forM_ (CF.moduleDecls m) \b ->
+      do
+        let insertBindQuery topLevel ss ident bind =
+              SQL.execute
+                conn
+                ( SQL.Query
+                    "INSERT INTO corefn_declarations (module_name, ident, top_level, value, start_line, end_line, start_col, end_col) \
+                    \VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
+                )
+                ( mName,
+                  P.runIdent ident,
+                  topLevel,
+                  A.encode $ CFJ.bindToJSON bind,
+                  P.sourcePosLine $ P.spanStart ss,
+                  P.sourcePosLine $ P.spanEnd ss,
+                  P.sourcePosColumn $ P.spanStart ss,
+                  P.sourcePosColumn $ P.spanEnd ss
+                )
+            (insertBind', insertExpr', handleBinder, handleCaseAlternative) =
+              traverseCoreFn (insertBind False) insertExpr handleBinder handleCaseAlternative
+            insertBind :: Bool -> CF.Bind CF.Ann -> IO (CF.Bind CF.Ann)
+            insertBind topLevel bind = do
+              case bind of
+                CF.NonRec (ss, _comments, _meta) ident expr -> do
+                  insertBindQuery topLevel ss ident bind
+                  void $ insertExpr' expr
+                CF.Rec binds -> forM_ binds $ \(((ss, _, _), ident), expr) -> do
+                  insertBindQuery topLevel ss ident bind
+                  insertExpr' expr
+              pure bind
+
+            insertExpr :: CF.Expr CF.Ann -> IO (CF.Expr CF.Ann)
+            insertExpr expr = do
+              SQL.execute
+                conn
+                ( SQL.Query
+                    "INSERT INTO corefn_expressions (module_name, value, start_line, end_line, start_col, end_col, lines, cols)\
+                    \ VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
+                )
+                ( mName,
+                  A.encode $ CFJ.exprToJSON expr,
+                  P.sourcePosLine start,
+                  P.sourcePosLine end,
+                  P.sourcePosColumn start,
+                  P.sourcePosColumn end,
+                  lines',
+                  cols
+                )
+              case expr of
+                CF.Let _ binds _ -> do
+                  traverse_ insertBind' binds
+                _ -> pure ()
+              pure expr
+              where
+                (ss, _comments, _meta) = CF.extractAnn expr
+                start = P.spanStart ss
+                end = P.spanEnd ss
+                lines' = P.sourcePosLine end - P.sourcePosLine start
+                cols = P.sourcePosColumn end - P.sourcePosColumn start
+
+        void $ insertBind True b
+        void $ insertBind' b
+
+addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+addExternIndexing conn ma =
+  ma
+    { P.codegen = \m docs ext -> lift (indexExtern conn ext) <* P.codegen ma m docs ext
+    }
+
+indexExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()
+indexExtern conn extern = liftIO do
+  path <- liftIO $ makeAbsolute externPath
+  SQL.executeNamed
+    conn
+    (SQL.Query "DELETE FROM externs WHERE path = :path")
+    [":path" := path]
+  SQL.executeNamed
+    conn
+    (SQL.Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name, shown) VALUES (:path, :ef_version, :value, :module_name, :shown)")
+    [ ":path" := path,
+      ":ef_version" := P.efVersion extern,
+      ":value" := serialise extern,
+      ":module_name" := P.runModuleName name,
+      ":shown" := (show extern :: Text)
+    ]
+  forM_ (P.efImports extern) $ insertEfImport conn name
+  forM_ (P.efExports extern) $ insertEfExport conn name
+  forM_ (P.efDeclarations extern) $ insertEfDeclaration conn name
   where
-    insertBind :: Text -> Bool -> CF.Bind CF.Ann -> IO (CF.Bind CF.Ann)
-    insertBind mName topLevel bind = do
-      case bind of
-        CF.NonRec (ss, _comments, _meta) ident expr -> do
-          let
-          SQL.execute
-            conn
-            ( SQL.Query
-                "INSERT INTO corefn_declarations (module_name, ident, top_level, value, start_line, end_line, start_col, end_col) \
-                \VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
-            )
-            ( mName,
-              P.runIdent ident,
-              topLevel,
-              A.encode $ CFJ.bindToJSON bind,
-              P.sourcePosLine $ P.spanStart ss,
-              P.sourcePosLine $ P.spanEnd ss,
-              P.sourcePosColumn $ P.spanStart ss,
-              P.sourcePosColumn $ P.spanEnd ss
-            )
-        CF.Rec binds -> forM_ binds $ \((ann, ident), expr) ->
-          void $ insertBind mName topLevel (CF.NonRec ann ident expr)
-      pure bind
-
-    insertExpr :: Text -> CF.Expr CF.Ann -> IO (CF.Expr CF.Ann)
-    insertExpr mName expr = do
-      SQL.execute
-        conn
-        ( SQL.Query
-            "INSERT INTO corefn_expressions (module_name, value, start_line, end_line, start_col, end_col, lines, cols)\
-            \ VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
-        )
-        ( mName,
-          A.encode $ CFJ.exprToJSON expr,
-          P.sourcePosLine start,
-          P.sourcePosLine end,
-          P.sourcePosColumn start,
-          P.sourcePosColumn end,
-          lines',
-          cols
-        )
-      pure expr
-      where
-        (ss, _comments, _meta) = CF.extractAnn expr
-        start = P.spanStart ss
-        end = P.spanEnd ss
-        lines' = P.sourcePosLine end - P.sourcePosLine start
-        cols = P.sourcePosColumn end - P.sourcePosColumn start
+    name = efModuleName extern
+    externPath = P.spanName (P.efSourceSpan extern)
+
+insertEfImport :: Connection -> P.ModuleName -> P.ExternsImport -> IO ()
+insertEfImport conn moduleName' ei = do
+  SQL.executeNamed
+    conn
+    (SQL.Query "INSERT OR REPLACE INTO ef_imports (module_name, imported_module, import_type, imported_as, value) VALUES (:module_name, :imported_module, :import_type, :imported_as, :value)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":imported_module" := P.runModuleName (P.eiModule ei),
+      ":import_type" := serialise (P.eiImportType ei),
+      ":imported_as" := fmap P.runModuleName (P.eiImportedAs ei),
+      ":value" := serialise ei
+    ]
+
+insertEfDeclaration :: Connection -> P.ModuleName -> P.ExternsDeclaration -> IO ()
+insertEfDeclaration conn moduleName' decl = do
+  SQL.executeNamed
+    conn
+    (SQL.Query "INSERT OR REPLACE INTO ef_declarations (module_name, value, shown, name, start_col, start_line, end_col, end_line, category) VALUES (:module_name, :value, :shown, :name, :start_col, :start_line, :end_col, :end_line, :category)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":name" := printEfDeclName decl,
+      ":value" := serialise decl,
+      ":shown" := (show decl :: Text),
+      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
+      ":start_line" := (P.sourcePosLine . P.spanStart) span,
+      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
+      ":end_line" := (P.sourcePosLine . P.spanEnd) span,
+      ":category" := efDeclCategory decl
+    ]
+  where
+    span = efDeclSourceSpan decl
+
+insertEfExport :: Connection -> P.ModuleName -> P.DeclarationRef -> IO ()
+insertEfExport conn moduleName' dr = do
+  SQL.executeNamed
+    conn
+    (SQL.Query "INSERT OR REPLACE INTO ef_exports (module_name, value, name, printed_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :name, :printed_name, :start_col, :start_line, :end_col, :end_line)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":value" := serialise dr,
+      ":name" := serialise (declRefName dr),
+      ":printed_name" := printName (declRefName dr),
+      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
+      ":start_line" := (P.sourcePosLine . P.spanStart) span,
+      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
+      ":end_line" := (P.sourcePosLine . P.spanEnd) span
+    ]
+  where
+    span = P.declRefSourceSpan dr
+
+initDb :: Connection -> IO ()
+initDb conn = do
+  dropTables conn
+  SQL.execute_ conn "pragma journal_mode=wal;"
+  SQL.execute_ conn "pragma foreign_keys = ON;"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module_name TEXT references corefn_modules(name), imported_module TEXT, UNIQUE(module_name, imported_module) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT references corefn_modules(name), ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name), value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name), imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT references externs(module_name), export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT references externs(module_name), name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
+
+  addDbIndexes conn
+
+addDbIndexes :: Connection -> IO ()
+addDbIndexes conn = do
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_modules_name ON corefn_modules (name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_modules_path ON corefn_modules (path)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_imports_module ON corefn_imports (module_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_imports_imported_module ON corefn_imports (imported_module)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_declarations_module_name ON corefn_declarations (module_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_declarations_start_line ON corefn_declarations (start_line)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_declarations_end_line ON corefn_declarations (end_line)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_start_line ON corefn_expressions (start_line)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_end_line ON corefn_expressions (end_line)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_lines ON corefn_expressions (lines)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_cols ON corefn_expressions (cols)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS externs_path ON externs (path)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS externs_module_name ON externs (module_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_module_name ON ef_imports (module_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_imported_module ON ef_imports (imported_module)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_import_type ON ef_imports (import_type)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_imported_as ON ef_imports (imported_as)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_exports_module_name ON ef_exports (module_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_exports_export_name ON ef_exports (export_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_declarations_module_name ON ef_declarations (module_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_declarations_name ON ef_declarations (name)"
+
+dropTables :: Connection -> IO ()
+dropTables conn = do
+  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_modules"
+  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_imports"
+  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_declarations"
+  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_expressions"
\ No newline at end of file

From 5e56301eb0d697cb06a4b33bd623bb6d055cae4d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 06:15:43 +0200
Subject: [PATCH 056/297] fix queries

---
 src/Language/PureScript/Lsp/Cache/Query.hs | 25 +++-----
 src/Language/PureScript/Lsp/Prim.hs        | 34 ++++++-----
 src/Language/PureScript/LspSimple.hs       | 71 ++++++++++++----------
 3 files changed, 64 insertions(+), 66 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index a4453c2a88..039ebff970 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -67,10 +67,10 @@ getCoreFnExprAt path (LSP.Position line col) = do
       "SELECT corefn_expressions.value FROM corefn_expressions \
       \INNER JOIN corefn_modules on corefn_expressions.module_name = corefn_modules.name \
       \WHERE startLine <= :line AND endLine >= :line \
-      \AND startColumn <= :column AND endColumn >= :column\
-      \AND path = :path\
-      \AND lines = 0\
-      \ORDER BY cols ASC\
+      \AND startColumn <= :column AND endColumn >= :column \
+      \AND path = :path \
+      \AND lines = 0 \
+      \ORDER BY cols ASC \
       \LIMIT 1"
       [ ":line" := toInteger line,
         ":column" := toInteger col,
@@ -89,10 +89,10 @@ getCodeFnBindAt path (LSP.Position line col) = do
       "SELECT corefn_declarations.value FROM corefn_declarations \
       \INNER JOIN corefn_modules on corefn_declarations.module_name = corefn_modules.name \
       \WHERE startLine <= :line AND endLine >= :line \
-      \AND startColumn <= :column AND endColumn >= :column\
-      \AND path = :path\
-      \AND lines = 0\
-      \ORDER BY cols ASC\
+      \AND startColumn <= :column AND endColumn >= :column \
+      \AND path = :path \
+      \AND lines = 0 \
+      \ORDER BY cols ASC \
       \LIMIT 1"
       [ ":line" := toInteger (line + 1),
         ":column" := toInteger (col + 1),
@@ -200,12 +200,3 @@ getEfDeclarationOnlyInModule moduleName' name = do
   logDebugN $ "getEfDeclarationOnlyInModule decls: " <> show moduleName' <> " . " <> show name <> " : " <> T.pack (show $ length decls)
   pure $ deserialise . fromOnly <$> listToMaybe decls
 
-getDeclaration :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.Declaration)
-getDeclaration moduleName' printed_name = do
-  decls <-
-    DB.queryNamed
-      "SELECT value FROM declarations WHERE module_name = :module_name AND printed_name = :printed_name"
-      [ ":module_name" := P.runModuleName moduleName',
-        ":printed_name" := printed_name
-      ]
-  pure $ deserialise . fromOnly <$> listToMaybe decls
diff --git a/src/Language/PureScript/Lsp/Prim.hs b/src/Language/PureScript/Lsp/Prim.hs
index 85d7e8b770..f1e1983517 100644
--- a/src/Language/PureScript/Lsp/Prim.hs
+++ b/src/Language/PureScript/Lsp/Prim.hs
@@ -7,10 +7,13 @@ import Data.Version (showVersion)
 import Language.PureScript (primEnv)
 import Language.PureScript qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
-
 import Protolude
 
--- primExternsMap :: Map P.ModuleName (P.SourceSpan, P.Imports, P.Exports)
+primExternsMap :: Map P.ModuleName [P.ExternsFile]
+primExternsMap =
+  primExterns
+    <&> (\ef -> (P.efModuleName ef, [ef]))
+    & Map.fromListWith (<>)
 
 primExterns :: [P.ExternsFile]
 primExterns = Map.toList primEnv <&> toExtern
@@ -131,20 +134,19 @@ primExterns = Map.toList primEnv <&> toExtern
         toEfImportModule mn = P.ExternsImport mn P.Implicit Nothing
 
         efDeclarations :: [P.ExternsDeclaration]
-        efDeclarations = efExports >>= \case 
-          P.TypeClassRef _ss name -> pure $ P.EDClass  name [] [] [] [] False
-          P.TypeOpRef _ss name -> pure $ P.EDValue (P.Ident $ P.runOpName name) P.srcREmpty
-          P.TypeRef _ss name _ctrs -> pure $ P.EDType name P.srcREmpty (P.DataType P.Data [] [])
-          P.ValueRef _ss name -> pure $ P.EDValue name P.srcREmpty
-          P.ValueOpRef _ss name -> pure $ P.EDValue (P.Ident $ P.runOpName name) P.srcREmpty
-          -- P.TypeInstanceRef _ss name source -> pure $ P.EDInstance (_ modName name) _ _ _ _ _ _ _ _ _
-          _ -> []
-          
-         
-            --  TypeClassRef SourceSpan (ProperName 'ClassName)
-            -- -- |
-            -- -- A type operator
-            -- --
+        efDeclarations =
+          efExports >>= \case
+            P.TypeClassRef _ss name -> pure $ P.EDClass name [] [] [] [] False
+            P.TypeOpRef _ss name -> pure $ P.EDValue (P.Ident $ P.runOpName name) P.srcREmpty
+            P.TypeRef _ss name _ctrs -> pure $ P.EDType name P.srcREmpty (P.DataType P.Data [] [])
+            P.ValueRef _ss name -> pure $ P.EDValue name P.srcREmpty
+            P.ValueOpRef _ss name -> pure $ P.EDValue (P.Ident $ P.runOpName name) P.srcREmpty
+            _ -> []
+
+--  TypeClassRef SourceSpan (ProperName 'ClassName)
+-- -- |
+-- -- A type operator
+-- --
 
 -- | The data which will be serialized to an externs file
 -- data ExternsFile = ExternsFile
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index c43db4d052..877c2a9864 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -10,6 +10,7 @@
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.LspSimple (main) where
 
@@ -40,7 +41,7 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), pre
 import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
-import Language.PureScript.Lsp.Cache.Query (getDeclaration, getEfDeclaration)
+import Language.PureScript.Lsp.Cache.Query (getEfDeclaration, getCoreFnExprAt)
 import Language.PureScript.Lsp.Print (printDeclarationType)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
@@ -192,44 +193,48 @@ handlers diagErrs =
             forLsp val f = maybe nullRes f val
         liftLsp $ logDebugN $ "filePathMb: " <> show filePathMb
         liftLsp $ logDebugN $ "docUri: " <> show docUri
+
         forLsp filePathMb \filePath -> do
+          corefnExpr <- liftLsp $ getCoreFnExprAt filePath pos
+          liftLsp $ logDebugN $ "corefnExpr: " <> show corefnExpr
           vfMb <- Server.getVirtualFile docUri
           liftLsp $ logDebugN $ "vfMb exists: " <> show (isJust vfMb)
           forLsp vfMb \vf -> do
             let word = getWordAt (VFS._file_text vf) pos
             liftLsp $ logWarnN $ "word: " <> show word
-            if word == ""
-              then nullRes
-              else do
-                mNameMb <- liftLspWithErr $ selectExternModuleNameFromFilePath filePath
-                liftLsp $ logDebugN $ "mNameMb: " <> show mNameMb
-                forLsp (join $ hush mNameMb) $ \mName -> do
-                  declMb <- liftLsp $ getEfDeclaration mName word
-                  forLsp declMb $ \(importedMod, decl) -> do
-                    liftLsp $ logWarnN $ "importedMod: " <> show importedMod
-                    astDeclMb <- liftLsp $ getDeclaration importedMod word
-                    liftLsp $ logWarnN $ "astDeclMb: " <> show astDeclMb
-                    let declSpan = efDeclSourceSpan decl
-                        declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
-                        declComments = maybe (convertComments $ efDeclComments decl) (Just . printDeclarationType) astDeclMb
-                        hoverInfo =
-                          Types.InL $
-                            Types.Hover
-                              ( Types.InL $
-                                  Types.MarkupContent
-                                    Types.MarkupKind_Markdown
-                                    ( "```purescript\n"
-                                        <> word
-                                        <> " :: "
-                                        <> declType
-                                        <> "\n"
-                                        <> fold declComments
-                                        <> "\n```"
-                                    )
-                              )
-                              Nothing
-                    liftLsp $ logWarnN $ "Comments: " <> show declComments
-                    res $ Right hoverInfo
+            nullRes 
+            -- if word == ""
+            --   then nullRes
+            --   else do
+            --     mNameMb <- liftLspWithErr $ selectExternModuleNameFromFilePath filePath
+            --     liftLsp $ logDebugN $ "mNameMb: " <> show mNameMb
+            --     forLsp (join $ hush mNameMb) $ \mName -> do
+            --       declMb <- liftLsp $ getEfDeclaration mName word
+            --       forLsp declMb $ \(importedMod, decl) -> do
+            --         liftLsp $ logWarnN $ "importedMod: " <> show importedMod
+            --         astDeclMb <- pure Nothing -- liftLsp $ getDeclaration importedMod word
+            --         liftLsp $ logWarnN $ "astDeclMb: " <> show astDeclMb
+            --         let declSpan = efDeclSourceSpan decl
+            --             declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
+            --             declComments = maybe (convertComments $ efDeclComments decl) (Just . printDeclarationType) astDeclMb
+            --             hoverInfo =
+            --               Types.InL $
+            --                 Types.Hover
+            --                   ( Types.InL $
+            --                       Types.MarkupContent
+            --                         Types.MarkupKind_Markdown
+            --                         ( "```purescript\n"
+            --                             <> word
+            --                             <> " :: "
+            --                             <> declType
+            --                             <> "\n"
+            --                             <> fold declComments
+            --                             <> "\n```"
+            --                         )
+            --                   )
+            --                   Nothing
+            --         liftLsp $ logWarnN $ "Comments: " <> show declComments
+            --         res $ Right hoverInfo
                     -- let moduleName' = case cache of
                     --       Just (CurrentFile mName _ _ ) -> Just mName
                     --       _ -> Nothing

From b89aa2924fc75df5552127f5eea4ec945680b597 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 06:18:01 +0200
Subject: [PATCH 057/297] remove noisy logs

---
 src/Language/PureScript/Lsp/Rebuild.hs |  1 -
 src/Language/PureScript/LspSimple.hs   | 12 +-----------
 2 files changed, 1 insertion(+), 12 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 5c0dc0048a..1c99e878c9 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -72,7 +72,6 @@ rebuildFile' rebuildDeps srcPath = do
     Right m -> pure m
   let moduleName = P.getModuleName m
   externs <- sortExterns m =<< selectAllExternsMap
-  logDebugN $ "Sorted externs: " <> T.pack (show $ map P.efModuleName externs)
   when rebuildDeps do
     forM_ externs \ef -> do
       let depSrcPath = P.spanName $ P.efSourceSpan ef
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 877c2a9864..1d94d50f5e 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -92,12 +92,8 @@ handlers diagErrs =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
         res <- liftLspWithErr do
-          logDebugN "Externs inserted"
           initFinished
           logDebugN "Init finished"
-          -- void $ rebuildFileAndDeps "src/Main.purs"
-          logDebugN "Rebuilt Main.purs"
-
         case res of
           Left err -> do
             liftLsp $ logErrorN $ "Initalise error: " <> show err
@@ -131,9 +127,6 @@ handlers diagErrs =
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
         liftLsp $ logDebugN "SMethod_TextDocumentDiagnostic"
         (errs, diagnostics) <- getFileDiagnotics req
-        unless (null errs) $ liftLsp do
-          logDebugN $ "Errors: " <> show errs
-          logDebugN $ "diagnostics: " <> show diagnostics
         insertDiagnosticErrors diagErrs errs diagnostics
         res $
           Right $
@@ -141,14 +134,11 @@ handlers diagErrs =
               Types.InL $
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
-        liftLsp $ logDebugN "SMethod_TextDocumentCodeAction"
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
             uri = getMsgUri req
-        liftLsp $ logDebugN "SMethod_TextDocumentCodeAction 0"
 
         errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
-        liftLsp $ logDebugN "SMethod_TextDocumentCodeAction 1"
         res $
           Right $
             Types.InL $
@@ -366,7 +356,7 @@ handlers diagErrs =
             diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
         pure (errors, diags)
       Left err -> do
-        liftLsp $ logErrorN $ "Rebuild error: " <> show err
+        liftLsp $ logErrorN $ "Rebuild error: " <> textError err
         pure ([], [])
       Right errs | Errors.nonEmpty errs -> do
         let errors = runMultipleErrors errs

From e8f504dccc36774e91bc21803fa7a219b3dec624 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 06:20:09 +0200
Subject: [PATCH 058/297] snake case cols

---
 src/Language/PureScript/Lsp/Cache/Query.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 039ebff970..c3553ebe99 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -66,8 +66,8 @@ getCoreFnExprAt path (LSP.Position line col) = do
     DB.queryNamed
       "SELECT corefn_expressions.value FROM corefn_expressions \
       \INNER JOIN corefn_modules on corefn_expressions.module_name = corefn_modules.name \
-      \WHERE startLine <= :line AND endLine >= :line \
-      \AND startColumn <= :column AND endColumn >= :column \
+      \WHERE start_line <= :line AND end_line >= :line \
+      \AND start_column <= :column AND end_column >= :column \
       \AND path = :path \
       \AND lines = 0 \
       \ORDER BY cols ASC \
@@ -88,8 +88,8 @@ getCodeFnBindAt path (LSP.Position line col) = do
     DB.queryNamed
       "SELECT corefn_declarations.value FROM corefn_declarations \
       \INNER JOIN corefn_modules on corefn_declarations.module_name = corefn_modules.name \
-      \WHERE startLine <= :line AND endLine >= :line \
-      \AND startColumn <= :column AND endColumn >= :column \
+      \WHERE start_line <= :line AND end_line >= :line \
+      \AND start_column <= :column AND end_column >= :column \
       \AND path = :path \
       \AND lines = 0 \
       \ORDER BY cols ASC \

From 1b663a8103d4ec30eb360c29abeead4e8b5c423b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 07:33:45 +0200
Subject: [PATCH 059/297] fixes decoding for core fn queries

---
 src/Language/PureScript/Lsp/Cache/Query.hs | 22 +++++++++--------
 src/Language/PureScript/Make/Index.hs      | 28 ++++++++++------------
 2 files changed, 24 insertions(+), 26 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index c3553ebe99..bed8d64301 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -46,6 +46,7 @@ import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents
 import System.FilePath (normalise, (</>))
 import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebugN, logErrorN, logWarnN, mapLoggingT)
 import Language.PureScript (Ident)
+import Data.Aeson qualified as A
 
 -- import Control.Monad.Logger (logDebugN)
 
@@ -62,34 +63,35 @@ import Language.PureScript (Ident)
 
 getCoreFnExprAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Expr CF.Ann))
 getCoreFnExprAt path (LSP.Position line col) = do
-  decls :: [SQL.Only String] <-
+  decls :: [SQL.Only Lazy.ByteString] <-
     DB.queryNamed
       "SELECT corefn_expressions.value FROM corefn_expressions \
       \INNER JOIN corefn_modules on corefn_expressions.module_name = corefn_modules.name \
       \WHERE start_line <= :line AND end_line >= :line \
-      \AND start_column <= :column AND end_column >= :column \
+      \AND start_col <= :column AND end_col >= :column \
       \AND path = :path \
       \AND lines = 0 \
       \ORDER BY cols ASC \
       \LIMIT 1"
-      [ ":line" := toInteger line,
-        ":column" := toInteger col,
+      [ ":line" := toInteger (line + 1),
+        ":column" := toInteger (col + 1),
         ":path" := path
       ]
+
   pure $
     A.parseMaybe (CF.exprFromJSON path)
-      =<< fromString
-      . fromOnly
+      =<< A.decode'
+      =<< fromOnly
       <$> listToMaybe decls
 
 getCodeFnBindAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Bind CF.Ann))
 getCodeFnBindAt path (LSP.Position line col) = do
-  decls :: [SQL.Only String] <-
+  decls :: [SQL.Only Lazy.ByteString] <-
     DB.queryNamed
       "SELECT corefn_declarations.value FROM corefn_declarations \
       \INNER JOIN corefn_modules on corefn_declarations.module_name = corefn_modules.name \
       \WHERE start_line <= :line AND end_line >= :line \
-      \AND start_column <= :column AND end_column >= :column \
+      \AND start_col <= :column AND end_col >= :column \
       \AND path = :path \
       \AND lines = 0 \
       \ORDER BY cols ASC \
@@ -100,8 +102,8 @@ getCodeFnBindAt path (LSP.Position line col) = do
       ]
   pure $
     A.parseMaybe (CF.bindFromJSON path)
-      =<< fromString
-      . fromOnly
+      =<< A.decode'
+      =<< fromOnly
       <$> listToMaybe decls
 
 -- findLocalBinding :: (P.Ident -> Bool) -> Expr a -> Maybe (CF.Binder a)
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 0e770a3073..aa20d790d7 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -17,6 +17,7 @@ import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple (Connection, NamedParam ((:=)))
 import Database.SQLite.Simple qualified as SQL
+import Distribution.Compat.Directory (makeAbsolute)
 import Language.PureScript (declRefName)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
@@ -43,8 +44,6 @@ import Language.PureScript.Options qualified as P
 import Paths_purescript qualified as Paths
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
-import Distribution.Compat.Directory (makeAbsolute)
-import Database.SQLite.Simple qualified as SQL
 
 addCoreFnIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addCoreFnIndexing conn ma =
@@ -92,26 +91,25 @@ indexCoreFn conn m = do
                   P.sourcePosColumn $ P.spanStart ss,
                   P.sourcePosColumn $ P.spanEnd ss
                 )
-            (insertBind', insertExpr', handleBinder, handleCaseAlternative) =
+            (handleBind, handleExpr, handleBinder, handleCaseAlternative) =
               traverseCoreFn (insertBind False) insertExpr handleBinder handleCaseAlternative
+
             insertBind :: Bool -> CF.Bind CF.Ann -> IO (CF.Bind CF.Ann)
             insertBind topLevel bind = do
               case bind of
                 CF.NonRec (ss, _comments, _meta) ident expr -> do
                   insertBindQuery topLevel ss ident bind
-                  void $ insertExpr' expr
                 CF.Rec binds -> forM_ binds $ \(((ss, _, _), ident), expr) -> do
                   insertBindQuery topLevel ss ident bind
-                  insertExpr' expr
-              pure bind
+              handleBind bind
 
             insertExpr :: CF.Expr CF.Ann -> IO (CF.Expr CF.Ann)
             insertExpr expr = do
               SQL.execute
                 conn
                 ( SQL.Query
-                    "INSERT INTO corefn_expressions (module_name, value, start_line, end_line, start_col, end_col, lines, cols)\
-                    \ VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
+                    "INSERT INTO corefn_expressions (module_name, value, start_line, end_line, start_col, end_col, lines, cols, shown)\
+                    \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)"
                 )
                 ( mName,
                   A.encode $ CFJ.exprToJSON expr,
@@ -120,13 +118,10 @@ indexCoreFn conn m = do
                   P.sourcePosColumn start,
                   P.sourcePosColumn end,
                   lines',
-                  cols
+                  cols,
+                  show expr :: Text
                 )
-              case expr of
-                CF.Let _ binds _ -> do
-                  traverse_ insertBind' binds
-                _ -> pure ()
-              pure expr
+              handleExpr expr
               where
                 (ss, _comments, _meta) = CF.extractAnn expr
                 start = P.spanStart ss
@@ -135,7 +130,7 @@ indexCoreFn conn m = do
                 cols = P.sourcePosColumn end - P.sourcePosColumn start
 
         void $ insertBind True b
-        void $ insertBind' b
+        void $ handleBind b
 
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
@@ -221,7 +216,7 @@ initDb conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module_name TEXT references corefn_modules(name), imported_module TEXT, UNIQUE(module_name, imported_module) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT references corefn_modules(name), ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name), value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name), value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, shown TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name), imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT references externs(module_name), export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
@@ -242,6 +237,7 @@ addDbIndexes conn = do
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_end_line ON corefn_expressions (end_line)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_lines ON corefn_expressions (lines)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_cols ON corefn_expressions (cols)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_module_name ON corefn_expressions (module_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS externs_path ON externs (path)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS externs_module_name ON externs (module_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_module_name ON ef_imports (module_name)"

From bcbf7e6cf0d7f7798efab42f86657b6dec2217dc Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 08:01:13 +0200
Subject: [PATCH 060/297] adds type on hover

---
 src/Language/PureScript/LspSimple.hs | 306 +++++++++++++++------------
 1 file changed, 176 insertions(+), 130 deletions(-)

diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 1d94d50f5e..f9067fd275 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -6,11 +6,11 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 -- {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.LspSimple (main) where
 
@@ -32,6 +32,8 @@ import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
+import Language.PureScript qualified as P
+import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
@@ -41,12 +43,14 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), pre
 import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
-import Language.PureScript.Lsp.Cache.Query (getEfDeclaration, getCoreFnExprAt)
+import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclaration, getEfDeclarationOnlyInModule)
 import Language.PureScript.Lsp.Print (printDeclarationType)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Lsp.Util (efDeclComments, efDeclSourceSpan, efDeclSourceType, getWordAt)
+import Language.PureScript.Names (runIdent)
+import Language.PureScript.Names qualified as P
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
@@ -179,20 +183,62 @@ handlers diagErrs =
                 ^. LSP.uri
                   . to Types.toNormalizedUri
             nullRes = res $ Right $ Types.InR Types.Null
+
+            markdownRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM () ()
+            markdownRes word type' comments =
+              res $
+                Right $
+                  Types.InL $
+                    Types.Hover
+                      ( Types.InL $
+                          Types.MarkupContent
+                            Types.MarkupKind_Markdown
+                            ( "```purescript\n"
+                                <> word
+                                <> annotation
+                                <> "\n"
+                                <> fold (convertComments comments)
+                                <> "\n```"
+                            )
+                      )
+                      Nothing
+              where
+                annotation = case type' of
+                  Just t -> " :: " <> t
+                  Nothing -> ""
             forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
             forLsp val f = maybe nullRes f val
         liftLsp $ logDebugN $ "filePathMb: " <> show filePathMb
         liftLsp $ logDebugN $ "docUri: " <> show docUri
 
         forLsp filePathMb \filePath -> do
-          corefnExpr <- liftLsp $ getCoreFnExprAt filePath pos
-          liftLsp $ logDebugN $ "corefnExpr: " <> show corefnExpr
-          vfMb <- Server.getVirtualFile docUri
-          liftLsp $ logDebugN $ "vfMb exists: " <> show (isJust vfMb)
-          forLsp vfMb \vf -> do
-            let word = getWordAt (VFS._file_text vf) pos
-            liftLsp $ logWarnN $ "word: " <> show word
-            nullRes 
+          corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
+          forLsp corefnExprMb \case
+            CF.Literal _ _ -> nullRes
+            CF.Constructor (_ss, comments, meta) tName cMame _ -> do
+              markdownRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
+            CF.Var (_ss, comments, meta) (P.Qualified qb ident) -> do
+              typeMb <- liftLsp $ case qb of
+                P.ByModuleName mName ->
+                  fmap (prettyPrintTypeSingleLine . efDeclSourceType)
+                    <$> getEfDeclarationOnlyInModule mName (runIdent ident)
+                P.BySourcePos _pos -> pure $ Just "local var"
+
+              markdownRes (P.runIdent ident) typeMb comments
+
+            -- forLsp declMb \decl -> do
+            --   let declSpan = efDeclSourceSpan decl
+            --       declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
+            --       declComments = convertComments $ efDeclComments decl
+            --   markdownRes (P.runIdent qIdent) declType declComments
+            _ -> nullRes
+
+            -- vfMb <- Server.getVirtualFile docUri
+            -- liftLsp $ logDebugN $ "vfMb exists: " <> show (isJust vfMb)
+            -- forLsp vfMb \vf -> do
+            --   let word = getWordAt (VFS._file_text vf) pos
+            --   liftLsp $ logWarnN $ "word: " <> show word
+            --   nullRes
             -- if word == ""
             --   then nullRes
             --   else do
@@ -207,128 +253,128 @@ handlers diagErrs =
             --         let declSpan = efDeclSourceSpan decl
             --             declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
             --             declComments = maybe (convertComments $ efDeclComments decl) (Just . printDeclarationType) astDeclMb
-            --             hoverInfo =
-            --               Types.InL $
-            --                 Types.Hover
-            --                   ( Types.InL $
-            --                       Types.MarkupContent
-            --                         Types.MarkupKind_Markdown
-            --                         ( "```purescript\n"
-            --                             <> word
-            --                             <> " :: "
-            --                             <> declType
-            --                             <> "\n"
-            --                             <> fold declComments
-            --                             <> "\n```"
-            --                         )
-            --                   )
-            --                   Nothing
+            -- hoverInfo =
+            --   Types.InL $
+            --     Types.Hover
+            --       ( Types.InL $
+            --           Types.MarkupContent
+            --             Types.MarkupKind_Markdown
+            --             ( "```purescript\n"
+            --                 <> word
+            --                 <> " :: "
+            --                 <> declType
+            --                 <> "\n"
+            --                 <> fold declComments
+            --                 <> "\n```"
+            --             )
+            --       )
+            --       Nothing
             --         liftLsp $ logWarnN $ "Comments: " <> show declComments
             --         res $ Right hoverInfo
-                    -- let moduleName' = case cache of
-                    --       Just (CurrentFile mName _ _ ) -> Just mName
-                    --       _ -> Nothing
-
-                    -- imports <-
-                    --   filePathMb
-                    --     & maybe (pure Nothing) (liftLsp . parseImportsFromFile)
-
-                    -- let filters :: [Filter]
-                    --     filters =
-                    --       imports
-                    --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                    --     getInputModName (n, _, _) = n
-
-                    --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                    --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                    -- completions <- liftLsp $ get_actCompletionsWithPrim word filters moduleName'
-
-                    -- let hoverInfo = case head <$> completions of
-                    --       Right (Just completion) -> completionToHoverInfo word completion
-                    --       _ -> word
-
-                    -- res $
-                    --   Right $
-                    --     Types.InL $
-                    --       Types.Hover
-                    --         ( Types.InL $
-                    --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
-                    --         )
-                    --         Nothing
-                    --             ,
-                    -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-                    --   sendInfoMsg "SMethod_TextDocumentDefinition"
-                    --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-                    --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-                    --       uri =
-                    --         req
-                    --           ^. LSP.params
-                    --             . LSP.textDocument
-                    --             . LSP.uri
-                    --             . to Types.toNormalizedUri
-
-                    --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-                    --   vfMb <- Server.getVirtualFile uri
-
-                    --   for_ vfMb \vf -> do
-                    --     let word = getWordAt (VFS._file_text vf) pos
-                    --     cache <- liftLsp cachedRebuild
-                    --     let moduleName' = case cache of
-                    --           Right (Just (mName, _)) -> Just mName
-                    --           _ -> Nothing
-
-                    --     imports <-
-                    --       filePathMb
-                    --         & maybe (pure Nothing) (fmap hush . liftLsp . parseImportsFromFile)
-
-                    --     let filters :: [Filter]
-                    --         filters =
-                    --           imports
-                    --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-                    --         getInputModName (n, _, _) = n
-
-                    --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-                    --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-                    --     completions :: Either IdeError [Completion] <- liftLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-                    --     sendInfoMsg $ "Completions: " <> show completions
-                    --     let withLocation =
-                    --           fold completions
-                    --             & mapMaybe
-                    --               ( \c -> case complLocation c of
-                    --                   Just loc -> Just (c, loc)
-                    --                   Nothing -> Nothing
-                    --               )
-                    --             & head
-
-                    --     paths <- liftLsp $ Map.map snd . fsModules <$> getFileState
-
-                    --     case withLocation of
-                    --       Just (completion, location) -> do
-                    --         let fpMb =
-                    --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
-
-                    --         case fpMb of
-                    --           Nothing -> do
-                    --             sendInfoMsg "No file path for module"
-                    --             nullRes
-                    --           Just fp ->
-                    --             res $
-                    --               Right $
-                    --                 Types.InL $
-                    --                   Types.Definition $
-                    --                     Types.InL $
-                    --                       Types.Location
-                    --                         (Types.filePathToUri fp)
-                    --                         (spanToRange location)
-                    --       _ -> do
-                    --         sendInfoMsg "No location for completion"
-                    --         nullRes
+            -- let moduleName' = case cache of
+            --       Just (CurrentFile mName _ _ ) -> Just mName
+            --       _ -> Nothing
+
+            -- imports <-
+            --   filePathMb
+            --     & maybe (pure Nothing) (liftLsp . parseImportsFromFile)
+
+            -- let filters :: [Filter]
+            --     filters =
+            --       imports
+            --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+            --     getInputModName (n, _, _) = n
+
+            --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+            --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+            -- completions <- liftLsp $ get_actCompletionsWithPrim word filters moduleName'
+
+            -- let hoverInfo = case head <$> completions of
+            --       Right (Just completion) -> completionToHoverInfo word completion
+            --       _ -> word
+
+            -- res $
+            --   Right $
+            --     Types.InL $
+            --       Types.Hover
+            --         ( Types.InL $
+            --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
+            --         )
+            --         Nothing
+            --             ,
+            -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+            --   sendInfoMsg "SMethod_TextDocumentDefinition"
+            --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+            --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            --       uri =
+            --         req
+            --           ^. LSP.params
+            --             . LSP.textDocument
+            --             . LSP.uri
+            --             . to Types.toNormalizedUri
+
+            --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+            --   vfMb <- Server.getVirtualFile uri
+
+            --   for_ vfMb \vf -> do
+            --     let word = getWordAt (VFS._file_text vf) pos
+            --     cache <- liftLsp cachedRebuild
+            --     let moduleName' = case cache of
+            --           Right (Just (mName, _)) -> Just mName
+            --           _ -> Nothing
+
+            --     imports <-
+            --       filePathMb
+            --         & maybe (pure Nothing) (fmap hush . liftLsp . parseImportsFromFile)
+
+            --     let filters :: [Filter]
+            --         filters =
+            --           imports
+            --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
+
+            --         getInputModName (n, _, _) = n
+
+            --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
+            --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
+
+            --     completions :: Either IdeError [Completion] <- liftLsp $ getExactCompletionsWithPrim word filters moduleName'
+
+            --     sendInfoMsg $ "Completions: " <> show completions
+            --     let withLocation =
+            --           fold completions
+            --             & mapMaybe
+            --               ( \c -> case complLocation c of
+            --                   Just loc -> Just (c, loc)
+            --                   Nothing -> Nothing
+            --               )
+            --             & head
+
+            --     paths <- liftLsp $ Map.map snd . fsModules <$> getFileState
+
+            --     case withLocation of
+            --       Just (completion, location) -> do
+            --         let fpMb =
+            --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
+
+            --         case fpMb of
+            --           Nothing -> do
+            --             sendInfoMsg "No file path for module"
+            --             nullRes
+            --           Just fp ->
+            --             res $
+            --               Right $
+            --                 Types.InL $
+            --                   Types.Definition $
+            --                     Types.InL $
+            --                       Types.Location
+            --                         (Types.filePathToUri fp)
+            --                         (spanToRange location)
+            --       _ -> do
+            --         sendInfoMsg "No location for completion"
+            --         nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])

From 7f0c30e8fa97470f617f228f5a6bf7ee2e3d22c6 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 10:23:37 +0200
Subject: [PATCH 061/297] go to definition for by source pos working

---
 src/Language/PureScript/Lsp/Cache.hs       |   4 +
 src/Language/PureScript/Lsp/Cache/Query.hs |  66 +++------
 src/Language/PureScript/LspSimple.hs       | 162 ++++++++-------------
 3 files changed, 81 insertions(+), 151 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 6a1ccc34ec..54b2d03b55 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -37,6 +37,10 @@ selectExternModuleNameFromFilePath path = do
   res <- DB.queryNamed (Query "SELECT module_name FROM externs WHERE path = :path") [":path" := absPath]
   pure $ P.ModuleName . fromOnly <$> listToMaybe res
 
+selectExternPathFromModuleName :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m (Maybe FilePath)
+selectExternPathFromModuleName mName = 
+  DB.queryNamed (Query "SELECT path FROM externs WHERE module_name = :module_name") [":module_name" := P.runModuleName mName] <&> listToMaybe . fmap fromOnly
+
 
 -- | Finds all the externs inside the output folder and returns the
 -- corresponding module names
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index bed8d64301..38bfac8b24 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -47,6 +47,7 @@ import System.FilePath (normalise, (</>))
 import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebugN, logErrorN, logWarnN, mapLoggingT)
 import Language.PureScript (Ident)
 import Data.Aeson qualified as A
+import Language.PureScript.AST.SourcePos (SourcePos (SourcePos))
 
 -- import Control.Monad.Logger (logDebugN)
 
@@ -146,59 +147,28 @@ importContainsIdent ident import' = case P.eiImportType import' of
       then Just False
       else Nothing
 
-getEfDeclaration :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
-getEfDeclaration moduleName' name = do
-  inModule <- getEfDeclarationOnlyInModule moduleName' name
-  case inModule of
-    Just decl -> pure $ Just (moduleName', decl)
-    Nothing -> getEFImportedDeclaration moduleName' name
-
-getEFImportedDeclaration :: forall m. (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (P.ModuleName, P.ExternsDeclaration))
-getEFImportedDeclaration moduleName' name = do
-  imports <- getEfImports moduleName'
-  exported <- getEfImportsMap (fmap P.eiModule imports)
-  foldM (getFromModule exported) Nothing imports
-  where
-    getFromModule exported acc import' = do
-      case acc of
-        Just _ -> pure acc
-        Nothing -> case importContainsIdent name import' of
-          Just False -> pure acc
-          _ -> do
-            inModule <- getEfDeclarationOnlyInModule importModName name
-            case inModule of
-              Just decl -> pure $ Just (importModName, decl)
-              Nothing -> getFromExports
-      where
-        importModName = P.eiModule import'
-        moduleExports = fromMaybe [] $ Map.lookup importModName exported
-
-        getFromExports :: m (Maybe (P.ModuleName, P.ExternsDeclaration))
-        getFromExports = foldM getFromExport Nothing moduleExports
-
-        getFromExport ::
-          Maybe (P.ModuleName, P.ExternsDeclaration) ->
-          P.DeclarationRef ->
-          m (Maybe (P.ModuleName, P.ExternsDeclaration))
-        getFromExport acc' export' = do
-          case acc of
-            Just _ -> pure acc'
-            Nothing -> do
-              case export' of
-                P.ModuleRef _ mName -> getEfDeclaration mName name
-                P.ReExportRef _ss (P.ExportSource _ definedIn) ref
-                  | printName (declRefName ref) == name ->
-                      fmap (definedIn,) <$> getEfDeclarationOnlyInModule definedIn name
-                _ -> pure acc'
-
-getEfDeclarationOnlyInModule :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
-getEfDeclarationOnlyInModule moduleName' name = do
+getEfDeclarationInModule :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
+getEfDeclarationInModule moduleName' name = do
   decls <-
     DB.queryNamed
       "SELECT value FROM ef_declarations WHERE module_name = :module_name AND name = :name"
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := name
       ]
-  logDebugN $ "getEfDeclarationOnlyInModule decls: " <> show moduleName' <> " . " <> show name <> " : " <> T.pack (show $ length decls)
+  logDebugN $ "getEfDeclarationInModule decls: " <> show moduleName' <> " . " <> show name <> " : " <> T.pack (show $ length decls)
   pure $ deserialise . fromOnly <$> listToMaybe decls
 
+getEfDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> SourcePos -> m [P.ExternsDeclaration]
+getEfDeclarationsAtSrcPos path (SourcePos line col) = do
+  decls <-
+    DB.queryNamed
+      "SELECT value FROM ef_declarations \
+      \inner join externs on ef_declarations.module_name = externs.module_name \
+      \WHERE start_line <= :line AND end_line >= :line \
+      \AND start_col <= :column AND end_col >= :column \
+      \AND path = :path"
+      [ ":line" := line,
+        ":column" := col,
+        ":path" := path
+      ]
+  pure $ deserialise . fromOnly <$> decls
\ No newline at end of file
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index f9067fd275..8eaf424340 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -28,11 +28,13 @@ import GHC.IO (unsafePerformIO)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
+import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
+import Language.PureScript.AST.SourcePos (SourcePos (sourcePosColumn))
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
@@ -42,8 +44,8 @@ import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), prettyPrintTypeSingleLine, textError)
 import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
-import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
-import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclaration, getEfDeclarationOnlyInModule)
+import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
+import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
 import Language.PureScript.Lsp.Print (printDeclarationType)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
@@ -54,7 +56,8 @@ import Language.PureScript.Names qualified as P
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
-import "monad-logger" Control.Monad.Logger (LoggingT, logDebugN, logErrorN, logWarnN, mapLoggingT)
+import "monad-logger" Control.Monad.Logger (LoggingT, logDebug, logDebugN, logErrorN, logWarnN, mapLoggingT)
+import Language.Haskell.TH (listT)
 
 type HandlerM config = Server.LspT config (ReaderT LspEnvironment (LoggingT IO))
 
@@ -184,8 +187,8 @@ handlers diagErrs =
                   . to Types.toNormalizedUri
             nullRes = res $ Right $ Types.InR Types.Null
 
-            markdownRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM () ()
-            markdownRes word type' comments =
+            markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM () ()
+            markdownTypeRes word type' comments =
               res $
                 Right $
                   Types.InL $
@@ -206,116 +209,65 @@ handlers diagErrs =
                 annotation = case type' of
                   Just t -> " :: " <> t
                   Nothing -> ""
+
             forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
             forLsp val f = maybe nullRes f val
-        liftLsp $ logDebugN $ "filePathMb: " <> show filePathMb
-        liftLsp $ logDebugN $ "docUri: " <> show docUri
 
         forLsp filePathMb \filePath -> do
           corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
           forLsp corefnExprMb \case
             CF.Literal _ _ -> nullRes
             CF.Constructor (_ss, comments, meta) tName cMame _ -> do
-              markdownRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
+              markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
             CF.Var (_ss, comments, meta) (P.Qualified qb ident) -> do
               typeMb <- liftLsp $ case qb of
                 P.ByModuleName mName ->
                   fmap (prettyPrintTypeSingleLine . efDeclSourceType)
-                    <$> getEfDeclarationOnlyInModule mName (runIdent ident)
-                P.BySourcePos _pos -> pure $ Just "local var"
+                    <$> getEfDeclarationInModule mName (runIdent ident)
+                P.BySourcePos pos' -> do
+                  decls <- getEfDeclarationsAtSrcPos filePath pos'
+                  logDebugN $ "pos: " <> T.pack (show pos')
+                  logDebugN $ "$ length decls at pos: " <> T.pack (show $ length decls)
+                  logDebugN $ "decls at pos: " <> T.pack (show decls)
+                  pure (prettyPrintTypeSingleLine . efDeclSourceType <$> listToMaybe decls)
+
+              markdownTypeRes (P.runIdent ident) typeMb comments
+            _ -> nullRes,
+      Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+        sendInfoMsg "SMethod_TextDocumentDefinition"
+        let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            uri :: Types.NormalizedUri
+            uri =
+              req
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to Types.toNormalizedUri
 
-              markdownRes (P.runIdent ident) typeMb comments
+            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
 
-            -- forLsp declMb \decl -> do
-            --   let declSpan = efDeclSourceSpan decl
-            --       declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
-            --       declComments = convertComments $ efDeclComments decl
-            --   markdownRes (P.runIdent qIdent) declType declComments
-            _ -> nullRes
+            locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
+
+            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp val f = maybe nullRes f val
 
-            -- vfMb <- Server.getVirtualFile docUri
-            -- liftLsp $ logDebugN $ "vfMb exists: " <> show (isJust vfMb)
-            -- forLsp vfMb \vf -> do
-            --   let word = getWordAt (VFS._file_text vf) pos
-            --   liftLsp $ logWarnN $ "word: " <> show word
-            --   nullRes
-            -- if word == ""
-            --   then nullRes
-            --   else do
-            --     mNameMb <- liftLspWithErr $ selectExternModuleNameFromFilePath filePath
-            --     liftLsp $ logDebugN $ "mNameMb: " <> show mNameMb
-            --     forLsp (join $ hush mNameMb) $ \mName -> do
-            --       declMb <- liftLsp $ getEfDeclaration mName word
-            --       forLsp declMb $ \(importedMod, decl) -> do
-            --         liftLsp $ logWarnN $ "importedMod: " <> show importedMod
-            --         astDeclMb <- pure Nothing -- liftLsp $ getDeclaration importedMod word
-            --         liftLsp $ logWarnN $ "astDeclMb: " <> show astDeclMb
-            --         let declSpan = efDeclSourceSpan decl
-            --             declType = prettyPrintTypeSingleLine $ efDeclSourceType decl
-            --             declComments = maybe (convertComments $ efDeclComments decl) (Just . printDeclarationType) astDeclMb
-            -- hoverInfo =
-            --   Types.InL $
-            --     Types.Hover
-            --       ( Types.InL $
-            --           Types.MarkupContent
-            --             Types.MarkupKind_Markdown
-            --             ( "```purescript\n"
-            --                 <> word
-            --                 <> " :: "
-            --                 <> declType
-            --                 <> "\n"
-            --                 <> fold declComments
-            --                 <> "\n```"
-            --             )
-            --       )
-            --       Nothing
-            --         liftLsp $ logWarnN $ "Comments: " <> show declComments
-            --         res $ Right hoverInfo
-            -- let moduleName' = case cache of
-            --       Just (CurrentFile mName _ _ ) -> Just mName
-            --       _ -> Nothing
-
-            -- imports <-
-            --   filePathMb
-            --     & maybe (pure Nothing) (liftLsp . parseImportsFromFile)
-
-            -- let filters :: [Filter]
-            --     filters =
-            --       imports
-            --         & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-            --     getInputModName (n, _, _) = n
-
-            --     insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-            --     insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-            -- completions <- liftLsp $ get_actCompletionsWithPrim word filters moduleName'
-
-            -- let hoverInfo = case head <$> completions of
-            --       Right (Just completion) -> completionToHoverInfo word completion
-            --       _ -> word
-
-            -- res $
-            --   Right $
-            --     Types.InL $
-            --       Types.Hover
-            --         ( Types.InL $
-            --             Types.MarkupContent Types.MarkupKind_Markdown hoverInfo
-            --         )
-            --         Nothing
-            --             ,
-            -- Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-            --   sendInfoMsg "SMethod_TextDocumentDefinition"
-            --   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-            --       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            --       uri =
-            --         req
-            --           ^. LSP.params
-            --             . LSP.textDocument
-            --             . LSP.uri
-            --             . to Types.toNormalizedUri
-
-            --       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+        forLsp filePathMb \filePath -> do
+          corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
+          forLsp corefnExprMb \case
+            CF.Var (_ss, _comments, _meta) (P.Qualified qb ident) -> do
+              let name = P.runIdent ident
+              case qb of
+                P.ByModuleName mName -> do
+                  declMb <- liftLsp $ getEfDeclarationInModule mName name
+                  forLsp declMb \decl -> do
+                    modFpMb <- liftLsp $ selectExternPathFromModuleName mName
+                    forLsp modFpMb \modFp -> do
+                      let sourceSpan = efDeclSourceSpan decl
+                      locationRes modFp (spanToRange sourceSpan)
+                P.BySourcePos srcPos ->
+                  locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
+            _ -> nullRes
 
             --   vfMb <- Server.getVirtualFile uri
 
@@ -437,10 +389,14 @@ handlers diagErrs =
                   )
 
 spanToRange :: Errors.SourceSpan -> Types.Range
-spanToRange (Errors.SourceSpan _ (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+spanToRange (Errors.SourceSpan _ start end) =
   Types.Range
-    (Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1))
-    (Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1))
+    (sourcePosToPosition start)
+    (sourcePosToPosition end)
+
+sourcePosToPosition :: Errors.SourcePos -> Types.Position
+sourcePosToPosition (Errors.SourcePos line col) =
+  Types.Position (fromIntegral $ line - 1) (fromIntegral $ col - 1)
 
 sendError :: IdeError -> HandlerM config ()
 sendError err =

From 72849284ae9e322aa1168b7732e748ce0a57e550 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 15:23:09 +0200
Subject: [PATCH 062/297] adds environment and decl indexing

---
 app/Command/Compile.hs                      |   5 +-
 purescript.cabal                            |   1 +
 src/Language/PureScript/AST/Declarations.hs |  29 ++
 src/Language/PureScript/Docs/AsMarkdown.hs  |   1 +
 src/Language/PureScript/Docs/Collect.hs     |   1 +
 src/Language/PureScript/Environment.hs      |   6 +-
 src/Language/PureScript/Ide/Rebuild.hs      |   2 +-
 src/Language/PureScript/Lsp/Cache/Query.hs  |  23 +-
 src/Language/PureScript/Lsp/Rebuild.hs      |  13 +-
 src/Language/PureScript/LspSimple.hs        |  55 ++--
 src/Language/PureScript/Make.hs             |   4 +-
 src/Language/PureScript/Make/Actions.hs     |   9 +-
 src/Language/PureScript/Make/Index.hs       | 312 +++++++++++++++++++-
 13 files changed, 382 insertions(+), 79 deletions(-)

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index dc78776c58..fcfc6bd22b 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -17,7 +17,7 @@ import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Errors.JSON (JSONResult (..), toJSONErrors)
 import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
-import Language.PureScript.Make.Index (addCoreFnIndexing, addExternIndexing, initDb)
+import Language.PureScript.Make.Index (addAllIndexing, initDb)
 import Options.Applicative qualified as Opts
 import SharedCLI qualified
 import System.Console.ANSI qualified as ANSI
@@ -83,8 +83,7 @@ compile PSCMakeOptions {..} = do
     conn <- liftIO $ mkConnection pscmOutputDir
     liftIO $ initDb conn
     let makeActions =
-          addCoreFnIndexing conn $
-            addExternIndexing conn $
+          addAllIndexing conn $
               buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
     P.make makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
diff --git a/purescript.cabal b/purescript.cabal
index d78a75e519..174cf52c5f 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -342,6 +342,7 @@ library
     Language.PureScript.Linter.Wildcards
     Language.PureScript.Lsp
     Language.PureScript.Lsp.DB
+    Language.PureScript.Lsp.Docs
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Cache.IO
     Language.PureScript.Lsp.Cache.Query
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 448775abee..54898a5ce5 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -772,6 +772,35 @@ data Expr
   | PositionedValue SourceSpan [Comment] Expr
   deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
+exprSourceSpan :: Expr -> Maybe SourceSpan
+exprSourceSpan (Literal ss _) = Just ss
+exprSourceSpan (UnaryMinus ss _) = Just ss
+exprSourceSpan (BinaryNoParens _ _ _) = Nothing
+exprSourceSpan (Parens _) = Nothing
+exprSourceSpan (Accessor _ _) = Nothing
+exprSourceSpan (ObjectUpdate _ _) = Nothing
+exprSourceSpan (ObjectUpdateNested _ _) = Nothing
+exprSourceSpan (Abs _ _) = Nothing
+exprSourceSpan (App _ _) = Nothing
+exprSourceSpan (VisibleTypeApp _ _) = Nothing
+exprSourceSpan (Unused _) = Nothing
+exprSourceSpan (Var ss _) = Just ss
+exprSourceSpan (Op ss _) = Just ss
+exprSourceSpan (IfThenElse _ _ _) = Nothing
+exprSourceSpan (Constructor ss _) = Just ss
+exprSourceSpan (Case _ _) = Nothing
+exprSourceSpan (TypedValue _ _ _) = Nothing
+exprSourceSpan (Let _ _ _) = Nothing
+exprSourceSpan (Do _ _) = Nothing
+exprSourceSpan (Ado _ _ _) = Nothing
+exprSourceSpan (TypeClassDictionary _ _ _) = Nothing
+exprSourceSpan (DeferredDictionary _ _) = Nothing
+exprSourceSpan (DerivedInstancePlaceholder _ _) = Nothing
+exprSourceSpan AnonymousArgument = Nothing
+exprSourceSpan (Hole _) = Nothing
+exprSourceSpan (PositionedValue ss _ _) = Just ss
+
+
 -- |
 -- Metadata that tells where a let binding originated
 --
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 82139ccbe4..8a57e17e5a 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -2,6 +2,7 @@ module Language.PureScript.Docs.AsMarkdown
   ( Docs
   , runDocs
   , moduleAsMarkdown
+  , declAsMarkdown
   , codeToString
   ) where
 
diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs
index 0da65d2251..8c0bd1ada7 100644
--- a/src/Language/PureScript/Docs/Collect.hs
+++ b/src/Language/PureScript/Docs/Collect.hs
@@ -1,6 +1,7 @@
 
 module Language.PureScript.Docs.Collect
   ( collectDocs
+  , parseDocsJsonFile
   ) where
 
 import Protolude hiding (check)
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index f0595ce8aa..1e15273793 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Language.PureScript.Environment where
 
 import Prelude
@@ -27,6 +28,7 @@ import Language.PureScript.Roles (Role(..))
 import Language.PureScript.TypeClassDictionaries (NamedDict)
 import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables)
 import Language.PureScript.Constants.Prim qualified as C
+import Codec.Serialise qualified as S
 
 -- | The @Environment@ defines all values and types which are currently in scope:
 data Environment = Environment
@@ -45,7 +47,7 @@ data Environment = Environment
   -- scope (ie dictionaries brought in by a constrained type).
   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
   -- ^ Type classes
-  } deriving (Show, Generic)
+  } deriving (Show, Generic, S.Serialise)
 
 instance NFData Environment
 
@@ -71,7 +73,7 @@ data TypeClassData = TypeClassData
   -- ^ A sets of arguments that can be used to infer all other arguments.
   , typeClassIsEmpty :: Bool
   -- ^ Whether or not dictionaries for this type class are necessarily empty.
-  } deriving (Show, Generic)
+  } deriving (Show, Generic, S.Serialise)
 
 instance NFData TypeClassData
 
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 57a800d686..1e84131773 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -184,7 +184,7 @@ shushProgress ma =
 -- | Stops any kind of codegen
 shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
-  ma { P.codegen = \_ _ _ -> pure ()
+  ma { P.codegen = \_ _ _ _ _-> pure ()
      , P.ffiCodegen = \_ -> pure ()
      }
 
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 38bfac8b24..0f05f2ba3d 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -10,6 +10,7 @@ import Codec.Serialise (deserialise, serialise)
 import Control.Lens (Field1 (_1), (^.), _1)
 import Control.Monad.Trans.Writer (execWriterT)
 import Data.Aeson (encode)
+import Data.Aeson qualified as A
 import Data.Aeson.Types qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.List qualified as List
@@ -23,8 +24,10 @@ import GHC.Base (String)
 import GHC.Real (Integral (toInteger))
 import Language.LSP.Protocol.Types (Position)
 import Language.LSP.Protocol.Types qualified as LSP
+import Language.PureScript (Ident)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.Declarations (declRefName, declSourceAnn)
+import Language.PureScript.AST.SourcePos (SourcePos (SourcePos))
 import Language.PureScript.AST.Traversals (accumTypes)
 import Language.PureScript.Comments qualified as P
 import Language.PureScript.CoreFn qualified as CF
@@ -45,9 +48,6 @@ import Protolude qualified as Either
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
 import System.FilePath (normalise, (</>))
 import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebugN, logErrorN, logWarnN, mapLoggingT)
-import Language.PureScript (Ident)
-import Data.Aeson qualified as A
-import Language.PureScript.AST.SourcePos (SourcePos (SourcePos))
 
 -- import Control.Monad.Logger (logDebugN)
 
@@ -107,12 +107,6 @@ getCodeFnBindAt path (LSP.Position line col) = do
       =<< fromOnly
       <$> listToMaybe decls
 
--- findLocalBinding :: (P.Ident -> Bool) -> Expr a -> Maybe (CF.Binder a)
--- findLocalBinding f = go
---   where
---     go (Abs _ ident _) | f ident = Just (VarBinder nullSourceAnn ident)
---     go (Let _ binds _) = asum (fmap (go . binder) binds)
---     go _ = Nothing
 
 ------------------------------------------------------------------------------------------------------------------------
 ------------ Externs ---------------------------------------------------------------------------------------------------
@@ -138,15 +132,6 @@ getEfExports moduleNames = do
       ]
   pure $ bimap P.ModuleName deserialise <$> exports
 
-importContainsIdent :: Text -> P.ExternsImport -> Maybe Bool
-importContainsIdent ident import' = case P.eiImportType import' of
-  P.Implicit -> Nothing
-  P.Explicit refs -> Just $ any ((==) ident . printName . P.declRefName) refs
-  P.Hiding refs ->
-    if any ((==) ident . printName . P.declRefName) refs
-      then Just False
-      else Nothing
-
 getEfDeclarationInModule :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
 getEfDeclarationInModule moduleName' name = do
   decls <-
@@ -162,7 +147,7 @@ getEfDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => FilePa
 getEfDeclarationsAtSrcPos path (SourcePos line col) = do
   decls <-
     DB.queryNamed
-      "SELECT value FROM ef_declarations \
+      "SELECT ef_declarations.value FROM ef_declarations \
       \inner join externs on ef_declarations.module_name = externs.module_name \
       \WHERE start_line <= :line AND end_line >= :line \
       \AND start_col <= :column AND end_col >= :column \
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 1c99e878c9..0a895f01de 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -19,17 +19,17 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
+import Language.PureScript.Lsp.Cache (selectAllExternsMap)
 import Language.PureScript.Lsp.State (cacheRebuild)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
+import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.ModuleDependencies qualified as P
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
-import Language.PureScript.Make.Index (addCoreFnIndexing, addExternIndexing)
-import Language.PureScript.Lsp.Cache (selectAllExternsMap)
 
 rebuildFileAndDeps ::
   ( MonadIO m,
@@ -90,8 +90,7 @@ rebuildFile' rebuildDeps srcPath = do
         P.buildMakeActions outputDirectory filePathMap foreigns False
           & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
           & shushProgress
-          & addCoreFnIndexing conn
-          & addExternIndexing conn
+          & addAllIndexing conn
   (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
     newExterns <- P.rebuildModule makeEnv externs m
     unless pureRebuild $
@@ -105,7 +104,7 @@ rebuildFile' rebuildDeps srcPath = do
       logDebugN $ "Rebuilt file: " <> T.pack srcPath
       pure (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
   where
-    codegenTargets = Set.singleton P.JS
+    codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
 -- | Rebuilds a module but opens up its export list first and stores the result
 -- inside the rebuild cache
@@ -121,7 +120,7 @@ rebuildModuleOpen makeEnv externs m = void $ runExceptT do
   (openResult, _) <-
     liftIO $
       P.runMake P.defaultOptions $
-        P.rebuildModule ( shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
+        P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
   case openResult of
     Left _ ->
       throwError (GeneralError "Failed when rebuilding with open exports")
@@ -136,7 +135,7 @@ shushProgress ma =
 shushCodegen :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
   ma
-    { P.codegen = \_ _ _ -> pure (),
+    { P.codegen = \_ _ _ _ _ -> pure (),
       P.ffiCodegen = \_ -> pure ()
     }
 
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 8eaf424340..2172cb4304 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -25,6 +25,7 @@ import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Time (getCurrentTime)
 import GHC.IO (unsafePerformIO)
+import Language.Haskell.TH (listT)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
@@ -46,6 +47,7 @@ import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
 import Language.PureScript.Lsp.Print (printDeclarationType)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
@@ -57,7 +59,6 @@ import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, logDebug, logDebugN, logErrorN, logWarnN, mapLoggingT)
-import Language.Haskell.TH (listT)
 
 type HandlerM config = Server.LspT config (ReaderT LspEnvironment (LoggingT IO))
 
@@ -187,24 +188,20 @@ handlers diagErrs =
                   . to Types.toNormalizedUri
             nullRes = res $ Right $ Types.InR Types.Null
 
+            markdownRes :: Text -> HandlerM () ()
+            markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
+
             markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM () ()
             markdownTypeRes word type' comments =
-              res $
-                Right $
-                  Types.InL $
-                    Types.Hover
-                      ( Types.InL $
-                          Types.MarkupContent
-                            Types.MarkupKind_Markdown
-                            ( "```purescript\n"
-                                <> word
-                                <> annotation
-                                <> "\n"
-                                <> fold (convertComments comments)
-                                <> "\n```"
-                            )
-                      )
-                      Nothing
+              markdownRes $ pursTypeStr word type' comments
+
+            pursTypeStr word type' comments =
+              "```purescript\n"
+                <> word
+                <> annotation
+                <> "\n"
+                <> fold (convertComments comments)
+                <> "\n```"
               where
                 annotation = case type' of
                   Just t -> " :: " <> t
@@ -215,23 +212,23 @@ handlers diagErrs =
 
         forLsp filePathMb \filePath -> do
           corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
+          liftLsp $ logDebugN $ "Corefn expr: " <> show corefnExprMb
           forLsp corefnExprMb \case
             CF.Literal _ _ -> nullRes
             CF.Constructor (_ss, comments, meta) tName cMame _ -> do
               markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
             CF.Var (_ss, comments, meta) (P.Qualified qb ident) -> do
-              typeMb <- liftLsp $ case qb of
-                P.ByModuleName mName ->
-                  fmap (prettyPrintTypeSingleLine . efDeclSourceType)
-                    <$> getEfDeclarationInModule mName (runIdent ident)
-                P.BySourcePos pos' -> do
-                  decls <- getEfDeclarationsAtSrcPos filePath pos'
-                  logDebugN $ "pos: " <> T.pack (show pos')
-                  logDebugN $ "$ length decls at pos: " <> T.pack (show $ length decls)
-                  logDebugN $ "decls at pos: " <> T.pack (show decls)
-                  pure (prettyPrintTypeSingleLine . efDeclSourceType <$> listToMaybe decls)
-
-              markdownTypeRes (P.runIdent ident) typeMb comments
+              case qb of
+                P.ByModuleName mName -> do
+                  docsMb <- liftLsp $ readDeclarationDocsAsMarkdown mName (P.runIdent ident)
+                  case docsMb of
+                    Just docs -> markdownRes docs
+                    _ -> do
+                      declMb <- liftLsp $ getEfDeclarationInModule mName (runIdent ident)
+                      markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
+
+                P.BySourcePos pos' ->
+                  markdownTypeRes (P.runIdent ident) Nothing []
             _ -> nullRes,
       Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDefinition"
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 027c93834f..409a381efd 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -150,13 +150,13 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   -- a bug in the compiler, which should be reported as such.
   -- 2. We do not want to perform any extra work generating docs unless the
   -- user has asked for docs to be generated.
-  let docs = case Docs.convertModule externs exEnv env' m of
+  let docs = case Docs.convertModule externs exEnv env' withPrim of
                Left errs -> internalError $
                  "Failed to produce docs for " ++ T.unpack (runModuleName moduleName)
                  ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs
                Right d -> d
 
-  evalSupplyT nextVar'' $ codegen renamed docs exts
+  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
   return (exts, optimized, docs)
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index f138327c8d..0019dc559f 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -34,7 +34,7 @@ import Data.Text.Encoding qualified as TE
 import Data.Time.Clock (UTCTime)
 import Data.Version (showVersion)
 import Language.JavaScript.Parser qualified as JS
-import Language.PureScript.AST (SourcePos(..))
+import Language.PureScript.AST (SourcePos(..), Module)
 import Language.PureScript.Bundle qualified as Bundle
 import Language.PureScript.CodeGen.JS qualified as J
 import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps)
@@ -58,6 +58,7 @@ import System.Directory (getCurrentDirectory)
 import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirectories)
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr)
+import Language.PureScript.Environment (Environment)
 
 -- | Determines when to rebuild a module
 data RebuildPolicy
@@ -112,7 +113,7 @@ data MakeActions m = MakeActions
   , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
   -- ^ Read the externs file for a module as a string and also return the actual
   -- path for the file.
-  , codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
+  , codegen :: Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
   -- ^ Run the code generator for the module and write any required output files.
   , ffiCodegen :: CF.Module CF.Ann -> m ()
   -- ^ Check ffi and print it in the output directory.
@@ -245,8 +246,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
       writeJSONFile (outputFilename modName "docs.json") docsMod
 
-  codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
-  codegen m docs exts = do
+  codegen :: Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
+  codegen _env _m m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
     codegenTargets <- lift $ asks optionsCodegenTargets
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index aa20d790d7..5ba5229cc4 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -6,6 +6,7 @@
 module Language.PureScript.Make.Index where
 
 import Codec.Serialise (serialise)
+import Control.Exception (handle)
 import Control.Monad.Cont (MonadIO)
 import Control.Monad.Supply (SupplyT (SupplyT))
 import Data.Aeson qualified as A
@@ -20,12 +21,16 @@ import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
 import Language.PureScript (declRefName)
 import Language.PureScript.AST qualified as P
+import Language.PureScript.AST.Declarations (exprSourceSpan)
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.AST.Traversals qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.CoreFn.FromJSON qualified as CFJ
 import Language.PureScript.CoreFn.ToJSON qualified as CFJ
 import Language.PureScript.CoreFn.Traversals (traverseCoreFn)
 import Language.PureScript.Docs.Types qualified as Docs
+import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
@@ -41,14 +46,87 @@ import Language.PureScript.Make qualified as P
 import Language.PureScript.ModuleDependencies qualified as P
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
+import Language.PureScript.Types (everywhereOnTypesM)
 import Paths_purescript qualified as Paths
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
 
+addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+addAllIndexing conn ma =
+  addAstModuleIndexing conn $
+    addEnvIndexing conn $
+      addCoreFnIndexing conn $
+        addExternIndexing conn ma
+
+addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+addAstModuleIndexing conn ma =
+  ma
+    { P.codegen = \env astM m docs ext -> lift (indexAstModule conn astM) <* P.codegen ma env astM m docs ext
+    }
+
+indexAstModule :: (MonadIO m) => Connection -> P.Module -> m ()
+indexAstModule conn (P.Module _ss _comments name decls _exports) = liftIO do
+  SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
+  SQL.execute conn "DELETE FROM ast_expressions WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
+
+  let insertAstExpr :: P.Expr -> IO ()
+      insertAstExpr expr =
+        SQL.execute
+          conn
+          (SQL.Query "INSERT INTO ast_expressions (module_name, value, shown, start_line, end_line, start_col, end_col, length) VALUES (?, ?, ?, ?, ?, ?, ?, ?)")
+          ( P.runModuleName name,
+            serialise expr,
+            show expr :: Text,
+            fmap (P.sourcePosLine . P.spanStart) ss,
+            fmap (P.sourcePosLine . P.spanEnd) ss,
+            fmap (P.sourcePosColumn . P.spanStart) ss,
+            fmap (P.sourcePosColumn . P.spanEnd) ss,
+            T.length (show expr :: Text)
+          )
+        where
+          ss = exprSourceSpan expr
+
+      (handleDecl, _, _) =
+        P.everywhereOnValuesM
+          pure
+          (\e -> e <$ insertAstExpr e)
+          pure
+
+  forM_ decls \decl -> do
+    let (ss, _) = P.declSourceAnn decl
+    SQL.execute
+      conn
+      (SQL.Query "INSERT INTO ast_declarations (module_name, value, shown, start_line, end_line, start_col, end_col) VALUES (?, ?, ?, ?, ?, ?, ?)")
+      ( P.runModuleName name,
+        serialise decl,
+        show decl :: Text,
+        P.sourcePosLine $ P.spanStart ss,
+        P.sourcePosLine $ P.spanEnd ss,
+        P.sourcePosColumn $ P.spanStart ss,
+        P.sourcePosColumn $ P.spanEnd ss
+      )
+    handleDecl decl
+
+addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+addEnvIndexing conn ma =
+  ma
+    { P.codegen = \env astM m docs ext -> lift (indexEnv conn (P.getModuleName astM) env) <* P.codegen ma env astM m docs ext
+    }
+
+indexEnv :: (MonadIO m) => Connection -> P.ModuleName -> P.Environment -> m ()
+indexEnv conn name env =
+  liftIO $
+    SQL.executeNamed
+      conn
+      (SQL.Query "INSERT OR REPLACE INTO envs (module_name, value) VALUES (:module_name, :value)")
+      [ ":module_name" := P.runModuleName name,
+        ":value" := serialise env
+      ]
+
 addCoreFnIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addCoreFnIndexing conn ma =
   ma
-    { P.codegen = \m docs ext -> lift (indexCoreFn conn m) <* P.codegen ma m docs ext
+    { P.codegen = \env astM m docs ext -> lift (indexCoreFn conn m) <* P.codegen ma env astM m docs ext
     }
 
 indexCoreFn :: forall m. (MonadIO m) => Connection -> CF.Module CF.Ann -> m ()
@@ -65,6 +143,10 @@ indexCoreFn conn m = do
         A.encode $ CFJ.moduleToJSON Paths.version m
       )
 
+    SQL.execute conn "DELETE FROM corefn_imports WHERE module_name = ?" (SQL.Only mName)
+    SQL.execute conn "DELETE FROM corefn_declarations WHERE module_name = ?" (SQL.Only mName)
+    SQL.execute conn "DELETE FROM corefn_expressions WHERE module_name = ?" (SQL.Only mName)
+
     forM_ (CF.moduleImports m) \((span, _, _), importedModule) -> do
       SQL.execute
         conn
@@ -94,13 +176,17 @@ indexCoreFn conn m = do
             (handleBind, handleExpr, handleBinder, handleCaseAlternative) =
               traverseCoreFn (insertBind False) insertExpr handleBinder handleCaseAlternative
 
-            insertBind :: Bool -> CF.Bind CF.Ann -> IO (CF.Bind CF.Ann)
-            insertBind topLevel bind = do
+            insertBind' :: Bool -> CF.Bind CF.Ann -> IO ()
+            insertBind' topLevel bind = do
               case bind of
                 CF.NonRec (ss, _comments, _meta) ident expr -> do
                   insertBindQuery topLevel ss ident bind
                 CF.Rec binds -> forM_ binds $ \(((ss, _, _), ident), expr) -> do
                   insertBindQuery topLevel ss ident bind
+
+            insertBind :: Bool -> CF.Bind CF.Ann -> IO (CF.Bind CF.Ann)
+            insertBind topLevel bind = do
+              insertBind' topLevel bind
               handleBind bind
 
             insertExpr :: CF.Expr CF.Ann -> IO (CF.Expr CF.Ann)
@@ -129,13 +215,13 @@ indexCoreFn conn m = do
                 lines' = P.sourcePosLine end - P.sourcePosLine start
                 cols = P.sourcePosColumn end - P.sourcePosColumn start
 
-        void $ insertBind True b
+        void $ insertBind' True b
         void $ handleBind b
 
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma
-    { P.codegen = \m docs ext -> lift (indexExtern conn ext) <* P.codegen ma m docs ext
+    { P.codegen = \env astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma env astM m docs ext
     }
 
 indexExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()
@@ -213,14 +299,17 @@ initDb conn = do
   dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module_name TEXT references corefn_modules(name), imported_module TEXT, UNIQUE(module_name, imported_module) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT references corefn_modules(name), ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name), value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, shown TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, imported_module TEXT, UNIQUE(module_name, imported_module) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, shown TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name), imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT references externs(module_name), export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT references externs(module_name), name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT references externs(module_name) ON DELETE CASCADE, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT references externs(module_name) ON DELETE CASCADE, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
 
   addDbIndexes conn
 
@@ -251,7 +340,206 @@ addDbIndexes conn = do
 
 dropTables :: Connection -> IO ()
 dropTables conn = do
+  SQL.execute_ conn "DROP TABLE IF EXISTS ast_declarations"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ast_expressions"
+  SQL.execute_ conn "DROP TABLE IF EXISTS envs"
   SQL.execute_ conn "DROP TABLE IF EXISTS corefn_modules"
   SQL.execute_ conn "DROP TABLE IF EXISTS corefn_imports"
   SQL.execute_ conn "DROP TABLE IF EXISTS corefn_declarations"
-  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_expressions"
\ No newline at end of file
+  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_expressions"
+  SQL.execute_ conn "DROP TABLE IF EXISTS externs"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ef_exports"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ef_declarations"
+
+-- xzzz =
+--   TypedValue
+--     True
+--     ( Var
+--         (SS {ss = SP {l = 15, c = 31}, end = SP {l = 15, c = 34}})
+--         ( Qualified
+--             ( ByModuleName
+--                 (ModuleName "Data.Functor")
+--             )
+--             (Ident "map")
+--         )
+--     )
+--     ( ForAll
+--         (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--         TypeVarVisible
+--         "f"
+--         ( Just
+--             ( TypeApp
+--                 (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--                 ( TypeApp
+--                     (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--                     ( TypeConstructor
+--                         (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--                         ( Qualified
+--                             ( ByModuleName
+--                                 (ModuleName "Prim")
+--                             )
+--                             (ProperName {runProperName = "Function"})
+--                         )
+--                     )
+--                     ( TypeConstructor
+--                         (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--                         ( Qualified
+--                             ( ByModuleName
+--                                 (ModuleName "Prim")
+--                             )
+--                             (ProperName {runProperName = "Type"})
+--                         )
+--                     )
+--                 )
+--                 ( TypeConstructor
+--                     (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--                     ( Qualified
+--                         ( ByModuleName
+--                             (ModuleName "Prim")
+--                         )
+--                         (ProperName {runProperName = "Type"})
+--                     )
+--                 )
+--             )
+--         )
+--         ( ForAll
+--             (SS {ss = SP {l = 32, c = 10}, end = SP {l = 32, c = 44}}, [])
+--             TypeVarInvisible
+--             "a"
+--             ( Just
+--                 ( TypeConstructor
+--                     (SS {ss = SP {l = 32, c = 25}, end = SP {l = 32, c = 27}}, [])
+--                     ( Qualified
+--                         ( ByModuleName
+--                             (ModuleName "Prim")
+--                         )
+--                         (ProperName {runProperName = "Type"})
+--                     )
+--                 )
+--             )
+--             ( ForAll
+--                 (SS {ss = SP {l = 32, c = 19}, end = SP {l = 32, c = 44}}, [])
+--                 TypeVarInvisible
+--                 "b"
+--                 ( Just
+--                     ( TypeConstructor
+--                         (SS {ss = SP {l = 32, c = 25}, end = SP {l = 32, c = 27}}, [])
+--                         ( Qualified
+--                             ( ByModuleName
+--                                 (ModuleName "Prim")
+--                             )
+--                             (ProperName {runProperName = "Type"})
+--                         )
+--                     )
+--                 )
+--                 ( ConstrainedType
+--                     (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--                     ( Constraint
+--                         { constraintAnn =
+--                             (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, []),
+--                           constraintClass =
+--                             Qualified
+--                               ( ByModuleName
+--                                   (ModuleName "Data.Functor")
+--                               )
+--                               (ProperName {runProperName = "Functor"}),
+--                           constraintKindArgs = [],
+--                           constraintArgs =
+--                             [ TypeVar
+--                                 (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
+--                                 "f"
+--                             ],
+--                           constraintData = Nothing
+--                         }
+--                     )
+--                     ( TypeApp
+--                         (SS {ss = SP {l = 32, c = 22}, end = SP {l = 32, c = 44}}, [])
+--                         ( TypeApp
+--                             (SS {ss = SP {l = 32, c = 22}, end = SP {l = 32, c = 44}}, [])
+--                             ( TypeConstructor
+--                                 (SS {ss = SP {l = 32, c = 31}, end = SP {l = 32, c = 33}}, [])
+--                                 ( Qualified
+--                                     ( ByModuleName
+--                                         (ModuleName "Prim")
+--                                     )
+--                                     (ProperName {runProperName = "Function"})
+--                                 )
+--                             )
+--                             ( TypeApp
+--                                 (SS {ss = SP {l = 32, c = 23}, end = SP {l = 32, c = 29}}, [])
+--                                 ( TypeApp
+--                                     (SS {ss = SP {l = 32, c = 23}, end = SP {l = 32, c = 29}}, [])
+--                                     ( TypeConstructor
+--                                         (SS {ss = SP {l = 32, c = 25}, end = SP {l = 32, c = 27}}, [])
+--                                         ( Qualified
+--                                             ( ByModuleName
+--                                                 (ModuleName "Prim")
+--                                             )
+--                                             (ProperName {runProperName = "Function"})
+--                                         )
+--                                     )
+--                                     ( TypeVar
+--                                         (SS {ss = SP {l = 32, c = 23}, end = SP {l = 32, c = 24}}, [])
+--                                         "a"
+--                                     )
+--                                 )
+--                                 ( TypeVar
+--                                     (SS {ss = SP {l = 32, c = 28}, end = SP {l = 32, c = 29}}, [])
+--                                     "b"
+--                                 )
+--                             )
+--                         )
+--                         ( TypeApp
+--                             (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 44}}, [])
+--                             ( TypeApp
+--                                 (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 44}}, [])
+--                                 ( TypeConstructor
+--                                     (SS {ss = SP {l = 32, c = 38}, end = SP {l = 32, c = 40}}, [])
+--                                     ( Qualified
+--                                         ( ByModuleName
+--                                             (ModuleName "Prim")
+--                                         )
+--                                         (ProperName {runProperName = "Function"})
+--                                     )
+--                                 )
+--                                 ( TypeApp
+--                                     (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 37}}, [])
+--                                     ( TypeVar
+--                                         (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 35}}, [])
+--                                         "f"
+--                                     )
+--                                     ( TypeVar
+--                                         (SS {ss = SP {l = 32, c = 36}, end = SP {l = 32, c = 37}}, [])
+--                                         "a"
+--                                     )
+--                                 )
+--                             )
+--                             ( TypeApp
+--                                 (SS {ss = SP {l = 32, c = 41}, end = SP {l = 32, c = 44}}, [])
+--                                 ( TypeVar
+--                                     (SS {ss = SP {l = 32, c = 41}, end = SP {l = 32, c = 42}}, [])
+--                                     "f"
+--                                 )
+--                                 ( TypeVar
+--                                     (SS {ss = SP {l = 32, c = 43}, end = SP {l = 32, c = 44}}, [])
+--                                     "b"
+--                                 )
+--                             )
+--                         )
+--                     )
+--                 )
+--                 ( Just
+--                     (SkS {rss = 0})
+--                 )
+--             )
+--             ( Just
+--                 (SkS {rss = 1})
+--             )
+--         )
+--         ( Just
+--             (SkS {rss = 2})
+--         )
+--     )
+
+TypedValue True (Var (SourceSpan {spanName = "src/B.purs", spanStart = SourcePos {sourcePosLine = 15, sourcePosColumn = 31}, spanEnd = SourcePos {sourcePosLine = 15, sourcePosColumn = 34}}) (Qualified (ByModuleName (ModuleName "Data.Functor")) (Ident "map"))) (ForAll (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) TypeVarVisible "f" (Just (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))) (ForAll (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 10}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 27}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (ForAll (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 19}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) TypeVarInvisible "b" (Just (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 27}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (ConstrainedType (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (Constraint {constraintAnn = (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]), constraintClass = Qualified (ByModuleName (ModuleName "Data.Functor")) (ProperName {runProperName = "Functor"}), constraintKindArgs = [], constraintArgs = [TypeVar (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) "f"], constraintData = Nothing}) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 22}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 22}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 31}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 33}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 29}},[]) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 29}},[]) (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 27}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 24}},[]) "a")) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 28}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 29}},[]) "b"))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 38}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 40}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 37}},[]) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 35}},[]) "f") (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 37}},[]) "a"))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 42}},[]) "f") (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 43}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) "b"))))) (Just (SkolemScope {runSkolemScope = 0}))) (Just (SkolemScope {runSkolemScope = 1}))) (Just (SkolemScope {runSkolemScope = 2})))
\ No newline at end of file

From 707f6c8bf5a45cc7bc0234b525be327cfe0a3093 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 1 Oct 2024 15:23:22 +0200
Subject: [PATCH 063/297] adds docs lookup

---
 src/Language/PureScript/Lsp/Docs.hs | 20 ++++++++++++++++++++
 1 file changed, 20 insertions(+)
 create mode 100644 src/Language/PureScript/Lsp/Docs.hs

diff --git a/src/Language/PureScript/Lsp/Docs.hs b/src/Language/PureScript/Lsp/Docs.hs
new file mode 100644
index 0000000000..11c96183d6
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Docs.hs
@@ -0,0 +1,20 @@
+module Language.PureScript.Lsp.Docs where
+
+import Control.Arrow ((>>>))
+import Language.PureScript.Docs qualified as Docs
+import Language.PureScript.Docs.Collect (parseDocsJsonFile)
+import Language.PureScript.Docs.Types qualified as P
+import Language.PureScript.Names qualified as P
+import Protolude
+import Language.PureScript.Lsp.Types (LspEnvironment (lspConfig), LspConfig (confOutputPath))
+import Language.PureScript.Docs.AsMarkdown (runDocs, declAsMarkdown)
+
+readDeclarationDocs :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Docs.Declaration)
+readDeclarationDocs modName ident = do
+  outputDirectory <- asks (confOutputPath . lspConfig)
+  modMb <- liftIO $ catchError (Just <$> parseDocsJsonFile outputDirectory modName) (const $ pure Nothing)
+  pure $ modMb >>= (P.modDeclarations >>> find ((== ident) . P.declTitle))
+
+
+readDeclarationDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Text)
+readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$> readDeclarationDocs modName ident 
\ No newline at end of file

From 55c11a3baa7787e1d1a2fc92f8202f38773d1e09 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 02:50:41 +0200
Subject: [PATCH 064/297] hover over typeclasses showing kind

---
 src/Language/PureScript/Lsp/Cache/Query.hs |  14 ++
 src/Language/PureScript/Lsp/Rebuild.hs     |  14 +-
 src/Language/PureScript/Lsp/State.hs       |  16 +--
 src/Language/PureScript/Lsp/Types.hs       |   4 +-
 src/Language/PureScript/Lsp/Util.hs        | 143 +++++++++++++++++----
 src/Language/PureScript/LspSimple.hs       |  31 +++--
 src/Language/PureScript/Make.hs            |  26 ++--
 src/Language/PureScript/Make/Index.hs      |   1 -
 8 files changed, 178 insertions(+), 71 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 0f05f2ba3d..68f23e13f5 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -156,4 +156,18 @@ getEfDeclarationsAtSrcPos path (SourcePos line col) = do
         ":column" := col,
         ":path" := path
       ]
+  pure $ deserialise . fromOnly <$> decls
+
+getAstDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> SourcePos -> m [P.Declaration]
+getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
+  decls <-
+    DB.queryNamed
+      "SELECT value FROM ast_declarations \
+      \WHERE start_line <= :line AND end_line >= :line \
+      \AND start_col <= :column AND end_col >= :column \
+      \AND module_name = :module_name"
+      [ ":line" := line,
+        ":column" := col,
+        ":module_name" := P.runModuleName moduleName'
+      ]
   pure $ deserialise . fromOnly <$> decls
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 0a895f01de..b46e0e928c 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -31,16 +31,6 @@ import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
 
-rebuildFileAndDeps ::
-  ( MonadIO m,
-    MonadError IdeError m,
-    MonadReader LspEnvironment m,
-    MonadLogger m
-  ) =>
-  FilePath ->
-  m (FilePath, P.MultipleErrors)
-rebuildFileAndDeps = rebuildFile' True
-
 rebuildFile ::
   ( MonadIO m,
     MonadError IdeError m,
@@ -120,11 +110,11 @@ rebuildModuleOpen makeEnv externs m = void $ runExceptT do
   (openResult, _) <-
     liftIO $
       P.runMake P.defaultOptions $
-        P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
+        P.rebuildModuleAndGetEnv (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
   case openResult of
     Left _ ->
       throwError (GeneralError "Failed when rebuilding with open exports")
-    Right result -> cacheRebuild result m
+    Right (result, env) -> cacheRebuild result m env
 
 -- | Shuts the compiler up about progress messages
 shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 4aaf791f47..139c173f53 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -1,23 +1,23 @@
 {-# LANGUAGE PackageImports #-}
-module Language.PureScript.Lsp.State where
 
+module Language.PureScript.Lsp.State where
 
 import Control.Concurrent.STM (modifyTVar, readTVar)
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFile (..))
 import Language.PureScript.Lsp.Types
 import Protolude hiding (moduleName, unzip)
-import Language.PureScript.AST.Declarations qualified as P
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> P.Module -> m ()
-cacheRebuild ef module' = do
+cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> P.Module -> P.Environment -> m ()
+cacheRebuild ef module' env = do
   st <- lspStateVar <$> ask
   liftIO . atomically . modifyTVar st $ \x ->
     x
-      { currentFile = Just $ CurrentFile (efModuleName ef) module' ef
+      { currentFile = Just $ CurrentFile (efModuleName ef) module' ef env
       }
 
-
 cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => m (Maybe CurrentFile)
 cachedRebuild = do
   st <- lspStateVar <$> ask
@@ -25,15 +25,13 @@ cachedRebuild = do
     st' <- readTVar st
     pure $ currentFile st'
 
-
-getInitialized :: (MonadIO m, MonadReader LspEnvironment m) => m Bool 
+getInitialized :: (MonadIO m, MonadReader LspEnvironment m) => m Bool
 getInitialized = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ do
     st' <- readTVar st
     pure $ lspInitalized st'
 
-
 initFinished :: (MonadIO m, MonadReader LspEnvironment m) => m ()
 initFinished = do
   st <- lspStateVar <$> ask
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index e8f6561a44..81455cbc82 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -11,6 +11,7 @@ import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude
+import Language.PureScript.Environment qualified as P
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -39,6 +40,7 @@ data LspState = LspState
 data CurrentFile = CurrentFile
   { currentModuleName :: P.ModuleName,
     currentModule :: P.Module,
-    currentExternsFile :: P.ExternsFile
+    currentExternsFile :: P.ExternsFile,
+    currentEnv :: P.Environment
   }
   deriving (Show)
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index be40f75b3a..eba8e34d76 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -1,23 +1,31 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PackageImports #-}
 
 module Language.PureScript.Lsp.Util where
 
 import Codec.Serialise qualified as S
+-- import Language.PureScript.Linter qualified as P
+
+import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view, (^.))
+import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed as Rope
 import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.LSP.Protocol.Types (UInt)
 import Language.LSP.Protocol.Types qualified as Types
-import Language.PureScript.AST qualified as P
+import Language.PureScript qualified as P
 import Language.PureScript.AST.Declarations (declSourceAnn)
-import Language.PureScript.Comments qualified as P
 import Language.PureScript.Errors qualified as Errors
-import Language.PureScript.Externs qualified as P
--- import Language.PureScript.Linter qualified as P
-import Language.PureScript.Types qualified as P
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
+import Language.PureScript.Lsp.Print (printName)
+import Language.PureScript.Lsp.State (cachedRebuild)
+import Language.PureScript.Lsp.Types (CurrentFile (currentEnv), LspEnvironment)
+import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
 import Protolude hiding (to)
+import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
 
 posInSpan :: Types.Position -> Errors.SourceSpan -> Bool
 posInSpan (Types.Position line col) (Errors.SourceSpan _ (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
@@ -57,25 +65,108 @@ getWordOnLine line' col =
     isWordBreak :: Char -> Bool
     isWordBreak = not . (isAlphaNum ||^ (== '_'))
 
--- getNameAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> m (Maybe P.Name)
--- getNameAtPosition pos = do
+getNamesAtPosition :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
+getNamesAtPosition pos modName src = do
+  let search = getWordAt src pos
+  decls <- getAstDeclarationsAtSrcPos modName (positionToSourcePos pos)
+  case head decls of
+    Nothing -> do
+      logDebugN $ "No declaration found at position " <> show pos
+      pure mempty
+    Just decl -> do
+      logDebugN $ "Found declaration: " <> show decl
+      let goDef _ = mempty
+          getDeclName :: P.Declaration -> Set (P.Qualified P.Name)
+          getDeclName decl' = case decl' of
+            P.DataDeclaration _ _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
+            P.TypeSynonymDeclaration _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
+            P.TypeClassDeclaration _ n _ _ _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyClassName n
+            P.TypeDeclaration (P.TypeDeclarationData _ _ st) -> Set.fromList $ getTypeNames st
+            P.ValueDeclaration (P.ValueDeclarationData _ ident _ _ _) -> Set.singleton $ flip P.mkQualified modName $ P.IdentName ident
+            P.ExternDeclaration _ _ st -> Set.fromList $ getTypeNames st
+            P.ExternDataDeclaration _ name st -> Set.fromList (getTypeNames st) <> Set.singleton (flip P.mkQualified modName $ P.TyName name)
+            _ -> mempty
+          getExprName :: P.Expr -> Set (P.Qualified P.Name)
+          getExprName expr = case expr of
+            P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
+            P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
+            P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+            P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+            P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+            P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
+            _ -> mempty
+
+          getTypeNames :: P.SourceType -> [P.Qualified P.Name]
+          getTypeNames = P.everythingOnTypes (<>) goType
+            where
+              goType :: P.SourceType -> [P.Qualified P.Name]
+              goType = \case
+                P.TypeConstructor _ (P.Qualified _ pn) -> [flip P.mkQualified modName $ P.TyName pn]
+                P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
+                -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
+                _ -> []
+
+          goBinder :: P.Binder -> Set (P.Qualified P.Name)
+          goBinder = \case
+            P.ConstructorBinder _ (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.DctorName ident
+            P.OpBinder _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.ValOpName ident
+            P.TypedBinder st _ -> Set.fromList $ getTypeNames st
+            _ -> mempty
+
+          exprNames = P.everythingOnValues (<>) getDeclName getExprName goBinder goDef goDef ^. _1 $ decl
+          typeNames = Set.fromList $ usedTypeNames modName decl
+      pure $
+        Set.filter ((==) search . printName . P.disqualify) $
+          exprNames <> Set.map (flip P.mkQualified modName . P.TyName) typeNames
+
+lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadLogger m, MonadIO m) => P.Qualified P.Name -> m (Maybe P.SourceType)
+lookupTypeInEnv (P.Qualified qb name) = do
+  envMb :: Maybe P.Environment <- fmap currentEnv <$> cachedRebuild
+  logDebugN $ "Looking up " <> show name <> " in environment"
+  -- logDebugN $ "Environment: " <> show envMb
+  pure $
+    envMb
+      >>= ( \(P.Environment {..}) -> case name of
+              P.IdentName ident -> view _1 <$> Map.lookup (P.Qualified qb ident) names
+              P.ValOpName _opName -> Nothing
+              P.TyName tyName ->
+                (view _1 <$> Map.lookup (P.Qualified qb tyName) types)
+                  <|> (view _2 <$> Map.lookup (P.Qualified qb tyName) typeSynonyms)
+              P.TyOpName _opName -> Nothing
+              P.DctorName dctorName -> view _3 <$> Map.lookup (P.Qualified qb dctorName) dataConstructors
+              P.TyClassName tyClassName ->
+                (view _1 <$> Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) types)
+              --  <|> (_ =<< Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) typeClasses)
+              --  <|> (typeClassDictionaries)
+              _ -> Nothing
+              -- P.Qualified (P.ByModuleName mn) n -> P.lookupType n mn env
+              -- P.Qualified (P.BySourcePos _) n -> P.lookupType n (P.moduleName env) env
+          )
+
+-- getNamesAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
+-- getNamesAtPosition pos modName src = do
+--   let search = getWordAt src pos
 --   cacheMb <- cachedRebuild
 --   case getDeclarationAtPos pos =<< P.getModuleDeclarations . currentModule <$> cacheMb of
---     Nothing -> pure Nothing
+--     Nothing -> pure mempty
 --     Just decl -> do
---       let name :: Maybe P.Name
---           name = P.everythingOnValues (<|>) getDeclarationName goDef goDef goDef goDef ^. _1 $ decl
---           goDef _ = Nothing
---           getDeclarationName :: P.Declaration -> Maybe P.Name
---           getDeclarationName = \case
---             _ -> Nothing
-
---       pure name
-  -- where 
-  --   getExprName :: P.Expr -> Maybe P.Name
-  --   getExprName = \case
-  --     P.Var _ q -> Just $ P.IdentName $ P.disqualify q
-  --     _ -> Nothing
+--       let goDef _ = mempty
+--           getDeclName :: P.Declaration -> Set (P.Qualified P.Name)
+--           getDeclName decl' = case decl' of
+--             P.DataDeclaration _ _ n _ _ | P.runProperName n == search -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
+--             P.TypeSynonymDeclaration _ n _ _ | P.runProperName n == search -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
+--             P.TypeClassDeclaration _ n _ _ _ _ | P.runProperName n == search -> Set.singleton $ flip P.mkQualified modName $ P.TyClassName n
+--             _ -> mempty
+--           getExprName :: P.Expr -> Set (P.Qualified P.Name)
+--           getExprName expr = case expr of
+--             P.Var _ (P.Qualified qb ident) | runIdent ident == search -> Set.singleton $ P.Qualified qb $ P.IdentName ident
+--             P.Constructor _ (P.Qualified qb ident) | P.runProperName ident == search -> Set.singleton $ P.Qualified qb $ P.DctorName ident
+--             P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ | P.runProperName ident == search -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+--             _ -> mempty
+
+--           exprNames = P.everythingOnValues (<>) getDeclName getExprName goDef goDef goDef ^. _1 $ decl
+--           typeNames = Set.fromList $ filter ((==) search . P.runProperName) $ usedTypeNames modName decl
+--       pure $ exprNames <> Set.map (flip P.mkQualified modName . P.TyName) typeNames
 
 -- cacheMb
 --   & maybe
@@ -91,7 +182,6 @@ getWordOnLine line' col =
 --       -- pure $ P.IdentName ident
 --       pure Nothing
 
-
 data ExternsDeclarationCategory
   = EDCType
   | EDCTypeSynonym
@@ -134,4 +224,11 @@ efDeclComments = foldr getComments [] . efDeclSourceType
   where
     getComments :: Errors.SourceAnn -> [P.Comment] -> [P.Comment]
     getComments (_, cs) acc = cs ++ acc
-
+    
+sourcePosToPosition :: Errors.SourcePos -> Types.Position
+sourcePosToPosition (Errors.SourcePos line col) =
+  Types.Position (fromIntegral $ line - 1) (fromIntegral $ col - 1)
+
+positionToSourcePos :: Types.Position -> Errors.SourcePos
+positionToSourcePos (Types.Position line col) =
+  Errors.SourcePos (fromIntegral $ line + 1) (fromIntegral $ col + 1)
\ No newline at end of file
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 2172cb4304..16487ffb96 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -36,6 +36,7 @@ import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.AST.SourcePos (SourcePos (sourcePosColumn))
+import Language.PureScript.Constants.TH (ty)
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
@@ -48,12 +49,12 @@ import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
-import Language.PureScript.Lsp.Print (printDeclarationType)
+import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
 import Language.PureScript.Lsp.Types (LspEnvironment)
-import Language.PureScript.Lsp.Util (efDeclComments, efDeclSourceSpan, efDeclSourceType, getWordAt)
-import Language.PureScript.Names (runIdent)
+import Language.PureScript.Lsp.Util (efDeclComments, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
+import Language.PureScript.Names (disqualify, runIdent)
 import Language.PureScript.Names qualified as P
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
@@ -226,10 +227,24 @@ handlers diagErrs =
                     _ -> do
                       declMb <- liftLsp $ getEfDeclarationInModule mName (runIdent ident)
                       markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
-
                 P.BySourcePos pos' ->
                   markdownTypeRes (P.runIdent ident) Nothing []
-            _ -> nullRes,
+            _ -> do
+              vfMb <- Server.getVirtualFile docUri
+              forLsp vfMb \vf -> do
+                let word = getWordAt (VFS._file_text vf) pos
+                mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
+                forLsp mNameMb \mName -> do
+                  names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
+                  liftLsp $ logDebugN $ "Names at position: " <> show (Set.toList names)
+                  forLsp (head names) \name -> do
+                    typeMb <- liftLsp $ lookupTypeInEnv name
+                    liftLsp $ logDebugN $ "Type in env: " <> show typeMb
+                    forLsp typeMb \t -> do
+                      markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) [],
+      --   declMb <- liftLsp $ getEfDeclarationInModule mName name
+      --   markdownTypeRes name (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) []
+      -- -- pure (),
       Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDefinition"
         let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
@@ -391,9 +406,6 @@ spanToRange (Errors.SourceSpan _ start end) =
     (sourcePosToPosition start)
     (sourcePosToPosition end)
 
-sourcePosToPosition :: Errors.SourcePos -> Types.Position
-sourcePosToPosition (Errors.SourcePos line col) =
-  Types.Position (fromIntegral $ line - 1) (fromIntegral $ col - 1)
 
 sendError :: IdeError -> HandlerM config ()
 sendError err =
@@ -403,9 +415,6 @@ sendError err =
         "Something went wrong:\n" <> textError err
     )
 
--- rebuildFile :: FilePath -> LspM Success
--- rebuildFile file = do
---   rebuildFile file  mempty
 
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 409a381efd..aff82b3cfa 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -2,7 +2,7 @@ module Language.PureScript.Make
   (
   -- * Make API
   rebuildModule
-  , rebuildModuleAndGetArtifacts
+  , rebuildModuleAndGetEnv
   , rebuildModule'
   , make
   , inferForeignModules
@@ -24,7 +24,6 @@ import Control.Monad.Trans.Control (MonadBaseControl(..))
 import Control.Monad.Trans.State (runStateT)
 import Control.Monad.Writer.Class (MonadWriter(..), censor)
 import Control.Monad.Writer.Strict (runWriterT)
-import Language.PureScript.CoreFn.Module qualified as CoreFn
 import Data.Function (on)
 import Data.Foldable (fold, for_)
 import Data.List (foldl', sortOn)
@@ -38,7 +37,6 @@ import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..)
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Docs.Convert qualified as Docs
-import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (initEnvironment)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
 import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile)
@@ -56,8 +54,8 @@ import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.CoreFn qualified as CF
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
-import Language.PureScript.CoreFn.Ann (Ann)
 import Control.Lens (Field1(_1), view)
+import Language.PureScript.Environment qualified as P
 
 -- | Rebuild a single module.
 --
@@ -73,16 +71,16 @@ rebuildModule actions externs m = do
   env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs
   rebuildModule' actions env externs m
 
-rebuildModuleAndGetArtifacts
+rebuildModuleAndGetEnv
   :: forall m
    . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => MakeActions m
   -> [ExternsFile]
   -> Module
-  -> m (ExternsFile, CoreFn.Module Ann, Docs.Module)
-rebuildModuleAndGetArtifacts actions externs m = do
+  -> m (ExternsFile, P.Environment)
+rebuildModuleAndGetEnv actions externs m = do
   env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs
-  rebuildModuleAndGetArtifacts' actions env externs m
+  rebuildModuleAndGetEnv' actions env externs m
 
 rebuildModule'
   :: forall m
@@ -92,15 +90,15 @@ rebuildModule'
   -> [ExternsFile]
   -> Module
   -> m ExternsFile
-rebuildModule' act env ext mdl = view _1 <$> rebuildModuleAndGetArtifacts' act env ext mdl 
+rebuildModule' act env ext mdl = view _1 <$> rebuildModuleAndGetEnv' act env ext mdl 
 
-rebuildModuleAndGetArtifacts' :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+rebuildModuleAndGetEnv' :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => MakeActions m
   -> Env
   -> [ExternsFile]
   -> Module
-  -> m (ExternsFile, CoreFn.Module Ann, Docs.Module)
-rebuildModuleAndGetArtifacts' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
+  -> m (ExternsFile, P.Environment)
+rebuildModuleAndGetEnv' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
 
 rebuildModuleWithIndex
   :: forall m
@@ -110,7 +108,7 @@ rebuildModuleWithIndex
   -> [ExternsFile]
   -> Module
   -> Maybe (Int, Int)
-  -> m (ExternsFile,  CoreFn.Module Ann, Docs.Module)
+  -> m (ExternsFile, P.Environment)
 rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
@@ -157,7 +155,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
                Right d -> d
 
   evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
-  return (exts, optimized, docs)
+  return (exts, env')
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
 --
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 5ba5229cc4..41aa9f5b27 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -542,4 +542,3 @@ dropTables conn = do
 --         )
 --     )
 
-TypedValue True (Var (SourceSpan {spanName = "src/B.purs", spanStart = SourcePos {sourcePosLine = 15, sourcePosColumn = 31}, spanEnd = SourcePos {sourcePosLine = 15, sourcePosColumn = 34}}) (Qualified (ByModuleName (ModuleName "Data.Functor")) (Ident "map"))) (ForAll (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) TypeVarVisible "f" (Just (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))) (ForAll (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 10}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 27}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (ForAll (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 19}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) TypeVarInvisible "b" (Just (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 27}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (ConstrainedType (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (Constraint {constraintAnn = (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]), constraintClass = Qualified (ByModuleName (ModuleName "Data.Functor")) (ProperName {runProperName = "Functor"}), constraintKindArgs = [], constraintArgs = [TypeVar (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) "f"], constraintData = Nothing}) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 22}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 22}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 31}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 33}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 29}},[]) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 29}},[]) (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 27}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 24}},[]) "a")) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 28}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 29}},[]) "b"))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeConstructor (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 38}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 40}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 37}},[]) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 35}},[]) "f") (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 37}},[]) "a"))) (TypeApp (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 42}},[]) "f") (TypeVar (SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Functor.purs", spanStart = SourcePos {sourcePosLine = 32, sourcePosColumn = 43}, spanEnd = SourcePos {sourcePosLine = 32, sourcePosColumn = 44}},[]) "b"))))) (Just (SkolemScope {runSkolemScope = 0}))) (Just (SkolemScope {runSkolemScope = 1}))) (Just (SkolemScope {runSkolemScope = 2})))
\ No newline at end of file

From 0d4a271f5e9c839b342189552b43578dda83c13b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 03:20:20 +0200
Subject: [PATCH 065/297] get more docs on hover

---
 src/Language/PureScript/Lsp/Docs.hs  | 13 ++++++----
 src/Language/PureScript/LspSimple.hs | 36 ++++++++++++++++------------
 2 files changed, 30 insertions(+), 19 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Docs.hs b/src/Language/PureScript/Lsp/Docs.hs
index 11c96183d6..0b2695dbad 100644
--- a/src/Language/PureScript/Lsp/Docs.hs
+++ b/src/Language/PureScript/Lsp/Docs.hs
@@ -2,12 +2,13 @@ module Language.PureScript.Lsp.Docs where
 
 import Control.Arrow ((>>>))
 import Language.PureScript.Docs qualified as Docs
+import Language.PureScript.Docs.AsMarkdown (declAsMarkdown, runDocs)
 import Language.PureScript.Docs.Collect (parseDocsJsonFile)
 import Language.PureScript.Docs.Types qualified as P
+import Language.PureScript.Lsp.Print (printName)
+import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig))
 import Language.PureScript.Names qualified as P
 import Protolude
-import Language.PureScript.Lsp.Types (LspEnvironment (lspConfig), LspConfig (confOutputPath))
-import Language.PureScript.Docs.AsMarkdown (runDocs, declAsMarkdown)
 
 readDeclarationDocs :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Docs.Declaration)
 readDeclarationDocs modName ident = do
@@ -15,6 +16,10 @@ readDeclarationDocs modName ident = do
   modMb <- liftIO $ catchError (Just <$> parseDocsJsonFile outputDirectory modName) (const $ pure Nothing)
   pure $ modMb >>= (P.modDeclarations >>> find ((== ident) . P.declTitle))
 
-
 readDeclarationDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Text)
-readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$> readDeclarationDocs modName ident 
\ No newline at end of file
+readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$> readDeclarationDocs modName ident
+
+readQualifiedNameDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.Qualified P.Name -> m (Maybe Text)
+readQualifiedNameDocsAsMarkdown = \case
+  (P.Qualified (P.ByModuleName modName) ident) -> readDeclarationDocsAsMarkdown modName (printName ident)
+  _ -> pure Nothing
\ No newline at end of file
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 16487ffb96..364c6189ae 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -48,7 +48,7 @@ import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
@@ -214,11 +214,18 @@ handlers diagErrs =
         forLsp filePathMb \filePath -> do
           corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
           liftLsp $ logDebugN $ "Corefn expr: " <> show corefnExprMb
-          forLsp corefnExprMb \case
-            CF.Literal _ _ -> nullRes
-            CF.Constructor (_ss, comments, meta) tName cMame _ -> do
-              markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
-            CF.Var (_ss, comments, meta) (P.Qualified qb ident) -> do
+          case corefnExprMb of
+            Just (CF.Literal _ _) -> nullRes
+            Just (CF.Constructor (ss, comments, meta) tName cMame _) -> do
+              docsMb <- liftLsp do
+                logDebugN $ "Span name: " <> show (P.spanName ss)
+                mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
+                logDebugN $ "Module name: " <> show mNameMb
+                maybe (pure Nothing) (flip readDeclarationDocsAsMarkdown (P.runProperName tName)) mNameMb
+              case docsMb of
+                Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
+                Just docs -> markdownRes docs
+            Just (CF.Var (_ss, comments, meta) (P.Qualified qb ident)) -> do
               case qb of
                 P.ByModuleName mName -> do
                   docsMb <- liftLsp $ readDeclarationDocsAsMarkdown mName (P.runIdent ident)
@@ -238,13 +245,14 @@ handlers diagErrs =
                   names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
                   liftLsp $ logDebugN $ "Names at position: " <> show (Set.toList names)
                   forLsp (head names) \name -> do
-                    typeMb <- liftLsp $ lookupTypeInEnv name
-                    liftLsp $ logDebugN $ "Type in env: " <> show typeMb
-                    forLsp typeMb \t -> do
-                      markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) [],
-      --   declMb <- liftLsp $ getEfDeclarationInModule mName name
-      --   markdownTypeRes name (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) []
-      -- -- pure (),
+                    docsMb <- liftLsp $ readQualifiedNameDocsAsMarkdown name
+                    case docsMb of
+                      Nothing -> do
+                        typeMb <- liftLsp $ lookupTypeInEnv name
+                        liftLsp $ logDebugN $ "Type in env: " <> show typeMb
+                        forLsp typeMb \t -> do
+                          markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
+                      Just docs -> markdownRes docs,
       Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDefinition"
         let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
@@ -406,7 +414,6 @@ spanToRange (Errors.SourceSpan _ start end) =
     (sourcePosToPosition start)
     (sourcePosToPosition end)
 
-
 sendError :: IdeError -> HandlerM config ()
 sendError err =
   Server.sendNotification
@@ -415,7 +422,6 @@ sendError err =
         "Something went wrong:\n" <> textError err
     )
 
-
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
 

From bfab3d33f6ba8489bb09cb61c9fa31bb6a6ff085 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 04:45:31 +0200
Subject: [PATCH 066/297] type class go to definition working

---
 src/Language/PureScript/Lsp/Cache/Query.hs |  10 ++
 src/Language/PureScript/Lsp/Docs.hs        |   9 ++
 src/Language/PureScript/Lsp/Util.hs        |   1 +
 src/Language/PureScript/LspSimple.hs       | 113 ++++++++-------------
 src/Language/PureScript/Make/Index.hs      |  11 +-
 5 files changed, 70 insertions(+), 74 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 68f23e13f5..2849d0f008 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -158,6 +158,16 @@ getEfDeclarationsAtSrcPos path (SourcePos line col) = do
       ]
   pure $ deserialise . fromOnly <$> decls
 
+getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.Declaration)
+getAstDeclarationInModule moduleName' name = do
+  decls <-
+    DB.queryNamed
+      "SELECT value FROM ast_declarations WHERE module_name = :module_name AND name = :name"
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := name
+      ]
+  pure $ deserialise . fromOnly <$> listToMaybe decls
+
 getAstDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> SourcePos -> m [P.Declaration]
 getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
   decls <-
diff --git a/src/Language/PureScript/Lsp/Docs.hs b/src/Language/PureScript/Lsp/Docs.hs
index 0b2695dbad..faa6737a5b 100644
--- a/src/Language/PureScript/Lsp/Docs.hs
+++ b/src/Language/PureScript/Lsp/Docs.hs
@@ -9,6 +9,7 @@ import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig))
 import Language.PureScript.Names qualified as P
 import Protolude
+import Language.PureScript.AST.SourcePos qualified as P
 
 readDeclarationDocs :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Docs.Declaration)
 readDeclarationDocs modName ident = do
@@ -22,4 +23,12 @@ readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$
 readQualifiedNameDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.Qualified P.Name -> m (Maybe Text)
 readQualifiedNameDocsAsMarkdown = \case
   (P.Qualified (P.ByModuleName modName) ident) -> readDeclarationDocsAsMarkdown modName (printName ident)
+  _ -> pure Nothing
+
+readDeclarationDocsSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.SourceSpan)
+readDeclarationDocsSourceSpan modName ident = readDeclarationDocs modName ident <&> (=<<) P.declSourceSpan
+
+readQualifiedNameDocsSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => P.Qualified P.Name -> m (Maybe P.SourceSpan)
+readQualifiedNameDocsSourceSpan = \case
+  (P.Qualified (P.ByModuleName modName) ident) -> readDeclarationDocsSourceSpan modName (printName ident)
   _ -> pure Nothing
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index eba8e34d76..e066422ffb 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -136,6 +136,7 @@ lookupTypeInEnv (P.Qualified qb name) = do
               P.DctorName dctorName -> view _3 <$> Map.lookup (P.Qualified qb dctorName) dataConstructors
               P.TyClassName tyClassName ->
                 (view _1 <$> Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) types)
+                -- <|> (srcInstanceType )
               --  <|> (_ =<< Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) typeClasses)
               --  <|> (typeClassDictionaries)
               _ -> Nothing
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 364c6189ae..86b330f9fb 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -11,10 +11,11 @@
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module Language.PureScript.LspSimple (main) where
 
-import Control.Lens ((^.))
+import Control.Lens (Field1 (_1), view, (^.))
 import Control.Lens.Getter (to)
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
@@ -35,8 +36,10 @@ import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
-import Language.PureScript.AST.SourcePos (SourcePos (sourcePosColumn))
+import Language.PureScript.AST.SourcePos (SourcePos (sourcePosColumn), nullSourceSpan)
+import Language.PureScript.AST.SourcePos qualified as P
 import Language.PureScript.Constants.TH (ty)
+import Language.PureScript.CoreFn.Expr (extractAnn)
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
@@ -47,8 +50,8 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), pre
 import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown)
+import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos, getAstDeclarationInModule)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
@@ -60,6 +63,7 @@ import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, logDebug, logDebugN, logErrorN, logWarnN, mapLoggingT)
+import Control.Monad.Cont (MonadTrans(lift))
 
 type HandlerM config = Server.LspT config (ReaderT LspEnvironment (LoggingT IO))
 
@@ -213,14 +217,11 @@ handlers diagErrs =
 
         forLsp filePathMb \filePath -> do
           corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
-          liftLsp $ logDebugN $ "Corefn expr: " <> show corefnExprMb
           case corefnExprMb of
             Just (CF.Literal _ _) -> nullRes
             Just (CF.Constructor (ss, comments, meta) tName cMame _) -> do
               docsMb <- liftLsp do
-                logDebugN $ "Span name: " <> show (P.spanName ss)
                 mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
-                logDebugN $ "Module name: " <> show mNameMb
                 maybe (pure Nothing) (flip readDeclarationDocsAsMarkdown (P.runProperName tName)) mNameMb
               case docsMb of
                 Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
@@ -239,17 +240,14 @@ handlers diagErrs =
             _ -> do
               vfMb <- Server.getVirtualFile docUri
               forLsp vfMb \vf -> do
-                let word = getWordAt (VFS._file_text vf) pos
                 mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
                 forLsp mNameMb \mName -> do
                   names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
-                  liftLsp $ logDebugN $ "Names at position: " <> show (Set.toList names)
                   forLsp (head names) \name -> do
                     docsMb <- liftLsp $ readQualifiedNameDocsAsMarkdown name
                     case docsMb of
                       Nothing -> do
                         typeMb <- liftLsp $ lookupTypeInEnv name
-                        liftLsp $ logDebugN $ "Type in env: " <> show typeMb
                         forLsp typeMb \t -> do
                           markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
                       Just docs -> markdownRes docs,
@@ -274,8 +272,9 @@ handlers diagErrs =
 
         forLsp filePathMb \filePath -> do
           corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
-          forLsp corefnExprMb \case
-            CF.Var (_ss, _comments, _meta) (P.Qualified qb ident) -> do
+          case corefnExprMb of
+            Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
+              liftLsp $ logDebugN $ "Found Corefn Var source span: " <> show ss
               let name = P.runIdent ident
               case qb of
                 P.ByModuleName mName -> do
@@ -287,66 +286,36 @@ handlers diagErrs =
                       locationRes modFp (spanToRange sourceSpan)
                 P.BySourcePos srcPos ->
                   locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-            _ -> nullRes
-
-            --   vfMb <- Server.getVirtualFile uri
-
-            --   for_ vfMb \vf -> do
-            --     let word = getWordAt (VFS._file_text vf) pos
-            --     cache <- liftLsp cachedRebuild
-            --     let moduleName' = case cache of
-            --           Right (Just (mName, _)) -> Just mName
-            --           _ -> Nothing
-
-            --     imports <-
-            --       filePathMb
-            --         & maybe (pure Nothing) (fmap hush . liftLsp . parseImportsFromFile)
-
-            --     let filters :: [Filter]
-            --         filters =
-            --           imports
-            --             & maybe [] (pure . (moduleFilter . insertCurrentModule . Set.fromList . fmap getInputModName) . snd)
-
-            --         getInputModName (n, _, _) = n
-
-            --         insertCurrentModule :: Set P.ModuleName -> Set P.ModuleName
-            --         insertCurrentModule mods = maybe mods (flip Set.insert mods) moduleName'
-
-            --     completions :: Either IdeError [Completion] <- liftLsp $ getExactCompletionsWithPrim word filters moduleName'
-
-            --     sendInfoMsg $ "Completions: " <> show completions
-            --     let withLocation =
-            --           fold completions
-            --             & mapMaybe
-            --               ( \c -> case complLocation c of
-            --                   Just loc -> Just (c, loc)
-            --                   Nothing -> Nothing
-            --               )
-            --             & head
-
-            --     paths <- liftLsp $ Map.map snd . fsModules <$> getFileState
-
-            --     case withLocation of
-            --       Just (completion, location) -> do
-            --         let fpMb =
-            --               Map.lookup (P.ModuleName . complModule $ completion) (either mempty identity paths)
-
-            --         case fpMb of
-            --           Nothing -> do
-            --             sendInfoMsg "No file path for module"
-            --             nullRes
-            --           Just fp ->
-            --             res $
-            --               Right $
-            --                 Types.InL $
-            --                   Types.Definition $
-            --                     Types.InL $
-            --                       Types.Location
-            --                         (Types.filePathToUri fp)
-            --                         (spanToRange location)
-            --       _ -> do
-            --         sendInfoMsg "No location for completion"
-            --         nullRes
+            _ -> do
+              vfMb <- Server.getVirtualFile uri
+              forLsp vfMb \vf -> do
+                mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
+                forLsp mNameMb \mName -> do
+                  names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
+                  forLsp (head names) \name -> do
+                    liftLsp $ logDebugN $ "Found name: " <> show name
+                    spanMb <- liftLsp $ readQualifiedNameDocsSourceSpan name
+                    liftLsp $ logDebugN $ "Found docs span: " <> show spanMb
+                    case spanMb of
+                      _ -> do
+                        case name of
+                          P.Qualified (P.BySourcePos pos') _ -> do
+                            liftLsp $ logDebugN $ "Found source pos: " <> show pos'
+                            locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
+                          P.Qualified (P.ByModuleName nameModule) ident -> do
+                            liftLsp $ logDebugN $ "Found module name: " <> show nameModule
+                            declMb <- liftLsp $ getAstDeclarationInModule nameModule (printName ident)
+                            liftLsp $ logDebugN $ "Found decl: " <> show declMb
+                            forLsp declMb \decl -> do
+                              modFpMb <- liftLsp $ selectExternPathFromModuleName nameModule
+                              forLsp modFpMb \modFp -> do
+                                liftLsp $ logDebugN $ "Found modFp: " <> show modFp
+                                let sourceSpan = P.declSourceSpan decl
+                                liftLsp $ logDebugN $ "Found decl sourceSpan: " <> show sourceSpan
+                                locationRes modFp (spanToRange sourceSpan)
+                      Just span ->
+                        locationRes (P.spanName span) (spanToRange span)
+
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 41aa9f5b27..27f3ecb979 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -96,8 +96,9 @@ indexAstModule conn (P.Module _ss _comments name decls _exports) = liftIO do
     let (ss, _) = P.declSourceAnn decl
     SQL.execute
       conn
-      (SQL.Query "INSERT INTO ast_declarations (module_name, value, shown, start_line, end_line, start_col, end_col) VALUES (?, ?, ?, ?, ?, ?, ?)")
+      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, shown, start_line, end_line, start_col, end_col) VALUES (?, ?, ?, ?, ?, ?, ?, ?)")
       ( P.runModuleName name,
+        printName <$> P.declName decl,
         serialise decl,
         show decl :: Text,
         P.sourcePosLine $ P.spanStart ss,
@@ -299,7 +300,7 @@ initDb conn = do
   dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
@@ -315,6 +316,12 @@ initDb conn = do
 
 addDbIndexes :: Connection -> IO ()
 addDbIndexes conn = do
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_module_name ON ast_declarations (module_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_name ON ast_declarations (name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_start_line ON ast_declarations (start_line)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_end_line ON ast_declarations (end_line)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_expressions_start_line ON ast_expressions (start_line)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_expressions_end_line ON ast_expressions (end_line)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_modules_name ON corefn_modules (name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_modules_path ON corefn_modules (path)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_imports_module ON corefn_imports (module_name)"

From 0238024c3c2f09101e27dca135288e5ed3ab8d15 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 05:24:10 +0200
Subject: [PATCH 067/297] adds logs for no found decl

---
 src/Language/PureScript/CST.hs             |  7 ++++
 src/Language/PureScript/Lsp/Cache/Query.hs |  1 -
 src/Language/PureScript/Lsp/Rebuild.hs     | 27 ++------------
 src/Language/PureScript/Lsp/Util.hs        |  4 +--
 src/Language/PureScript/LspSimple.hs       | 41 +++++++++++-----------
 5 files changed, 31 insertions(+), 49 deletions(-)

diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs
index b8e895fb20..64ca8fbbaf 100644
--- a/src/Language/PureScript/CST.hs
+++ b/src/Language/PureScript/CST.hs
@@ -33,6 +33,7 @@ import Language.PureScript.CST.Monad (Parser, ParserM(..), ParserState(..), LexR
 import Language.PureScript.CST.Parser
 import Language.PureScript.CST.Print
 import Language.PureScript.CST.Types
+import Language.PureScript.AST.SourcePos (SourceAnn)
 
 pureResult :: a -> PartialResult a
 pureResult a = PartialResult a ([], pure a)
@@ -64,6 +65,12 @@ parseFromFiles toFilePath input =
 parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module)
 parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule (lexModule content)
 
+parseCST :: Text -> Either (NE.NonEmpty ParserError) (PartialResult (Module ()))
+parseCST content = parseModule (lexModule content)
+
+parseCSTAnn :: Text -> Either (NE.NonEmpty ParserError) (PartialResult (Module SourcePos))
+parseCSTAnn content = _ (lexModule content)
+
 parseFromFile :: FilePath -> Text -> ([ParserWarning], Either (NE.NonEmpty ParserError) AST.Module)
 parseFromFile fp content = fmap (convertModule fp) <$> parse content
 
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 2849d0f008..dfa9e99a22 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -140,7 +140,6 @@ getEfDeclarationInModule moduleName' name = do
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := name
       ]
-  logDebugN $ "getEfDeclarationInModule decls: " <> show moduleName' <> " . " <> show name <> " : " <> T.pack (show $ length decls)
   pure $ deserialise . fromOnly <$> listToMaybe decls
 
 getEfDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> SourcePos -> m [P.ExternsDeclaration]
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index b46e0e928c..d36e7faf7d 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -29,29 +29,15 @@ import Language.PureScript.ModuleDependencies qualified as P
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
-import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
 
 rebuildFile ::
   ( MonadIO m,
     MonadError IdeError m,
-    MonadReader LspEnvironment m,
-    MonadLogger m
+    MonadReader LspEnvironment m
   ) =>
   FilePath ->
   m (FilePath, P.MultipleErrors)
-rebuildFile = rebuildFile' False
-
-rebuildFile' ::
-  ( MonadIO m,
-    MonadError IdeError m,
-    MonadReader LspEnvironment m,
-    MonadLogger m
-  ) =>
-  Bool ->
-  FilePath ->
-  m (FilePath, P.MultipleErrors)
-rebuildFile' rebuildDeps srcPath = do
-  logDebugN $ "Rebuilding file: " <> T.pack srcPath
+rebuildFile srcPath = do
   (fp, input) <-
     case List.stripPrefix "data:" srcPath of
       Just source -> pure ("", T.pack source)
@@ -62,14 +48,6 @@ rebuildFile' rebuildDeps srcPath = do
     Right m -> pure m
   let moduleName = P.getModuleName m
   externs <- sortExterns m =<< selectAllExternsMap
-  when rebuildDeps do
-    forM_ externs \ef -> do
-      let depSrcPath = P.spanName $ P.efSourceSpan ef
-          modName = P.runModuleName $ P.efModuleName ef
-      when (modName /= "Prim" && T.take 5 modName /= "Prim.") do
-        logDebugN $ "Rebuilding dependency: " <> T.pack depSrcPath
-        void $ rebuildFile' False depSrcPath
-
   outputDirectory <- asks (confOutputPath . lspConfig)
   let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
   let pureRebuild = fp == ""
@@ -91,7 +69,6 @@ rebuildFile' rebuildDeps srcPath = do
       throwError (RebuildError [(fp, input)] errors)
     Right newExterns -> do
       rebuildModuleOpen makeEnv externs m
-      logDebugN $ "Rebuilt file: " <> T.pack srcPath
       pure (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
   where
     codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index e066422ffb..c66ca4f720 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -68,13 +68,13 @@ getWordOnLine line' col =
 getNamesAtPosition :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
 getNamesAtPosition pos modName src = do
   let search = getWordAt src pos
+  logDebugN $ "Looking up " <> search <> " in module " <> P.runModuleName modName
   decls <- getAstDeclarationsAtSrcPos modName (positionToSourcePos pos)
   case head decls of
     Nothing -> do
-      logDebugN $ "No declaration found at position " <> show pos
+      logDebugN "No declaration found at position"
       pure mempty
     Just decl -> do
-      logDebugN $ "Found declaration: " <> show decl
       let goDef _ = mempty
           getDeclName :: P.Declaration -> Set (P.Qualified P.Name)
           getDeclName decl' = case decl' of
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 86b330f9fb..9f72c3370d 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -119,7 +119,6 @@ handlers diagErrs =
             fileName = Types.uriToFilePath uri
         void $ liftLspWithErr do
           waitForInit
-          logDebugN "Rebuilding file from open"
           traverse rebuildFile fileName,
       Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
         liftLsp $ logDebugN "TextDocumentDidChange",
@@ -130,7 +129,6 @@ handlers diagErrs =
             fileName = Types.uriToFilePath uri
         void $ liftLspWithErr do
           waitForInit
-          logDebugN "Rebuilding file from save"
           traverse rebuildFile fileName,
       Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
         cfg <- getConfig
@@ -271,27 +269,30 @@ handlers diagErrs =
             forLsp val f = maybe nullRes f val
 
         forLsp filePathMb \filePath -> do
-          corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
-          case corefnExprMb of
-            Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
-              liftLsp $ logDebugN $ "Found Corefn Var source span: " <> show ss
-              let name = P.runIdent ident
-              case qb of
-                P.ByModuleName mName -> do
-                  declMb <- liftLsp $ getEfDeclarationInModule mName name
-                  forLsp declMb \decl -> do
-                    modFpMb <- liftLsp $ selectExternPathFromModuleName mName
-                    forLsp modFpMb \modFp -> do
-                      let sourceSpan = efDeclSourceSpan decl
-                      locationRes modFp (spanToRange sourceSpan)
-                P.BySourcePos srcPos ->
-                  locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-            _ -> do
+          -- corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
+          -- case corefnExprMb of
+          --   Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
+          --     liftLsp $ logDebugN $ "Found Corefn Var source span: " <> show ss
+          --     let name = P.runIdent ident
+          --     case qb of
+          --       P.ByModuleName mName -> do
+          --         declMb <- liftLsp $ getEfDeclarationInModule mName name
+          --         forLsp declMb \decl -> do
+          --           modFpMb <- liftLsp $ selectExternPathFromModuleName mName
+          --           forLsp modFpMb \modFp -> do
+          --             let sourceSpan = efDeclSourceSpan decl
+          --             locationRes modFp (spanToRange sourceSpan)
+          --       P.BySourcePos srcPos ->
+          --         locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
+            -- _ -> do
               vfMb <- Server.getVirtualFile uri
               forLsp vfMb \vf -> do
                 mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
+                liftLsp $ logDebugN $ "Module name: " <> show mNameMb
+                liftLsp $ logDebugN $ "Pos: " <> show pos
                 forLsp mNameMb \mName -> do
                   names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
+                  liftLsp $ logDebugN $ "Found names: " <> show names
                   forLsp (head names) \name -> do
                     liftLsp $ logDebugN $ "Found name: " <> show name
                     spanMb <- liftLsp $ readQualifiedNameDocsSourceSpan name
@@ -323,11 +324,9 @@ handlers diagErrs =
       let uri :: Uri
           uri = getMsgUri msg
           fileName = Types.uriToFilePath uri
-      logT $ "Rebuilding file: " <> show (uri, fileName)
       case fileName of
         Just file -> do
-          res <- fmap snd <$> liftLspWithErr (waitForInit *> logWarnN "rebuilding for diagnostics" *> rebuildFile file)
-          logT $ "Rebuild result: " <> show res
+          res <- fmap snd <$> liftLspWithErr (rebuildFile file)
           getResultDiagnostics res
         Nothing -> do
           sendInfoMsg $ "No file path for uri: " <> show uri

From 454a1d8f5caca85dd4c3339ba7c3a6dda6066092 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 05:54:39 +0200
Subject: [PATCH 068/297] get smallest declarations first

---
 src/Language/PureScript/CST.hs             |   7 --
 src/Language/PureScript/Lsp/Cache/Query.hs |   3 +-
 src/Language/PureScript/Lsp/Util.hs        |  15 +--
 src/Language/PureScript/LspSimple.hs       | 103 +++++++++++----------
 src/Language/PureScript/Make/Index.hs      |  17 ++--
 5 files changed, 69 insertions(+), 76 deletions(-)

diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs
index 64ca8fbbaf..b8e895fb20 100644
--- a/src/Language/PureScript/CST.hs
+++ b/src/Language/PureScript/CST.hs
@@ -33,7 +33,6 @@ import Language.PureScript.CST.Monad (Parser, ParserM(..), ParserState(..), LexR
 import Language.PureScript.CST.Parser
 import Language.PureScript.CST.Print
 import Language.PureScript.CST.Types
-import Language.PureScript.AST.SourcePos (SourceAnn)
 
 pureResult :: a -> PartialResult a
 pureResult a = PartialResult a ([], pure a)
@@ -65,12 +64,6 @@ parseFromFiles toFilePath input =
 parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module)
 parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule (lexModule content)
 
-parseCST :: Text -> Either (NE.NonEmpty ParserError) (PartialResult (Module ()))
-parseCST content = parseModule (lexModule content)
-
-parseCSTAnn :: Text -> Either (NE.NonEmpty ParserError) (PartialResult (Module SourcePos))
-parseCSTAnn content = _ (lexModule content)
-
 parseFromFile :: FilePath -> Text -> ([ParserWarning], Either (NE.NonEmpty ParserError) AST.Module)
 parseFromFile fp content = fmap (convertModule fp) <$> parse content
 
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index dfa9e99a22..a65409df74 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -174,7 +174,8 @@ getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
       "SELECT value FROM ast_declarations \
       \WHERE start_line <= :line AND end_line >= :line \
       \AND start_col <= :column AND end_col >= :column \
-      \AND module_name = :module_name"
+      \AND module_name = :module_name \
+      \ORDER BY lines ASC, cols ASC"
       [ ":line" := line,
         ":column" := col,
         ":module_name" := P.runModuleName moduleName'
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index c66ca4f720..b27fe2032d 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -70,11 +70,7 @@ getNamesAtPosition pos modName src = do
   let search = getWordAt src pos
   logDebugN $ "Looking up " <> search <> " in module " <> P.runModuleName modName
   decls <- getAstDeclarationsAtSrcPos modName (positionToSourcePos pos)
-  case head decls of
-    Nothing -> do
-      logDebugN "No declaration found at position"
-      pure mempty
-    Just decl -> do
+  pure $ mconcat $  decls <&> \decl -> do
       let goDef _ = mempty
           getDeclName :: P.Declaration -> Set (P.Qualified P.Name)
           getDeclName decl' = case decl' of
@@ -115,8 +111,8 @@ getNamesAtPosition pos modName src = do
 
           exprNames = P.everythingOnValues (<>) getDeclName getExprName goBinder goDef goDef ^. _1 $ decl
           typeNames = Set.fromList $ usedTypeNames modName decl
-      pure $
-        Set.filter ((==) search . printName . P.disqualify) $
+      
+      Set.filter ((==) search . printName . P.disqualify) $
           exprNames <> Set.map (flip P.mkQualified modName . P.TyName) typeNames
 
 lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadLogger m, MonadIO m) => P.Qualified P.Name -> m (Maybe P.SourceType)
@@ -135,10 +131,7 @@ lookupTypeInEnv (P.Qualified qb name) = do
               P.TyOpName _opName -> Nothing
               P.DctorName dctorName -> view _3 <$> Map.lookup (P.Qualified qb dctorName) dataConstructors
               P.TyClassName tyClassName ->
-                (view _1 <$> Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) types)
-                -- <|> (srcInstanceType )
-              --  <|> (_ =<< Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) typeClasses)
-              --  <|> (typeClassDictionaries)
+                view _1 <$> Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) types
               _ -> Nothing
               -- P.Qualified (P.ByModuleName mn) n -> P.lookupType n mn env
               -- P.Qualified (P.BySourcePos _) n -> P.lookupType n (P.moduleName env) env
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 9f72c3370d..c18c6a4f67 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -6,17 +6,18 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 -- {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module Language.PureScript.LspSimple (main) where
 
 import Control.Lens (Field1 (_1), view, (^.))
 import Control.Lens.Getter (to)
+import Control.Monad.Cont (MonadTrans (lift))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
@@ -50,7 +51,7 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), pre
 import Language.PureScript.Ide.Logging (runErrLogger)
 import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos, getAstDeclarationInModule)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
@@ -63,7 +64,6 @@ import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
 import "monad-logger" Control.Monad.Logger (LoggingT, logDebug, logDebugN, logErrorN, logWarnN, mapLoggingT)
-import Control.Monad.Cont (MonadTrans(lift))
 
 type HandlerM config = Server.LspT config (ReaderT LspEnvironment (LoggingT IO))
 
@@ -269,54 +269,55 @@ handlers diagErrs =
             forLsp val f = maybe nullRes f val
 
         forLsp filePathMb \filePath -> do
-          -- corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
-          -- case corefnExprMb of
-          --   Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
-          --     liftLsp $ logDebugN $ "Found Corefn Var source span: " <> show ss
-          --     let name = P.runIdent ident
-          --     case qb of
-          --       P.ByModuleName mName -> do
-          --         declMb <- liftLsp $ getEfDeclarationInModule mName name
-          --         forLsp declMb \decl -> do
-          --           modFpMb <- liftLsp $ selectExternPathFromModuleName mName
-          --           forLsp modFpMb \modFp -> do
-          --             let sourceSpan = efDeclSourceSpan decl
-          --             locationRes modFp (spanToRange sourceSpan)
-          --       P.BySourcePos srcPos ->
-          --         locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-            -- _ -> do
-              vfMb <- Server.getVirtualFile uri
-              forLsp vfMb \vf -> do
-                mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
-                liftLsp $ logDebugN $ "Module name: " <> show mNameMb
-                liftLsp $ logDebugN $ "Pos: " <> show pos
-                forLsp mNameMb \mName -> do
-                  names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
-                  liftLsp $ logDebugN $ "Found names: " <> show names
-                  forLsp (head names) \name -> do
-                    liftLsp $ logDebugN $ "Found name: " <> show name
-                    spanMb <- liftLsp $ readQualifiedNameDocsSourceSpan name
-                    liftLsp $ logDebugN $ "Found docs span: " <> show spanMb
-                    case spanMb of
-                      _ -> do
-                        case name of
-                          P.Qualified (P.BySourcePos pos') _ -> do
-                            liftLsp $ logDebugN $ "Found source pos: " <> show pos'
-                            locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
-                          P.Qualified (P.ByModuleName nameModule) ident -> do
-                            liftLsp $ logDebugN $ "Found module name: " <> show nameModule
-                            declMb <- liftLsp $ getAstDeclarationInModule nameModule (printName ident)
-                            liftLsp $ logDebugN $ "Found decl: " <> show declMb
-                            forLsp declMb \decl -> do
-                              modFpMb <- liftLsp $ selectExternPathFromModuleName nameModule
-                              forLsp modFpMb \modFp -> do
-                                liftLsp $ logDebugN $ "Found modFp: " <> show modFp
-                                let sourceSpan = P.declSourceSpan decl
-                                liftLsp $ logDebugN $ "Found decl sourceSpan: " <> show sourceSpan
-                                locationRes modFp (spanToRange sourceSpan)
-                      Just span ->
-                        locationRes (P.spanName span) (spanToRange span)
-
+          vfMb <- Server.getVirtualFile uri
+          forLsp vfMb \vf -> do
+            mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
+            liftLsp $ logDebugN $ "Module name: " <> show mNameMb
+            liftLsp $ logDebugN $ "Pos: " <> show pos
+            forLsp mNameMb \mName -> do
+              names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
+              liftLsp $ logDebugN $ "Found names: " <> show names
+              case head names of
+                Just name -> do
+                  liftLsp $ logDebugN $ "Found name: " <> show name
+                  spanMb <- liftLsp $ readQualifiedNameDocsSourceSpan name
+                  liftLsp $ logDebugN $ "Found docs span: " <> show spanMb
+                  case spanMb of
+                    _ -> do
+                      case name of
+                        P.Qualified (P.BySourcePos pos') _ -> do
+                          liftLsp $ logDebugN $ "Found source pos: " <> show pos'
+                          locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
+                        P.Qualified (P.ByModuleName nameModule) ident -> do
+                          liftLsp $ logDebugN $ "Found module name: " <> show nameModule
+                          declMb <- liftLsp $ getAstDeclarationInModule nameModule (printName ident)
+                          liftLsp $ logDebugN $ "Found decl: " <> show declMb
+                          forLsp declMb \decl -> do
+                            modFpMb <- liftLsp $ selectExternPathFromModuleName nameModule
+                            forLsp modFpMb \modFp -> do
+                              liftLsp $ logDebugN $ "Found modFp: " <> show modFp
+                              let sourceSpan = P.declSourceSpan decl
+                              liftLsp $ logDebugN $ "Found decl sourceSpan: " <> show sourceSpan
+                              locationRes modFp (spanToRange sourceSpan)
+                    Just span ->
+                      locationRes (P.spanName span) (spanToRange span)
+                _ -> do
+                  corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
+                  case corefnExprMb of
+                    Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
+                      liftLsp $ logDebugN $ "Found Corefn Var source span: " <> show ss
+                      let name = P.runIdent ident
+                      case qb of
+                        P.ByModuleName coreMName -> do
+                          declMb <- liftLsp $ getEfDeclarationInModule coreMName name
+                          forLsp declMb \decl -> do
+                            modFpMb <- liftLsp $ selectExternPathFromModuleName coreMName
+                            forLsp modFpMb \modFp -> do
+                              let sourceSpan = efDeclSourceSpan decl
+                              locationRes modFp (spanToRange sourceSpan)
+                        P.BySourcePos srcPos ->
+                          locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
+                    _ -> nullRes
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 27f3ecb979..bc8d8e39c9 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -94,17 +94,22 @@ indexAstModule conn (P.Module _ss _comments name decls _exports) = liftIO do
 
   forM_ decls \decl -> do
     let (ss, _) = P.declSourceAnn decl
+    let start = P.spanStart ss
+        end = P.spanEnd ss
     SQL.execute
       conn
-      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, shown, start_line, end_line, start_col, end_col) VALUES (?, ?, ?, ?, ?, ?, ?, ?)")
+      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, shown, start_line, end_line, start_col, end_col, lines, cols) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)")
       ( P.runModuleName name,
         printName <$> P.declName decl,
         serialise decl,
         show decl :: Text,
-        P.sourcePosLine $ P.spanStart ss,
-        P.sourcePosLine $ P.spanEnd ss,
-        P.sourcePosColumn $ P.spanStart ss,
-        P.sourcePosColumn $ P.spanEnd ss
+        P.sourcePosLine start,
+        P.sourcePosLine end,
+        P.sourcePosColumn start,
+        P.sourcePosColumn end,
+        P.sourcePosLine end - P.sourcePosLine start,
+        P.sourcePosColumn end - P.sourcePosColumn start
+        
       )
     handleDecl decl
 
@@ -300,7 +305,7 @@ initDb conn = do
   dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"

From 39e1d904314af76282dd2646ce0e9327d561ad21 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 06:57:45 +0200
Subject: [PATCH 069/297] Effect and Unit go to def working

---
 src/Language/PureScript/Lsp/Util.hs  | 150 +++++++++++----------------
 src/Language/PureScript/LspSimple.hs |   1 +
 2 files changed, 63 insertions(+), 88 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index b27fe2032d..f7df11f97e 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -23,7 +23,7 @@ import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (CurrentFile (currentEnv), LspEnvironment)
-import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
+-- import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
 import Protolude hiding (to)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
 
@@ -66,54 +66,67 @@ getWordOnLine line' col =
     isWordBreak = not . (isAlphaNum ||^ (== '_'))
 
 getNamesAtPosition :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
-getNamesAtPosition pos modName src = do
+getNamesAtPosition pos moduleName' src = do
   let search = getWordAt src pos
-  logDebugN $ "Looking up " <> search <> " in module " <> P.runModuleName modName
-  decls <- getAstDeclarationsAtSrcPos modName (positionToSourcePos pos)
-  pure $ mconcat $  decls <&> \decl -> do
-      let goDef _ = mempty
-          getDeclName :: P.Declaration -> Set (P.Qualified P.Name)
-          getDeclName decl' = case decl' of
-            P.DataDeclaration _ _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
-            P.TypeSynonymDeclaration _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
-            P.TypeClassDeclaration _ n _ _ _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyClassName n
-            P.TypeDeclaration (P.TypeDeclarationData _ _ st) -> Set.fromList $ getTypeNames st
-            P.ValueDeclaration (P.ValueDeclarationData _ ident _ _ _) -> Set.singleton $ flip P.mkQualified modName $ P.IdentName ident
-            P.ExternDeclaration _ _ st -> Set.fromList $ getTypeNames st
-            P.ExternDataDeclaration _ name st -> Set.fromList (getTypeNames st) <> Set.singleton (flip P.mkQualified modName $ P.TyName name)
-            _ -> mempty
-          getExprName :: P.Expr -> Set (P.Qualified P.Name)
-          getExprName expr = case expr of
-            P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
-            P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
-            P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-            P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-            P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-            P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
-            _ -> mempty
-
-          getTypeNames :: P.SourceType -> [P.Qualified P.Name]
-          getTypeNames = P.everythingOnTypes (<>) goType
-            where
-              goType :: P.SourceType -> [P.Qualified P.Name]
-              goType = \case
-                P.TypeConstructor _ (P.Qualified _ pn) -> [flip P.mkQualified modName $ P.TyName pn]
-                P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
-                -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
-                _ -> []
-
-          goBinder :: P.Binder -> Set (P.Qualified P.Name)
-          goBinder = \case
-            P.ConstructorBinder _ (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.DctorName ident
-            P.OpBinder _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.ValOpName ident
-            P.TypedBinder st _ -> Set.fromList $ getTypeNames st
-            _ -> mempty
-
-          exprNames = P.everythingOnValues (<>) getDeclName getExprName goBinder goDef goDef ^. _1 $ decl
-          typeNames = Set.fromList $ usedTypeNames modName decl
-      
-      Set.filter ((==) search . printName . P.disqualify) $
-          exprNames <> Set.map (flip P.mkQualified modName . P.TyName) typeNames
+  logDebugN $ "Looking up " <> search <> " in module " <> P.runModuleName moduleName'
+  decls <- getAstDeclarationsAtSrcPos moduleName' (positionToSourcePos pos)
+  logDebugN $ "Found declarations: " <> T.pack (show $ length decls) <> show (fmap (T.take 400 . show) decls)
+  pure $
+    mconcat $
+      decls <&> \decl -> do
+        let goDef m _ = (m, mempty)
+            getDeclName :: P.ModuleName -> P.Declaration -> (P.ModuleName, Set (P.Qualified P.Name))
+            getDeclName modName decl' = case decl' of
+              P.ImportDeclaration _ newMod _ _ -> (newMod, mempty)
+              _ ->
+                (modName,)
+                  case decl' of
+                    P.DataDeclaration _ _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
+                    P.TypeSynonymDeclaration _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
+                    P.TypeClassDeclaration _ n _ _ _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyClassName n
+                    P.TypeDeclaration (P.TypeDeclarationData _ _ st) -> Set.fromList $ getTypeNames st
+                    P.ValueDeclaration (P.ValueDeclarationData _ ident _ _ _) ->
+                      Set.singleton $ flip P.mkQualified modName $ P.IdentName ident
+                    P.ExternDeclaration _ _ st -> Set.fromList $ getTypeNames st
+                    P.ExternDataDeclaration _ name st ->
+                      Set.fromList (getTypeNames st)
+                        <> Set.singleton (flip P.mkQualified modName $ P.TyName name)
+                    _ -> mempty
+
+            getExprName :: P.ModuleName -> P.Expr -> (P.ModuleName, Set (P.Qualified P.Name))
+            getExprName modName expr = (modName,) case expr of
+              P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
+              P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
+              P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+              P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+              P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+              P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
+              _ -> mempty
+
+            getTypeNames :: P.SourceType -> [P.Qualified P.Name]
+            getTypeNames = P.everythingOnTypes (<>) goType
+              where
+                goType :: P.SourceType -> [P.Qualified P.Name]
+                goType = \case
+                  P.TypeConstructor _ ctr -> [fmap P.TyName ctr]
+                  P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
+                  -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
+                  _ -> []
+
+            goBinder :: P.ModuleName -> P.Binder -> (P.ModuleName, Set (P.Qualified P.Name))
+            goBinder modName b = (modName,) case b of
+              P.ConstructorBinder _ (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.DctorName ident
+              P.OpBinder _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.ValOpName ident
+              P.TypedBinder st _ -> Set.fromList $ getTypeNames st
+              _ -> mempty
+
+            exprNames = P.everythingWithContextOnValues moduleName' Set.empty (<>) getDeclName getExprName goBinder goDef goDef ^. _1 $ decl
+        -- typeNames = Set.fromList $ usedTypeNames moduleName' decl
+
+        Set.filter ((==) search . printName . P.disqualify) $
+          exprNames
+
+-- <> Set.map (flip P.mkQualified moduleName' . P.TyName) typeNames
 
 lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadLogger m, MonadIO m) => P.Qualified P.Name -> m (Maybe P.SourceType)
 lookupTypeInEnv (P.Qualified qb name) = do
@@ -137,45 +150,6 @@ lookupTypeInEnv (P.Qualified qb name) = do
               -- P.Qualified (P.BySourcePos _) n -> P.lookupType n (P.moduleName env) env
           )
 
--- getNamesAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
--- getNamesAtPosition pos modName src = do
---   let search = getWordAt src pos
---   cacheMb <- cachedRebuild
---   case getDeclarationAtPos pos =<< P.getModuleDeclarations . currentModule <$> cacheMb of
---     Nothing -> pure mempty
---     Just decl -> do
---       let goDef _ = mempty
---           getDeclName :: P.Declaration -> Set (P.Qualified P.Name)
---           getDeclName decl' = case decl' of
---             P.DataDeclaration _ _ n _ _ | P.runProperName n == search -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
---             P.TypeSynonymDeclaration _ n _ _ | P.runProperName n == search -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
---             P.TypeClassDeclaration _ n _ _ _ _ | P.runProperName n == search -> Set.singleton $ flip P.mkQualified modName $ P.TyClassName n
---             _ -> mempty
---           getExprName :: P.Expr -> Set (P.Qualified P.Name)
---           getExprName expr = case expr of
---             P.Var _ (P.Qualified qb ident) | runIdent ident == search -> Set.singleton $ P.Qualified qb $ P.IdentName ident
---             P.Constructor _ (P.Qualified qb ident) | P.runProperName ident == search -> Set.singleton $ P.Qualified qb $ P.DctorName ident
---             P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ | P.runProperName ident == search -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
---             _ -> mempty
-
---           exprNames = P.everythingOnValues (<>) getDeclName getExprName goDef goDef goDef ^. _1 $ decl
---           typeNames = Set.fromList $ filter ((==) search . P.runProperName) $ usedTypeNames modName decl
---       pure $ exprNames <> Set.map (flip P.mkQualified modName . P.TyName) typeNames
-
--- cacheMb
---   & maybe
---     (pure _)
---     \CurrentFile {..} -> do
-
---       -- let module' = P.efModule currentExterns
---       -- let decls = P.getModuleDeclarations module'
---       -- let file = P.efSource currentExterns
---       -- let word = getWordAt file Types.Position {..}
---       -- let decl = getDeclarationAtPos Types.Position {..} decls
---       -- let ident = P.Ident (P.IdentName $ P.Ident word)
---       -- pure $ P.IdentName ident
---       pure Nothing
-
 data ExternsDeclarationCategory
   = EDCType
   | EDCTypeSynonym
@@ -218,7 +192,7 @@ efDeclComments = foldr getComments [] . efDeclSourceType
   where
     getComments :: Errors.SourceAnn -> [P.Comment] -> [P.Comment]
     getComments (_, cs) acc = cs ++ acc
-    
+
 sourcePosToPosition :: Errors.SourcePos -> Types.Position
 sourcePosToPosition (Errors.SourcePos line col) =
   Types.Position (fromIntegral $ line - 1) (fromIntegral $ col - 1)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index c18c6a4f67..6cff097af5 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -277,6 +277,7 @@ handlers diagErrs =
             forLsp mNameMb \mName -> do
               names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
               liftLsp $ logDebugN $ "Found names: " <> show names
+              
               case head names of
                 Just name -> do
                   liftLsp $ logDebugN $ "Found name: " <> show name

From 8313d3a1c6513d9d6f928436555ed7983c678f76 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 11:30:38 +0200
Subject: [PATCH 070/297] stop unneeded indexing

---
 src/Language/PureScript/AST/Declarations.hs |   7 --
 src/Language/PureScript/Lsp/Cache/Query.hs  |  17 ++-
 src/Language/PureScript/Lsp/Util.hs         |  24 ++++-
 src/Language/PureScript/LspSimple.hs        | 114 ++++++++++++++++----
 src/Language/PureScript/Make/Index.hs       |  69 ++++++------
 5 files changed, 170 insertions(+), 61 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 54898a5ce5..bd288518ea 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -508,13 +508,6 @@ declSourceAnn (ImportDeclaration sa _ _ _) = sa
 declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa
 declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _ _ _ _) = sa
 
--- declSourceType :: Declaration -> SourceType
--- declSourceType (DataDeclaration td _ _ _) = tydeclType td
--- declSourceType (TypeDeclaration td) = tydeclType td
--- declSourceType (KindDeclaration _ _ _ ty) = ty
--- declSourceType (RoleDeclaration RoleDeclarationData{..}) = foldr (\_ ty -> SourceTypeApp ty C.TyType) C.TyType rdeclRoles
-
-
 declSourceSpan :: Declaration -> SourceSpan
 declSourceSpan = fst . declSourceAnn
 
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index a65409df74..b9ac4c16c9 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -180,4 +180,19 @@ getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
         ":column" := col,
         ":module_name" := P.runModuleName moduleName'
       ]
-  pure $ deserialise . fromOnly <$> decls
\ No newline at end of file
+  pure $ deserialise . fromOnly <$> decls
+
+
+getAstDeclarationsStartingWith :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m [(P.ModuleName, P.Declaration)]
+getAstDeclarationsStartingWith moduleName' prefix = do
+  decls :: [(Text, Lazy.ByteString )] <-
+    DB.queryNamed
+      "SELECT value, module_name FROM ast_declarations \
+      \WHERE (module_name = :module_name OR exported) \
+      \AND name LIKE :prefix \
+      \ORDER BY name ASC \
+      \LIMIT 100"
+      [ ":module_name" := P.runModuleName moduleName',
+        ":prefix" := prefix <> "%"
+      ]
+  pure $ bimap P.ModuleName deserialise <$> decls
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index f7df11f97e..5d7caacba7 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -46,7 +46,7 @@ getWordAt file Types.Position {..} =
 
 getWordOnLine :: Text -> UInt -> Text
 getWordOnLine line' col =
-  let start = getPrevWs (fromIntegral col) line'
+  let start = getPrevWs (fromIntegral col - 1) line'
       end = getNextWs (fromIntegral col) line'
    in T.strip $ T.take (end - start) $ T.drop start line'
   where
@@ -63,7 +63,7 @@ getWordOnLine line' col =
       _ -> getPrevWs (idx - 1) txt
 
     isWordBreak :: Char -> Bool
-    isWordBreak = not . (isAlphaNum ||^ (== '_'))
+    isWordBreak = not . (isAlphaNum ||^ (== '_') ||^ (== '.'))
 
 getNamesAtPosition :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
 getNamesAtPosition pos moduleName' src = do
@@ -199,4 +199,22 @@ sourcePosToPosition (Errors.SourcePos line col) =
 
 positionToSourcePos :: Types.Position -> Errors.SourcePos
 positionToSourcePos (Types.Position line col) =
-  Errors.SourcePos (fromIntegral $ line + 1) (fromIntegral $ col + 1)
\ No newline at end of file
+  Errors.SourcePos (fromIntegral $ line + 1) (fromIntegral $ col + 1)
+
+declToCompletionItemKind :: P.Declaration -> Maybe Types.CompletionItemKind
+declToCompletionItemKind = \case 
+  P.DataDeclaration {} -> Just Types.CompletionItemKind_EnumMember
+  P.TypeSynonymDeclaration {} -> Just Types.CompletionItemKind_Struct
+  P.DataBindingGroupDeclaration {} -> Nothing 
+  P.TypeClassDeclaration {} -> Just Types.CompletionItemKind_Interface
+  P.TypeDeclaration {} -> Just Types.CompletionItemKind_Class
+  P.ValueDeclaration {} -> Just Types.CompletionItemKind_Value
+  P.KindDeclaration {} -> Just Types.CompletionItemKind_Class
+  P.RoleDeclaration {} -> Nothing
+  P.ExternDeclaration {} -> Just Types.CompletionItemKind_Value
+  _ -> Nothing
+
+  
+
+  
+  
\ No newline at end of file
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 6cff097af5..fe8791cb52 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -20,6 +20,7 @@ import Control.Lens.Getter (to)
 import Control.Monad.Cont (MonadTrans (lift))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
+import Data.Aeson qualified as A
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
@@ -49,15 +50,15 @@ import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), prettyPrintTypeSingleLine, textError)
 import Language.PureScript.Ide.Logging (runErrLogger)
-import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll))
+import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll), declarationType, _IdeDeclModule)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
 import Language.PureScript.Lsp.Types (LspEnvironment)
-import Language.PureScript.Lsp.Util (efDeclComments, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclComments, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Names (disqualify, runIdent)
 import Language.PureScript.Names qualified as P
 import Protolude hiding (to)
@@ -277,7 +278,7 @@ handlers diagErrs =
             forLsp mNameMb \mName -> do
               names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
               liftLsp $ logDebugN $ "Found names: " <> show names
-              
+
               case head names of
                 Just name -> do
                   liftLsp $ logDebugN $ "Found name: " <> show name
@@ -318,7 +319,97 @@ handlers diagErrs =
                               locationRes modFp (spanToRange sourceSpan)
                         P.BySourcePos srcPos ->
                           locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-                    _ -> nullRes
+                    _ -> nullRes,
+      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
+        liftLsp $ logDebugN "SMethod_TextDocumentCompletion"
+        let Types.CompletionParams docIdent pos _prog _prog' completionCtx = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            uri :: Types.NormalizedUri
+            uri =
+              req
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to Types.toNormalizedUri
+
+            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp val f = maybe nullRes f val
+
+        liftLsp $ logDebugN $ "Completion params: " <> show completionCtx
+        liftLsp $ logDebugN $ "filePathMb: " <> show filePathMb
+        forLsp filePathMb \filePath -> do
+          vfMb <- Server.getVirtualFile uri
+          forLsp vfMb \vf -> do
+            let word = getWordAt (VFS._file_text vf) pos
+            liftLsp $ logDebugN $ "Word: " <> show word <> " len " <> show (T.length word)
+            if word == ""
+              then nullRes
+              else do
+                mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
+                liftLsp $ logDebugN $ "Module name: " <> show mNameMb
+                forLsp mNameMb \mName -> do
+                  decls <- liftLsp $ getAstDeclarationsStartingWith mName word
+                  liftLsp $ logDebugN $ "Found decls: " <> show decls
+                  declDocs <-
+                    Map.fromList . catMaybes <$> forM decls \(declModule, decl) -> do
+                      let name = printName <$> P.declName decl
+                      docsMb <- liftLsp $ maybe (pure Nothing) (readDeclarationDocsAsMarkdown declModule) name
+                      pure $ (decl,) <$> docsMb
+                  res $
+                    Right $
+                      Types.InL $
+                        decls <&> \(declModule, decl) ->
+                          Types.CompletionItem
+                            { _label = foldMap printName (P.declName decl),
+                              _labelDetails =
+                                Just $
+                                  Types.CompletionItemLabelDetails
+                                    (Just $ printDeclarationType decl)
+                                    (convertComments $ snd $ P.declSourceAnn decl),
+                              _kind = declToCompletionItemKind decl,
+                              _tags = Nothing, --  Maybe [Types.CompletionItemTag]
+                              _detail = Just $ printDeclarationType decl,
+                              _documentation =
+                                Types.InR . Types.MarkupContent Types.MarkupKind_Markdown
+                                  <$> Map.lookup decl declDocs, 
+                              _deprecated = Nothing, --  Maybe Bool
+                              _preselect = Nothing, --  Maybe Bool
+                              _sortText = Nothing, --  Maybe Text
+                              _filterText = Nothing, --  Maybe Text
+                              _insertText = Nothing, --  Maybe Text
+                              _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
+                              _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
+                              _textEdit = Nothing, --  Maybe
+                              --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                              _textEditText = Nothing, --  Maybe Text
+                              _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
+                              _commitCharacters = Nothing, --  Maybe [Text]
+                              _command = Nothing, --  Maybe Types.Command
+                              _data_ = Nothing --  Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
+                            }
+
+                            --                           _label :: Text
+                            -- _labelDetails :: Maybe Types.CompletionItemLabelDetails
+                            -- _kind :: Maybe Types.CompletionItemKind
+                            -- _tags :: Maybe [Types.CompletionItemTag]
+                            -- _detail :: Maybe Text
+                            -- _documentation :: Maybe (Text Types.|? Types.MarkupContent)
+                            -- _deprecated :: Maybe Bool
+                            -- _preselect :: Maybe Bool
+                            -- _sortText :: Maybe Text
+                            -- _filterText :: Maybe Text
+                            -- _insertText :: Maybe Text
+                            -- _insertTextFormat :: Maybe Types.InsertTextFormat
+                            -- _insertTextMode :: Maybe Types.InsertTextMode
+                            -- _textEdit :: Maybe
+                            --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                            -- _textEditText :: Maybe Text
+                            -- _additionalTextEdits :: Maybe [Types.TextEdit]
+                            -- _commitCharacters :: Maybe [Text]
+                            -- _command :: Maybe Types.Command
+                            -- _data_ :: Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -483,16 +574,3 @@ logToFile txt =
 --   let insertPrim = Map.union idePrimDeclarations
 --   pure (getExactCompletions search filters (insertPrim modules))
 -- z = getAllModules
-
-completionToHoverInfo :: Text -> Completion -> Text
-completionToHoverInfo word Completion {..} =
-  typeStr <> "\n" <> fromMaybe "" complDocumentation
-  where
-    typeStr =
-      "```purescript\n"
-        <> compactTypeStr
-        <> (if showExpanded then "\n" <> expandedTypeStr else "")
-        <> "\n```"
-    showExpanded = complExpandedType /= "" && (complExpandedType /= complType)
-    compactTypeStr = word <> " :: " <> complType
-    expandedTypeStr = word <> " :: " <> complExpandedType
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index bc8d8e39c9..f726b1be46 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -54,7 +54,7 @@ import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
   addAstModuleIndexing conn $
-    addEnvIndexing conn $
+    -- addEnvIndexing conn $
       addCoreFnIndexing conn $
         addExternIndexing conn ma
 
@@ -65,11 +65,43 @@ addAstModuleIndexing conn ma =
     }
 
 indexAstModule :: (MonadIO m) => Connection -> P.Module -> m ()
-indexAstModule conn (P.Module _ss _comments name decls _exports) = liftIO do
+indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) = liftIO do
   SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
   SQL.execute conn "DELETE FROM ast_expressions WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
+  
+  let exports = Set.fromList $ P.exportedDeclarations m
 
-  let insertAstExpr :: P.Expr -> IO ()
+  forM_ decls \decl -> do
+    let (ss, _) = P.declSourceAnn decl
+    let start = P.spanStart ss
+        end = P.spanEnd ss
+    SQL.executeNamed 
+      conn 
+      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, shown, start_line, end_line, start_col, end_col, lines, cols, exported) VALUES (:module_name, :name, :value, :shown, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+      [ ":module_name" := P.runModuleName name,
+        ":name" := printName <$> P.declName decl,
+        ":value" := serialise decl,
+        ":shown" :=( show decl :: Text),
+        ":start_line" := P.sourcePosLine start,
+        ":end_line" := P.sourcePosLine end,
+        ":start_col" := P.sourcePosColumn start,
+        ":end_col" := P.sourcePosColumn end,
+        ":lines" := P.sourcePosLine end - P.sourcePosLine start,
+        ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
+        ":exported" := Set.member decl exports
+      ]
+      
+
+insertDeclExprs :: (MonadIO m) => Connection -> P.ModuleName ->  P.Declaration -> m ()
+insertDeclExprs conn name decl = liftIO $ void $ handleDecl decl
+  where
+      (handleDecl, _, _) =
+        P.everywhereOnValuesM
+          pure
+          (\e -> e <$ insertAstExpr e)
+          pure
+
+      insertAstExpr :: P.Expr -> IO ()
       insertAstExpr expr =
         SQL.execute
           conn
@@ -86,33 +118,6 @@ indexAstModule conn (P.Module _ss _comments name decls _exports) = liftIO do
         where
           ss = exprSourceSpan expr
 
-      (handleDecl, _, _) =
-        P.everywhereOnValuesM
-          pure
-          (\e -> e <$ insertAstExpr e)
-          pure
-
-  forM_ decls \decl -> do
-    let (ss, _) = P.declSourceAnn decl
-    let start = P.spanStart ss
-        end = P.spanEnd ss
-    SQL.execute
-      conn
-      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, shown, start_line, end_line, start_col, end_col, lines, cols) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)")
-      ( P.runModuleName name,
-        printName <$> P.declName decl,
-        serialise decl,
-        show decl :: Text,
-        P.sourcePosLine start,
-        P.sourcePosLine end,
-        P.sourcePosColumn start,
-        P.sourcePosColumn end,
-        P.sourcePosLine end - P.sourcePosLine start,
-        P.sourcePosColumn end - P.sourcePosColumn start
-        
-      )
-    handleDecl decl
-
 addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addEnvIndexing conn ma =
   ma
@@ -302,10 +307,10 @@ insertEfExport conn moduleName' dr = do
 
 initDb :: Connection -> IO ()
 initDb conn = do
-  dropTables conn
+  -- dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"

From 65e3741b76a5723a5df848869712f0e8cc20685b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 12:18:36 +0200
Subject: [PATCH 071/297] suggestions looking decent

---
 src/Language/PureScript/Lsp/Cache/Query.hs |   2 +-
 src/Language/PureScript/Lsp/Print.hs       |   5 +
 src/Language/PureScript/LspSimple.hs       | 104 +++++++++++----------
 3 files changed, 60 insertions(+), 51 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index b9ac4c16c9..f0b01618ba 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -187,7 +187,7 @@ getAstDeclarationsStartingWith :: (MonadIO m, MonadReader LspEnvironment m) => P
 getAstDeclarationsStartingWith moduleName' prefix = do
   decls :: [(Text, Lazy.ByteString )] <-
     DB.queryNamed
-      "SELECT value, module_name FROM ast_declarations \
+      "SELECT module_name, value FROM ast_declarations \
       \WHERE (module_name = :module_name OR exported) \
       \AND name LIKE :prefix \
       \ORDER BY name ASC \
diff --git a/src/Language/PureScript/Lsp/Print.hs b/src/Language/PureScript/Lsp/Print.hs
index 221ff79c92..440ff559dc 100644
--- a/src/Language/PureScript/Lsp/Print.hs
+++ b/src/Language/PureScript/Lsp/Print.hs
@@ -21,6 +21,11 @@ printDeclarationType decl =
       accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
         decl
 
+printDeclarationTypeMb :: P.Declaration -> Maybe Text
+printDeclarationTypeMb decl =
+    (head :: [Text] -> Maybe Text) $
+      accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
+        decl
 
 printName :: P.Name -> Text
 printName = \case
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index fe8791cb52..09fc45a314 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -54,7 +54,7 @@ import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
-import Language.PureScript.Lsp.Print (printDeclarationType, printName)
+import Language.PureScript.Lsp.Print (printDeclarationType, printDeclarationTypeMb, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
 import Language.PureScript.Lsp.Types (LspEnvironment)
@@ -361,55 +361,56 @@ handlers diagErrs =
                     Right $
                       Types.InL $
                         decls <&> \(declModule, decl) ->
-                          Types.CompletionItem
-                            { _label = foldMap printName (P.declName decl),
-                              _labelDetails =
-                                Just $
-                                  Types.CompletionItemLabelDetails
-                                    (Just $ printDeclarationType decl)
-                                    (convertComments $ snd $ P.declSourceAnn decl),
-                              _kind = declToCompletionItemKind decl,
-                              _tags = Nothing, --  Maybe [Types.CompletionItemTag]
-                              _detail = Just $ printDeclarationType decl,
-                              _documentation =
-                                Types.InR . Types.MarkupContent Types.MarkupKind_Markdown
-                                  <$> Map.lookup decl declDocs, 
-                              _deprecated = Nothing, --  Maybe Bool
-                              _preselect = Nothing, --  Maybe Bool
-                              _sortText = Nothing, --  Maybe Text
-                              _filterText = Nothing, --  Maybe Text
-                              _insertText = Nothing, --  Maybe Text
-                              _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
-                              _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
-                              _textEdit = Nothing, --  Maybe
-                              --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
-                              _textEditText = Nothing, --  Maybe Text
-                              _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
-                              _commitCharacters = Nothing, --  Maybe [Text]
-                              _command = Nothing, --  Maybe Types.Command
-                              _data_ = Nothing --  Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
-                            }
-
-                            --                           _label :: Text
-                            -- _labelDetails :: Maybe Types.CompletionItemLabelDetails
-                            -- _kind :: Maybe Types.CompletionItemKind
-                            -- _tags :: Maybe [Types.CompletionItemTag]
-                            -- _detail :: Maybe Text
-                            -- _documentation :: Maybe (Text Types.|? Types.MarkupContent)
-                            -- _deprecated :: Maybe Bool
-                            -- _preselect :: Maybe Bool
-                            -- _sortText :: Maybe Text
-                            -- _filterText :: Maybe Text
-                            -- _insertText :: Maybe Text
-                            -- _insertTextFormat :: Maybe Types.InsertTextFormat
-                            -- _insertTextMode :: Maybe Types.InsertTextMode
-                            -- _textEdit :: Maybe
-                            --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
-                            -- _textEditText :: Maybe Text
-                            -- _additionalTextEdits :: Maybe [Types.TextEdit]
-                            -- _commitCharacters :: Maybe [Text]
-                            -- _command :: Maybe Types.Command
-                            -- _data_ :: Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
+                          let label = foldMap printName (P.declName decl)
+                           in Types.CompletionItem
+                                { _label = label,
+                                  _labelDetails =
+                                    Just $
+                                      Types.CompletionItemLabelDetails
+                                        (Just $ " " <> printDeclarationType decl)
+                                        (Just $ " " <> P.runModuleName declModule),
+                                  _kind = declToCompletionItemKind decl,
+                                  _tags = Nothing, --  Maybe [Types.CompletionItemTag]
+                                  _detail = Nothing, --  Just $ wrapPursMd $ "  " <> label <> foldMap (" :: " <>) (printDeclarationTypeMb decl),
+                                  _documentation =
+                                    Types.InR . Types.MarkupContent Types.MarkupKind_Markdown
+                                      <$> (Map.lookup decl declDocs <|> fmap wrapPursMd (printDeclarationTypeMb decl)),
+                                  _deprecated = Nothing, --  Maybe Bool
+                                  _preselect = Nothing, --  Maybe Bool
+                                  _sortText = Nothing, --  Maybe Text
+                                  _filterText = Nothing, --  Maybe Text
+                                  _insertText = Nothing, --  Maybe Text
+                                  _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
+                                  _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
+                                  _textEdit = Nothing, --  Maybe
+                                  --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                                  _textEditText = Nothing, --  Maybe Text
+                                  _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
+                                  _commitCharacters = Nothing, --  Maybe [Text]
+                                  _command = Nothing, --  Maybe Types.Command
+                                  _data_ = Nothing --  Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
+                                }
+
+                                --                           _label :: Text
+                                -- _labelDetails :: Maybe Types.CompletionItemLabelDetails
+                                -- _kind :: Maybe Types.CompletionItemKind
+                                -- _tags :: Maybe [Types.CompletionItemTag]
+                                -- _detail :: Maybe Text
+                                -- _documentation :: Maybe (Text Types.|? Types.MarkupContent)
+                                -- _deprecated :: Maybe Bool
+                                -- _preselect :: Maybe Bool
+                                -- _sortText :: Maybe Text
+                                -- _filterText :: Maybe Text
+                                -- _insertText :: Maybe Text
+                                -- _insertTextFormat :: Maybe Types.InsertTextFormat
+                                -- _insertTextMode :: Maybe Types.InsertTextMode
+                                -- _textEdit :: Maybe
+                                --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                                -- _textEditText :: Maybe Text
+                                -- _additionalTextEdits :: Maybe [Types.TextEdit]
+                                -- _commitCharacters :: Maybe [Text]
+                                -- _command :: Maybe Types.Command
+                                -- _data_ :: Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -551,6 +552,9 @@ logToFile txt =
       )
       (const $ pure ())
 
+wrapPursMd :: Text -> Text
+wrapPursMd txt = "```purescript\n" <> txt <> "\n```"
+
 -- getCompletionsWithPrim ::
 --   (Ide m) =>
 --   [Filter] ->

From 4200bff0d0836e3cfc32a5ace8af152cba2b84c4 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 14:50:37 +0200
Subject: [PATCH 072/297] start SMethod_CompletionItemResolve

---
 src/Language/PureScript/Docs/AsMarkdown.hs |  7 ++++
 src/Language/PureScript/Lsp/Types.hs       | 10 ++++-
 src/Language/PureScript/LspSimple.hs       | 44 +++++++++-------------
 3 files changed, 34 insertions(+), 27 deletions(-)

diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 8a57e17e5a..c20602be72 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -2,6 +2,7 @@ module Language.PureScript.Docs.AsMarkdown
   ( Docs
   , runDocs
   , moduleAsMarkdown
+  , declAndModuleNameAsMarkdown
   , declAsMarkdown
   , codeToString
   ) where
@@ -34,6 +35,12 @@ moduleAsMarkdown Module{..} = do
     spacer
     mapM_ declAsMarkdown decls
 
+declAndModuleNameAsMarkdown :: P.ModuleName -> Declaration -> Docs
+declAndModuleNameAsMarkdown mn decl = do
+  headerLevel 2 $ "Module " <> P.runModuleName mn
+  spacer
+  declAsMarkdown decl
+
 declAsMarkdown :: Declaration -> Docs
 declAsMarkdown decl@Declaration{..} = do
   headerLevel 4 (ticks declTitle)
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 81455cbc82..28ed90224a 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -8,10 +8,10 @@ import Language.PureScript.AST.Declarations qualified as P
 -- import Language.PureScript.Ide.Types (IdeLogLevel)
 
 import Language.PureScript.DB (mkConnection)
+import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude
-import Language.PureScript.Environment qualified as P
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -44,3 +44,11 @@ data CurrentFile = CurrentFile
     currentEnv :: P.Environment
   }
   deriving (Show)
+
+data CompleteItemData = CompleteItemData
+  { cidPath :: FilePath,
+    cidModuleName :: P.ModuleName,
+    cidImportedModuleName :: Text,
+    cidImportedValue :: Text
+  }
+  deriving (Show)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 09fc45a314..4f5dc13a72 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -17,6 +17,7 @@ module Language.PureScript.LspSimple (main) where
 
 import Control.Lens (Field1 (_1), view, (^.))
 import Control.Lens.Getter (to)
+import Control.Lens.Setter (set)
 import Control.Monad.Cont (MonadTrans (lift))
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader (mapReaderT)
@@ -344,7 +345,7 @@ handlers diagErrs =
           forLsp vfMb \vf -> do
             let word = getWordAt (VFS._file_text vf) pos
             liftLsp $ logDebugN $ "Word: " <> show word <> " len " <> show (T.length word)
-            if word == ""
+            if T.length word < 2
               then nullRes
               else do
                 mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
@@ -370,8 +371,8 @@ handlers diagErrs =
                                         (Just $ " " <> printDeclarationType decl)
                                         (Just $ " " <> P.runModuleName declModule),
                                   _kind = declToCompletionItemKind decl,
-                                  _tags = Nothing, --  Maybe [Types.CompletionItemTag]
-                                  _detail = Nothing, --  Just $ wrapPursMd $ "  " <> label <> foldMap (" :: " <>) (printDeclarationTypeMb decl),
+                                  _tags = Nothing,
+                                  _detail = Nothing,
                                   _documentation =
                                     Types.InR . Types.MarkupContent Types.MarkupKind_Markdown
                                       <$> (Map.lookup decl declDocs <|> fmap wrapPursMd (printDeclarationTypeMb decl)),
@@ -388,29 +389,20 @@ handlers diagErrs =
                                   _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
                                   _commitCharacters = Nothing, --  Maybe [Text]
                                   _command = Nothing, --  Maybe Types.Command
-                                  _data_ = Nothing --  Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
-                                }
-
-                                --                           _label :: Text
-                                -- _labelDetails :: Maybe Types.CompletionItemLabelDetails
-                                -- _kind :: Maybe Types.CompletionItemKind
-                                -- _tags :: Maybe [Types.CompletionItemTag]
-                                -- _detail :: Maybe Text
-                                -- _documentation :: Maybe (Text Types.|? Types.MarkupContent)
-                                -- _deprecated :: Maybe Bool
-                                -- _preselect :: Maybe Bool
-                                -- _sortText :: Maybe Text
-                                -- _filterText :: Maybe Text
-                                -- _insertText :: Maybe Text
-                                -- _insertTextFormat :: Maybe Types.InsertTextFormat
-                                -- _insertTextMode :: Maybe Types.InsertTextMode
-                                -- _textEdit :: Maybe
-                                --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
-                                -- _textEditText :: Maybe Text
-                                -- _additionalTextEdits :: Maybe [Types.TextEdit]
-                                -- _commitCharacters :: Maybe [Text]
-                                -- _command :: Maybe Types.Command
-                                -- _data_ :: Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
+                                  _data_ = Just $ A.toJSON (mName, declModule, label) --  Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
+                                },
+      Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
+        let completionItem = req ^. LSP.params
+        -- filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+        -- uri :: Types.NormalizedUri
+        -- uri =
+        --   req
+        --     ^. LSP.params
+        --       . LSP.textDocument
+        --       . LSP.uri
+        --       . to Types.toNormalizedUri
+        liftLsp $ logDebugN "SMethod_TextDocumentCompletionItemResolve"
+        res $ Right (set LSP.documentation Nothing completionItem)
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])

From 5c2b17b2e52625edbf3d3c15c78e4f4f9fed67d3 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 2 Oct 2024 16:56:43 +0200
Subject: [PATCH 073/297] adds json decl to code complete

---
 src/Language/PureScript/AST/Declarations.hs | 48 +++++++++++++--------
 src/Language/PureScript/Environment.hs      | 10 +++++
 src/Language/PureScript/Lsp/Types.hs        | 13 ++++--
 src/Language/PureScript/LspSimple.hs        |  5 ++-
 4 files changed, 53 insertions(+), 23 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index bd288518ea..a73997bda7 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -3,37 +3,37 @@
 
 -- |
 -- Data types for modules and declarations
---
 module Language.PureScript.AST.Declarations where
 
-import Prelude
-import Protolude.Exceptions (hush)
-
 import Codec.Serialise (Serialise)
+import Codec.Serialise qualified as S
 import Control.DeepSeq (NFData)
-import Data.Functor.Identity (Identity(..))
-
-import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON)
+import Data.Aeson (ToJSON (toJSON))
+import Data.Aeson qualified as A
+import Data.Aeson.TH (Options (..), SumEncoding (..), defaultOptions, deriveJSON)
+import Data.Functor.Identity (Identity (..))
+import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 import Data.Text (Text)
-import Data.List.NonEmpty qualified as NEL
 import GHC.Generics (Generic)
-
 import Language.PureScript.AST.Binders (Binder)
-import Language.PureScript.AST.Literals (Literal(..))
+import Language.PureScript.AST.Declarations.ChainId (ChainId)
+import Language.PureScript.AST.Literals (Literal (..))
 import Language.PureScript.AST.Operators (Fixity)
 import Language.PureScript.AST.SourcePos (SourceAnn, SourceSpan)
-import Language.PureScript.AST.Declarations.ChainId (ChainId)
-import Language.PureScript.Types (SourceConstraint, SourceType)
-import Language.PureScript.PSString (PSString)
+import Language.PureScript.Comments (Comment)
+import Language.PureScript.Constants.Prim qualified as C
+import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
 import Language.PureScript.Label (Label)
-import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), toMaybeModuleName)
+import Language.PureScript.Names (Ident (..), ModuleName (..), Name (..), OpName, OpNameType (..), ProperName, ProperNameType (..), Qualified (..), QualifiedBy (..), toMaybeModuleName, pattern ByNullSourcePos)
+import Language.PureScript.PSString (PSString)
 import Language.PureScript.Roles (Role)
 import Language.PureScript.TypeClassDictionaries (NamedDict)
-import Language.PureScript.Comments (Comment)
-import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind)
-import Language.PureScript.Constants.Prim qualified as C
-import Codec.Serialise qualified as S
+import Language.PureScript.Types (SourceConstraint, SourceType)
+import Protolude (ConvertText (toS), readMaybe)
+import Protolude.Exceptions (hush)
+import Prelude
+import Data.ByteString.Lazy qualified as Lazy
 
 -- | A map of locally-bound names in scope.
 type Context = [(Ident, SourceType)]
@@ -448,6 +448,18 @@ data Declaration
   | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
   deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
+instance A.ToJSON Declaration where
+  toJSON = A.toJSON . show . S.serialise
+
+instance A.FromJSON Declaration where
+  parseJSON = A.withText "Declaration" $ \t ->
+    case readMaybe (toS t :: Text) :: Maybe Lazy.ByteString of
+      Nothing -> fail "Unable to read declaration"
+      Just bs ->
+        case S.deserialiseOrFail bs of
+          Left e -> fail $ show e
+          Right x -> pure x
+
 data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName)
   deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 1e15273793..90f30753cc 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -51,6 +51,16 @@ data Environment = Environment
 
 instance NFData Environment
 
+
+data EnvironmentLazy m = EnvironmentLazy 
+  { namesLazy :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
+  , typesLazy :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
+  , dataConstructorsLazy :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
+  , typeSynonymsLazy :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
+  , typeClassDictionariesLazy :: QualifiedBy -> m (Maybe (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
+  , typeClassesLazy :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
+  }
+
 -- | Information about a type class
 data TypeClassData = TypeClassData
   { typeClassArguments :: [(Text, Maybe SourceType)]
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 28ed90224a..4c2a9a7c35 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module Language.PureScript.Lsp.Types where
 
@@ -12,6 +13,8 @@ import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude
+import Data.Aeson (ToJSON, FromJSON)
+import Data.Aeson qualified as A
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -48,7 +51,11 @@ data CurrentFile = CurrentFile
 data CompleteItemData = CompleteItemData
   { cidPath :: FilePath,
     cidModuleName :: P.ModuleName,
-    cidImportedModuleName :: Text,
-    cidImportedValue :: Text
+    cidImportedModuleName :: P.ModuleName,
+    cidImportedDeclaration :: P.Declaration
   }
-  deriving (Show)
+  deriving (Show, Eq, Generic, ToJSON, FromJSON)
+
+decodeCompleteItemData :: Maybe A.Value -> A.Result (Maybe CompleteItemData)
+decodeCompleteItemData Nothing = pure Nothing 
+decodeCompleteItemData (Just v) = A.fromJSON v
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 4f5dc13a72..9e7c106473 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -58,7 +58,7 @@ import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifie
 import Language.PureScript.Lsp.Print (printDeclarationType, printDeclarationTypeMb, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.State (initFinished, waitForInit)
-import Language.PureScript.Lsp.Types (LspEnvironment)
+import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEnvironment, decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclComments, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Names (disqualify, runIdent)
 import Language.PureScript.Names qualified as P
@@ -389,10 +389,11 @@ handlers diagErrs =
                                   _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
                                   _commitCharacters = Nothing, --  Maybe [Text]
                                   _command = Nothing, --  Maybe Types.Command
-                                  _data_ = Just $ A.toJSON (mName, declModule, label) --  Maybe aeson-2.0.3.0:Data.Aeson.Types.Internal.Value
+                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModule decl
                                 },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         let completionItem = req ^. LSP.params
+            data_ = completionItem ^. LSP.data_ & decodeCompleteItemData
         -- filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
         -- uri :: Types.NormalizedUri
         -- uri =

From 6e839aad90af57de244becabd5e1ceb1988a1f10 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 3 Oct 2024 10:35:30 +0200
Subject: [PATCH 074/297] use same monad for lsp logic and handlers

---
 app/Command/Lsp.hs                         |  13 +-
 purescript.cabal                           |   4 +
 src/Language/PureScript/Lsp/Cache/Query.hs |  29 +-
 src/Language/PureScript/Lsp/Imports.hs     |   5 +
 src/Language/PureScript/Lsp/Log.hs         |  45 +++
 src/Language/PureScript/Lsp/ReadFile.hs    |  32 +++
 src/Language/PureScript/Lsp/Rebuild.hs     |  96 +++----
 src/Language/PureScript/Lsp/Types.hs       |  25 +-
 src/Language/PureScript/Lsp/Util.hs        |  17 +-
 src/Language/PureScript/LspSimple.hs       | 312 +++++++--------------
 10 files changed, 254 insertions(+), 324 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Imports.hs
 create mode 100644 src/Language/PureScript/Lsp/Log.hs
 create mode 100644 src/Language/PureScript/Lsp/ReadFile.hs

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index c917da3fdd..8d70220f51 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -1,7 +1,6 @@
 module Command.Lsp (command) where
 
-import Language.PureScript.Ide.Types (IdeLogLevel (..))
-import Language.PureScript.Lsp.Types (LspConfig (..), mkEnv)
+import Language.PureScript.Lsp.Types (LspConfig (..), mkEnv, LspLogLevel(..))
 import Language.PureScript.LspSimple as Lsp
 import Options.Applicative qualified as Opts
 import Protolude
@@ -14,7 +13,7 @@ data ServerOptions = ServerOptions
     _serverGlobsFromFile :: Maybe FilePath,
     _serverGlobsExcluded :: [FilePath],
     _serverOutputPath :: FilePath,
-    _serverLoglevel :: IdeLogLevel
+    _serverLoglevel :: LspLogLevel
   }
   deriving (Show)
 
@@ -41,8 +40,8 @@ command = Opts.helper <*> subcommands
       let conf =
             LspConfig
               { confOutputPath = outputPath,
-                confGlobs = globs
-                -- confLogLevel = logLevel
+                confGlobs = globs,
+                confLogLevel = logLevel
               }
       env <- mkEnv conf
       startServer env
@@ -63,13 +62,13 @@ command = Opts.helper <*> subcommands
                   )
             )
 
-    parseLogLevel :: Text -> IdeLogLevel
+    parseLogLevel :: Text -> LspLogLevel
     parseLogLevel s = case s of
       "debug" -> LogDebug
       "perf" -> LogPerf
       "all" -> LogAll
       "none" -> LogNone
-      _ -> LogDefault
+      _ -> LogWarning
 
     startServer env = do
       code <- Lsp.main env
diff --git a/purescript.cabal b/purescript.cabal
index 174cf52c5f..7597d1e628 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -176,6 +176,7 @@ common defaults
     edit-distance >=0.2.2.1 && <0.3,
     file-embed >=0.0.15.0 && <0.1,
     filepath >=1.4.2.2 && <1.5,
+    exceptions >=0.10.4  && <0.11,
     Glob >=0.10.2 && <0.11,
     haskeline >=0.8.2 && <0.9,
     language-javascript ==0.7.0.0,
@@ -343,11 +344,14 @@ library
     Language.PureScript.Lsp
     Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Docs
+    Language.PureScript.Lsp.Imports
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Cache.IO
     Language.PureScript.Lsp.Cache.Query
+    Language.PureScript.Lsp.Log
     Language.PureScript.Lsp.Prim
     Language.PureScript.Lsp.Print
+    Language.PureScript.Lsp.ReadFile
     Language.PureScript.Lsp.Rebuild
     Language.PureScript.Lsp.State
     Language.PureScript.Lsp.Types
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index f0b01618ba..3b04b01a3c 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -1,53 +1,30 @@
 {-# LANGUAGE PackageImports #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.Lsp.Cache.Query where
 
 -- import Language.PureScript.Bundle (getImportedModules)
 
-import Codec.Serialise (deserialise, serialise)
-import Control.Lens (Field1 (_1), (^.), _1)
-import Control.Monad.Trans.Writer (execWriterT)
+import Codec.Serialise (deserialise)
 import Data.Aeson (encode)
 import Data.Aeson qualified as A
 import Data.Aeson.Types qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.List qualified as List
 import Data.Map qualified as Map
-import Data.Set qualified as Set
-import Data.String (fromString)
-import Data.Text qualified as T
 import Database.SQLite.Simple (NamedParam ((:=)), fromOnly)
 import Database.SQLite.Simple qualified as SQL
-import GHC.Base (String)
-import GHC.Real (Integral (toInteger))
-import Language.LSP.Protocol.Types (Position)
 import Language.LSP.Protocol.Types qualified as LSP
-import Language.PureScript (Ident)
 import Language.PureScript.AST qualified as P
-import Language.PureScript.AST.Declarations (declRefName, declSourceAnn)
 import Language.PureScript.AST.SourcePos (SourcePos (SourcePos))
-import Language.PureScript.AST.Traversals (accumTypes)
-import Language.PureScript.Comments qualified as P
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.CoreFn.Expr as CF
 import Language.PureScript.CoreFn.FromJSON qualified as CF
-import Language.PureScript.Externs (ExternsFile (efModuleName), externsFileName)
 import Language.PureScript.Externs qualified as P
-import Language.PureScript.Ide.Error (IdeError (GeneralError))
-import Language.PureScript.Ide.Externs (readExternFile)
-import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.DB qualified as DB
-import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
-import Language.PureScript.Pretty.Types (prettyPrintType)
 import Protolude
-import Protolude qualified as Either
-import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
-import System.FilePath (normalise, (</>))
-import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebugN, logErrorN, logWarnN, mapLoggingT)
 
 -- import Control.Monad.Logger (logDebugN)
 
@@ -132,7 +109,7 @@ getEfExports moduleNames = do
       ]
   pure $ bimap P.ModuleName deserialise <$> exports
 
-getEfDeclarationInModule :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
+getEfDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
 getEfDeclarationInModule moduleName' name = do
   decls <-
     DB.queryNamed
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
new file mode 100644
index 0000000000..2a405678fe
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -0,0 +1,5 @@
+module Language.PureScript.Lsp.Imports where
+
+
+-- import Protolude
+
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
new file mode 100644
index 0000000000..cb2c50dbf7
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -0,0 +1,45 @@
+module Language.PureScript.Lsp.Log where
+
+import Protolude
+import Language.PureScript.Lsp.Types (LspEnvironment (lspConfig), LspLogLevel (..), LspConfig (confLogLevel))
+
+
+
+infoLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+infoLsp = logLsp LogMsgInfo
+
+warnLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+warnLsp = logLsp LogMsgWarning
+
+errorLsp  :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+errorLsp = logLsp LogMsgError
+
+debugLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+debugLsp = logLsp LogMsgDebug
+
+perfLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+perfLsp = logLsp LogMsgPerf
+
+
+logLsp :: (MonadIO m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text -> m ()
+logLsp msgLogLevel msg = do
+  logLevel <- confLogLevel . lspConfig <$> ask
+  when (shouldLog msgLogLevel logLevel) $ do
+    liftIO $ putErrLn (show msgLogLevel <> ": " <> show msg :: Text)
+
+
+data LogMsgSeverity
+  = LogMsgInfo
+  | LogMsgWarning
+  | LogMsgError
+  | LogMsgDebug
+  | LogMsgPerf
+  deriving (Show, Eq)
+
+shouldLog :: LogMsgSeverity -> LspLogLevel -> Bool
+shouldLog msgLogLevel logLevel = case msgLogLevel of
+  LogMsgInfo -> logLevel `elem` [LogInfo, LogDebug, LogAll]
+  LogMsgWarning -> logLevel `elem` [LogWarning, LogInfo, LogDebug, LogAll]
+  LogMsgError -> logLevel `elem` [LogError, LogWarning, LogInfo, LogDebug, LogAll]
+  LogMsgDebug -> logLevel == LogDebug || logLevel == LogAll
+  LogMsgPerf -> logLevel == LogPerf || logLevel == LogAll
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/ReadFile.hs b/src/Language/PureScript/Lsp/ReadFile.hs
new file mode 100644
index 0000000000..6570c4b321
--- /dev/null
+++ b/src/Language/PureScript/Lsp/ReadFile.hs
@@ -0,0 +1,32 @@
+module Language.PureScript.Lsp.ReadFile where
+
+import Control.Monad.Catch (MonadThrow (throwM))
+import GHC.IO.Exception (IOException (ioe_description))
+import Protolude hiding
+  ( decodeUtf8,
+    encodeUtf8,
+    to,
+  )
+import System.Directory (makeAbsolute)
+import System.IO.UTF8 (readUTF8FileT)
+
+
+lspReadFile ::
+  (MonadIO m, MonadThrow m) =>
+  FilePath ->
+  m (FilePath, Text)
+lspReadFile fp = do
+  absPath <-
+    liftIO (try (makeAbsolute fp)) >>= \case
+      Left (err :: IOException) ->
+        throwM
+          (err {ioe_description = "Couldn't resolve path for: " <> show fp <> ", " <> ioe_description err})
+      Right absPath -> pure absPath
+  contents <-
+    liftIO (try (readUTF8FileT absPath)) >>= \case
+      Left (err :: IOException) ->
+        throwM
+          (err {ioe_description = "Couldn't resolve path for: " <> show fp <> ", " <> ioe_description err})
+      Right contents ->
+        pure contents
+  pure (absPath, contents)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index d36e7faf7d..5a7d16f2d6 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -4,23 +4,23 @@
 
 module Language.PureScript.Lsp.Rebuild where
 
+import Control.Monad.Catch (MonadThrow)
 import Data.List qualified as List
 import Data.Map.Lazy qualified as M
 import Data.Maybe (fromJust)
 import Data.Set qualified as S
 import Data.Set qualified as Set
 import Data.Text qualified as T
+import Language.PureScript (MultipleErrors)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
-import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
-import Language.PureScript.Ide.Util (ideReadFile)
 import Language.PureScript.Lsp.Cache (selectAllExternsMap)
-import Language.PureScript.Lsp.State (cacheRebuild)
+import Language.PureScript.Lsp.ReadFile (lspReadFile)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
@@ -32,67 +32,49 @@ import Protolude hiding (moduleName)
 
 rebuildFile ::
   ( MonadIO m,
-    MonadError IdeError m,
+    MonadThrow m,
     MonadReader LspEnvironment m
   ) =>
   FilePath ->
-  m (FilePath, P.MultipleErrors)
+  m (Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors))
 rebuildFile srcPath = do
   (fp, input) <-
     case List.stripPrefix "data:" srcPath of
       Just source -> pure ("", T.pack source)
-      _ -> ideReadFile srcPath -- todo replace with VFS
-  (pwarnings, m) <- case sequence $ CST.parseFromFile fp input of
+      _ -> lspReadFile srcPath -- todo replace with VFS
+  case sequence $ CST.parseFromFile fp input of
     Left parseError ->
-      throwError $ RebuildError [(fp, input)] $ CST.toMultipleErrors fp parseError
-    Right m -> pure m
-  let moduleName = P.getModuleName m
-  externs <- sortExterns m =<< selectAllExternsMap
-  outputDirectory <- asks (confOutputPath . lspConfig)
-  let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
-  let pureRebuild = fp == ""
-  let modulePath = if pureRebuild then fp else srcPath
-  foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
-  conn <- asks lspDbConnection
-  let makeEnv =
-        P.buildMakeActions outputDirectory filePathMap foreigns False
-          & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
-          & shushProgress
-          & addAllIndexing conn
-  (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-    newExterns <- P.rebuildModule makeEnv externs m
-    unless pureRebuild $
-      updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
-    pure newExterns
-  case result of
-    Left errors ->
-      throwError (RebuildError [(fp, input)] errors)
-    Right newExterns -> do
-      rebuildModuleOpen makeEnv externs m
-      pure (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
+      pure $ Left ([(fp, input)], CST.toMultipleErrors fp parseError)
+    Right (pwarnings, m) -> do
+      let moduleName = P.getModuleName m
+      externsResult <- sortExterns m =<< selectAllExternsMap
+      case externsResult of
+        Left err -> pure $ Left $ ([], err)
+        Right externs -> do
+          outputDirectory <- asks (confOutputPath . lspConfig)
+          let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+          let pureRebuild = fp == ""
+          let modulePath = if pureRebuild then fp else srcPath
+          foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
+          conn <- asks lspDbConnection
+          let makeEnv =
+                P.buildMakeActions outputDirectory filePathMap foreigns False
+                  & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
+                  & shushProgress
+                  & addAllIndexing conn
+          (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+            newExterns <- P.rebuildModule makeEnv externs m
+            unless pureRebuild $
+              updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
+            pure newExterns
+          case result of
+            Left errors ->
+              pure (Left ([(fp, input)], errors))
+            Right newExterns -> do
+              pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
   where
     codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
--- | Rebuilds a module but opens up its export list first and stores the result
--- inside the rebuild cache
-rebuildModuleOpen ::
-  ( MonadReader LspEnvironment m,
-    MonadIO m
-  ) =>
-  P.MakeActions P.Make ->
-  [P.ExternsFile] ->
-  P.Module ->
-  m ()
-rebuildModuleOpen makeEnv externs m = void $ runExceptT do
-  (openResult, _) <-
-    liftIO $
-      P.runMake P.defaultOptions $
-        P.rebuildModuleAndGetEnv (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m)
-  case openResult of
-    Left _ ->
-      throwError (GeneralError "Failed when rebuilding with open exports")
-    Right (result, env) -> cacheRebuild result m env
-
 -- | Shuts the compiler up about progress messages
 shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushProgress ma =
@@ -122,10 +104,10 @@ enableForeignCheck foreigns codegenTargets ma =
 -- module. Throws an error if there is a cyclic dependency within the
 -- ExternsFiles
 sortExterns ::
-  (MonadError IdeError m) =>
+  (MonadThrow m) =>
   P.Module ->
   ModuleMap P.ExternsFile ->
-  m [P.ExternsFile]
+  m (Either MultipleErrors [P.ExternsFile])
 sortExterns m ex = do
   sorted' <-
     runExceptT
@@ -137,10 +119,10 @@ sortExterns m ex = do
       $ ex
   case sorted' of
     Left err ->
-      throwError (RebuildError [] err)
+      pure $ Left err
     Right (sorted, graph) -> do
       let deps = fromJust (List.lookup (P.getModuleName m) graph)
-      pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
+      pure $ Right $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
   where
     mkShallowModule P.ExternsFile {..} =
       P.Module (P.internalModuleSourceSpan "<rebuild>") [] efModuleName (map mkImport efImports) Nothing
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 4c2a9a7c35..1a648d46c9 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -1,20 +1,20 @@
-{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE PackageImports #-}
 
 module Language.PureScript.Lsp.Types where
 
 import Control.Concurrent.STM (TVar, newTVarIO)
-import Database.SQLite.Simple (Connection)
-import Language.PureScript.AST.Declarations qualified as P
 -- import Language.PureScript.Ide.Types (IdeLogLevel)
 
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson qualified as A
+import Database.SQLite.Simple (Connection)
+import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude
-import Data.Aeson (ToJSON, FromJSON)
-import Data.Aeson qualified as A
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -30,7 +30,8 @@ mkEnv conf = do
 
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
-    confGlobs :: [FilePath]
+    confGlobs :: [FilePath],
+    confLogLevel :: LspLogLevel
   }
   deriving (Show)
 
@@ -56,6 +57,16 @@ data CompleteItemData = CompleteItemData
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
+data LspLogLevel
+  = LogAll
+  | LogDebug
+  | LogPerf
+  | LogInfo
+  | LogWarning
+  | LogError
+  | LogNone
+  deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
+
 decodeCompleteItemData :: Maybe A.Value -> A.Result (Maybe CompleteItemData)
-decodeCompleteItemData Nothing = pure Nothing 
+decodeCompleteItemData Nothing = pure Nothing
 decodeCompleteItemData (Just v) = A.fromJSON v
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 5d7caacba7..b8f84f3daa 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -25,7 +25,7 @@ import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (CurrentFile (currentEnv), LspEnvironment)
 -- import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
 import Protolude hiding (to)
-import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
+import Language.PureScript.Lsp.Log (debugLsp)
 
 posInSpan :: Types.Position -> Errors.SourceSpan -> Bool
 posInSpan (Types.Position line col) (Errors.SourceSpan _ (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
@@ -65,12 +65,12 @@ getWordOnLine line' col =
     isWordBreak :: Char -> Bool
     isWordBreak = not . (isAlphaNum ||^ (== '_') ||^ (== '.'))
 
-getNamesAtPosition :: (MonadIO m, MonadLogger m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
+getNamesAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
 getNamesAtPosition pos moduleName' src = do
   let search = getWordAt src pos
-  logDebugN $ "Looking up " <> search <> " in module " <> P.runModuleName moduleName'
+  debugLsp $ "Looking up " <> search <> " in module " <> P.runModuleName moduleName'
   decls <- getAstDeclarationsAtSrcPos moduleName' (positionToSourcePos pos)
-  logDebugN $ "Found declarations: " <> T.pack (show $ length decls) <> show (fmap (T.take 400 . show) decls)
+  debugLsp $ "Found declarations: " <> T.pack (show $ length decls) <> show (fmap (T.take 400 . show) decls)
   pure $
     mconcat $
       decls <&> \decl -> do
@@ -123,16 +123,15 @@ getNamesAtPosition pos moduleName' src = do
             exprNames = P.everythingWithContextOnValues moduleName' Set.empty (<>) getDeclName getExprName goBinder goDef goDef ^. _1 $ decl
         -- typeNames = Set.fromList $ usedTypeNames moduleName' decl
 
-        Set.filter ((==) search . printName . P.disqualify) $
-          exprNames
+        Set.filter ((==) search . printName . P.disqualify) exprNames
 
 -- <> Set.map (flip P.mkQualified moduleName' . P.TyName) typeNames
 
-lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadLogger m, MonadIO m) => P.Qualified P.Name -> m (Maybe P.SourceType)
+lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => P.Qualified P.Name -> m (Maybe P.SourceType)
 lookupTypeInEnv (P.Qualified qb name) = do
   envMb :: Maybe P.Environment <- fmap currentEnv <$> cachedRebuild
-  logDebugN $ "Looking up " <> show name <> " in environment"
-  -- logDebugN $ "Environment: " <> show envMb
+  debugLsp $ "Looking up " <> show name <> " in environment"
+  -- debugLsp $ "Environment: " <> show envMb
   pure $
     envMb
       >>= ( \(P.Environment {..}) -> case name of
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 9e7c106473..a1efd4b5dd 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -1,35 +1,22 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
--- {-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-local-binds #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.LspSimple (main) where
 
-import Control.Lens (Field1 (_1), view, (^.))
+import Control.Lens ((^.))
 import Control.Lens.Getter (to)
 import Control.Lens.Setter (set)
-import Control.Monad.Cont (MonadTrans (lift))
 import Control.Monad.IO.Unlift
-import Control.Monad.Reader (mapReaderT)
 import Data.Aeson qualified as A
 import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Data.Time (getCurrentTime)
-import GHC.IO (unsafePerformIO)
-import Language.Haskell.TH (listT)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
@@ -39,106 +26,59 @@ import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
-import Language.PureScript.AST.SourcePos (SourcePos (sourcePosColumn), nullSourceSpan)
-import Language.PureScript.AST.SourcePos qualified as P
-import Language.PureScript.Constants.TH (ty)
-import Language.PureScript.CoreFn.Expr (extractAnn)
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
-import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError), prettyPrintTypeSingleLine, textError)
-import Language.PureScript.Ide.Logging (runErrLogger)
-import Language.PureScript.Ide.Types (Completion (Completion, complDocumentation, complExpandedType, complType), IdeLogLevel (LogAll), declarationType, _IdeDeclModule)
+import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule, getEfDeclarationsAtSrcPos)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
-import Language.PureScript.Lsp.Print (printDeclarationType, printDeclarationTypeMb, printName)
+import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
-import Language.PureScript.Lsp.State (initFinished, waitForInit)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEnvironment, decodeCompleteItemData)
-import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclComments, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Names (disqualify, runIdent)
-import Language.PureScript.Names qualified as P
 import Protolude hiding (to)
-import System.Directory (createDirectoryIfMissing)
 import Text.PrettyPrint.Boxes (render)
-import "monad-logger" Control.Monad.Logger (LoggingT, logDebug, logDebugN, logErrorN, logWarnN, mapLoggingT)
 
-type HandlerM config = Server.LspT config (ReaderT LspEnvironment (LoggingT IO))
-
-type LspM = ReaderT LspEnvironment (LoggingT (ExceptT IdeError IO))
-
-liftLsp :: LspM a -> HandlerM config a
-liftLsp = lift . mapReaderT (mapLoggingT (throwIdeError <=< runExceptT))
-  where
-    throwIdeError = \case
-      Left err -> liftIO $ throwIO err
-      Right a -> pure a
-
-liftLspWithErr :: LspM a -> HandlerM config (Either IdeError a)
-liftLspWithErr = lift . flip catchError errorHandler . mapReaderT (mapLoggingT runExceptT)
-  where
-    errorHandler ::
-      IOException ->
-      ReaderT LspEnvironment (LoggingT IO) (Either IdeError a)
-    errorHandler err = do
-      logErrorN $ T.pack (show err)
-      pure $ Left $ GeneralError $ show err
+type HandlerM config = ReaderT LspEnvironment ((Server.LspT config IO))
 
 type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
 
-insertDiagnosticError :: (MonadIO m, Ord k) => IORef (Map k a) -> a -> k -> m ()
-insertDiagnosticError diagErrs err diag = liftIO $ modifyIORef diagErrs (Map.insert diag err)
-
 insertDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [a] -> [k] -> m ()
 insertDiagnosticErrors diagErrs errs diags = liftIO $ modifyIORef diagErrs (Map.union $ Map.fromList $ zip diags errs)
 
-getDiagnosticError :: (MonadIO m, Ord k) => IORef (Map k a) -> k -> m (Maybe a)
-getDiagnosticError diagErrs diags = liftIO $ Map.lookup diags <$> readIORef diagErrs
-
 getDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [k] -> m (Map k a)
 getDiagnosticErrors diagErrs diags = liftIO $ flip Map.restrictKeys (Set.fromList diags) <$> readIORef diagErrs
 
 handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
-    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
-        res <- liftLspWithErr do
-          initFinished
-          logDebugN "Init finished"
-        case res of
-          Left err -> do
-            liftLsp $ logErrorN $ "Initalise error: " <> show err
-            sendInfoMsg "Failed to initialise lsp server"
-          Right _ -> sendInfoMsg "OA purs lsp server initialized",
+    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> sendInfoMsg "Failed to initialise lsp server",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        liftLsp $ logDebugN "TextDocumentDidOpen"
+        debugLsp "TextDocumentDidOpen"
         let uri :: Uri
             uri = getMsgUri msg
             fileName = Types.uriToFilePath uri
-        void $ liftLspWithErr do
-          waitForInit
-          traverse rebuildFile fileName,
-      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \msg -> do
-        liftLsp $ logDebugN "TextDocumentDidChange",
+
+        traverse_ rebuildFile fileName,
+      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> debugLsp "TextDocumentDidChange",
       Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
-        liftLsp $ logDebugN "SMethod_TextDocumentDidSave"
+        debugLsp "SMethod_TextDocumentDidSave"
         let uri :: Uri
             uri = getMsgUri msg
             fileName = Types.uriToFilePath uri
-        void $ liftLspWithErr do
-          waitForInit
-          traverse rebuildFile fileName,
-      Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
+        traverse_ rebuildFile fileName,
+      Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
         cfg <- getConfig
-        liftLsp $ logDebugN $ "Config changed: " <> show cfg,
-      Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
-        liftLsp $ logDebugN "SMethod_SetTrace",
+        debugLsp $ "Config changed: " <> show cfg,
+      Server.notificationHandler Message.SMethod_SetTrace $ \_msg -> debugLsp "SMethod_SetTrace",
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
-        liftLsp $ logDebugN "SMethod_TextDocumentDiagnostic"
+        debugLsp "SMethod_TextDocumentDiagnostic"
         (errs, diagnostics) <- getFileDiagnotics req
         insertDiagnosticErrors diagErrs errs diagnostics
         res $
@@ -155,7 +95,7 @@ handlers diagErrs =
         res $
           Right $
             Types.InL $
-              errs & fmap \(diag, err) ->
+              errs & fmap \(_diag, err) ->
                 let textEdits :: [Types.TextEdit]
                     textEdits =
                       toSuggestion err
@@ -163,7 +103,7 @@ handlers diagErrs =
                           >>= suggestionToEdit
 
                     suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just errorPos@JsonErrors.ErrorPosition {..})) =
+                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
                       let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
                           end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
                        in pure $ Types.TextEdit (Types.Range start end) replacement
@@ -184,8 +124,8 @@ handlers diagErrs =
                         Nothing
                         Nothing,
       Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-        liftLsp $ logDebugN "SMethod_TextDocumentHover"
-        let Types.HoverParams docIdent pos@(Types.Position line col) _workDone = req ^. LSP.params
+        debugLsp "SMethod_TextDocumentHover"
+        let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             docUri =
               docIdent
@@ -216,40 +156,39 @@ handlers diagErrs =
             forLsp val f = maybe nullRes f val
 
         forLsp filePathMb \filePath -> do
-          corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
+          corefnExprMb <- getCoreFnExprAt filePath pos
           case corefnExprMb of
             Just (CF.Literal _ _) -> nullRes
-            Just (CF.Constructor (ss, comments, meta) tName cMame _) -> do
-              docsMb <- liftLsp do
+            Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
+              docsMb <- do
                 mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
-                maybe (pure Nothing) (flip readDeclarationDocsAsMarkdown (P.runProperName tName)) mNameMb
+                maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` (P.runProperName tName)) mNameMb
               case docsMb of
                 Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
                 Just docs -> markdownRes docs
-            Just (CF.Var (_ss, comments, meta) (P.Qualified qb ident)) -> do
+            Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
               case qb of
                 P.ByModuleName mName -> do
-                  docsMb <- liftLsp $ readDeclarationDocsAsMarkdown mName (P.runIdent ident)
+                  docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
                   case docsMb of
                     Just docs -> markdownRes docs
                     _ -> do
-                      declMb <- liftLsp $ getEfDeclarationInModule mName (runIdent ident)
+                      declMb <- getEfDeclarationInModule mName (runIdent ident)
                       markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
-                P.BySourcePos pos' ->
+                P.BySourcePos _pos' ->
                   markdownTypeRes (P.runIdent ident) Nothing []
             _ -> do
               vfMb <- Server.getVirtualFile docUri
               forLsp vfMb \vf -> do
-                mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
+                mNameMb <- selectExternModuleNameFromFilePath filePath
                 forLsp mNameMb \mName -> do
-                  names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
+                  names <- getNamesAtPosition pos mName (VFS._file_text vf)
                   forLsp (head names) \name -> do
-                    docsMb <- liftLsp $ readQualifiedNameDocsAsMarkdown name
+                    docsMb <- readQualifiedNameDocsAsMarkdown name
                     case docsMb of
                       Nothing -> do
-                        typeMb <- liftLsp $ lookupTypeInEnv name
-                        forLsp typeMb \t -> do
-                          markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
+                        typeMb <- lookupTypeInEnv name
+                        forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
                       Just docs -> markdownRes docs,
       Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
         sendInfoMsg "SMethod_TextDocumentDefinition"
@@ -273,48 +212,48 @@ handlers diagErrs =
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
-            mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
-            liftLsp $ logDebugN $ "Module name: " <> show mNameMb
-            liftLsp $ logDebugN $ "Pos: " <> show pos
+            mNameMb <- selectExternModuleNameFromFilePath filePath
+            debugLsp $ "Module name: " <> show mNameMb
+            debugLsp $ "Pos: " <> show pos
             forLsp mNameMb \mName -> do
-              names <- liftLsp $ getNamesAtPosition pos mName (VFS._file_text vf)
-              liftLsp $ logDebugN $ "Found names: " <> show names
+              names <- getNamesAtPosition pos mName (VFS._file_text vf)
+              debugLsp $ "Found names: " <> show names
 
               case head names of
                 Just name -> do
-                  liftLsp $ logDebugN $ "Found name: " <> show name
-                  spanMb <- liftLsp $ readQualifiedNameDocsSourceSpan name
-                  liftLsp $ logDebugN $ "Found docs span: " <> show spanMb
+                  debugLsp $ "Found name: " <> show name
+                  spanMb <- readQualifiedNameDocsSourceSpan name
+                  debugLsp $ "Found docs span: " <> show spanMb
                   case spanMb of
                     _ -> do
                       case name of
                         P.Qualified (P.BySourcePos pos') _ -> do
-                          liftLsp $ logDebugN $ "Found source pos: " <> show pos'
+                          debugLsp $ "Found source pos: " <> show pos'
                           locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
                         P.Qualified (P.ByModuleName nameModule) ident -> do
-                          liftLsp $ logDebugN $ "Found module name: " <> show nameModule
-                          declMb <- liftLsp $ getAstDeclarationInModule nameModule (printName ident)
-                          liftLsp $ logDebugN $ "Found decl: " <> show declMb
+                          debugLsp $ "Found module name: " <> show nameModule
+                          declMb <- getAstDeclarationInModule nameModule (printName ident)
+                          debugLsp $ "Found decl: " <> show declMb
                           forLsp declMb \decl -> do
-                            modFpMb <- liftLsp $ selectExternPathFromModuleName nameModule
+                            modFpMb <- selectExternPathFromModuleName nameModule
                             forLsp modFpMb \modFp -> do
-                              liftLsp $ logDebugN $ "Found modFp: " <> show modFp
+                              debugLsp $ "Found modFp: " <> show modFp
                               let sourceSpan = P.declSourceSpan decl
-                              liftLsp $ logDebugN $ "Found decl sourceSpan: " <> show sourceSpan
+                              debugLsp $ "Found decl sourceSpan: " <> show sourceSpan
                               locationRes modFp (spanToRange sourceSpan)
                     Just span ->
                       locationRes (P.spanName span) (spanToRange span)
                 _ -> do
-                  corefnExprMb <- liftLsp $ getCoreFnExprAt filePath pos
+                  corefnExprMb <- getCoreFnExprAt filePath pos
                   case corefnExprMb of
                     Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
-                      liftLsp $ logDebugN $ "Found Corefn Var source span: " <> show ss
+                      debugLsp $ "Found Corefn Var source span: " <> show ss
                       let name = P.runIdent ident
                       case qb of
                         P.ByModuleName coreMName -> do
-                          declMb <- liftLsp $ getEfDeclarationInModule coreMName name
+                          declMb <- getEfDeclarationInModule coreMName name
                           forLsp declMb \decl -> do
-                            modFpMb <- liftLsp $ selectExternPathFromModuleName coreMName
+                            modFpMb <- selectExternPathFromModuleName coreMName
                             forLsp modFpMb \modFp -> do
                               let sourceSpan = efDeclSourceSpan decl
                               locationRes modFp (spanToRange sourceSpan)
@@ -322,7 +261,7 @@ handlers diagErrs =
                           locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
                     _ -> nullRes,
       Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
-        liftLsp $ logDebugN "SMethod_TextDocumentCompletion"
+        debugLsp "SMethod_TextDocumentCompletion"
         let Types.CompletionParams docIdent pos _prog _prog' completionCtx = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             uri :: Types.NormalizedUri
@@ -338,26 +277,21 @@ handlers diagErrs =
             forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
             forLsp val f = maybe nullRes f val
 
-        liftLsp $ logDebugN $ "Completion params: " <> show completionCtx
-        liftLsp $ logDebugN $ "filePathMb: " <> show filePathMb
+        debugLsp $ "Completion params: " <> show completionCtx
+        debugLsp $ "filePathMb: " <> show filePathMb
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
             let word = getWordAt (VFS._file_text vf) pos
-            liftLsp $ logDebugN $ "Word: " <> show word <> " len " <> show (T.length word)
+            debugLsp $ "Word: " <> show word <> " len " <> show (T.length word)
             if T.length word < 2
               then nullRes
               else do
-                mNameMb <- liftLsp $ selectExternModuleNameFromFilePath filePath
-                liftLsp $ logDebugN $ "Module name: " <> show mNameMb
+                mNameMb <- selectExternModuleNameFromFilePath filePath
+                debugLsp $ "Module name: " <> show mNameMb
                 forLsp mNameMb \mName -> do
-                  decls <- liftLsp $ getAstDeclarationsStartingWith mName word
-                  liftLsp $ logDebugN $ "Found decls: " <> show decls
-                  declDocs <-
-                    Map.fromList . catMaybes <$> forM decls \(declModule, decl) -> do
-                      let name = printName <$> P.declName decl
-                      docsMb <- liftLsp $ maybe (pure Nothing) (readDeclarationDocsAsMarkdown declModule) name
-                      pure $ (decl,) <$> docsMb
+                  decls <- getAstDeclarationsStartingWith mName word
+                  debugLsp $ "Found decls: " <> show decls
                   res $
                     Right $
                       Types.InL $
@@ -373,9 +307,7 @@ handlers diagErrs =
                                   _kind = declToCompletionItemKind decl,
                                   _tags = Nothing,
                                   _detail = Nothing,
-                                  _documentation =
-                                    Types.InR . Types.MarkupContent Types.MarkupKind_Markdown
-                                      <$> (Map.lookup decl declDocs <|> fmap wrapPursMd (printDeclarationTypeMb decl)),
+                                  _documentation = Nothing,
                                   _deprecated = Nothing, --  Maybe Bool
                                   _preselect = Nothing, --  Maybe Bool
                                   _sortText = Nothing, --  Maybe Text
@@ -392,18 +324,29 @@ handlers diagErrs =
                                   _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModule decl
                                 },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
+        debugLsp "SMethod_CompletionItemResolve"
         let completionItem = req ^. LSP.params
-            data_ = completionItem ^. LSP.data_ & decodeCompleteItemData
-        -- filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-        -- uri :: Types.NormalizedUri
-        -- uri =
-        --   req
-        --     ^. LSP.params
-        --       . LSP.textDocument
-        --       . LSP.uri
-        --       . to Types.toNormalizedUri
-        liftLsp $ logDebugN "SMethod_TextDocumentCompletionItemResolve"
-        res $ Right (set LSP.documentation Nothing completionItem)
+            result = completionItem ^. LSP.data_ & decodeCompleteItemData
+
+        case result of
+          A.Success (Just (CompleteItemData _filePath _mName declModule decl)) -> do
+            let label = foldMap printName (P.declName decl)
+            docsMb <- readDeclarationDocsAsMarkdown declModule label
+            let addDocs :: Types.CompletionItem -> Types.CompletionItem
+                addDocs =
+                  docsMb & maybe
+                    identity
+                    \docs ->
+                      set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
+
+                addImport :: Types.CompletionItem -> Types.CompletionItem
+                addImport = identity
+            res $
+              Right $
+                completionItem
+                  & addDocs
+                  & addImport
+          _ -> res $ Right completionItem
     ]
   where
     getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
@@ -413,7 +356,7 @@ handlers diagErrs =
           fileName = Types.uriToFilePath uri
       case fileName of
         Just file -> do
-          res <- fmap snd <$> liftLspWithErr (rebuildFile file)
+          res <- rebuildFile file
           getResultDiagnostics res
         Nothing -> do
           sendInfoMsg $ "No file path for uri: " <> show uri
@@ -422,23 +365,20 @@ handlers diagErrs =
     getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
     getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
 
-    getResultDiagnostics :: Either IdeError MultipleErrors -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
+    getResultDiagnostics :: Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors) -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
     getResultDiagnostics res = case res of
-      Left (RebuildError _ errs) -> do
+      Left (_, errs) -> do
         let errors = runMultipleErrors errs
             diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
         pure (errors, diags)
-      Left err -> do
-        liftLsp $ logErrorN $ "Rebuild error: " <> textError err
-        pure ([], [])
-      Right errs | Errors.nonEmpty errs -> do
+      Right (_, errs) | Errors.nonEmpty errs -> do
         let errors = runMultipleErrors errs
             diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
         pure (errors, diags)
       _ -> pure ([], [])
       where
         errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
-        errorMessageDiagnostic severity msg@((ErrorMessage hints _)) =
+        errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
           Types.Diagnostic
             (Types.Range start end)
             (Just severity)
@@ -469,14 +409,6 @@ spanToRange (Errors.SourceSpan _ start end) =
     (sourcePosToPosition start)
     (sourcePosToPosition end)
 
-sendError :: IdeError -> HandlerM config ()
-sendError err =
-  Server.sendNotification
-    Message.SMethod_WindowShowMessage
-    ( Types.ShowMessageParams Types.MessageType_Error $
-        "Something went wrong:\n" <> textError err
-    )
-
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
 
@@ -488,16 +420,12 @@ main lspEnv = do
       { parseConfig = const $ const $ Right (),
         onConfigChange = const $ pure (),
         defaultConfig = (),
-        configSection = "oa-purescript-simple",
-        doInitialize = \env _req -> do
-          logT "Init OA purs lsp server"
-          pure $ Right env,
-        staticHandlers = \_caps -> do handlers diagErrs,
+        configSection = "oa-purescript-lsp",
+        doInitialize = \env _req -> pure $ Right env,
+        staticHandlers = \_caps -> handlers diagErrs,
         interpretHandler = \env ->
           Server.Iso
-            ( runErrLogger LogAll
-                . flip runReaderT lspEnv
-                . Server.runLspT env
+            ( Server.runLspT env . flip runReaderT lspEnv
             )
             liftIO,
         options = lspOptions
@@ -519,55 +447,3 @@ lspOptions =
     { Server.optTextDocumentSync = Just syncOptions,
       Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
     }
-
-spy :: (Show a) => Text -> a -> a
-spy msg a = unsafePerformIO $ do
-  logT $ msg <> ": " <> show a
-  pure a
-
-unsafeLog :: (Show a) => a -> ()
-unsafeLog a = unsafePerformIO $ log_ a
-
-log_ :: (MonadIO m, Show a) => a -> m ()
-log_ = logToFile . show
-
-logT :: (MonadIO m) => Text -> m ()
-logT = logToFile
-
-logToFile :: (MonadIO m) => Text -> m ()
-logToFile txt =
-  liftIO $
-    catchError
-      ( do
-          createDirectoryIfMissing True "logs"
-          time <- show <$> getCurrentTime
-          writeFile ("logs/" <> time <> "-----" <> T.unpack txt) $ txt <> "\n"
-      )
-      (const $ pure ())
-
-wrapPursMd :: Text -> Text
-wrapPursMd txt = "```purescript\n" <> txt <> "\n```"
-
--- getCompletionsWithPrim ::
---   (Ide m) =>
---   [Filter] ->
---   Matcher IdeDeclarationAnn ->
---   Maybe P.ModuleName ->
---   Purs.Completion.CompletionOptions ->
---   m [Completion]
--- getCompletionsWithPrim filters matcher currentModule complOptions = do
---   modules <- getAllModules currentModule
---   let insertPrim = Map.union idePrimDeclarations
---   pure (getCompletions filters matcher complOptions (insertPrim modules))
-
--- getExactCompletionsWithPrim ::
---   (Ide m) =>
---   Text ->
---   [Filter] ->
---   Maybe P.ModuleName ->
---   m [Completion]
--- getExactCompletionsWithPrim search filters currentModule = do
---   modules <- getAllModules currentModule
---   let insertPrim = Map.union idePrimDeclarations
---   pure (getExactCompletions search filters (insertPrim modules))
--- z = getAllModules

From 02a92eed68db52f800d16e97fc4827c111bf9cc4 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 3 Oct 2024 10:42:42 +0200
Subject: [PATCH 075/297] move handlers to own module

---
 purescript.cabal                        |   1 +
 src/Language/PureScript/Lsp/Handlers.hs | 412 +++++++++++++++++++++++
 src/Language/PureScript/Lsp/Log.hs      |   1 +
 src/Language/PureScript/LspSimple.hs    | 413 +-----------------------
 4 files changed, 419 insertions(+), 408 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Handlers.hs

diff --git a/purescript.cabal b/purescript.cabal
index 7597d1e628..7e54bb240d 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -348,6 +348,7 @@ library
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Cache.IO
     Language.PureScript.Lsp.Cache.Query
+    Language.PureScript.Lsp.Handlers
     Language.PureScript.Lsp.Log
     Language.PureScript.Lsp.Prim
     Language.PureScript.Lsp.Print
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
new file mode 100644
index 0000000000..9fd4215690
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -0,0 +1,412 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+
+module Language.PureScript.Lsp.Handlers where
+
+
+import Control.Lens ((^.))
+import Control.Lens.Getter (to)
+import Control.Lens.Setter (set)
+import Control.Monad.IO.Unlift
+import Data.Aeson qualified as A
+import Data.IORef (IORef, modifyIORef, readIORef)
+import Data.List.NonEmpty qualified as NEL
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+import Data.Text qualified as T
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types (Diagnostic, Uri)
+import Language.LSP.Protocol.Types qualified as LSP
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server (getConfig)
+import Language.LSP.Server qualified as Server
+import Language.LSP.VFS qualified as VFS
+import Language.PureScript qualified as P
+import Language.PureScript.CoreFn.Expr qualified as CF
+import Language.PureScript.Docs.Convert.Single (convertComments)
+import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
+import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Errors.JSON (toSuggestion)
+import Language.PureScript.Errors.JSON qualified as JsonErrors
+import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
+import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
+import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Print (printDeclarationType, printName)
+import Language.PureScript.Lsp.Rebuild (rebuildFile)
+import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEnvironment, decodeCompleteItemData)
+import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
+import Language.PureScript.Names (disqualify, runIdent)
+import Protolude hiding (to)
+import Text.PrettyPrint.Boxes (render)
+
+type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
+
+type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
+
+insertDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [a] -> [k] -> m ()
+insertDiagnosticErrors diagErrs errs diags = liftIO $ modifyIORef diagErrs (Map.union $ Map.fromList $ zip diags errs)
+
+getDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [k] -> m (Map k a)
+getDiagnosticErrors diagErrs diags = liftIO $ flip Map.restrictKeys (Set.fromList diags) <$> readIORef diagErrs
+
+handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
+handlers diagErrs =
+  mconcat
+    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> sendInfoMsg "Failed to initialise lsp server",
+      Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
+        debugLsp "TextDocumentDidOpen"
+        let uri :: Uri
+            uri = getMsgUri msg
+            fileName = Types.uriToFilePath uri
+
+        traverse_ rebuildFile fileName,
+      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> debugLsp "TextDocumentDidChange",
+      Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
+        debugLsp "SMethod_TextDocumentDidSave"
+        let uri :: Uri
+            uri = getMsgUri msg
+            fileName = Types.uriToFilePath uri
+        traverse_ rebuildFile fileName,
+      Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
+        cfg <- getConfig
+        debugLsp $ "Config changed: " <> show cfg,
+      Server.notificationHandler Message.SMethod_SetTrace $ \_msg -> debugLsp "SMethod_SetTrace",
+      Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
+        debugLsp "SMethod_TextDocumentDiagnostic"
+        (errs, diagnostics) <- getFileDiagnotics req
+        insertDiagnosticErrors diagErrs errs diagnostics
+        res $
+          Right $
+            Types.DocumentDiagnosticReport $
+              Types.InL $
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
+        let params = req ^. LSP.params
+            diags = params ^. LSP.context . LSP.diagnostics
+            uri = getMsgUri req
+
+        errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
+        res $
+          Right $
+            Types.InL $
+              errs & fmap \(_diag, err) ->
+                let textEdits :: [Types.TextEdit]
+                    textEdits =
+                      toSuggestion err
+                        & maybeToList
+                          >>= suggestionToEdit
+
+                    suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
+                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
+                      let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
+                          end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
+                       in pure $ Types.TextEdit (Types.Range start end) replacement
+                    suggestionToEdit _ = []
+                 in Types.InR $
+                      Types.CodeAction
+                        "Apply suggestion"
+                        (Just Types.CodeActionKind_QuickFix)
+                        (Just diags)
+                        (Just True)
+                        Nothing -- disabled
+                        ( Just $
+                            Types.WorkspaceEdit
+                              (Just $ Map.singleton uri textEdits)
+                              Nothing
+                              Nothing
+                        )
+                        Nothing
+                        Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+        debugLsp "SMethod_TextDocumentHover"
+        let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            docUri =
+              docIdent
+                ^. LSP.uri
+                  . to Types.toNormalizedUri
+            nullRes = res $ Right $ Types.InR Types.Null
+
+            markdownRes :: Text -> HandlerM () ()
+            markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
+
+            markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM () ()
+            markdownTypeRes word type' comments =
+              markdownRes $ pursTypeStr word type' comments
+
+            pursTypeStr word type' comments =
+              "```purescript\n"
+                <> word
+                <> annotation
+                <> "\n"
+                <> fold (convertComments comments)
+                <> "\n```"
+              where
+                annotation = case type' of
+                  Just t -> " :: " <> t
+                  Nothing -> ""
+
+            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp val f = maybe nullRes f val
+
+        forLsp filePathMb \filePath -> do
+          corefnExprMb <- getCoreFnExprAt filePath pos
+          case corefnExprMb of
+            Just (CF.Literal _ _) -> nullRes
+            Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
+              docsMb <- do
+                mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
+                maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` (P.runProperName tName)) mNameMb
+              case docsMb of
+                Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
+                Just docs -> markdownRes docs
+            Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
+              case qb of
+                P.ByModuleName mName -> do
+                  docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
+                  case docsMb of
+                    Just docs -> markdownRes docs
+                    _ -> do
+                      declMb <- getEfDeclarationInModule mName (runIdent ident)
+                      markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
+                P.BySourcePos _pos' ->
+                  markdownTypeRes (P.runIdent ident) Nothing []
+            _ -> do
+              vfMb <- Server.getVirtualFile docUri
+              forLsp vfMb \vf -> do
+                mNameMb <- selectExternModuleNameFromFilePath filePath
+                forLsp mNameMb \mName -> do
+                  names <- getNamesAtPosition pos mName (VFS._file_text vf)
+                  forLsp (head names) \name -> do
+                    docsMb <- readQualifiedNameDocsAsMarkdown name
+                    case docsMb of
+                      Nothing -> do
+                        typeMb <- lookupTypeInEnv name
+                        forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
+                      Just docs -> markdownRes docs,
+      Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+        sendInfoMsg "SMethod_TextDocumentDefinition"
+        let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            uri :: Types.NormalizedUri
+            uri =
+              req
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to Types.toNormalizedUri
+
+            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+            locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
+
+            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp val f = maybe nullRes f val
+
+        forLsp filePathMb \filePath -> do
+          vfMb <- Server.getVirtualFile uri
+          forLsp vfMb \vf -> do
+            mNameMb <- selectExternModuleNameFromFilePath filePath
+            debugLsp $ "Module name: " <> show mNameMb
+            debugLsp $ "Pos: " <> show pos
+            forLsp mNameMb \mName -> do
+              names <- getNamesAtPosition pos mName (VFS._file_text vf)
+              debugLsp $ "Found names: " <> show names
+
+              case head names of
+                Just name -> do
+                  debugLsp $ "Found name: " <> show name
+                  spanMb <- readQualifiedNameDocsSourceSpan name
+                  debugLsp $ "Found docs span: " <> show spanMb
+                  case spanMb of
+                    _ -> do
+                      case name of
+                        P.Qualified (P.BySourcePos pos') _ -> do
+                          debugLsp $ "Found source pos: " <> show pos'
+                          locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
+                        P.Qualified (P.ByModuleName nameModule) ident -> do
+                          debugLsp $ "Found module name: " <> show nameModule
+                          declMb <- getAstDeclarationInModule nameModule (printName ident)
+                          debugLsp $ "Found decl: " <> show declMb
+                          forLsp declMb \decl -> do
+                            modFpMb <- selectExternPathFromModuleName nameModule
+                            forLsp modFpMb \modFp -> do
+                              debugLsp $ "Found modFp: " <> show modFp
+                              let sourceSpan = P.declSourceSpan decl
+                              debugLsp $ "Found decl sourceSpan: " <> show sourceSpan
+                              locationRes modFp (spanToRange sourceSpan)
+                    Just span ->
+                      locationRes (P.spanName span) (spanToRange span)
+                _ -> do
+                  corefnExprMb <- getCoreFnExprAt filePath pos
+                  case corefnExprMb of
+                    Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
+                      debugLsp $ "Found Corefn Var source span: " <> show ss
+                      let name = P.runIdent ident
+                      case qb of
+                        P.ByModuleName coreMName -> do
+                          declMb <- getEfDeclarationInModule coreMName name
+                          forLsp declMb \decl -> do
+                            modFpMb <- selectExternPathFromModuleName coreMName
+                            forLsp modFpMb \modFp -> do
+                              let sourceSpan = efDeclSourceSpan decl
+                              locationRes modFp (spanToRange sourceSpan)
+                        P.BySourcePos srcPos ->
+                          locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
+                    _ -> nullRes,
+      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
+        debugLsp "SMethod_TextDocumentCompletion"
+        let Types.CompletionParams docIdent pos _prog _prog' completionCtx = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            uri :: Types.NormalizedUri
+            uri =
+              req
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to Types.toNormalizedUri
+
+            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp val f = maybe nullRes f val
+
+        debugLsp $ "Completion params: " <> show completionCtx
+        debugLsp $ "filePathMb: " <> show filePathMb
+        forLsp filePathMb \filePath -> do
+          vfMb <- Server.getVirtualFile uri
+          forLsp vfMb \vf -> do
+            let word = getWordAt (VFS._file_text vf) pos
+            debugLsp $ "Word: " <> show word <> " len " <> show (T.length word)
+            if T.length word < 2
+              then nullRes
+              else do
+                mNameMb <- selectExternModuleNameFromFilePath filePath
+                debugLsp $ "Module name: " <> show mNameMb
+                forLsp mNameMb \mName -> do
+                  decls <- getAstDeclarationsStartingWith mName word
+                  debugLsp $ "Found decls: " <> show decls
+                  res $
+                    Right $
+                      Types.InL $
+                        decls <&> \(declModule, decl) ->
+                          let label = foldMap printName (P.declName decl)
+                           in Types.CompletionItem
+                                { _label = label,
+                                  _labelDetails =
+                                    Just $
+                                      Types.CompletionItemLabelDetails
+                                        (Just $ " " <> printDeclarationType decl)
+                                        (Just $ " " <> P.runModuleName declModule),
+                                  _kind = declToCompletionItemKind decl,
+                                  _tags = Nothing,
+                                  _detail = Nothing,
+                                  _documentation = Nothing,
+                                  _deprecated = Nothing, --  Maybe Bool
+                                  _preselect = Nothing, --  Maybe Bool
+                                  _sortText = Nothing, --  Maybe Text
+                                  _filterText = Nothing, --  Maybe Text
+                                  _insertText = Nothing, --  Maybe Text
+                                  _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
+                                  _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
+                                  _textEdit = Nothing, --  Maybe
+                                  --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                                  _textEditText = Nothing, --  Maybe Text
+                                  _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
+                                  _commitCharacters = Nothing, --  Maybe [Text]
+                                  _command = Nothing, --  Maybe Types.Command
+                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModule decl
+                                },
+      Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
+        debugLsp "SMethod_CompletionItemResolve"
+        let completionItem = req ^. LSP.params
+            result = completionItem ^. LSP.data_ & decodeCompleteItemData
+
+        case result of
+          A.Success (Just (CompleteItemData _filePath _mName declModule decl)) -> do
+            let label = foldMap printName (P.declName decl)
+            docsMb <- readDeclarationDocsAsMarkdown declModule label
+            let addDocs :: Types.CompletionItem -> Types.CompletionItem
+                addDocs =
+                  docsMb & maybe
+                    identity
+                    \docs ->
+                      set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
+
+                addImport :: Types.CompletionItem -> Types.CompletionItem
+                addImport = identity
+            res $
+              Right $
+                completionItem
+                  & addDocs
+                  & addImport
+          _ -> res $ Right completionItem
+    ]
+  where
+    getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
+    getFileDiagnotics msg = do
+      let uri :: Uri
+          uri = getMsgUri msg
+          fileName = Types.uriToFilePath uri
+      case fileName of
+        Just file -> do
+          res <- rebuildFile file
+          getResultDiagnostics res
+        Nothing -> do
+          sendInfoMsg $ "No file path for uri: " <> show uri
+          pure ([], [])
+
+    getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
+    getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
+
+    getResultDiagnostics :: Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors) -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
+    getResultDiagnostics res = case res of
+      Left (_, errs) -> do
+        let errors = runMultipleErrors errs
+            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
+        pure (errors, diags)
+      Right (_, errs) | Errors.nonEmpty errs -> do
+        let errors = runMultipleErrors errs
+            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
+        pure (errors, diags)
+      _ -> pure ([], [])
+      where
+        errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
+        errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
+          Types.Diagnostic
+            (Types.Range start end)
+            (Just severity)
+            (Just $ Types.InR $ errorCode msg)
+            (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
+            (T.pack <$> spanName)
+            (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
+            Nothing
+            Nothing
+            Nothing
+          where
+            notFound = Types.Position 0 0
+            (spanName, start, end) = getPositions $ errorSpan msg
+
+            getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
+
+            getPositionsMb = fmap $ \spans ->
+              let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+                    NEL.head spans
+               in ( Just name,
+                    Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
+                    Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
+                  )
+
+spanToRange :: Errors.SourceSpan -> Types.Range
+spanToRange (Errors.SourceSpan _ start end) =
+  Types.Range
+    (sourcePosToPosition start)
+    (sourcePosToPosition end)
+
+sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
+sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index cb2c50dbf7..c4dc76e73b 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -25,6 +25,7 @@ logLsp :: (MonadIO m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text ->
 logLsp msgLogLevel msg = do
   logLevel <- confLogLevel . lspConfig <$> ask
   when (shouldLog msgLogLevel logLevel) $ do
+    -- Use stderr for logging as LSP messages should be on stdout
     liftIO $ putErrLn (show msgLogLevel <> ": " <> show msg :: Text)
 
 
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index a1efd4b5dd..4851cea238 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -1,416 +1,13 @@
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
 module Language.PureScript.LspSimple (main) where
 
-import Control.Lens ((^.))
-import Control.Lens.Getter (to)
-import Control.Lens.Setter (set)
 import Control.Monad.IO.Unlift
-import Data.Aeson qualified as A
-import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
-import Data.List.NonEmpty qualified as NEL
+import Data.IORef (newIORef)
 import Data.Map qualified as Map
-import Data.Set qualified as Set
-import Data.Text qualified as T
-import Language.LSP.Protocol.Lens qualified as LSP
-import Language.LSP.Protocol.Message qualified as Message
-import Language.LSP.Protocol.Types (Diagnostic, Uri)
-import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
-import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
-import Language.LSP.VFS qualified as VFS
-import Language.PureScript qualified as P
-import Language.PureScript.CoreFn.Expr qualified as CF
-import Language.PureScript.Docs.Convert.Single (convertComments)
-import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
-import Language.PureScript.Errors qualified as Errors
-import Language.PureScript.Errors.JSON (toSuggestion)
-import Language.PureScript.Errors.JSON qualified as JsonErrors
-import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
-import Language.PureScript.Lsp.Log (debugLsp)
-import Language.PureScript.Lsp.Print (printDeclarationType, printName)
-import Language.PureScript.Lsp.Rebuild (rebuildFile)
-import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEnvironment, decodeCompleteItemData)
-import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
-import Language.PureScript.Names (disqualify, runIdent)
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
-import Text.PrettyPrint.Boxes (render)
-
-type HandlerM config = ReaderT LspEnvironment ((Server.LspT config IO))
-
-type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
-
-insertDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [a] -> [k] -> m ()
-insertDiagnosticErrors diagErrs errs diags = liftIO $ modifyIORef diagErrs (Map.union $ Map.fromList $ zip diags errs)
-
-getDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [k] -> m (Map k a)
-getDiagnosticErrors diagErrs diags = liftIO $ flip Map.restrictKeys (Set.fromList diags) <$> readIORef diagErrs
-
-handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
-handlers diagErrs =
-  mconcat
-    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> sendInfoMsg "Failed to initialise lsp server",
-      Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        debugLsp "TextDocumentDidOpen"
-        let uri :: Uri
-            uri = getMsgUri msg
-            fileName = Types.uriToFilePath uri
-
-        traverse_ rebuildFile fileName,
-      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> debugLsp "TextDocumentDidChange",
-      Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
-        debugLsp "SMethod_TextDocumentDidSave"
-        let uri :: Uri
-            uri = getMsgUri msg
-            fileName = Types.uriToFilePath uri
-        traverse_ rebuildFile fileName,
-      Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
-        cfg <- getConfig
-        debugLsp $ "Config changed: " <> show cfg,
-      Server.notificationHandler Message.SMethod_SetTrace $ \_msg -> debugLsp "SMethod_SetTrace",
-      Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
-        debugLsp "SMethod_TextDocumentDiagnostic"
-        (errs, diagnostics) <- getFileDiagnotics req
-        insertDiagnosticErrors diagErrs errs diagnostics
-        res $
-          Right $
-            Types.DocumentDiagnosticReport $
-              Types.InL $
-                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
-        let params = req ^. LSP.params
-            diags = params ^. LSP.context . LSP.diagnostics
-            uri = getMsgUri req
-
-        errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
-        res $
-          Right $
-            Types.InL $
-              errs & fmap \(_diag, err) ->
-                let textEdits :: [Types.TextEdit]
-                    textEdits =
-                      toSuggestion err
-                        & maybeToList
-                          >>= suggestionToEdit
-
-                    suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
-                      let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
-                          end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
-                       in pure $ Types.TextEdit (Types.Range start end) replacement
-                    suggestionToEdit _ = []
-                 in Types.InR $
-                      Types.CodeAction
-                        "Apply suggestion"
-                        (Just Types.CodeActionKind_QuickFix)
-                        (Just diags)
-                        (Just True)
-                        Nothing -- disabled
-                        ( Just $
-                            Types.WorkspaceEdit
-                              (Just $ Map.singleton uri textEdits)
-                              Nothing
-                              Nothing
-                        )
-                        Nothing
-                        Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-        debugLsp "SMethod_TextDocumentHover"
-        let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
-            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            docUri =
-              docIdent
-                ^. LSP.uri
-                  . to Types.toNormalizedUri
-            nullRes = res $ Right $ Types.InR Types.Null
-
-            markdownRes :: Text -> HandlerM () ()
-            markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
-
-            markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM () ()
-            markdownTypeRes word type' comments =
-              markdownRes $ pursTypeStr word type' comments
-
-            pursTypeStr word type' comments =
-              "```purescript\n"
-                <> word
-                <> annotation
-                <> "\n"
-                <> fold (convertComments comments)
-                <> "\n```"
-              where
-                annotation = case type' of
-                  Just t -> " :: " <> t
-                  Nothing -> ""
-
-            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
-            forLsp val f = maybe nullRes f val
-
-        forLsp filePathMb \filePath -> do
-          corefnExprMb <- getCoreFnExprAt filePath pos
-          case corefnExprMb of
-            Just (CF.Literal _ _) -> nullRes
-            Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
-              docsMb <- do
-                mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
-                maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` (P.runProperName tName)) mNameMb
-              case docsMb of
-                Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
-                Just docs -> markdownRes docs
-            Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
-              case qb of
-                P.ByModuleName mName -> do
-                  docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
-                  case docsMb of
-                    Just docs -> markdownRes docs
-                    _ -> do
-                      declMb <- getEfDeclarationInModule mName (runIdent ident)
-                      markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
-                P.BySourcePos _pos' ->
-                  markdownTypeRes (P.runIdent ident) Nothing []
-            _ -> do
-              vfMb <- Server.getVirtualFile docUri
-              forLsp vfMb \vf -> do
-                mNameMb <- selectExternModuleNameFromFilePath filePath
-                forLsp mNameMb \mName -> do
-                  names <- getNamesAtPosition pos mName (VFS._file_text vf)
-                  forLsp (head names) \name -> do
-                    docsMb <- readQualifiedNameDocsAsMarkdown name
-                    case docsMb of
-                      Nothing -> do
-                        typeMb <- lookupTypeInEnv name
-                        forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
-                      Just docs -> markdownRes docs,
-      Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentDefinition"
-        let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            uri :: Types.NormalizedUri
-            uri =
-              req
-                ^. LSP.params
-                  . LSP.textDocument
-                  . LSP.uri
-                  . to Types.toNormalizedUri
-
-            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-            locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
-
-            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
-            forLsp val f = maybe nullRes f val
-
-        forLsp filePathMb \filePath -> do
-          vfMb <- Server.getVirtualFile uri
-          forLsp vfMb \vf -> do
-            mNameMb <- selectExternModuleNameFromFilePath filePath
-            debugLsp $ "Module name: " <> show mNameMb
-            debugLsp $ "Pos: " <> show pos
-            forLsp mNameMb \mName -> do
-              names <- getNamesAtPosition pos mName (VFS._file_text vf)
-              debugLsp $ "Found names: " <> show names
-
-              case head names of
-                Just name -> do
-                  debugLsp $ "Found name: " <> show name
-                  spanMb <- readQualifiedNameDocsSourceSpan name
-                  debugLsp $ "Found docs span: " <> show spanMb
-                  case spanMb of
-                    _ -> do
-                      case name of
-                        P.Qualified (P.BySourcePos pos') _ -> do
-                          debugLsp $ "Found source pos: " <> show pos'
-                          locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
-                        P.Qualified (P.ByModuleName nameModule) ident -> do
-                          debugLsp $ "Found module name: " <> show nameModule
-                          declMb <- getAstDeclarationInModule nameModule (printName ident)
-                          debugLsp $ "Found decl: " <> show declMb
-                          forLsp declMb \decl -> do
-                            modFpMb <- selectExternPathFromModuleName nameModule
-                            forLsp modFpMb \modFp -> do
-                              debugLsp $ "Found modFp: " <> show modFp
-                              let sourceSpan = P.declSourceSpan decl
-                              debugLsp $ "Found decl sourceSpan: " <> show sourceSpan
-                              locationRes modFp (spanToRange sourceSpan)
-                    Just span ->
-                      locationRes (P.spanName span) (spanToRange span)
-                _ -> do
-                  corefnExprMb <- getCoreFnExprAt filePath pos
-                  case corefnExprMb of
-                    Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
-                      debugLsp $ "Found Corefn Var source span: " <> show ss
-                      let name = P.runIdent ident
-                      case qb of
-                        P.ByModuleName coreMName -> do
-                          declMb <- getEfDeclarationInModule coreMName name
-                          forLsp declMb \decl -> do
-                            modFpMb <- selectExternPathFromModuleName coreMName
-                            forLsp modFpMb \modFp -> do
-                              let sourceSpan = efDeclSourceSpan decl
-                              locationRes modFp (spanToRange sourceSpan)
-                        P.BySourcePos srcPos ->
-                          locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-                    _ -> nullRes,
-      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
-        debugLsp "SMethod_TextDocumentCompletion"
-        let Types.CompletionParams docIdent pos _prog _prog' completionCtx = req ^. LSP.params
-            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            uri :: Types.NormalizedUri
-            uri =
-              req
-                ^. LSP.params
-                  . LSP.textDocument
-                  . LSP.uri
-                  . to Types.toNormalizedUri
-
-            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
-            forLsp val f = maybe nullRes f val
-
-        debugLsp $ "Completion params: " <> show completionCtx
-        debugLsp $ "filePathMb: " <> show filePathMb
-        forLsp filePathMb \filePath -> do
-          vfMb <- Server.getVirtualFile uri
-          forLsp vfMb \vf -> do
-            let word = getWordAt (VFS._file_text vf) pos
-            debugLsp $ "Word: " <> show word <> " len " <> show (T.length word)
-            if T.length word < 2
-              then nullRes
-              else do
-                mNameMb <- selectExternModuleNameFromFilePath filePath
-                debugLsp $ "Module name: " <> show mNameMb
-                forLsp mNameMb \mName -> do
-                  decls <- getAstDeclarationsStartingWith mName word
-                  debugLsp $ "Found decls: " <> show decls
-                  res $
-                    Right $
-                      Types.InL $
-                        decls <&> \(declModule, decl) ->
-                          let label = foldMap printName (P.declName decl)
-                           in Types.CompletionItem
-                                { _label = label,
-                                  _labelDetails =
-                                    Just $
-                                      Types.CompletionItemLabelDetails
-                                        (Just $ " " <> printDeclarationType decl)
-                                        (Just $ " " <> P.runModuleName declModule),
-                                  _kind = declToCompletionItemKind decl,
-                                  _tags = Nothing,
-                                  _detail = Nothing,
-                                  _documentation = Nothing,
-                                  _deprecated = Nothing, --  Maybe Bool
-                                  _preselect = Nothing, --  Maybe Bool
-                                  _sortText = Nothing, --  Maybe Text
-                                  _filterText = Nothing, --  Maybe Text
-                                  _insertText = Nothing, --  Maybe Text
-                                  _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
-                                  _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
-                                  _textEdit = Nothing, --  Maybe
-                                  --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
-                                  _textEditText = Nothing, --  Maybe Text
-                                  _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
-                                  _commitCharacters = Nothing, --  Maybe [Text]
-                                  _command = Nothing, --  Maybe Types.Command
-                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModule decl
-                                },
-      Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
-        debugLsp "SMethod_CompletionItemResolve"
-        let completionItem = req ^. LSP.params
-            result = completionItem ^. LSP.data_ & decodeCompleteItemData
-
-        case result of
-          A.Success (Just (CompleteItemData _filePath _mName declModule decl)) -> do
-            let label = foldMap printName (P.declName decl)
-            docsMb <- readDeclarationDocsAsMarkdown declModule label
-            let addDocs :: Types.CompletionItem -> Types.CompletionItem
-                addDocs =
-                  docsMb & maybe
-                    identity
-                    \docs ->
-                      set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
-
-                addImport :: Types.CompletionItem -> Types.CompletionItem
-                addImport = identity
-            res $
-              Right $
-                completionItem
-                  & addDocs
-                  & addImport
-          _ -> res $ Right completionItem
-    ]
-  where
-    getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
-    getFileDiagnotics msg = do
-      let uri :: Uri
-          uri = getMsgUri msg
-          fileName = Types.uriToFilePath uri
-      case fileName of
-        Just file -> do
-          res <- rebuildFile file
-          getResultDiagnostics res
-        Nothing -> do
-          sendInfoMsg $ "No file path for uri: " <> show uri
-          pure ([], [])
-
-    getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
-    getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
-
-    getResultDiagnostics :: Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors) -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
-    getResultDiagnostics res = case res of
-      Left (_, errs) -> do
-        let errors = runMultipleErrors errs
-            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
-        pure (errors, diags)
-      Right (_, errs) | Errors.nonEmpty errs -> do
-        let errors = runMultipleErrors errs
-            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
-        pure (errors, diags)
-      _ -> pure ([], [])
-      where
-        errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
-        errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
-          Types.Diagnostic
-            (Types.Range start end)
-            (Just severity)
-            (Just $ Types.InR $ errorCode msg)
-            (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
-            (T.pack <$> spanName)
-            (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
-            Nothing
-            Nothing
-            Nothing
-          where
-            notFound = Types.Position 0 0
-            (spanName, start, end) = getPositions $ errorSpan msg
-
-            getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
-
-            getPositionsMb = fmap $ \spans ->
-              let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
-                    NEL.head spans
-               in ( Just name,
-                    Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
-                    Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
-                  )
-
-spanToRange :: Errors.SourceSpan -> Types.Range
-spanToRange (Errors.SourceSpan _ start end) =
-  Types.Range
-    (sourcePosToPosition start)
-    (sourcePosToPosition end)
-
-sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
-sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
+import Language.PureScript.Lsp.Handlers (handlers)
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
@@ -423,9 +20,9 @@ main lspEnv = do
         configSection = "oa-purescript-lsp",
         doInitialize = \env _req -> pure $ Right env,
         staticHandlers = \_caps -> handlers diagErrs,
-        interpretHandler = \env ->
+        interpretHandler = \serverEnv ->
           Server.Iso
-            ( Server.runLspT env . flip runReaderT lspEnv
+            ( Server.runLspT serverEnv . flip runReaderT lspEnv
             )
             liftIO,
         options = lspOptions

From d115503c14fa4ac36e7f51ffd53522fd3b3f7dbb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 3 Oct 2024 10:43:59 +0200
Subject: [PATCH 076/297] better log labels

---
 src/Language/PureScript/Lsp/Log.hs | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index c4dc76e73b..80b81899b5 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -1,9 +1,7 @@
 module Language.PureScript.Lsp.Log where
 
+import Language.PureScript.Lsp.Types (LspConfig (confLogLevel), LspEnvironment (lspConfig), LspLogLevel (..))
 import Protolude
-import Language.PureScript.Lsp.Types (LspEnvironment (lspConfig), LspLogLevel (..), LspConfig (confLogLevel))
-
-
 
 infoLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
 infoLsp = logLsp LogMsgInfo
@@ -11,7 +9,7 @@ infoLsp = logLsp LogMsgInfo
 warnLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
 warnLsp = logLsp LogMsgWarning
 
-errorLsp  :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+errorLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
 errorLsp = logLsp LogMsgError
 
 debugLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
@@ -20,14 +18,12 @@ debugLsp = logLsp LogMsgDebug
 perfLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
 perfLsp = logLsp LogMsgPerf
 
-
 logLsp :: (MonadIO m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text -> m ()
 logLsp msgLogLevel msg = do
   logLevel <- confLogLevel . lspConfig <$> ask
   when (shouldLog msgLogLevel logLevel) $ do
     -- Use stderr for logging as LSP messages should be on stdout
-    liftIO $ putErrLn (show msgLogLevel <> ": " <> show msg :: Text)
-
+    liftIO $ putErrLn (printLogMsgSeverity msgLogLevel <> ": " <> show msg)
 
 data LogMsgSeverity
   = LogMsgInfo
@@ -37,6 +33,13 @@ data LogMsgSeverity
   | LogMsgPerf
   deriving (Show, Eq)
 
+printLogMsgSeverity :: LogMsgSeverity -> Text
+printLogMsgSeverity LogMsgInfo = "INFO"
+printLogMsgSeverity LogMsgWarning = "WARNING"
+printLogMsgSeverity LogMsgError = "ERROR"
+printLogMsgSeverity LogMsgDebug = "DEBUG"
+printLogMsgSeverity LogMsgPerf = "PERF"
+
 shouldLog :: LogMsgSeverity -> LspLogLevel -> Bool
 shouldLog msgLogLevel logLevel = case msgLogLevel of
   LogMsgInfo -> logLevel `elem` [LogInfo, LogDebug, LogAll]

From f82eb755816ef76e31e6eb618c7a788eae0e6f82 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 3 Oct 2024 11:43:26 +0200
Subject: [PATCH 077/297] add reactor to lsp server

---
 src/Language/PureScript/Lsp/Handlers.hs |  2 +-
 src/Language/PureScript/Lsp/Util.hs     |  8 ++++-
 src/Language/PureScript/LspSimple.hs    | 46 +++++++++++++++++++++++--
 3 files changed, 51 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 9fd4215690..6dea0d22cd 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -57,7 +57,7 @@ getDiagnosticErrors diagErrs diags = liftIO $ flip Map.restrictKeys (Set.fromLis
 handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
 handlers diagErrs =
   mconcat
-    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> sendInfoMsg "Failed to initialise lsp server",
+    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> sendInfoMsg "Lsp initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
         debugLsp "TextDocumentDidOpen"
         let uri :: Uri
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index b8f84f3daa..74135c7c37 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -16,7 +16,13 @@ import Data.Text.Utf16.Rope.Mixed as Rope
 import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.LSP.Protocol.Types (UInt)
 import Language.LSP.Protocol.Types qualified as Types
-import Language.PureScript qualified as P
+import Language.PureScript.AST qualified as P
+import Language.PureScript.Comments qualified as P
+import Language.PureScript.Environment qualified as P
+import Language.PureScript.Externs qualified as P
+import Language.PureScript.Linter qualified as P
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Types qualified as P
 import Language.PureScript.AST.Declarations (declSourceAnn)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
index 4851cea238..8bc782df44 100644
--- a/src/Language/PureScript/LspSimple.hs
+++ b/src/Language/PureScript/LspSimple.hs
@@ -1,16 +1,23 @@
+{-# LANGUAGE PolyKinds #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+
 module Language.PureScript.LspSimple (main) where
 
+import Control.Concurrent.STM.TChan
 import Control.Monad.IO.Unlift
 import Data.IORef (newIORef)
 import Data.Map qualified as Map
+import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server as LSP.Server
 import Language.LSP.Server qualified as Server
+import Language.PureScript.Lsp.Handlers (DiagnosticErrors, HandlerM, handlers)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
-import Language.PureScript.Lsp.Handlers (handlers)
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
+  rin <- atomically newTChan :: IO (TChan ReactorInput)
   diagErrs <- newIORef Map.empty
   Server.runServer $
     Server.ServerDefinition
@@ -18,8 +25,8 @@ main lspEnv = do
         onConfigChange = const $ pure (),
         defaultConfig = (),
         configSection = "oa-purescript-lsp",
-        doInitialize = \env _req -> pure $ Right env,
-        staticHandlers = \_caps -> handlers diagErrs,
+        doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env),
+        staticHandlers = \_caps -> lspHandlers lspEnv diagErrs rin,
         interpretHandler = \serverEnv ->
           Server.Iso
             ( Server.runLspT serverEnv . flip runReaderT lspEnv
@@ -44,3 +51,36 @@ lspOptions =
     { Server.optTextDocumentSync = Just syncOptions,
       Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
     }
+
+-- The reactor is a process that serialises and buffers all requests from the
+-- LSP client, so they can be sent to the backend compiler one at a time, and a
+-- reply sent.
+
+newtype ReactorInput
+  = ReactorAction (IO ())
+
+-- | The single point that all events flow through, allowing management of state
+-- to stitch replies and requests together from the two asynchronous sides: lsp
+-- server and backend compiler
+reactor :: TChan ReactorInput -> IO ()
+reactor inp = do
+  forever $ do
+    ReactorAction act <- atomically $ readTChan inp
+    act
+
+-- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
+-- input into the reactor
+lspHandlers :: LspEnvironment -> DiagnosticErrors -> TChan ReactorInput -> Handlers (HandlerM ())
+lspHandlers lspEnv diagErrors rin = mapHandlers goReq goNot (handlers diagErrors)
+  where
+    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
+    goReq f msg k = do
+      env <- getLspEnv
+      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg k)
+
+    goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
+    goNot f msg = do
+      env <- getLspEnv
+      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg)
+
+    runHandler env a = runLspT env $ runReaderT a lspEnv

From d687616ed6a6aa6a92b440e949b5a5173f1e5c14 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 3 Oct 2024 11:48:51 +0200
Subject: [PATCH 078/297] remove comments

---
 src/Language/PureScript/Lsp/Cache/Query.hs | 14 --------------
 1 file changed, 14 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 3b04b01a3c..bdae267d46 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -3,8 +3,6 @@
 
 module Language.PureScript.Lsp.Cache.Query where
 
--- import Language.PureScript.Bundle (getImportedModules)
-
 import Codec.Serialise (deserialise)
 import Data.Aeson (encode)
 import Data.Aeson qualified as A
@@ -26,18 +24,6 @@ import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
 
--- import Control.Monad.Logger (logDebugN)
-
--- getEfDeclarationAt :: (MonadIO m, MonadReader LspEnvironment m) => Position -> m (Maybe P.Declaration)
--- getEfDeclarationAt pos = do
---   decls <-
---     DB.queryNamed
---       "SELECT * FROM declarations WHERE startLine <= :line AND endLine >= :line AND startColumn <= :column AND endColumn >= :column"
---       [":line" := line
---       , ":column" := column
---       ]
---   pure $ listToMaybe decls
--- getImportedModules
 
 getCoreFnExprAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Expr CF.Ann))
 getCoreFnExprAt path (LSP.Position line col) = do

From 13955657317795942e667c869682140ef33508cd Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 3 Oct 2024 13:27:13 +0200
Subject: [PATCH 079/297] removes diagnostics ref

---
 app/Command/Lsp.hs                         |   2 +-
 purescript.cabal                           |   4 +-
 src/Language/PureScript/LSP.hs             | 299 +++------------------
 src/Language/PureScript/Lsp/Diagnostics.hs |  86 ++++++
 src/Language/PureScript/Lsp/Handlers.hs    |  99 +------
 src/Language/PureScript/Lsp/Imports.hs     |  15 +-
 src/Language/PureScript/LspSimple.hs       |  86 ------
 7 files changed, 155 insertions(+), 436 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Diagnostics.hs
 delete mode 100644 src/Language/PureScript/LspSimple.hs

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index 8d70220f51..82be5b376e 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -1,7 +1,7 @@
 module Command.Lsp (command) where
 
 import Language.PureScript.Lsp.Types (LspConfig (..), mkEnv, LspLogLevel(..))
-import Language.PureScript.LspSimple as Lsp
+import Language.PureScript.Lsp as Lsp
 import Options.Applicative qualified as Opts
 import Protolude
 import SharedCLI qualified
diff --git a/purescript.cabal b/purescript.cabal
index 7e54bb240d..796c134486 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -213,8 +213,6 @@ common defaults
     witherable >=0.4.2 && <0.5,
     lsp >=2.2.0 && <3.0,
     lsp-types >=2.2.0 && <3.0,
-    co-log-core >= 0.3.2.0 && < 0.4,
-    prettyprinter >= 1.7.0 && < 2.0,
     unliftio-core >= 0.2.0.0 && < 0.3,
     text-rope >= 0.2 && < 1.0
 
@@ -348,6 +346,7 @@ library
     Language.PureScript.Lsp.Cache
     Language.PureScript.Lsp.Cache.IO
     Language.PureScript.Lsp.Cache.Query
+    Language.PureScript.Lsp.Diagnostics
     Language.PureScript.Lsp.Handlers
     Language.PureScript.Lsp.Log
     Language.PureScript.Lsp.Prim
@@ -357,7 +356,6 @@ library
     Language.PureScript.Lsp.State
     Language.PureScript.Lsp.Types
     Language.PureScript.Lsp.Util
-    Language.PureScript.LspSimple
     Language.PureScript.Make
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 82c14205fe..c082285884 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -1,117 +1,54 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 module Language.PureScript.Lsp (main) where
 
-import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))
-import Colog.Core qualified as L
 import Control.Concurrent.STM.TChan
-import Control.Exception qualified as E
-import Control.Lens hiding (Iso)
-import Data.Aeson qualified as J
-import Data.Text qualified as T
-import Language.LSP.Diagnostics
-import Language.LSP.Logging (defaultClientLogger)
-import Language.LSP.Protocol.Lens qualified as LSP
+import Control.Monad.IO.Unlift
 import Language.LSP.Protocol.Message qualified as LSP
-import Language.LSP.Protocol.Types qualified as LSP
+import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server as LSP.Server
--- import Language.LSP.VFS  (VirtualFile(..))
-import Language.LSP.VFS  qualified as VFS
-import Prettyprinter
+import Language.LSP.Server qualified as Server
+import Language.PureScript.Lsp.Handlers (HandlerM, handlers)
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
-import System.IO as IO
 
--- -- ---------------------------------------------------------------------
--- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
--- {-# ANN module ("HLint: ignore Redundant do" :: String) #-}
--- {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-
--- -- ---------------------------------------------------------------------
--- --
-
-main :: IO ()
-main = do
-  run >>= \case
-    0 -> exitSuccess
-    c -> exitWith . ExitFailure $ c
-
--- ---------------------------------------------------------------------
-
-data Config = Config {fooTheBar :: Bool, wibbleFactor :: Int}
-  deriving (Generic, J.ToJSON, J.FromJSON, Show)
-
-run :: IO Int
-run = flip E.catches execptionHandlers $ do
+main :: LspEnvironment -> IO Int
+main lspEnv = do
   rin <- atomically newTChan :: IO (TChan ReactorInput)
-
-  let -- Three loggers:
-      -- 1. To stderr
-      -- 2. To the client (filtered by severity)
-      -- 3. To both
-      stderrLogger :: LogAction IO (WithSeverity T.Text)
-      stderrLogger = L.cmap show L.logStringStderr
-      clientLogger :: LogAction (LspM Config) (WithSeverity T.Text)
-      clientLogger = defaultClientLogger
-      dualLogger :: LogAction (LspM Config) (WithSeverity T.Text)
-      dualLogger = clientLogger <> L.hoistLogAction liftIO stderrLogger
-
-      serverDefinition =
-        ServerDefinition
-          { defaultConfig = Config {fooTheBar = False, wibbleFactor = 0},
-            parseConfig = \_old v -> do
-              case J.fromJSON v of
-                J.Error e -> Left (T.pack e)
-                J.Success cfg -> Right cfg,
-            onConfigChange = const $ pure (),
-            configSection = "demo",
-            doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env),
-            -- Handlers log to both the client and stderr
-            staticHandlers = \_caps -> lspHandlers dualLogger rin,
-            interpretHandler = \env -> Iso (runLspT env) liftIO,
-            options = lspOptions
-          }
-
-  let logToText = T.pack . show . pretty
-  runServerWithHandles
-    -- Log to both the client and stderr when we can, stderr beforehand
-    (L.cmap (fmap logToText) stderrLogger)
-    (L.cmap (fmap logToText) dualLogger)
-    stdin
-    stdout
-    serverDefinition
-  where
-    execptionHandlers =
-      [ E.Handler ioExcept,
-        E.Handler someExcept
-      ]
-    ioExcept (e :: E.IOException) = IO.print e >> return 1
-    someExcept (e :: E.SomeException) = IO.print e >> return 1
-
--- ---------------------------------------------------------------------
-
-syncOptions :: LSP.TextDocumentSyncOptions
+  Server.runServer $
+    Server.ServerDefinition
+      { parseConfig = const $ const $ Right (),
+        onConfigChange = const $ pure (),
+        defaultConfig = (),
+        configSection = "oa-purescript-lsp",
+        doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env),
+        staticHandlers = \_caps -> lspHandlers lspEnv rin,
+        interpretHandler = \serverEnv ->
+          Server.Iso
+            ( Server.runLspT serverEnv . flip runReaderT lspEnv
+            )
+            liftIO,
+        options = lspOptions
+      }
+
+syncOptions :: Types.TextDocumentSyncOptions
 syncOptions =
-  LSP.TextDocumentSyncOptions
-    { LSP._openClose = Just True,
-      LSP._change = Just LSP.TextDocumentSyncKind_Incremental,
-      LSP._willSave = Just False,
-      LSP._willSaveWaitUntil = Just False,
-      LSP._save = Just $ LSP.InR $ LSP.SaveOptions $ Just False
+  Types.TextDocumentSyncOptions
+    { Types._openClose = Just True,
+      Types._change = Just Types.TextDocumentSyncKind_Incremental,
+      Types._willSave = Just False,
+      Types._willSaveWaitUntil = Just False,
+      Types._save = Just $ Types.InR $ Types.SaveOptions $ Just False
     }
 
-lspOptions :: Options
+lspOptions :: Server.Options
 lspOptions =
-  defaultOptions
-    { optTextDocumentSync = Just syncOptions,
-      optExecuteCommandCommands = Just ["lsp-hello-command"]
+  Server.defaultOptions
+    { Server.optTextDocumentSync = Just syncOptions,
+      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
     }
 
--- ---------------------------------------------------------------------
-
 -- The reactor is a process that serialises and buffers all requests from the
 -- LSP client, so they can be sent to the backend compiler one at a time, and a
 -- reply sent.
@@ -119,176 +56,28 @@ lspOptions =
 newtype ReactorInput
   = ReactorAction (IO ())
 
--- | Analyze the file and send any diagnostics to the client in a
--- "textDocument/publishDiagnostics" notification
-sendDiagnostics :: LSP.NormalizedUri -> Maybe Int32 -> LspM Config ()
-sendDiagnostics fileUri version = do
-  let diags =
-        [ LSP.Diagnostic
-            (LSP.Range (LSP.Position 0 1) (LSP.Position 0 5))
-            (Just LSP.DiagnosticSeverity_Warning) -- severity
-            Nothing -- code
-            Nothing
-            (Just "lsp-hello") -- source
-            "Example diagnostic message"
-            Nothing -- tags
-            (Just [])
-            Nothing
-        ]
-  publishDiagnostics 100 fileUri version (partitionBySource diags)
-
--- ---------------------------------------------------------------------
-
 -- | The single point that all events flow through, allowing management of state
 -- to stitch replies and requests together from the two asynchronous sides: lsp
 -- server and backend compiler
-reactor :: L.LogAction IO (WithSeverity T.Text) -> TChan ReactorInput -> IO ()
-reactor logger inp = do
-  logger <& "Started the reactor" `WithSeverity` Info
+reactor :: TChan ReactorInput -> IO ()
+reactor inp = do
   forever $ do
     ReactorAction act <- atomically $ readTChan inp
     act
 
 -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
 -- input into the reactor
-lspHandlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> TChan ReactorInput -> Handlers m
-lspHandlers logger rin = mapHandlers goReq goNot (handlers logger)
+lspHandlers :: LspEnvironment -> TChan ReactorInput -> Handlers (HandlerM ())
+lspHandlers lspEnv rin = mapHandlers goReq goNot handlers
   where
-    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (LspM Config) a -> LSP.Server.Handler (LspM Config) a
+    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
     goReq f msg k = do
       env <- getLspEnv
-      liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k)
+      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg k)
 
-    goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (LspM Config) a -> LSP.Server.Handler (LspM Config) a
+    goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
     goNot f msg = do
       env <- getLspEnv
-      liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg)
-
--- | Where the actual logic resides for handling requests and notifications.
-handlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> Handlers m
-handlers logger =
-  mconcat
-    [ notificationHandler LSP.SMethod_Initialized $ \_msg -> do
-        logger <& "Processing the Initialized notification" `WithSeverity` Info
-
-        -- We're initialized! Lets send a showMessageRequest now
-        let params =
-              LSP.ShowMessageRequestParams
-                LSP.MessageType_Warning
-                "What's your favourite language extension?"
-                (Just [LSP.MessageActionItem "Rank2Types", LSP.MessageActionItem "NPlusKPatterns"])
-
-        void $ sendRequest LSP.SMethod_WindowShowMessageRequest params $ \case
-          Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error
-          Right _ -> do
-            sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Excellent choice")
-
-            -- We can dynamically register a capability once the user accepts it
-            sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Turning on code lenses dynamically")
-
-            let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False)
-
-            void
-              $ registerCapability
-                mempty
-                LSP.SMethod_TextDocumentCodeLens
-                regOpts
-              $ \_req responder -> do
-                logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info
-                let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing
-                    rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing]
-                responder (Right $ LSP.InL rsp),
-      notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do
-        let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri
-            fileName = LSP.uriToFilePath doc
-        logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info
-        case fileName of
-          Nothing -> logger <& "No filename found" `WithSeverity` Error
-          Just _path -> do
-            -- res <- _ $rebuildFileAsync path Nothing (Set.singleton JS)
-            sendDiagnostics (LSP.toNormalizedUri doc) (Just 0),
-      notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do
-        cfg <- getConfig
-        logger L.<& ("Configuration changed: " <> T.pack (show (msg, cfg))) `WithSeverity` Info
-        sendNotification LSP.SMethod_WindowShowMessage $
-          LSP.ShowMessageParams LSP.MessageType_Info $
-            "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)),
-      notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do
-        let doc =
-              msg
-                ^. LSP.params
-                  . LSP.textDocument
-                  . LSP.uri
-                  . to LSP.toNormalizedUri
-        logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info
-        mdoc <- getVirtualFile doc
-        case mdoc of
-          Just (VFS.VirtualFile _version str _) -> do
-            logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info
-          Nothing -> do
-            logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info,
-      notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do
-        let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri
-            fileName = LSP.uriToFilePath doc
-        logger <& ("Processing DidSaveTextDocument  for: " <> T.pack (show fileName)) `WithSeverity` Info
-        sendDiagnostics (LSP.toNormalizedUri doc) Nothing,
-      requestHandler LSP.SMethod_TextDocumentRename $ \req responder -> do
-        logger <& "Processing a textDocument/rename request" `WithSeverity` Info
-        let params = req ^. LSP.params
-            LSP.Position l c = params ^. LSP.position
-            newName = params ^. LSP.newName
-        vdoc <- getVersionedTextDoc (params ^. LSP.textDocument)
-        -- Replace some text at the position with what the user entered
-        let edit = LSP.InL $ LSP.TextEdit (LSP.mkRange l c l (c + fromIntegral (T.length newName))) newName
-            tde = LSP.TextDocumentEdit (LSP._versionedTextDocumentIdentifier # vdoc) [edit]
-            -- "documentChanges" field is preferred over "changes"
-            rsp = LSP.WorkspaceEdit Nothing (Just [LSP.InL tde]) Nothing
-        responder (Right $ LSP.InL rsp),
-      requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do
-        logger <& "Processing a textDocument/hover request" `WithSeverity` Info
-        let LSP.HoverParams _doc pos _workDone = req ^. LSP.params
-            LSP.Position _l _c' = pos
-            rsp = LSP.Hover ms (Just range)
-            ms = LSP.InL $ LSP.mkMarkdown "Your type info here!"
-            range = LSP.Range pos pos
-        responder (Right $ LSP.InL rsp),
-      requestHandler LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do
-        logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info
-        let LSP.DocumentSymbolParams _ _ doc = req ^. LSP.params
-            loc = LSP.Location (doc ^. LSP.uri) (LSP.Range (LSP.Position 0 0) (LSP.Position 0 0))
-            rsp = [LSP.SymbolInformation "lsp-hello" LSP.SymbolKind_Function Nothing Nothing Nothing loc]
-        responder (Right $ LSP.InL rsp),
-      requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do
-        logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info
-        let params = req ^. LSP.params
-            doc = params ^. LSP.textDocument
-            diags = params ^. LSP.context . LSP.diagnostics
-            -- makeCommand only generates commands for diagnostics whose source is us
-            makeCommand d
-              | (LSP.Range s _) <- d ^. LSP.range,
-                (Just "lsp-hello") <- d ^. LSP.source =
-                  let title = fromMaybe "" $ Just "Apply LSP hello command:" <> head (T.lines $ d ^. LSP.message)
-                      -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above
-                      cmd = "lsp-hello-command"
-                      -- need 'file' and 'start_pos'
-                      args =
-                        [ J.object [("file", J.object [("textDocument", J.toJSON doc)])],
-                          J.object [("start_pos", J.object [("position", J.toJSON s)])]
-                        ]
-                      cmdparams = Just args
-                   in [LSP.Command title cmd cmdparams]
-            makeCommand _ = []
-            rsp = map LSP.InL $ concatMap makeCommand diags
-        responder (Right $ LSP.InL rsp),
-      requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do
-        logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info
-        let params = req ^. LSP.params
-            margs = params ^. LSP.arguments
+      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg)
 
-        logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug
-        responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request
-        void $ withProgress "Executing some long running command" (req ^. LSP.params . LSP.workDoneToken) Cancellable $ \update ->
-          forM [(0 :: LSP.UInt) .. 10] $ \i -> do
-            update (ProgressAmount (Just (i * 10)) (Just "Doing stuff"))
-            liftIO $ threadDelay (1 * 1000000)
-    ]
+    runHandler env a = runLspT env $ runReaderT a lspEnv
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
new file mode 100644
index 0000000000..6992b3f7ee
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -0,0 +1,86 @@
+module Language.PureScript.Lsp.Diagnostics where
+
+import Control.Lens ((^.))
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.IO.Unlift
+import Data.Aeson qualified as A
+import Data.List.NonEmpty qualified as NEL
+import Data.Text qualified as T
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Types (Diagnostic, Uri)
+import Language.LSP.Protocol.Types qualified as Types
+import Language.PureScript qualified as P
+import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
+import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Errors.JSON (toSuggestion)
+import Language.PureScript.Errors.JSON qualified as JsonErrors
+import Language.PureScript.Lsp.Rebuild (rebuildFile)
+import Language.PureScript.Lsp.Types (LspEnvironment)
+import Protolude hiding (to)
+import Text.PrettyPrint.Boxes (render)
+
+getFileDiagnotics :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri, MonadIO m, MonadThrow m, MonadReader LspEnvironment m) => s -> m ([ErrorMessage], [Diagnostic])
+getFileDiagnotics msg = do
+  let uri :: Uri
+      uri = getMsgUri msg
+      fileName = Types.uriToFilePath uri
+  case fileName of
+    Just file -> do
+      res <- rebuildFile file
+      pure $ getResultDiagnostics res
+    Nothing -> pure ([], [])
+
+getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
+getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
+
+getResultDiagnostics ::
+  Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors) ->
+  ([ErrorMessage], [Types.Diagnostic])
+getResultDiagnostics res = case res of
+  Left (_, errs) -> do
+    let errors = runMultipleErrors errs
+        diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
+    (errors, diags)
+  Right (_, errs) | Errors.nonEmpty errs -> do
+    let errors = runMultipleErrors errs
+        diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
+    (errors, diags)
+  _ -> ([], [])
+  where
+    errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
+    errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
+      let textEdits :: [Types.TextEdit]
+          textEdits =
+            toSuggestion msg
+              & maybeToList
+              >>= suggestionToEdit
+
+          suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
+          suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
+            let rangeStart = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
+                rangeEnd = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
+             in pure $ Types.TextEdit (Types.Range rangeStart rangeEnd) replacement
+          suggestionToEdit _ = []
+       in Types.Diagnostic
+            (Types.Range start end)
+            (Just severity)
+            (Just $ Types.InR $ errorCode msg)
+            (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
+            (T.pack <$> spanName)
+            (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
+            Nothing
+            Nothing
+            (Just $ A.toJSON textEdits)
+      where
+        notFound = Types.Position 0 0
+        (spanName, start, end) = getPositions $ errorSpan msg
+
+        getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
+
+        getPositionsMb = fmap $ \spans ->
+          let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+                NEL.head spans
+           in ( Just name,
+                Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
+                Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
+              )
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 6dea0d22cd..04b7cafdd7 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -5,20 +5,15 @@
 
 module Language.PureScript.Lsp.Handlers where
 
-
 import Control.Lens ((^.))
 import Control.Lens.Getter (to)
 import Control.Lens.Setter (set)
-import Control.Monad.IO.Unlift
 import Data.Aeson qualified as A
-import Data.IORef (IORef, modifyIORef, readIORef)
-import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
-import Data.Set qualified as Set
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
-import Language.LSP.Protocol.Types (Diagnostic, Uri)
+import Language.LSP.Protocol.Types (Uri)
 import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (getConfig)
@@ -27,13 +22,11 @@ import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
-import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
-import Language.PureScript.Errors.JSON (toSuggestion)
-import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Diagnostics (getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
@@ -42,20 +35,11 @@ import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEn
 import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
-import Text.PrettyPrint.Boxes (render)
 
 type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
-type DiagnosticErrors = IORef (Map Diagnostic ErrorMessage)
-
-insertDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [a] -> [k] -> m ()
-insertDiagnosticErrors diagErrs errs diags = liftIO $ modifyIORef diagErrs (Map.union $ Map.fromList $ zip diags errs)
-
-getDiagnosticErrors :: (MonadIO m, Ord k) => IORef (Map k a) -> [k] -> m (Map k a)
-getDiagnosticErrors diagErrs diags = liftIO $ flip Map.restrictKeys (Set.fromList diags) <$> readIORef diagErrs
-
-handlers :: DiagnosticErrors -> Server.Handlers (HandlerM ())
-handlers diagErrs =
+handlers :: Server.Handlers (HandlerM ())
+handlers =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> sendInfoMsg "Lsp initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
@@ -78,8 +62,7 @@ handlers diagErrs =
       Server.notificationHandler Message.SMethod_SetTrace $ \_msg -> debugLsp "SMethod_SetTrace",
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
         debugLsp "SMethod_TextDocumentDiagnostic"
-        (errs, diagnostics) <- getFileDiagnotics req
-        insertDiagnosticErrors diagErrs errs diagnostics
+        (_errs, diagnostics) <- getFileDiagnotics req
         res $
           Right $
             Types.DocumentDiagnosticReport $
@@ -90,23 +73,13 @@ handlers diagErrs =
             diags = params ^. LSP.context . LSP.diagnostics
             uri = getMsgUri req
 
-        errs <- Map.toList <$> getDiagnosticErrors diagErrs diags
         res $
           Right $
             Types.InL $
-              errs & fmap \(_diag, err) ->
-                let textEdits :: [Types.TextEdit]
-                    textEdits =
-                      toSuggestion err
-                        & maybeToList
-                          >>= suggestionToEdit
-
-                    suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-                    suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
-                      let start = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
-                          end = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
-                       in pure $ Types.TextEdit (Types.Range start end) replacement
-                    suggestionToEdit _ = []
+              diags <&> \diag ->
+                let textEdits = case A.fromJSON <$> diag ^. LSP.data_ of
+                      Just (A.Success tes) -> tes
+                      _ -> []
                  in Types.InR $
                       Types.CodeAction
                         "Apply suggestion"
@@ -347,60 +320,6 @@ handlers diagErrs =
                   & addImport
           _ -> res $ Right completionItem
     ]
-  where
-    getFileDiagnotics :: (LSP.HasUri a2 Uri, LSP.HasTextDocument a1 a2, LSP.HasParams s a1) => s -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
-    getFileDiagnotics msg = do
-      let uri :: Uri
-          uri = getMsgUri msg
-          fileName = Types.uriToFilePath uri
-      case fileName of
-        Just file -> do
-          res <- rebuildFile file
-          getResultDiagnostics res
-        Nothing -> do
-          sendInfoMsg $ "No file path for uri: " <> show uri
-          pure ([], [])
-
-    getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
-    getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
-
-    getResultDiagnostics :: Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors) -> HandlerM config ([ErrorMessage], [Types.Diagnostic])
-    getResultDiagnostics res = case res of
-      Left (_, errs) -> do
-        let errors = runMultipleErrors errs
-            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
-        pure (errors, diags)
-      Right (_, errs) | Errors.nonEmpty errs -> do
-        let errors = runMultipleErrors errs
-            diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
-        pure (errors, diags)
-      _ -> pure ([], [])
-      where
-        errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
-        errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
-          Types.Diagnostic
-            (Types.Range start end)
-            (Just severity)
-            (Just $ Types.InR $ errorCode msg)
-            (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
-            (T.pack <$> spanName)
-            (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
-            Nothing
-            Nothing
-            Nothing
-          where
-            notFound = Types.Position 0 0
-            (spanName, start, end) = getPositions $ errorSpan msg
-
-            getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
-
-            getPositionsMb = fmap $ \spans ->
-              let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
-                    NEL.head spans
-               in ( Just name,
-                    Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
-                    Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
-                  )
 
 spanToRange :: Errors.SourceSpan -> Types.Range
 spanToRange (Errors.SourceSpan _ start end) =
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 2a405678fe..f199a1ae32 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -1,5 +1,18 @@
 module Language.PureScript.Lsp.Imports where
 
+import Control.Lens (set)
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Types (CompletionItem, TextEdit)
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.Lsp.Types (CompleteItemData (..))
+import Language.PureScript.Names qualified as P
+import Protolude
 
--- import Protolude
+addImportToTextEdit :: (MonadIO m) => CompletionItem -> CompleteItemData -> m CompletionItem
+addImportToTextEdit completionItem completeItemData = do
+  importEdits <- getImportEdits completeItemData
+  pure $ set LSP.additionalTextEdits importEdits completionItem
 
+getImportEdits :: (MonadIO m) => CompleteItemData -> m (Maybe [TextEdit])
+getImportEdits (CompleteItemData path moduleName' importedModuleName decl) = do
+  undefined
diff --git a/src/Language/PureScript/LspSimple.hs b/src/Language/PureScript/LspSimple.hs
deleted file mode 100644
index 8bc782df44..0000000000
--- a/src/Language/PureScript/LspSimple.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE PolyKinds #-}
-{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-
-module Language.PureScript.LspSimple (main) where
-
-import Control.Concurrent.STM.TChan
-import Control.Monad.IO.Unlift
-import Data.IORef (newIORef)
-import Data.Map qualified as Map
-import Language.LSP.Protocol.Message qualified as LSP
-import Language.LSP.Protocol.Types qualified as Types
-import Language.LSP.Server as LSP.Server
-import Language.LSP.Server qualified as Server
-import Language.PureScript.Lsp.Handlers (DiagnosticErrors, HandlerM, handlers)
-import Language.PureScript.Lsp.Types (LspEnvironment)
-import Protolude hiding (to)
-
-main :: LspEnvironment -> IO Int
-main lspEnv = do
-  rin <- atomically newTChan :: IO (TChan ReactorInput)
-  diagErrs <- newIORef Map.empty
-  Server.runServer $
-    Server.ServerDefinition
-      { parseConfig = const $ const $ Right (),
-        onConfigChange = const $ pure (),
-        defaultConfig = (),
-        configSection = "oa-purescript-lsp",
-        doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env),
-        staticHandlers = \_caps -> lspHandlers lspEnv diagErrs rin,
-        interpretHandler = \serverEnv ->
-          Server.Iso
-            ( Server.runLspT serverEnv . flip runReaderT lspEnv
-            )
-            liftIO,
-        options = lspOptions
-      }
-
-syncOptions :: Types.TextDocumentSyncOptions
-syncOptions =
-  Types.TextDocumentSyncOptions
-    { Types._openClose = Just True,
-      Types._change = Just Types.TextDocumentSyncKind_Incremental,
-      Types._willSave = Just False,
-      Types._willSaveWaitUntil = Just False,
-      Types._save = Just $ Types.InR $ Types.SaveOptions $ Just False
-    }
-
-lspOptions :: Server.Options
-lspOptions =
-  Server.defaultOptions
-    { Server.optTextDocumentSync = Just syncOptions,
-      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
-    }
-
--- The reactor is a process that serialises and buffers all requests from the
--- LSP client, so they can be sent to the backend compiler one at a time, and a
--- reply sent.
-
-newtype ReactorInput
-  = ReactorAction (IO ())
-
--- | The single point that all events flow through, allowing management of state
--- to stitch replies and requests together from the two asynchronous sides: lsp
--- server and backend compiler
-reactor :: TChan ReactorInput -> IO ()
-reactor inp = do
-  forever $ do
-    ReactorAction act <- atomically $ readTChan inp
-    act
-
--- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
--- input into the reactor
-lspHandlers :: LspEnvironment -> DiagnosticErrors -> TChan ReactorInput -> Handlers (HandlerM ())
-lspHandlers lspEnv diagErrors rin = mapHandlers goReq goNot (handlers diagErrors)
-  where
-    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
-    goReq f msg k = do
-      env <- getLspEnv
-      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg k)
-
-    goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
-    goNot f msg = do
-      env <- getLspEnv
-      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg)
-
-    runHandler env a = runLspT env $ runReaderT a lspEnv

From 28d2498a667cc715f1d039937330cd130d7be892 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 3 Oct 2024 18:28:13 +0200
Subject: [PATCH 080/297] unqualified imports working

---
 src/Language/PureScript/Ide/Imports.hs  |  1 +
 src/Language/PureScript/Lsp/Handlers.hs | 12 ++--
 src/Language/PureScript/Lsp/Imports.hs  | 87 +++++++++++++++++++++++--
 src/Language/PureScript/Lsp/Types.hs    |  3 +-
 4 files changed, 89 insertions(+), 14 deletions(-)

diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index b96f090a7f..4001813804 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -19,6 +19,7 @@ module Language.PureScript.Ide.Imports
        , parseImport
        , prettyPrintImportSection
        , sliceImportSection
+       , parseModuleHeader
        , prettyPrintImport'
        , Import(Import)
        )
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 04b7cafdd7..08d681aa61 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -28,6 +28,7 @@ import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, select
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Diagnostics (getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
+import Language.PureScript.Lsp.Imports (addImportToTextEdit)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
@@ -293,7 +294,7 @@ handlers =
                                   _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
                                   _commitCharacters = Nothing, --  Maybe [Text]
                                   _command = Nothing, --  Maybe Types.Command
-                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModule decl
+                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModule decl word
                                 },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         debugLsp "SMethod_CompletionItemResolve"
@@ -301,23 +302,20 @@ handlers =
             result = completionItem ^. LSP.data_ & decodeCompleteItemData
 
         case result of
-          A.Success (Just (CompleteItemData _filePath _mName declModule decl)) -> do
+          A.Success (Just cid@(CompleteItemData _filePath _mName declModule decl _)) -> do
             let label = foldMap printName (P.declName decl)
             docsMb <- readDeclarationDocsAsMarkdown declModule label
+            withImports <- addImportToTextEdit completionItem cid
             let addDocs :: Types.CompletionItem -> Types.CompletionItem
                 addDocs =
                   docsMb & maybe
                     identity
                     \docs ->
                       set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
-
-                addImport :: Types.CompletionItem -> Types.CompletionItem
-                addImport = identity
             res $
               Right $
-                completionItem
+                withImports
                   & addDocs
-                  & addImport
           _ -> res $ Right completionItem
     ]
 
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index f199a1ae32..d2fd503187 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -1,18 +1,93 @@
 module Language.PureScript.Lsp.Imports where
 
 import Control.Lens (set)
+import Control.Monad.Catch (MonadThrow)
+import Data.Maybe as Maybe
+import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
-import Language.LSP.Protocol.Types (CompletionItem, TextEdit)
+import Language.LSP.Protocol.Types as LSP
 import Language.PureScript.AST.Declarations qualified as P
-import Language.PureScript.Lsp.Types (CompleteItemData (..))
+import Language.PureScript.AST.SourcePos (nullSourceSpan)
+import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
+import Language.PureScript.Lsp.Log (errorLsp)
+import Language.PureScript.Lsp.ReadFile (lspReadFile)
+import Language.PureScript.Lsp.Types (CompleteItemData (..), LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
 
-addImportToTextEdit :: (MonadIO m) => CompletionItem -> CompleteItemData -> m CompletionItem
+addImportToTextEdit :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompletionItem -> CompleteItemData -> m CompletionItem
 addImportToTextEdit completionItem completeItemData = do
   importEdits <- getImportEdits completeItemData
   pure $ set LSP.additionalTextEdits importEdits completionItem
 
-getImportEdits :: (MonadIO m) => CompleteItemData -> m (Maybe [TextEdit])
-getImportEdits (CompleteItemData path moduleName' importedModuleName decl) = do
-  undefined
+getImportEdits :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit])
+getImportEdits (CompleteItemData path moduleName' importedModuleName decl _word) = do
+  parseRes <- parseImportsFromFile path
+  case parseRes of
+    Left err -> do
+      errorLsp $ "In " <> T.pack path <> " failed to parse imports from file: " <> err
+      pure Nothing
+    Right (_mn, before, imports, _after) -> do
+      addDeclarationToImports moduleName' importedModuleName decl imports
+        <&> pure . importsToTextEdit before
+        & pure
+
+addDeclarationToImports :: P.ModuleName -> P.ModuleName -> P.Declaration -> [Import] -> Maybe [Import]
+addDeclarationToImports moduleName' importedModuleName decl imports
+  | importingSelf = Nothing
+  | Just existing <- alreadyImportedModuleMb,
+    Just ref <- refMb = case existing of
+      Import _ (P.Explicit refs') _ ->
+        if ref `notElem` refs'
+          then Just $ Import importedModuleName (P.Explicit (refs' <> [ref])) Nothing : withoutOldImport
+          else Nothing
+      Import _ P.Implicit _ -> Nothing
+      Import _ (P.Hiding refs') _ ->
+        if ref `elem` refs'
+          then Just $ Import importedModuleName (P.Hiding (filter (/= ref) refs')) Nothing : withoutOldImport
+          else Nothing
+  | otherwise = Just $ Import importedModuleName (P.Explicit refs) Nothing : imports
+  where
+    withoutOldImport :: [Import]
+    withoutOldImport =  maybe identity (\im -> filter (/= im)) alreadyImportedModuleMb imports  
+      
+    refs :: [P.DeclarationRef]
+    refs = toList refMb
+
+    refMb :: Maybe P.DeclarationRef
+    refMb =
+      P.declName decl >>= \case
+        P.IdentName name -> Just $ P.ValueRef nullSourceSpan name
+        P.ValOpName name -> Just $ P.ValueOpRef nullSourceSpan name
+        P.TyName name -> Just $ P.TypeRef nullSourceSpan name Nothing
+        P.TyOpName name -> Just $ P.TypeOpRef nullSourceSpan name
+        P.TyClassName name -> Just $ P.TypeClassRef nullSourceSpan name
+        P.ModName name -> Just $ P.ModuleRef nullSourceSpan name
+        P.DctorName _name -> Nothing
+
+    alreadyImportedModuleMb =
+      find (\(Import mn' _ _) -> mn' == importedModuleName) imports
+
+    importingSelf = moduleName' == importedModuleName
+
+importsToTextEdit :: [Text] -> [Import] -> TextEdit
+importsToTextEdit before imports =
+  TextEdit
+    ( LSP.Range
+        (LSP.Position beforeLine 0)
+        (LSP.Position (beforeLine + fromIntegral (length printed)) 0)
+    )
+    (T.unlines printed)
+  where
+    beforeLine = fromIntegral $ length before
+    printed = prettyPrintImportSection imports
+
+-- | Reads a file and returns the (lines before the imports, the imports, the
+-- lines after the imports)
+parseImportsFromFile ::
+  (MonadIO m, MonadThrow m) =>
+  FilePath ->
+  m (Either Text (P.ModuleName, [Text], [Import], [Text]))
+parseImportsFromFile fp = do
+  (_, file) <- lspReadFile fp
+  pure $ sliceImportSection (T.lines file)
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 1a648d46c9..c6712fea57 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -53,7 +53,8 @@ data CompleteItemData = CompleteItemData
   { cidPath :: FilePath,
     cidModuleName :: P.ModuleName,
     cidImportedModuleName :: P.ModuleName,
-    cidImportedDeclaration :: P.Declaration
+    cidImportedDeclaration :: P.Declaration, 
+    cidWord :: Text
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 

From 7e0a3e64e0cf551ec2cf2cbc730bb51eac277e63 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 4 Oct 2024 07:12:43 +0200
Subject: [PATCH 081/297] starts lsp test setup

---
 purescript.cabal                      |  3 ++
 src/Language/PureScript/LSP.hs        | 35 ++++++++-------
 stack.yaml                            |  1 +
 tests/Language/PureScript/Lsp/Test.hs |  3 ++
 tests/Main.hs                         |  2 +
 tests/TestLsp.hs                      | 63 +++++++++++++++++++++++++++
 tests/purs/lsp/A.purs                 |  4 ++
 tests/purs/lsp/Main.purs              |  6 +++
 8 files changed, 101 insertions(+), 16 deletions(-)
 create mode 100644 tests/Language/PureScript/Lsp/Test.hs
 create mode 100644 tests/TestLsp.hs
 create mode 100644 tests/purs/lsp/A.purs
 create mode 100644 tests/purs/lsp/Main.purs

diff --git a/purescript.cabal b/purescript.cabal
index 796c134486..44ca026feb 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -468,6 +468,7 @@ test-suite tests
     generic-random >=1.5.0.1 && <1.6,
     hspec >= 2.10.7 && < 3,
     HUnit >=1.6.2.0 && <1.7,
+    lsp-test >=0.14.0.0 && <0.18.0.0,
     newtype >=0.2.2.0 && <0.3,
     QuickCheck >=2.14.2 && <2.15,
     regex-base >=0.94.0.2 && <0.95,
@@ -488,6 +489,7 @@ test-suite tests
     Language.PureScript.Ide.StateSpec
     Language.PureScript.Ide.Test
     Language.PureScript.Ide.UsageSpec
+    Language.PureScript.Lsp.Test
     PscIdeSpec
     TestAst
     TestCompiler
@@ -497,6 +499,7 @@ test-suite tests
     TestGraph
     TestHierarchy
     TestIde
+    TestLsp
     TestMake
     TestPrimDocs
     TestPsci
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index c082285884..cb164efed1 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
-module Language.PureScript.Lsp (main) where
+module Language.PureScript.Lsp (main, serverDefinition) where
 
 import Control.Concurrent.STM.TChan
 import Control.Monad.IO.Unlift
@@ -16,21 +16,24 @@ import Protolude hiding (to)
 main :: LspEnvironment -> IO Int
 main lspEnv = do
   rin <- atomically newTChan :: IO (TChan ReactorInput)
-  Server.runServer $
-    Server.ServerDefinition
-      { parseConfig = const $ const $ Right (),
-        onConfigChange = const $ pure (),
-        defaultConfig = (),
-        configSection = "oa-purescript-lsp",
-        doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env),
-        staticHandlers = \_caps -> lspHandlers lspEnv rin,
-        interpretHandler = \serverEnv ->
-          Server.Iso
-            ( Server.runLspT serverEnv . flip runReaderT lspEnv
-            )
-            liftIO,
-        options = lspOptions
-      }
+  Server.runServer $ serverDefinition lspEnv rin
+
+serverDefinition :: LspEnvironment -> TChan ReactorInput -> ServerDefinition ()
+serverDefinition lspEnv rin =
+  Server.ServerDefinition
+    { parseConfig = const $ const $ Right (),
+      onConfigChange = const $ pure (),
+      defaultConfig = (),
+      configSection = "oa-purescript-lsp",
+      doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env),
+      staticHandlers = \_caps -> lspHandlers lspEnv rin,
+      interpretHandler = \serverEnv ->
+        Server.Iso
+          ( Server.runLspT serverEnv . flip runReaderT lspEnv
+          )
+          liftIO,
+      options = lspOptions
+    }
 
 syncOptions :: Types.TextDocumentSyncOptions
 syncOptions =
diff --git a/stack.yaml b/stack.yaml
index f0c51eb4ed..0b0cf5888e 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -28,6 +28,7 @@ extra-deps:
 - hspec-core-2.10.9
 - hspec-discover-2.10.9
 - lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c
+- lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406
 - lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215
 - mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409
 - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
diff --git a/tests/Language/PureScript/Lsp/Test.hs b/tests/Language/PureScript/Lsp/Test.hs
new file mode 100644
index 0000000000..b4fd9cb12c
--- /dev/null
+++ b/tests/Language/PureScript/Lsp/Test.hs
@@ -0,0 +1,3 @@
+module Language.PureScript.Lsp.Test where
+
+
diff --git a/tests/Main.hs b/tests/Main.hs
index b8f6ea979e..5328f8b5cf 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -15,6 +15,7 @@ import TestHierarchy qualified
 import TestPrimDocs qualified
 import TestPsci qualified
 import TestIde qualified
+import TestLsp qualified
 import TestPscPublish qualified
 import TestSourceMaps qualified
 -- import TestBundle qualified
@@ -35,6 +36,7 @@ main = do
     describe "cst" TestCst.spec
     describe "ast" TestAst.spec
     describe "ide" TestIde.spec
+    describe "lsp" TestLsp.spec
     beforeAll TestUtils.setupSupportModules $ do
       describe "compiler" TestCompiler.spec
       describe "sourcemaps" TestSourceMaps.spec
diff --git a/tests/TestLsp.hs b/tests/TestLsp.hs
new file mode 100644
index 0000000000..3758e52dda
--- /dev/null
+++ b/tests/TestLsp.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+
+module TestLsp where
+
+import Control.Concurrent.Async.Lifted (async, waitCatch)
+import Control.Concurrent.STM (atomically, newTChan)
+import Control.DeepSeq (force)
+import Control.Exception (Exception (fromException), evaluate)
+import Control.Lens ((^.))
+import Control.Monad (void)
+import Data.List (sort)
+import Data.Map qualified as Map
+import Data.Text qualified as Text
+import Distribution.Compat.CreatePipe (createPipe)
+import GHC.IO.Exception (ExitCode (ExitSuccess))
+import Language.LSP.Protocol.Lens (HasUri (uri))
+import Language.LSP.Protocol.Types (ClientCapabilities, Definition (Definition), Location (Location), Position (Position), Range (Range), type (|?) (InL))
+import Language.LSP.Server (runServer)
+import Language.LSP.Test (Session, fullLatestClientCaps, getDefinitions, openDoc, runSession, runSessionWithConfig, SessionConfig (SessionConfig))
+import Language.PureScript qualified as P
+import Language.PureScript.Docs qualified as D
+import Language.PureScript.Lsp (serverDefinition)
+import Language.PureScript.Lsp.Types (LspConfig (LspConfig), LspLogLevel (LogError), mkEnv)
+import Protolude hiding (Location)
+import System.Timeout (timeout)
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+-- runPursLspSession ::
+
+spec :: Spec
+spec = describe "lsp" $ do
+  it "should start" do
+    runSessionWithConfig sessionConfig "purs lsp server" fullLatestClientCaps "tests/purs/lsp" do
+      doc <- openDoc "Main.purs" "purs"
+
+      defs2 <- getDefinitions doc (Position 2 0)
+      defs3 <- getDefinitions doc (Position 3 0)
+      defs4 <- getDefinitions doc (Position 4 0)
+      let expRange = Range (Position 4 0) (Position 4 3)
+      liftIO do
+        defs2 `shouldBe` (InL $ Definition $ InL $ Location (doc ^. uri) expRange)
+      pure ()
+
+
+sessionConfig :: SessionConfig
+sessionConfig = SessionConfig 10 False False True mempty True True True Nothing 
+
+--   it "should run a test" $ do
+--     "abc" `shouldBe` "abc"
+
+-- runPursLspSession :: String -> ClientCapabilities -> FilePath -> Session b -> IO b
+-- runPursLspSession testConfig caps root session = do
+--   rin <- atomically newTChan
+--   env <- mkEnv $ LspConfig "/output" ["."] LogError
+--   server <- async $ void $ runServer $ serverDefinition env rin
+--   res <- runSession testConfig caps root session
+--   void $ timeout 3000000 $ do
+--     Left (fromException -> Just ExitSuccess) <- waitCatch server
+--     pure ()
+--   pure res
diff --git a/tests/purs/lsp/A.purs b/tests/purs/lsp/A.purs
new file mode 100644
index 0000000000..6e141be5b5
--- /dev/null
+++ b/tests/purs/lsp/A.purs
@@ -0,0 +1,4 @@
+module LspTests.A where 
+
+
+string = "Hello, World!"
\ No newline at end of file
diff --git a/tests/purs/lsp/Main.purs b/tests/purs/lsp/Main.purs
new file mode 100644
index 0000000000..18e3426475
--- /dev/null
+++ b/tests/purs/lsp/Main.purs
@@ -0,0 +1,6 @@
+module LspTests.Main where 
+
+import Prelude 
+
+string = "Hello, World!"
+

From 31bfc8d4bef172d4adf0470d809140d68758d0bb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 4 Oct 2024 07:30:58 +0200
Subject: [PATCH 082/297] remove init state

---
 src/Language/PureScript/Lsp/State.hs | 27 ---------------------------
 src/Language/PureScript/Lsp/Types.hs |  5 ++---
 2 files changed, 2 insertions(+), 30 deletions(-)

diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 139c173f53..7753d98714 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -24,30 +24,3 @@ cachedRebuild = do
   liftIO . atomically $ do
     st' <- readTVar st
     pure $ currentFile st'
-
-getInitialized :: (MonadIO m, MonadReader LspEnvironment m) => m Bool
-getInitialized = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically $ do
-    st' <- readTVar st
-    pure $ lspInitalized st'
-
-initFinished :: (MonadIO m, MonadReader LspEnvironment m) => m ()
-initFinished = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically . modifyTVar st $ \x ->
-    x
-      { lspInitalized = True
-      }
-
-whenInitialized :: (MonadIO m, MonadReader LspEnvironment m) => m () -> m ()
-whenInitialized action = do
-  initialized <- getInitialized
-  when initialized action
-
-waitForInit :: (MonadIO m, MonadReader LspEnvironment m) => m ()
-waitForInit = do
-  initialized <- getInitialized
-  unless initialized $ do
-    liftIO $ threadDelay 100000
-    waitForInit
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index c6712fea57..8471c1e189 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -25,7 +25,7 @@ data LspEnvironment = LspEnvironment
 mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do
   connection <- mkConnection $ confOutputPath conf
-  st <- newTVarIO (LspState Nothing False)
+  st <- newTVarIO (LspState Nothing)
   pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
@@ -36,8 +36,7 @@ data LspConfig = LspConfig
   deriving (Show)
 
 data LspState = LspState
-  { currentFile :: Maybe CurrentFile,
-    lspInitalized :: Bool
+  { currentFile :: Maybe CurrentFile
   }
   deriving (Show)
 

From f41abcd6da7c30129c5f5fa5c2388dbde9eabaf0 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 4 Oct 2024 10:15:47 +0200
Subject: [PATCH 083/297] adds compile custom command to lsp

---
 app/Command/Compile.hs                     | 24 +++-----
 purescript.cabal                           |  1 +
 src/Language/PureScript/Compile.hs         | 25 ++++++++
 src/Language/PureScript/Lsp/Diagnostics.hs | 70 +++++++++++-----------
 src/Language/PureScript/Lsp/Handlers.hs    | 29 +++++++--
 src/Language/PureScript/Lsp/Rebuild.hs     |  8 +--
 tests/TestLsp.hs                           |  1 -
 7 files changed, 98 insertions(+), 60 deletions(-)
 create mode 100644 src/Language/PureScript/Compile.hs

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index fcfc6bd22b..b5c2f03324 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -2,7 +2,6 @@ module Command.Compile (command) where
 
 import Control.Applicative (Alternative (..))
 import Control.Monad (when)
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson qualified as A
 import Data.Bool (bool)
 import Data.ByteString.Lazy.UTF8 qualified as LBU8
@@ -12,16 +11,15 @@ import Data.Set qualified as S
 import Data.Text qualified as T
 import Data.Traversable (for)
 import Language.PureScript qualified as P
-import Language.PureScript.CST qualified as CST
+import Language.PureScript.Compile qualified as P 
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Errors.JSON (JSONResult (..), toJSONErrors)
 import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
-import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
-import Language.PureScript.Make.Index (addAllIndexing, initDb)
+import Language.PureScript.Make.Index (initDb)
 import Options.Applicative qualified as Opts
 import SharedCLI qualified
 import System.Console.ANSI qualified as ANSI
-import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
+import System.Directory (getCurrentDirectory)
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (hPutStr, stderr, stdout)
 import System.IO.UTF8 (readUTF8FilesT)
@@ -74,21 +72,15 @@ compile PSCMakeOptions {..} = do
           "Usage: For basic information, try the `--help' option."
         ]
     exitFailure
+  conn <- mkConnection pscmOutputDir
+  initDb conn
   moduleFiles <- readUTF8FilesT input
-  (makeErrors, makeWarnings) <- runMake pscmOpts $ do
-    ms <- CST.parseModulesFromFiles id moduleFiles
-    let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
-    foreigns <- inferForeignModules filePathMap
-    liftIO $ createDirectoryIfMissing True pscmOutputDir
-    conn <- liftIO $ mkConnection pscmOutputDir
-    liftIO $ initDb conn
-    let makeActions =
-          addAllIndexing conn $
-              buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
-    P.make makeActions (map snd ms)
+  (makeErrors, makeWarnings) <- P.compile pscmOpts input conn pscmOutputDir pscmUsePrefix
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 
+
+
 outputDirectory :: Opts.Parser FilePath
 outputDirectory =
   Opts.strOption $
diff --git a/purescript.cabal b/purescript.cabal
index 44ca026feb..71f20fe41d 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -278,6 +278,7 @@ library
     Language.PureScript.CST.Types
     Language.PureScript.CST.Utils
     Language.PureScript.Comments
+    Language.PureScript.Compile
     Language.PureScript.Constants.Prim
     Language.PureScript.Crash
     Language.PureScript.DB
diff --git a/src/Language/PureScript/Compile.hs b/src/Language/PureScript/Compile.hs
new file mode 100644
index 0000000000..4ca62a22a6
--- /dev/null
+++ b/src/Language/PureScript/Compile.hs
@@ -0,0 +1,25 @@
+module Language.PureScript.Compile where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Map qualified as M
+import Database.SQLite.Simple (Connection)
+import Language.PureScript qualified as P
+import Language.PureScript.CST qualified as CST
+import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
+import Language.PureScript.Make.Index (addAllIndexing)
+import System.Directory (createDirectoryIfMissing)
+import System.IO.UTF8 (readUTF8FilesT)
+import Prelude
+
+compile :: P.Options -> [FilePath] -> Connection -> FilePath -> Bool -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
+compile opts input conn outputDir usePrefx = do
+  moduleFiles <- readUTF8FilesT input
+  runMake opts $ do
+    ms <- CST.parseModulesFromFiles id moduleFiles
+    let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
+    foreigns <- inferForeignModules filePathMap
+    liftIO $ createDirectoryIfMissing True outputDir
+    let makeActions =
+          addAllIndexing conn $
+            buildMakeActions outputDir filePathMap foreigns usePrefx
+    P.make makeActions (map snd ms)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 6992b3f7ee..9de48073a0 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -46,41 +46,41 @@ getResultDiagnostics res = case res of
         diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
     (errors, diags)
   _ -> ([], [])
-  where
-    errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
-    errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
-      let textEdits :: [Types.TextEdit]
-          textEdits =
-            toSuggestion msg
-              & maybeToList
-              >>= suggestionToEdit
 
-          suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-          suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
-            let rangeStart = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
-                rangeEnd = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
-             in pure $ Types.TextEdit (Types.Range rangeStart rangeEnd) replacement
-          suggestionToEdit _ = []
-       in Types.Diagnostic
-            (Types.Range start end)
-            (Just severity)
-            (Just $ Types.InR $ errorCode msg)
-            (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
-            (T.pack <$> spanName)
-            (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
-            Nothing
-            Nothing
-            (Just $ A.toJSON textEdits)
-      where
-        notFound = Types.Position 0 0
-        (spanName, start, end) = getPositions $ errorSpan msg
+errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
+errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
+  let textEdits :: [Types.TextEdit]
+      textEdits =
+        toSuggestion msg
+          & maybeToList
+            >>= suggestionToEdit
+
+      suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
+      suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
+        let rangeStart = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
+            rangeEnd = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
+         in pure $ Types.TextEdit (Types.Range rangeStart rangeEnd) replacement
+      suggestionToEdit _ = []
+   in Types.Diagnostic
+        (Types.Range start end)
+        (Just severity)
+        (Just $ Types.InR $ errorCode msg)
+        (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
+        (T.pack <$> spanName)
+        (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
+        Nothing
+        Nothing
+        (Just $ A.toJSON textEdits)
+  where
+    notFound = Types.Position 0 0
+    (spanName, start, end) = getPositions $ errorSpan msg
 
-        getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
+    getPositions = fromMaybe (Nothing, notFound, notFound) . getPositionsMb
 
-        getPositionsMb = fmap $ \spans ->
-          let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
-                NEL.head spans
-           in ( Just name,
-                Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
-                Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
-              )
+    getPositionsMb = fmap $ \spans ->
+      let (Errors.SourceSpan name (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+            NEL.head spans
+       in ( Just name,
+            Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
+            Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
+          )
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 08d681aa61..711bb83a8c 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module Language.PureScript.Lsp.Handlers where
@@ -20,19 +21,20 @@ import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
+import Language.PureScript.Compile (compile)
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
-import Language.PureScript.Lsp.Diagnostics (getFileDiagnotics, getMsgUri)
+import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
-import Language.PureScript.Lsp.Rebuild (rebuildFile)
-import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEnvironment, decodeCompleteItemData)
+import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
+import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData, LspConfig (confGlobs, confOutputPath))
 import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
@@ -69,6 +71,25 @@ handlers =
             Types.DocumentDiagnosticReport $
               Types.InL $
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
+        debugLsp "SMethod_CustomMethod rebuild"
+        config <- asks lspConfig
+        conn <- asks lspDbConnection
+        (result, warnings) <-
+          liftIO $
+            compile
+              (P.Options False False codegenTargets)
+              (confGlobs config)
+              conn
+              (confOutputPath config)
+              False
+
+        let diags :: [Types.Diagnostic]
+            diags =
+              (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
+                <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
+
+        res $ Right $ A.toJSON diags,
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
@@ -135,7 +156,7 @@ handlers =
             Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
               docsMb <- do
                 mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
-                maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` (P.runProperName tName)) mNameMb
+                maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` P.runProperName tName) mNameMb
               case docsMb of
                 Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
                 Just docs -> markdownRes docs
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 5a7d16f2d6..2defc5ab8e 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -72,8 +72,8 @@ rebuildFile srcPath = do
               pure (Left ([(fp, input)], errors))
             Right newExterns -> do
               pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
-  where
-    codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
+codegenTargets :: Set P.CodegenTarget
+codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
 -- | Shuts the compiler up about progress messages
 shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
@@ -95,9 +95,9 @@ enableForeignCheck ::
   S.Set P.CodegenTarget ->
   P.MakeActions P.Make ->
   P.MakeActions P.Make
-enableForeignCheck foreigns codegenTargets ma =
+enableForeignCheck foreigns codegenTargets' ma =
   ma
-    { P.ffiCodegen = ffiCodegen' foreigns codegenTargets Nothing
+    { P.ffiCodegen = ffiCodegen' foreigns codegenTargets' Nothing
     }
 
 -- | Returns a topologically sorted list of dependent ExternsFiles for the given
diff --git a/tests/TestLsp.hs b/tests/TestLsp.hs
index 3758e52dda..63005a7867 100644
--- a/tests/TestLsp.hs
+++ b/tests/TestLsp.hs
@@ -35,7 +35,6 @@ spec = describe "lsp" $ do
   it "should start" do
     runSessionWithConfig sessionConfig "purs lsp server" fullLatestClientCaps "tests/purs/lsp" do
       doc <- openDoc "Main.purs" "purs"
-
       defs2 <- getDefinitions doc (Position 2 0)
       defs3 <- getDefinitions doc (Position 3 0)
       defs4 <- getDefinitions doc (Position 4 0)

From 2683d114f28f7e8c676eb700a9c26cb59c7ed34c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 4 Oct 2024 15:21:06 +0200
Subject: [PATCH 084/297] adds compile command and test scaffold

---
 app/Command/Compile.hs                  |  2 +-
 src/Language/PureScript/Compile.hs      |  6 +--
 src/Language/PureScript/Lsp/Cache.hs    | 36 ++++++++++++++-
 src/Language/PureScript/Lsp/Handlers.hs | 54 +++++++++++++---------
 src/Language/PureScript/Lsp/Rebuild.hs  |  6 +--
 src/Language/PureScript/Make/Index.hs   |  9 +++-
 tests/TestLsp.hs                        | 61 +++++++++++++++++++++----
 7 files changed, 134 insertions(+), 40 deletions(-)

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index b5c2f03324..f88d9b4c64 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -75,7 +75,7 @@ compile PSCMakeOptions {..} = do
   conn <- mkConnection pscmOutputDir
   initDb conn
   moduleFiles <- readUTF8FilesT input
-  (makeErrors, makeWarnings) <- P.compile pscmOpts input conn pscmOutputDir pscmUsePrefix
+  (makeErrors, makeWarnings) <- P.compile pscmOpts moduleFiles conn pscmOutputDir pscmUsePrefix
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 
diff --git a/src/Language/PureScript/Compile.hs b/src/Language/PureScript/Compile.hs
index 4ca62a22a6..657f74d005 100644
--- a/src/Language/PureScript/Compile.hs
+++ b/src/Language/PureScript/Compile.hs
@@ -8,12 +8,10 @@ import Language.PureScript.CST qualified as CST
 import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
 import Language.PureScript.Make.Index (addAllIndexing)
 import System.Directory (createDirectoryIfMissing)
-import System.IO.UTF8 (readUTF8FilesT)
 import Prelude
 
-compile :: P.Options -> [FilePath] -> Connection -> FilePath -> Bool -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
-compile opts input conn outputDir usePrefx = do
-  moduleFiles <- readUTF8FilesT input
+compile :: P.Options -> [(FilePath, P.Text)] -> Connection -> FilePath -> Bool -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
+compile opts moduleFiles conn outputDir usePrefx = do
   runMake opts $ do
     ms <- CST.parseModulesFromFiles id moduleFiles
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 54b2d03b55..759890b7b3 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -15,6 +15,7 @@ import Language.PureScript.Names qualified as P
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute)
 import System.FilePath (normalise, (</>))
+
 -- import Language.PureScript.Lsp.Prim (primExterns)
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName ExternsFile)
@@ -25,6 +26,38 @@ selectAllExterns :: (MonadIO m, MonadReader LspEnvironment m) => m [ExternsFile]
 selectAllExterns = do
   DB.query_ (Query "SELECT value FROM externs") <&> fmap (deserialise . fromOnly)
 
+
+selectDependenciesMap :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m (Map P.ModuleName ExternsFile)
+selectDependenciesMap mName = do
+  Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectDependencies mName
+
+selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m [ExternsFile]
+selectDependencies mName = do
+  res <- DB.queryNamed (Query query') [":module_name" := P.runModuleName mName]
+  pure $ deserialise . fromOnly <$> res
+  where
+    query' =
+      unlines
+        [ "with recursive",
+          "graph(imported_module, level) as (",
+          " select module_name , 1 as level",
+          " from ef_imports where module_name = :module_name",
+          " union ",
+          " select d.imported_module as dep, graph.level + 1 as level",
+          " from graph join ef_imports d on graph.imported_module = d.module_name",
+          "),",
+          "topo as (",
+          " select imported_module, max(level) as level",
+          " from graph group by imported_module",
+          "),",
+          "module_names as (select distinct(module_name)",
+          "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
+          "and module_name != :module_name",
+          "order by level desc)",
+          "select * from externs ",
+          "join module_names on externs.module_name = module_names.module_name;"
+        ]
+
 selectExternFromFilePath :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe ExternsFile)
 selectExternFromFilePath path = do
   absPath <- liftIO $ makeAbsolute path
@@ -38,10 +71,9 @@ selectExternModuleNameFromFilePath path = do
   pure $ P.ModuleName . fromOnly <$> listToMaybe res
 
 selectExternPathFromModuleName :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m (Maybe FilePath)
-selectExternPathFromModuleName mName = 
+selectExternPathFromModuleName mName =
   DB.queryNamed (Query "SELECT path FROM externs WHERE module_name = :module_name") [":module_name" := P.runModuleName mName] <&> listToMaybe . fmap fromOnly
 
-
 -- | Finds all the externs inside the output folder and returns the
 -- corresponding module names
 findAvailableExterns :: (MonadIO m, MonadReader LspEnvironment m, MonadError IdeError m) => m [P.ModuleName]
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 711bb83a8c..7a7a1bea5f 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -25,6 +25,7 @@ import Language.PureScript.Compile (compile)
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
@@ -34,10 +35,12 @@ import Language.PureScript.Lsp.Imports (addImportToTextEdit)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Print (printDeclarationType, printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
-import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData, LspConfig (confGlobs, confOutputPath))
+import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confGlobs, confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
+import Language.PureScript.Make.Index (initDb)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
+import System.IO.UTF8 (readUTF8FilesT)
 
 type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
@@ -71,25 +74,6 @@ handlers =
             Types.DocumentDiagnosticReport $
               Types.InL $
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
-      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
-        debugLsp "SMethod_CustomMethod rebuild"
-        config <- asks lspConfig
-        conn <- asks lspDbConnection
-        (result, warnings) <-
-          liftIO $
-            compile
-              (P.Options False False codegenTargets)
-              (confGlobs config)
-              conn
-              (confOutputPath config)
-              False
-
-        let diags :: [Types.Diagnostic]
-            diags =
-              (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
-                <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
-
-        res $ Right $ A.toJSON diags,
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
@@ -337,7 +321,35 @@ handlers =
               Right $
                 withImports
                   & addDocs
-          _ -> res $ Right completionItem
+          _ -> res $ Right completionItem,
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
+        debugLsp "SMethod_CustomMethod build"
+        config <- asks lspConfig
+        conn <- asks lspDbConnection
+        liftIO $ initDb conn
+        input <-
+          liftIO $
+            toInputGlobs $
+              PSCGlobs
+                { pscInputGlobs = confGlobs config,
+                  pscInputGlobsFromFile = Nothing,
+                  pscExcludeGlobs = [],
+                  pscWarnFileTypeNotFound = warnFileTypeNotFound "lsp server"
+                }
+        moduleFiles <- liftIO $ readUTF8FilesT input
+        (result, warnings) <-
+          liftIO $
+            compile
+              (P.Options False False codegenTargets)
+              moduleFiles
+              conn
+              (confOutputPath config)
+              False
+        let diags :: [Types.Diagnostic]
+            diags =
+              (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
+                <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
+        res $ Right $ A.toJSON diags
     ]
 
 spanToRange :: Errors.SourceSpan -> Types.Range
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 2defc5ab8e..81cf4d0792 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -19,7 +19,7 @@ import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
-import Language.PureScript.Lsp.Cache (selectAllExternsMap)
+import Language.PureScript.Lsp.Cache (selectDependenciesMap)
 import Language.PureScript.Lsp.ReadFile (lspReadFile)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make (ffiCodegen')
@@ -47,9 +47,9 @@ rebuildFile srcPath = do
       pure $ Left ([(fp, input)], CST.toMultipleErrors fp parseError)
     Right (pwarnings, m) -> do
       let moduleName = P.getModuleName m
-      externsResult <- sortExterns m =<< selectAllExternsMap
+      externsResult <- sortExterns m =<< selectDependenciesMap moduleName
       case externsResult of
-        Left err -> pure $ Left $ ([], err)
+        Left err -> pure $ Left ([], err)
         Right externs -> do
           outputDirectory <- asks (confOutputPath . lspConfig)
           let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index f726b1be46..cc013d4dab 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -305,9 +305,16 @@ insertEfExport conn moduleName' dr = do
   where
     span = P.declRefSourceSpan dr
 
+
+initDb' :: Connection -> IO ()
+initDb' conn = catchError (initDb conn) \err -> do 
+  print ("DB connection error: " :: Text)
+  print err
+  pure ()
+
 initDb :: Connection -> IO ()
 initDb conn = do
-  -- dropTables conn
+  dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
diff --git a/tests/TestLsp.hs b/tests/TestLsp.hs
index 63005a7867..07b3b77250 100644
--- a/tests/TestLsp.hs
+++ b/tests/TestLsp.hs
@@ -1,27 +1,36 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-type-defaults #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 
-module TestLsp where
+module TestLsp (spec) where
 
 import Control.Concurrent.Async.Lifted (async, waitCatch)
 import Control.Concurrent.STM (atomically, newTChan)
 import Control.DeepSeq (force)
-import Control.Exception (Exception (fromException), evaluate)
+import Control.Exception (Exception (fromException), evaluate, throw)
 import Control.Lens ((^.))
 import Control.Monad (void)
+import Data.Aeson qualified as A
+import Data.Aeson.KeyMap (KeyMap)
+import Data.Aeson.KeyMap qualified as KeyMap
 import Data.List (sort)
 import Data.Map qualified as Map
+import Data.Maybe (fromJust)
 import Data.Text qualified as Text
 import Distribution.Compat.CreatePipe (createPipe)
 import GHC.IO.Exception (ExitCode (ExitSuccess))
 import Language.LSP.Protocol.Lens (HasUri (uri))
+import Language.LSP.Protocol.Lens qualified as L
+import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod))
 import Language.LSP.Protocol.Types (ClientCapabilities, Definition (Definition), Location (Location), Position (Position), Range (Range), type (|?) (InL))
 import Language.LSP.Server (runServer)
-import Language.LSP.Test (Session, fullLatestClientCaps, getDefinitions, openDoc, runSession, runSessionWithConfig, SessionConfig (SessionConfig))
+import Language.LSP.Test (Session, SessionConfig (SessionConfig), SessionException (UnexpectedResponseError), fullLatestClientCaps, getDefinitions, openDoc, request, runSession, runSessionWithConfig)
 import Language.PureScript qualified as P
 import Language.PureScript.Docs qualified as D
+import Language.PureScript.Ide.Filter.Declaration qualified as A
 import Language.PureScript.Lsp (serverDefinition)
 import Language.PureScript.Lsp.Types (LspConfig (LspConfig), LspLogLevel (LogError), mkEnv)
 import Protolude hiding (Location)
@@ -31,21 +40,48 @@ import Test.Hspec (Spec, describe, it, shouldBe)
 -- runPursLspSession ::
 
 spec :: Spec
-spec = describe "lsp" $ do
-  it "should start" do
-    runSessionWithConfig sessionConfig "purs lsp server" fullLatestClientCaps "tests/purs/lsp" do
+spec = describe "lsp  " $ do
+  it "should get definitions" do
+    runSessionWithConfig sessionConfig ("purs lsp server --log-level debug " <> globs) fullLatestClientCaps "tests/purs/lsp" do
+      void rebuildReq
       doc <- openDoc "Main.purs" "purs"
       defs2 <- getDefinitions doc (Position 2 0)
+      liftIO $ print "defs2" *> print defs2
       defs3 <- getDefinitions doc (Position 3 0)
+      liftIO $ print "defs3" *> print defs3
       defs4 <- getDefinitions doc (Position 4 0)
+      liftIO $ print "defs4" *> print defs4
       let expRange = Range (Position 4 0) (Position 4 3)
       liftIO do
+        print "defs2"
+        print defs2
+        print "defs3"
+        print defs3
+        print "defs4"
+        print defs4
         defs2 `shouldBe` (InL $ Definition $ InL $ Location (doc ^. uri) expRange)
       pure ()
-
+  where
+    rebuildReq = do
+      rsp <- request (SMethod_CustomMethod $ Proxy @"build") A.Null
+      liftIO $ do
+        print "got build response"
+        print rsp
+      case rsp ^. L.result of
+        Right x -> pure x
+        Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err
 
 sessionConfig :: SessionConfig
-sessionConfig = SessionConfig 10 False False True mempty True True True Nothing 
+sessionConfig = SessionConfig 30 True True True clientConfig True True True Nothing
+  where
+    clientConfig :: KeyMap A.Value
+    clientConfig = KeyMap.singleton "oa-purescript-lsp" (A.toJSON pursLspConfig)
+
+    pursLspConfig :: Map Text.Text A.Value
+    pursLspConfig = Map.empty
+
+-- Map.fromList
+--   [("field", A.Object mempty)]
 
 --   it "should run a test" $ do
 --     "abc" `shouldBe` "abc"
@@ -60,3 +96,12 @@ sessionConfig = SessionConfig 10 False False True mempty True True True Nothing
 --     Left (fromException -> Just ExitSuccess) <- waitCatch server
 --     pure ()
 --   pure res
+
+globs :: [Char]
+globs = prelude <> " " <> srcGlob
+
+prelude :: [Char]
+prelude = "tests/support/bower_components/purescript-prelude/src/**/*.purs"
+
+srcGlob :: [Char]
+srcGlob = "tests/purs/lsp/**/*.purs"
\ No newline at end of file

From 66251b0b3c27ad3cc49dac9e19e79b813f07ceb5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 4 Oct 2024 15:43:31 +0200
Subject: [PATCH 085/297] only fetch needed externs

---
 src/Language/PureScript/Lsp/Cache.hs   | 25 +++++++++++++++----------
 src/Language/PureScript/Lsp/Rebuild.hs |  2 +-
 2 files changed, 16 insertions(+), 11 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 759890b7b3..1687a638fe 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -3,9 +3,11 @@
 module Language.PureScript.Lsp.Cache where
 
 import Codec.Serialise (deserialise)
+import Data.Aeson qualified as A
 import Data.Map qualified as Map
 import Data.Text qualified as T
 import Database.SQLite.Simple
+import Language.PureScript.AST.Declarations as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
@@ -26,14 +28,13 @@ selectAllExterns :: (MonadIO m, MonadReader LspEnvironment m) => m [ExternsFile]
 selectAllExterns = do
   DB.query_ (Query "SELECT value FROM externs") <&> fmap (deserialise . fromOnly)
 
+selectDependenciesMap :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m (Map P.ModuleName ExternsFile)
+selectDependenciesMap importedModuleNames = do
+  Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectDependencies importedModuleNames
 
-selectDependenciesMap :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m (Map P.ModuleName ExternsFile)
-selectDependenciesMap mName = do
-  Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectDependencies mName
-
-selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m [ExternsFile]
-selectDependencies mName = do
-  res <- DB.queryNamed (Query query') [":module_name" := P.runModuleName mName]
+selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m [ExternsFile]
+selectDependencies (P.Module _ _ _ decls _) = do
+  res <- DB.queryNamed (Query query') [":module_names" := A.encode (fmap P.runModuleName importedModuleNames)]
   pure $ deserialise . fromOnly <$> res
   where
     query' =
@@ -41,7 +42,7 @@ selectDependencies mName = do
         [ "with recursive",
           "graph(imported_module, level) as (",
           " select module_name , 1 as level",
-          " from ef_imports where module_name = :module_name",
+          " from ef_imports where module_name IN (SELECT value FROM json_each(:module_names))",
           " union ",
           " select d.imported_module as dep, graph.level + 1 as level",
           " from graph join ef_imports d on graph.imported_module = d.module_name",
@@ -52,12 +53,16 @@ selectDependencies mName = do
           "),",
           "module_names as (select distinct(module_name)",
           "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
-          "and module_name != :module_name",
           "order by level desc)",
-          "select * from externs ",
+          "select value from externs ",
           "join module_names on externs.module_name = module_names.module_name;"
         ]
 
+    importedModuleNames =
+      decls >>= \case
+        P.ImportDeclaration _ importName _ _ -> [importName]
+        _ -> []
+
 selectExternFromFilePath :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe ExternsFile)
 selectExternFromFilePath path = do
   absPath <- liftIO $ makeAbsolute path
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 81cf4d0792..39e8afefb0 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -47,7 +47,7 @@ rebuildFile srcPath = do
       pure $ Left ([(fp, input)], CST.toMultipleErrors fp parseError)
     Right (pwarnings, m) -> do
       let moduleName = P.getModuleName m
-      externsResult <- sortExterns m =<< selectDependenciesMap moduleName
+      externsResult <- sortExterns m =<< selectDependenciesMap m
       case externsResult of
         Left err -> pure $ Left ([], err)
         Right externs -> do

From 55ccd1e7a665b6a098ae1fadbc57d23956039239 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 4 Oct 2024 16:27:42 +0200
Subject: [PATCH 086/297] adds time logs

---
 src/Language/PureScript/Lsp/Cache/Query.hs |  4 ++--
 src/Language/PureScript/Lsp/Handlers.hs    | 11 +++++------
 src/Language/PureScript/Lsp/Log.hs         | 14 ++++++++++++--
 src/Language/PureScript/Lsp/Util.hs        |  2 +-
 4 files changed, 20 insertions(+), 11 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index bdae267d46..d554167ef9 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -152,10 +152,10 @@ getAstDeclarationsStartingWith moduleName' prefix = do
     DB.queryNamed
       "SELECT module_name, value FROM ast_declarations \
       \WHERE (module_name = :module_name OR exported) \
-      \AND name LIKE :prefix \
+      \AND name GLOB :prefix \
       \ORDER BY name ASC \
       \LIMIT 100"
       [ ":module_name" := P.runModuleName moduleName',
-        ":prefix" := prefix <> "%"
+        ":prefix" := prefix <> "*"
       ]
   pure $ bimap P.ModuleName deserialise <$> decls
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 7a7a1bea5f..dcbdbe47b0 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -195,7 +195,7 @@ handlers =
             debugLsp $ "Pos: " <> show pos
             forLsp mNameMb \mName -> do
               names <- getNamesAtPosition pos mName (VFS._file_text vf)
-              debugLsp $ "Found names: " <> show names
+              debugLsp $ "Found names: " <> show (length names)
 
               case head names of
                 Just name -> do
@@ -211,7 +211,7 @@ handlers =
                         P.Qualified (P.ByModuleName nameModule) ident -> do
                           debugLsp $ "Found module name: " <> show nameModule
                           declMb <- getAstDeclarationInModule nameModule (printName ident)
-                          debugLsp $ "Found decl: " <> show declMb
+                          debugLsp $ "Found decl: " <> show (isJust declMb)
                           forLsp declMb \decl -> do
                             modFpMb <- selectExternPathFromModuleName nameModule
                             forLsp modFpMb \modFp -> do
@@ -240,7 +240,7 @@ handlers =
                     _ -> nullRes,
       Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
         debugLsp "SMethod_TextDocumentCompletion"
-        let Types.CompletionParams docIdent pos _prog _prog' completionCtx = req ^. LSP.params
+        let Types.CompletionParams docIdent pos _prog _prog' _completionCtx = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             uri :: Types.NormalizedUri
             uri =
@@ -255,13 +255,12 @@ handlers =
             forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
             forLsp val f = maybe nullRes f val
 
-        debugLsp $ "Completion params: " <> show completionCtx
         debugLsp $ "filePathMb: " <> show filePathMb
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
             let word = getWordAt (VFS._file_text vf) pos
-            debugLsp $ "Word: " <> show word <> " len " <> show (T.length word)
+            debugLsp $ "Word len " <> show (T.length word)
             if T.length word < 2
               then nullRes
               else do
@@ -269,7 +268,7 @@ handlers =
                 debugLsp $ "Module name: " <> show mNameMb
                 forLsp mNameMb \mName -> do
                   decls <- getAstDeclarationsStartingWith mName word
-                  debugLsp $ "Found decls: " <> show decls
+                  debugLsp $ "Found decls: " <> show (length decls)
                   res $
                     Right $
                       Types.InL $
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index 80b81899b5..adda0a5a6c 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -1,5 +1,7 @@
 module Language.PureScript.Lsp.Log where
 
+import Data.Text qualified as T
+import Data.Time (UTCTime (utctDayTime), defaultTimeLocale, formatTime, getCurrentTime)
 import Language.PureScript.Lsp.Types (LspConfig (confLogLevel), LspEnvironment (lspConfig), LspLogLevel (..))
 import Protolude
 
@@ -22,8 +24,16 @@ logLsp :: (MonadIO m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text ->
 logLsp msgLogLevel msg = do
   logLevel <- confLogLevel . lspConfig <$> ask
   when (shouldLog msgLogLevel logLevel) $ do
-    -- Use stderr for logging as LSP messages should be on stdout
-    liftIO $ putErrLn (printLogMsgSeverity msgLogLevel <> ": " <> show msg)
+    now <- liftIO $ utctDayTime <$> getCurrentTime
+    liftIO $
+      putErrLn -- Use stderr for logging as LSP messages should be on stdout
+        ( printLogMsgSeverity msgLogLevel
+            <> ": "
+            <> T.pack (formatTime defaultTimeLocale "%T" now)
+            <> " "
+            <> ": "
+            <> show msg
+        )
 
 data LogMsgSeverity
   = LogMsgInfo
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 74135c7c37..9e33798544 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -76,7 +76,7 @@ getNamesAtPosition pos moduleName' src = do
   let search = getWordAt src pos
   debugLsp $ "Looking up " <> search <> " in module " <> P.runModuleName moduleName'
   decls <- getAstDeclarationsAtSrcPos moduleName' (positionToSourcePos pos)
-  debugLsp $ "Found declarations: " <> T.pack (show $ length decls) <> show (fmap (T.take 400 . show) decls)
+  debugLsp $ "Found declarations: " <> T.pack (show $ length decls) 
   pure $
     mconcat $
       decls <&> \decl -> do

From 6485911e250f7b4e382fddd04f2953921cc1a838 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sat, 5 Oct 2024 04:41:52 +0200
Subject: [PATCH 087/297] get definition test passing

---
 src/Language/PureScript/DB.hs              |  5 ++-
 src/Language/PureScript/Lsp/Cache/Query.hs |  2 +-
 src/Language/PureScript/Lsp/Handlers.hs    | 20 +++++++++-
 src/Language/PureScript/Lsp/Types.hs       |  2 +
 src/Language/PureScript/Lsp/Util.hs        | 44 +++++++++++-----------
 src/Language/PureScript/Make/Index.hs      | 10 ++---
 tests/TestLsp.hs                           | 39 +++----------------
 7 files changed, 59 insertions(+), 63 deletions(-)

diff --git a/src/Language/PureScript/DB.hs b/src/Language/PureScript/DB.hs
index 7915e2e903..6a8adf25b9 100644
--- a/src/Language/PureScript/DB.hs
+++ b/src/Language/PureScript/DB.hs
@@ -6,4 +6,7 @@ import System.FilePath ((</>))
 
 mkConnection :: FilePath -> IO Connection
 mkConnection outputDir =  
-  open (outputDir </> "purescript.sqlite")
+  open (outputDir </> dbFile)
+
+dbFile :: FilePath
+dbFile = "purescript.sqlite"
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index d554167ef9..8eeef3110f 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -154,7 +154,7 @@ getAstDeclarationsStartingWith moduleName' prefix = do
       \WHERE (module_name = :module_name OR exported) \
       \AND name GLOB :prefix \
       \ORDER BY name ASC \
-      \LIMIT 100"
+      \LIMIT 50"
       [ ":module_name" := P.runModuleName moduleName',
         ":prefix" := prefix <> "*"
       ]
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index dcbdbe47b0..78da1b0830 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -40,7 +40,10 @@ import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan,
 import Language.PureScript.Make.Index (initDb)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
+import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
+import System.FilePath ((</>))
 import System.IO.UTF8 (readUTF8FilesT)
+import Language.PureScript.DB (dbFile)
 
 type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
@@ -169,7 +172,7 @@ handlers =
                         forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
                       Just docs -> markdownRes docs,
       Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-        sendInfoMsg "SMethod_TextDocumentDefinition"
+        debugLsp "SMethod_TextDocumentDefinition"
         let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             uri :: Types.NormalizedUri
@@ -186,7 +189,7 @@ handlers =
 
             forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
             forLsp val f = maybe nullRes f val
-
+        debugLsp $ "filePathMb: " <> show filePathMb
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
@@ -321,6 +324,19 @@ handlers =
                 withImports
                   & addDocs
           _ -> res $ Right completionItem,
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete output") $ \_req res -> do
+        debugLsp "SMethod_CustomMethod delete output"
+        outDir <- asks (confOutputPath . lspConfig)
+        debugLsp $ "Deleting output directory: " <> show outDir
+        liftIO $ createDirectoryIfMissing True outDir
+        contents <- liftIO $ listDirectory outDir
+        for_ contents \f -> do
+          debugLsp $ T.pack f
+          unless (f == dbFile || dbFile `isPrefixOf` f) do
+            let path = outDir </> f
+            debugLsp $ "Deleting: " <> show f
+            liftIO $ removePathForcibly path
+        res $ Right A.Null,
       Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
         debugLsp "SMethod_CustomMethod build"
         config <- asks lspConfig
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 8471c1e189..a9ce235cb0 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -15,6 +15,7 @@ import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude
+import System.Directory (createDirectoryIfMissing)
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -24,6 +25,7 @@ data LspEnvironment = LspEnvironment
 
 mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do
+  createDirectoryIfMissing True $ confOutputPath conf
   connection <- mkConnection $ confOutputPath conf
   st <- newTVarIO (LspState Nothing)
   pure $ LspEnvironment conf connection st
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 9e33798544..51fc8f6569 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -17,21 +17,22 @@ import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.LSP.Protocol.Types (UInt)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.PureScript.AST qualified as P
+import Language.PureScript.AST.Declarations (declSourceAnn)
 import Language.PureScript.Comments qualified as P
 import Language.PureScript.Environment qualified as P
+import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Linter qualified as P
-import Language.PureScript.Names qualified as P
-import Language.PureScript.Types qualified as P
-import Language.PureScript.AST.Declarations (declSourceAnn)
-import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
+-- import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
+
+import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (CurrentFile (currentEnv), LspEnvironment)
--- import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
-import Language.PureScript.Lsp.Log (debugLsp)
 
 posInSpan :: Types.Position -> Errors.SourceSpan -> Bool
 posInSpan (Types.Position line col) (Errors.SourceSpan _ (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
@@ -45,16 +46,22 @@ getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn)
 
 getWordAt :: Rope -> Types.Position -> Text
 getWordAt file Types.Position {..} =
-  let (_, after) = splitAtLine (fromIntegral _line) file
-      (ropeLine, _) = splitAtLine 1 after
-      line' = Rope.toText ropeLine
-   in getWordOnLine line' _character
+  if Rope.lengthInLines file < fromIntegral _line
+    then ""
+    else
+      let (_, after) = splitAtLine (fromIntegral _line) file
+          (ropeLine, _) = splitAtLine 1 after
+          line' = Rope.toText ropeLine
+       in getWordOnLine line' _character
 
 getWordOnLine :: Text -> UInt -> Text
 getWordOnLine line' col =
-  let start = getPrevWs (fromIntegral col - 1) line'
-      end = getNextWs (fromIntegral col) line'
-   in T.strip $ T.take (end - start) $ T.drop start line'
+  if T.length line' < fromIntegral col
+    then ""
+    else
+      let start = getPrevWs (fromIntegral col - 1) line'
+          end = getNextWs (fromIntegral col) line'
+       in T.strip $ T.take (end - start) $ T.drop start line'
   where
     getNextWs :: Int -> Text -> Int
     getNextWs idx txt | idx >= T.length txt = idx
@@ -76,7 +83,7 @@ getNamesAtPosition pos moduleName' src = do
   let search = getWordAt src pos
   debugLsp $ "Looking up " <> search <> " in module " <> P.runModuleName moduleName'
   decls <- getAstDeclarationsAtSrcPos moduleName' (positionToSourcePos pos)
-  debugLsp $ "Found declarations: " <> T.pack (show $ length decls) 
+  debugLsp $ "Found declarations: " <> T.pack (show $ length decls)
   pure $
     mconcat $
       decls <&> \decl -> do
@@ -207,10 +214,10 @@ positionToSourcePos (Types.Position line col) =
   Errors.SourcePos (fromIntegral $ line + 1) (fromIntegral $ col + 1)
 
 declToCompletionItemKind :: P.Declaration -> Maybe Types.CompletionItemKind
-declToCompletionItemKind = \case 
+declToCompletionItemKind = \case
   P.DataDeclaration {} -> Just Types.CompletionItemKind_EnumMember
   P.TypeSynonymDeclaration {} -> Just Types.CompletionItemKind_Struct
-  P.DataBindingGroupDeclaration {} -> Nothing 
+  P.DataBindingGroupDeclaration {} -> Nothing
   P.TypeClassDeclaration {} -> Just Types.CompletionItemKind_Interface
   P.TypeDeclaration {} -> Just Types.CompletionItemKind_Class
   P.ValueDeclaration {} -> Just Types.CompletionItemKind_Value
@@ -218,8 +225,3 @@ declToCompletionItemKind = \case
   P.RoleDeclaration {} -> Nothing
   P.ExternDeclaration {} -> Just Types.CompletionItemKind_Value
   _ -> Nothing
-
-  
-
-  
-  
\ No newline at end of file
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index cc013d4dab..d9b4a0ec88 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -38,7 +38,7 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
-import Language.PureScript.Lsp.Print (printEfDeclName, printName)
+import Language.PureScript.Lsp.Print (printEfDeclName, printName, printDeclarationType)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
 import Language.PureScript.Make (ffiCodegen')
@@ -77,11 +77,11 @@ indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) = liftIO do
         end = P.spanEnd ss
     SQL.executeNamed 
       conn 
-      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, shown, start_line, end_line, start_col, end_col, lines, cols, exported) VALUES (:module_name, :name, :value, :shown, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, printed_type, start_line, end_line, start_col, end_col, lines, cols, exported) VALUES (:module_name, :name, :value, :printed_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
       [ ":module_name" := P.runModuleName name,
         ":name" := printName <$> P.declName decl,
         ":value" := serialise decl,
-        ":shown" :=( show decl :: Text),
+        ":printed_type" := printDeclarationType decl,
         ":start_line" := P.sourcePosLine start,
         ":end_line" := P.sourcePosLine end,
         ":start_col" := P.sourcePosColumn start,
@@ -314,10 +314,10 @@ initDb' conn = catchError (initDb conn) \err -> do
 
 initDb :: Connection -> IO ()
 initDb conn = do
-  dropTables conn
+  -- dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
diff --git a/tests/TestLsp.hs b/tests/TestLsp.hs
index 07b3b77250..518ecc263a 100644
--- a/tests/TestLsp.hs
+++ b/tests/TestLsp.hs
@@ -40,29 +40,19 @@ import Test.Hspec (Spec, describe, it, shouldBe)
 -- runPursLspSession ::
 
 spec :: Spec
-spec = describe "lsp  " $ do
+spec =
   it "should get definitions" do
-    runSessionWithConfig sessionConfig ("purs lsp server --log-level debug " <> globs) fullLatestClientCaps "tests/purs/lsp" do
+    runSessionWithConfig sessionConfig ("purs lsp server " <> globs) fullLatestClientCaps "tests/purs/lsp" do
       void rebuildReq
       doc <- openDoc "Main.purs" "purs"
-      defs2 <- getDefinitions doc (Position 2 0)
-      liftIO $ print "defs2" *> print defs2
-      defs3 <- getDefinitions doc (Position 3 0)
-      liftIO $ print "defs3" *> print defs3
-      defs4 <- getDefinitions doc (Position 4 0)
-      liftIO $ print "defs4" *> print defs4
-      let expRange = Range (Position 4 0) (Position 4 3)
+      defsAtLine4 <- getDefinitions doc (Position 4 1)
+      let expRange = Range (Position 4 0) (Position 4 24)
       liftIO do
-        print "defs2"
-        print defs2
-        print "defs3"
-        print defs3
-        print "defs4"
-        print defs4
-        defs2 `shouldBe` (InL $ Definition $ InL $ Location (doc ^. uri) expRange)
+        defsAtLine4 `shouldBe` InL (Definition $ InL $ Location (doc ^. uri) expRange)
       pure ()
   where
     rebuildReq = do
+      void $ request (SMethod_CustomMethod $ Proxy @"delete output") A.Null
       rsp <- request (SMethod_CustomMethod $ Proxy @"build") A.Null
       liftIO $ do
         print "got build response"
@@ -80,23 +70,6 @@ sessionConfig = SessionConfig 30 True True True clientConfig True True True Noth
     pursLspConfig :: Map Text.Text A.Value
     pursLspConfig = Map.empty
 
--- Map.fromList
---   [("field", A.Object mempty)]
-
---   it "should run a test" $ do
---     "abc" `shouldBe` "abc"
-
--- runPursLspSession :: String -> ClientCapabilities -> FilePath -> Session b -> IO b
--- runPursLspSession testConfig caps root session = do
---   rin <- atomically newTChan
---   env <- mkEnv $ LspConfig "/output" ["."] LogError
---   server <- async $ void $ runServer $ serverDefinition env rin
---   res <- runSession testConfig caps root session
---   void $ timeout 3000000 $ do
---     Left (fromException -> Just ExitSuccess) <- waitCatch server
---     pure ()
---   pure res
-
 globs :: [Char]
 globs = prelude <> " " <> srcGlob
 

From e99728f98b6a54b403acefe8a5091a84bacaeef2 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sat, 5 Oct 2024 06:04:22 +0200
Subject: [PATCH 088/297] add lsp desugar

---
 src/Language/PureScript/Sugar.hs | 20 +++++++++++++++++++-
 1 file changed, 19 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 4d713d5418..07b175e39e 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -1,7 +1,7 @@
 -- |
 -- Desugaring passes
 --
-module Language.PureScript.Sugar (desugar, module S) where
+module Language.PureScript.Sugar (desugar, desugarLsp, module S) where
 
 import Control.Category ((>>>))
 import Control.Monad ((>=>))
@@ -73,3 +73,21 @@ desugar externs =
     >=> deriveInstances
     >=> desugarTypeClasses externs
     >=> createBindingGroupsModule
+
+-- TODO: add desugarImports, rebracket and desugarTypeClasses but getting externs and used imports from the DB
+desugarLsp
+  :: MonadSupply m
+  => MonadError MultipleErrors m
+  => Module
+  -> m Module
+desugarLsp  =
+  desugarSignedLiterals
+    >>> desugarObjectConstructors
+    >=> desugarDoModule
+    >=> desugarAdoModule
+    >=> desugarLetPatternModule
+    >>> desugarCasesModule
+    >=> desugarTypeDeclarationsModule
+    >=> checkFixityExports
+    >=> deriveInstances
+    >=> createBindingGroupsModule

From 783fc633c8081232abb686f4fc4c4b1a9284796e Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sat, 5 Oct 2024 06:04:35 +0200
Subject: [PATCH 089/297] adds EnvironmentFn

---
 src/Language/PureScript/Environment.hs | 24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 90f30753cc..9bb6838ccd 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -52,13 +52,23 @@ data Environment = Environment
 instance NFData Environment
 
 
-data EnvironmentLazy m = EnvironmentLazy 
-  { namesLazy :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
-  , typesLazy :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
-  , dataConstructorsLazy :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-  , typeSynonymsLazy :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
-  , typeClassDictionariesLazy :: QualifiedBy -> m (Maybe (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-  , typeClassesLazy :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
+data EnvironmentFn m = EnvironmentFn 
+  { namesFn :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
+  , typesFn :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
+  , dataConstructorsFn :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
+  , typeSynonymsFn :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
+  , typeClassDictionariesFn :: QualifiedBy -> m (Maybe (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
+  , typeClassesFn :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
+  }
+
+toEnvFn :: Applicative m => Environment -> EnvironmentFn m
+toEnvFn env = EnvironmentFn
+  { namesFn = \k -> pure $ M.lookup k (names env)
+  , typesFn = \k -> pure $ M.lookup k (types env)
+  , dataConstructorsFn = \k -> pure $ M.lookup k (dataConstructors env)
+  , typeSynonymsFn = \k -> pure $ M.lookup k (typeSynonyms env)
+  , typeClassDictionariesFn = \k -> pure $ M.lookup k (typeClassDictionaries env)
+  , typeClassesFn = \k -> pure $ M.lookup k (typeClasses env)
   }
 
 -- | Information about a type class

From a1b6de8da72fb9eafd16266a784c636de90325d9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sat, 5 Oct 2024 06:04:53 +0200
Subject: [PATCH 090/297] start rebuildModuleUsingDbEnv

---
 src/Language/PureScript/Make.hs | 422 ++++++++++++++++++--------------
 1 file changed, 236 insertions(+), 186 deletions(-)

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index aff82b3cfa..aed9d4d06c 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,115 +1,92 @@
 module Language.PureScript.Make
-  (
-  -- * Make API
-  rebuildModule
-  , rebuildModuleAndGetEnv
-  , rebuildModule'
-  , make
-  , inferForeignModules
-  , module Monad
-  , module Actions
-  ) where
-
-import Prelude
+  ( -- * Make API
+    rebuildModule,
+    rebuildModule',
+    make,
+    inferForeignModules,
+    module Monad,
+    module Actions,
+  )
+where
 
 import Control.Concurrent.Lifted as C
 import Control.DeepSeq (force)
-import Control.Exception.Lifted (onException, bracket_, evaluate)
+import Control.Exception.Lifted (bracket_, evaluate, onException)
 import Control.Monad (foldM, unless, when, (<=<))
-import Control.Monad.Base (MonadBase(liftBase))
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Base (MonadBase (liftBase))
+import Control.Monad.Error.Class (MonadError (..))
+import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
-import Control.Monad.Trans.Control (MonadBaseControl(..))
+import Control.Monad.Trans.Control (MonadBaseControl (..))
 import Control.Monad.Trans.State (runStateT)
-import Control.Monad.Writer.Class (MonadWriter(..), censor)
+import Control.Monad.Writer.Class (MonadWriter (..), censor)
 import Control.Monad.Writer.Strict (runWriterT)
-import Data.Function (on)
 import Data.Foldable (fold, for_)
+import Data.Function (on)
 import Data.List (foldl', sortOn)
 import Data.List.NonEmpty qualified as NEL
-import Data.Maybe (fromMaybe)
 import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
 import Data.Set qualified as S
 import Data.Text qualified as T
 import Debug.Trace (traceMarkerIO)
-import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim)
-import Language.PureScript.Crash (internalError)
+import Language.PureScript.AST (ErrorMessageHint (..), Module (..), SourceSpan (..), getModuleName, getModuleSourceSpan, importPrim)
 import Language.PureScript.CST qualified as CST
+import Language.PureScript.CoreFn qualified as CF
+import Language.PureScript.Crash (internalError)
 import Language.PureScript.Docs.Convert qualified as Docs
 import Language.PureScript.Environment (initEnvironment)
-import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
+import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
 import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile)
-import Language.PureScript.Linter (Name(..), lint, lintImports)
-import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules)
-import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
-import Language.PureScript.Renamer (renameInModule)
-import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
-import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule)
-import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult)
+import Language.PureScript.Linter (Name (..), lint, lintImports)
+import Language.PureScript.Make.Actions as Actions
+import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult)
 import Language.PureScript.Make.BuildPlan qualified as BuildPlan
 import Language.PureScript.Make.Cache qualified as Cache
-import Language.PureScript.Make.Actions as Actions
 import Language.PureScript.Make.Monad as Monad
-import Language.PureScript.CoreFn qualified as CF
+import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
+import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
+import Language.PureScript.Renamer (renameInModule)
+import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv, desugarLsp)
+import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
-import Control.Lens (Field1(_1), view)
-import Language.PureScript.Environment qualified as P
+import Prelude
 
 -- | Rebuild a single module.
 --
 -- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples).
-rebuildModule
-  :: forall m
-   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-  => MakeActions m
-  -> [ExternsFile]
-  -> Module
-  -> m ExternsFile
+rebuildModule ::
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  MakeActions m ->
+  [ExternsFile] ->
+  Module ->
+  m ExternsFile
 rebuildModule actions externs m = do
   env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs
   rebuildModule' actions env externs m
 
-rebuildModuleAndGetEnv
-  :: forall m
-   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-  => MakeActions m
-  -> [ExternsFile]
-  -> Module
-  -> m (ExternsFile, P.Environment)
-rebuildModuleAndGetEnv actions externs m = do
-  env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs
-  rebuildModuleAndGetEnv' actions env externs m
-
-rebuildModule'
-  :: forall m
-   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-  => MakeActions m
-  -> Env
-  -> [ExternsFile]
-  -> Module
-  -> m ExternsFile
-rebuildModule' act env ext mdl = view _1 <$> rebuildModuleAndGetEnv' act env ext mdl 
-
-rebuildModuleAndGetEnv' :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-  => MakeActions m
-  -> Env
-  -> [ExternsFile]
-  -> Module
-  -> m (ExternsFile, P.Environment)
-rebuildModuleAndGetEnv' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
-
-rebuildModuleWithIndex
-  :: forall m
-   . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-  => MakeActions m
-  -> Env
-  -> [ExternsFile]
-  -> Module
-  -> Maybe (Int, Int)
-  -> m (ExternsFile, P.Environment)
-rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do
+rebuildModule' ::
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  MakeActions m ->
+  Env ->
+  [ExternsFile] ->
+  Module ->
+  m ExternsFile
+rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
+
+rebuildModuleWithIndex ::
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  MakeActions m ->
+  Env ->
+  [ExternsFile] ->
+  Module ->
+  Maybe (Int, Int) ->
+  m ExternsFile
+rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
       withPrim = importPrim m
@@ -118,9 +95,14 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
     (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-    (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
-    let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) ->
-          M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible
+    (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+    let usedImports' =
+          foldl'
+            ( flip $ \(fromModuleName, newtypeCtorName) ->
+                M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
+            )
+            usedImports
+            checkConstructorImportsForCoercible
     -- Imports cannot be linted before type checking because we need to
     -- known which newtype constructors are used to solve Coercible
     -- constraints in order to not report them as unused.
@@ -149,23 +131,92 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   -- 2. We do not want to perform any extra work generating docs unless the
   -- user has asked for docs to be generated.
   let docs = case Docs.convertModule externs exEnv env' withPrim of
-               Left errs -> internalError $
-                 "Failed to produce docs for " ++ T.unpack (runModuleName moduleName)
-                 ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs
-               Right d -> d
+        Left errs ->
+          internalError $
+            "Failed to produce docs for "
+              ++ T.unpack (runModuleName moduleName)
+              ++ "; details:\n"
+              ++ prettyPrintMultipleErrors defaultPPEOptions errs
+        Right d -> d
 
   evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
-  return (exts, env')
+  return exts
+
+rebuildModuleUsingDbEnv ::
+  forall m.
+  (MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  MakeActions m ->
+  Module ->
+  m ExternsFile
+rebuildModuleUsingDbEnv MakeActions {..} m@(Module _ _ moduleName _ _) = do
+  let withPrim = importPrim m
+  lint withPrim
+  ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
+  
+    desugared <- desugarLsp withPrim
+    -- (desugared, (exEnv', usedImports)) <- runStateT (desugarLsp externs withPrim) (exEnv, mempty)
+
+    
+    let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
+    (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+    let usedImports' =
+          foldl'
+            ( flip $ \(fromModuleName, newtypeCtorName) ->
+                M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
+            )
+            usedImports
+            checkConstructorImportsForCoercible
+    -- Imports cannot be linted before type checking because we need to
+    -- known which newtype constructors are used to solve Coercible
+    -- constraints in order to not report them as unused.
+    censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
+    return (checked, checkEnv)
+
+  -- desugar case declarations *after* type- and exhaustiveness checking
+  -- since pattern guards introduces cases which the exhaustiveness checker
+  -- reports as not-exhaustive.
+  (deguarded, nextVar') <- runSupplyT nextVar $ do
+    desugarCaseGuards elaborated
+
+  regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
+  let mod' = Module ss coms moduleName regrouped exps
+      corefn = CF.moduleToCoreFn env' mod'
+      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
+      (renamedIdents, renamed) = renameInModule optimized
+      exts = moduleToExternsFile mod' env' renamedIdents
+  ffiCodegen renamed
+  -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
+  -- but I have not done so for two reasons:
+  -- 1. This should never fail; any genuine errors in the code should have been
+  -- caught earlier in this function. Therefore if we do fail here it indicates
+  -- a bug in the compiler, which should be reported as such.
+  -- 2. We do not want to perform any extra work generating docs unless the
+  -- user has asked for docs to be generated.
+  let docs = undefined
+    -- case Docs.convertModule externs exEnv env' withPrim of
+    --     Left errs ->
+    --       internalError $
+    --         "Failed to produce docs for "
+    --           ++ T.unpack (runModuleName moduleName)
+    --           ++ "; details:\n"
+    --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
+    --     Right d -> d
+
+  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
+  return exts
+
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
 --
 -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without
 -- having to typecheck those modules again.
-make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-     => MakeActions m
-     -> [CST.PartialResult Module]
-     -> m [ExternsFile]
-make ma@MakeActions{..} ms = do
+make ::
+  forall m.
+  (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  MakeActions m ->
+  [CST.PartialResult Module] ->
+  m [ExternsFile]
+make ma@MakeActions {..} ms = do
   checkModuleNames
   cacheDb <- readCacheDb
 
@@ -187,28 +238,29 @@ make ma@MakeActions{..} ms = do
   for_ toBeRebuilt $ \m -> fork $ do
     let moduleName = getModuleName . CST.resPartial $ m
     let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
-    buildModule lock buildPlan moduleName totalModuleCount
+    buildModule
+      lock
+      buildPlan
+      moduleName
+      totalModuleCount
       (spanName . getModuleSourceSpan . CST.resPartial $ m)
       (fst $ CST.resFull m)
       (fmap importPrim . snd $ CST.resFull m)
       (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
-
       -- Prevent hanging on other modules when there is an internal error
       -- (the exception is thrown, but other threads waiting on MVars are released)
       `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty)
 
   -- Wait for all threads to complete, and collect results (and errors).
   (failures, successes) <-
-    let
-      splitResults = \case
-        BuildJobSucceeded _ exts ->
-          Right exts
-        BuildJobFailed errs ->
-          Left errs
-        BuildJobSkipped ->
-          Left mempty
-    in
-      M.mapEither splitResults <$> BuildPlan.collectResults buildPlan
+    let splitResults = \case
+          BuildJobSucceeded _ exts ->
+            Right exts
+          BuildJobFailed errs ->
+            Left errs
+          BuildJobSkipped ->
+            Left mempty
+     in M.mapEither splitResults <$> BuildPlan.collectResults buildPlan
 
   -- Write the updated build cache database to disk
   writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb
@@ -226,93 +278,91 @@ make ma@MakeActions{..} ms = do
   -- so they can be folded into an Environment. This result is used in the tests
   -- and in PSCI.
   let lookupResult mn =
-        fromMaybe (internalError "make: module not found in results")
-        $ M.lookup mn successes
+        fromMaybe (internalError "make: module not found in results") $
+          M.lookup mn successes
   return (map (lookupResult . getModuleName . CST.resPartial) sorted)
-
   where
-  checkModuleNames :: m ()
-  checkModuleNames = checkNoPrim *> checkModuleNamesAreUnique
-
-  checkNoPrim :: m ()
-  checkNoPrim =
-    for_ ms $ \m ->
-      let mn = getModuleName $ CST.resPartial m
-      in when (isBuiltinModuleName mn) $
-           throwError
-             . errorMessage' (getModuleSourceSpan $ CST.resPartial m)
-             $ CannotDefinePrimModules mn
-
-  checkModuleNamesAreUnique :: m ()
-  checkModuleNamesAreUnique =
-    for_ (findDuplicates (getModuleName . CST.resPartial) ms) $ \mss ->
-      throwError . flip foldMap mss $ \ms' ->
-        let mn = getModuleName . CST.resPartial . NEL.head $ ms'
-        in errorMessage'' (fmap (getModuleSourceSpan . CST.resPartial) ms') $ DuplicateModule mn
-
-  -- Find all groups of duplicate values in a list based on a projection.
-  findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a]
-  findDuplicates f xs =
-    case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortOn f $ xs of
-      [] -> Nothing
-      xss -> Just xss
-
-  -- Sort a list so its elements appear in the same order as in another list.
-  inOrderOf :: (Ord a) => [a] -> [a] -> [a]
-  inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
-
-  buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
-  buildModule lock buildPlan moduleName cnt fp pwarnings mres deps = do
-    result <- flip catchError (return . BuildJobFailed) $ do
-      let pwarnings' = CST.toMultipleWarnings fp pwarnings
-      tell pwarnings'
-      m <- CST.unwrapParserError fp mres
-      -- We need to wait for dependencies to be built, before checking if the current
-      -- module should be rebuilt, so the first thing to do is to wait on the
-      -- MVars for the module's dependencies.
-      mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps
-
-      case mexterns of
-        Just (_, externs) -> do
-          -- We need to ensure that all dependencies have been included in Env
-          C.modifyMVar_ (bpEnv buildPlan) $ \env -> do
-            let
-              go :: Env -> ModuleName -> m Env
-              go e dep = case lookup dep (zip deps externs) of
-                Just exts
-                  | not (M.member dep e) -> externsEnv e exts
-                _ -> return e
-            foldM go env deps
-          env <- C.readMVar (bpEnv buildPlan)
-          idx <- C.takeMVar (bpIndex buildPlan)
-          C.putMVar (bpIndex buildPlan) (idx + 1)
-
-          -- Bracket all of the per-module work behind the semaphore, including
-          -- forcing the result. This is done to limit concurrency and keep
-          -- memory usage down; see comments above.
-          (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do
-            -- Eventlog markers for profiling; see debug/eventlog.js
-            liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start"
-            -- Force the externs and warnings to avoid retaining excess module
-            -- data after the module is finished compiling.
-            extsAndWarnings <- evaluate . force <=< listen $ do
-              view _1 <$>  rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
-            liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
-            return extsAndWarnings
-          return $ BuildJobSucceeded (pwarnings' <> warnings) exts
-        Nothing -> return BuildJobSkipped
-
-    BuildPlan.markComplete buildPlan moduleName result
+    checkModuleNames :: m ()
+    checkModuleNames = checkNoPrim *> checkModuleNamesAreUnique
+
+    checkNoPrim :: m ()
+    checkNoPrim =
+      for_ ms $ \m ->
+        let mn = getModuleName $ CST.resPartial m
+         in when (isBuiltinModuleName mn)
+              $ throwError
+                . errorMessage' (getModuleSourceSpan $ CST.resPartial m)
+              $ CannotDefinePrimModules mn
+
+    checkModuleNamesAreUnique :: m ()
+    checkModuleNamesAreUnique =
+      for_ (findDuplicates (getModuleName . CST.resPartial) ms) $ \mss ->
+        throwError . flip foldMap mss $ \ms' ->
+          let mn = getModuleName . CST.resPartial . NEL.head $ ms'
+           in errorMessage'' (fmap (getModuleSourceSpan . CST.resPartial) ms') $ DuplicateModule mn
+
+    -- Find all groups of duplicate values in a list based on a projection.
+    findDuplicates :: (Ord b) => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a]
+    findDuplicates f xs =
+      case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortOn f $ xs of
+        [] -> Nothing
+        xss -> Just xss
+
+    -- Sort a list so its elements appear in the same order as in another list.
+    inOrderOf :: (Ord a) => [a] -> [a] -> [a]
+    inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
+
+    buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
+    buildModule lock buildPlan moduleName cnt fp pwarnings mres deps = do
+      result <- flip catchError (return . BuildJobFailed) $ do
+        let pwarnings' = CST.toMultipleWarnings fp pwarnings
+        tell pwarnings'
+        m <- CST.unwrapParserError fp mres
+        -- We need to wait for dependencies to be built, before checking if the current
+        -- module should be rebuilt, so the first thing to do is to wait on the
+        -- MVars for the module's dependencies.
+        mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps
+
+        case mexterns of
+          Just (_, externs) -> do
+            -- We need to ensure that all dependencies have been included in Env
+            C.modifyMVar_ (bpEnv buildPlan) $ \env -> do
+              let go :: Env -> ModuleName -> m Env
+                  go e dep = case lookup dep (zip deps externs) of
+                    Just exts
+                      | not (M.member dep e) -> externsEnv e exts
+                    _ -> return e
+              foldM go env deps
+            env <- C.readMVar (bpEnv buildPlan)
+            idx <- C.takeMVar (bpIndex buildPlan)
+            C.putMVar (bpIndex buildPlan) (idx + 1)
+
+            -- Bracket all of the per-module work behind the semaphore, including
+            -- forcing the result. This is done to limit concurrency and keep
+            -- memory usage down; see comments above.
+            (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do
+              -- Eventlog markers for profiling; see debug/eventlog.js
+              liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start"
+              -- Force the externs and warnings to avoid retaining excess module
+              -- data after the module is finished compiling.
+              extsAndWarnings <- evaluate . force <=< listen $ do
+                rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
+              liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
+              return extsAndWarnings
+            return $ BuildJobSucceeded (pwarnings' <> warnings) exts
+          Nothing -> return BuildJobSkipped
+
+      BuildPlan.markComplete buildPlan moduleName result
 
 -- | Infer the module name for a module by looking for the same filename with
 -- a .js extension.
-inferForeignModules
-  :: forall m
-   . MonadIO m
-  => M.Map ModuleName (Either RebuildPolicy FilePath)
-  -> m (M.Map ModuleName FilePath)
+inferForeignModules ::
+  forall m.
+  (MonadIO m) =>
+  M.Map ModuleName (Either RebuildPolicy FilePath) ->
+  m (M.Map ModuleName FilePath)
 inferForeignModules =
-    fmap (M.mapMaybe id) . traverse inferForeignModule
+  fmap (M.mapMaybe id) . traverse inferForeignModule
   where
     inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)
     inferForeignModule (Left _) = return Nothing

From 1b5208f97068192be641cfb023735a9418828ce9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 6 Oct 2024 04:01:05 +0200
Subject: [PATCH 091/297] faster completion

---
 src/Language/PureScript/DB.hs              |   4 +-
 src/Language/PureScript/Lsp/Cache/Query.hs |  46 +++++---
 src/Language/PureScript/Lsp/Handlers.hs    |  74 +++++++------
 src/Language/PureScript/Lsp/Imports.hs     |  15 ++-
 src/Language/PureScript/Lsp/Types.hs       |   2 +-
 src/Language/PureScript/Lsp/Util.hs        |   4 +-
 src/Language/PureScript/Make.hs            | 122 ++++++++++-----------
 src/Language/PureScript/Make/Index.hs      |   9 +-
 8 files changed, 147 insertions(+), 129 deletions(-)

diff --git a/src/Language/PureScript/DB.hs b/src/Language/PureScript/DB.hs
index 6a8adf25b9..25f2591ea2 100644
--- a/src/Language/PureScript/DB.hs
+++ b/src/Language/PureScript/DB.hs
@@ -3,9 +3,11 @@ module Language.PureScript.DB where
 import Protolude
 import Database.SQLite.Simple (Connection, open)
 import System.FilePath ((</>))
+import System.Directory (createDirectoryIfMissing)
 
 mkConnection :: FilePath -> IO Connection
-mkConnection outputDir =  
+mkConnection outputDir =  do
+  createDirectoryIfMissing True outputDir
   open (outputDir </> dbFile)
 
 dbFile :: FilePath
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 8eeef3110f..e6d5ecf556 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -24,7 +24,6 @@ import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
 
-
 getCoreFnExprAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Expr CF.Ann))
 getCoreFnExprAt path (LSP.Position line col) = do
   decls :: [SQL.Only Lazy.ByteString] <-
@@ -70,7 +69,6 @@ getCodeFnBindAt path (LSP.Position line col) = do
       =<< fromOnly
       <$> listToMaybe decls
 
-
 ------------------------------------------------------------------------------------------------------------------------
 ------------ Externs ---------------------------------------------------------------------------------------------------
 ------------------------------------------------------------------------------------------------------------------------
@@ -145,17 +143,33 @@ getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
       ]
   pure $ deserialise . fromOnly <$> decls
 
-
-getAstDeclarationsStartingWith :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m [(P.ModuleName, P.Declaration)]
-getAstDeclarationsStartingWith moduleName' prefix = do
-  decls :: [(Text, Lazy.ByteString )] <-
-    DB.queryNamed
-      "SELECT module_name, value FROM ast_declarations \
-      \WHERE (module_name = :module_name OR exported) \
-      \AND name GLOB :prefix \
-      \ORDER BY name ASC \
-      \LIMIT 50"
-      [ ":module_name" := P.runModuleName moduleName',
-        ":prefix" := prefix <> "*"
-      ]
-  pure $ bimap P.ModuleName deserialise <$> decls
\ No newline at end of file
+getAstDeclarationsStartingWith ::
+  (MonadIO m, MonadReader LspEnvironment m) =>
+  Int ->
+  Int ->
+  P.ModuleName ->
+  Text ->
+  m [CompletionResult]
+getAstDeclarationsStartingWith limit offset moduleName' prefix = do
+  DB.queryNamed
+    "SELECT name, printed_type, module_name FROM ast_declarations \
+    \WHERE (module_name = :module_name OR exported) \
+    \AND name GLOB :prefix \
+    \ORDER BY name ASC \
+    \LIMIT :limit \
+    \OFFSET :offset"
+    [ ":module_name" := P.runModuleName moduleName',
+      ":prefix" := prefix <> "*",
+      ":limit" := limit,
+      ":offset" := offset
+    ]
+
+data CompletionResult = CompletionResult
+  { crName :: Text,
+    crType :: Text,
+    crModule :: P.ModuleName
+  }
+  deriving (Show, Generic)
+
+instance SQL.FromRow CompletionResult where
+  fromRow = CompletionResult <$> SQL.field <*> SQL.field <*> (P.ModuleName <$> SQL.field)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 78da1b0830..4f75c16b6f 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -23,27 +23,27 @@ import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.Compile (compile)
 import Language.PureScript.CoreFn.Expr qualified as CF
+import Language.PureScript.DB (dbFile)
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit)
 import Language.PureScript.Lsp.Log (debugLsp)
-import Language.PureScript.Lsp.Print (printDeclarationType, printName)
+import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confGlobs, confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
-import Language.PureScript.Lsp.Util (declToCompletionItemKind, efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Make.Index (initDb)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
 import System.FilePath ((</>))
 import System.IO.UTF8 (readUTF8FilesT)
-import Language.PureScript.DB (dbFile)
 
 type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
@@ -270,47 +270,49 @@ handlers =
                 mNameMb <- selectExternModuleNameFromFilePath filePath
                 debugLsp $ "Module name: " <> show mNameMb
                 forLsp mNameMb \mName -> do
-                  decls <- getAstDeclarationsStartingWith mName word
+                  let limit = 50
+                  decls <- getAstDeclarationsStartingWith limit 0 mName word
                   debugLsp $ "Found decls: " <> show (length decls)
                   res $
                     Right $
-                      Types.InL $
-                        decls <&> \(declModule, decl) ->
-                          let label = foldMap printName (P.declName decl)
-                           in Types.CompletionItem
-                                { _label = label,
-                                  _labelDetails =
-                                    Just $
-                                      Types.CompletionItemLabelDetails
-                                        (Just $ " " <> printDeclarationType decl)
-                                        (Just $ " " <> P.runModuleName declModule),
-                                  _kind = declToCompletionItemKind decl,
-                                  _tags = Nothing,
-                                  _detail = Nothing,
-                                  _documentation = Nothing,
-                                  _deprecated = Nothing, --  Maybe Bool
-                                  _preselect = Nothing, --  Maybe Bool
-                                  _sortText = Nothing, --  Maybe Text
-                                  _filterText = Nothing, --  Maybe Text
-                                  _insertText = Nothing, --  Maybe Text
-                                  _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
-                                  _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
-                                  _textEdit = Nothing, --  Maybe
-                                  --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
-                                  _textEditText = Nothing, --  Maybe Text
-                                  _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
-                                  _commitCharacters = Nothing, --  Maybe [Text]
-                                  _command = Nothing, --  Maybe Types.Command
-                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModule decl word
-                                },
+                      Types.InR $
+                        Types.InL $
+                          Types.CompletionList (length decls >= limit) Nothing $
+                            decls <&> \cr ->
+                              let label = crName cr
+                               in Types.CompletionItem
+                                    { _label = label,
+                                      _labelDetails =
+                                        Just $
+                                          Types.CompletionItemLabelDetails
+                                            (Just $ " " <> crType cr)
+                                            (Just $ " " <> P.runModuleName (crModule cr)),
+                                      _kind = Nothing, --  Maybe Types.CompletionItemKind TODO: add kind
+                                      _tags = Nothing,
+                                      _detail = Nothing,
+                                      _documentation = Nothing,
+                                      _deprecated = Nothing, --  Maybe Bool
+                                      _preselect = Nothing, --  Maybe Bool
+                                      _sortText = Nothing, --  Maybe Text
+                                      _filterText = Nothing, --  Maybe Text
+                                      _insertText = Nothing, --  Maybe Text
+                                      _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
+                                      _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
+                                      _textEdit = Nothing, --  Maybe
+                                      --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                                      _textEditText = Nothing, --  Maybe Text
+                                      _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
+                                      _commitCharacters = Nothing, --  Maybe [Text]
+                                      _command = Nothing, --  Maybe Types.Command
+                                      _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word
+                                    },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         debugLsp "SMethod_CompletionItemResolve"
         let completionItem = req ^. LSP.params
             result = completionItem ^. LSP.data_ & decodeCompleteItemData
 
         case result of
-          A.Success (Just cid@(CompleteItemData _filePath _mName declModule decl _)) -> do
-            let label = foldMap printName (P.declName decl)
+          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _)) -> do
             docsMb <- readDeclarationDocsAsMarkdown declModule label
             withImports <- addImportToTextEdit completionItem cid
             let addDocs :: Types.CompletionItem -> Types.CompletionItem
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index d2fd503187..166cd4b586 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -14,6 +14,7 @@ import Language.PureScript.Lsp.ReadFile (lspReadFile)
 import Language.PureScript.Lsp.Types (CompleteItemData (..), LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
 
 addImportToTextEdit :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompletionItem -> CompleteItemData -> m CompletionItem
 addImportToTextEdit completionItem completeItemData = do
@@ -21,16 +22,22 @@ addImportToTextEdit completionItem completeItemData = do
   pure $ set LSP.additionalTextEdits importEdits completionItem
 
 getImportEdits :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit])
-getImportEdits (CompleteItemData path moduleName' importedModuleName decl _word) = do
+getImportEdits (CompleteItemData path moduleName' importedModuleName name _word) = do
   parseRes <- parseImportsFromFile path
   case parseRes of
     Left err -> do
       errorLsp $ "In " <> T.pack path <> " failed to parse imports from file: " <> err
       pure Nothing
     Right (_mn, before, imports, _after) -> do
-      addDeclarationToImports moduleName' importedModuleName decl imports
-        <&> pure . importsToTextEdit before
-        & pure
+      declMb <- getAstDeclarationInModule importedModuleName name
+      case declMb of
+        Nothing -> do
+          errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> name
+          pure Nothing
+        Just decl -> do
+          addDeclarationToImports moduleName' importedModuleName decl imports
+            <&> pure . importsToTextEdit before
+            & pure
 
 addDeclarationToImports :: P.ModuleName -> P.ModuleName -> P.Declaration -> [Import] -> Maybe [Import]
 addDeclarationToImports moduleName' importedModuleName decl imports
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index a9ce235cb0..daea9ac198 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -54,7 +54,7 @@ data CompleteItemData = CompleteItemData
   { cidPath :: FilePath,
     cidModuleName :: P.ModuleName,
     cidImportedModuleName :: P.ModuleName,
-    cidImportedDeclaration :: P.Declaration, 
+    cidName :: Text,
     cidWord :: Text
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 51fc8f6569..22ba2bfe6f 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -46,7 +46,7 @@ getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn)
 
 getWordAt :: Rope -> Types.Position -> Text
 getWordAt file Types.Position {..} =
-  if Rope.lengthInLines file < fromIntegral _line
+  if Rope.lengthInLines file < fromIntegral _line || _line < 0
     then ""
     else
       let (_, after) = splitAtLine (fromIntegral _line) file
@@ -56,7 +56,7 @@ getWordAt file Types.Position {..} =
 
 getWordOnLine :: Text -> UInt -> Text
 getWordOnLine line' col =
-  if T.length line' < fromIntegral col
+  if T.length line' < fromIntegral col || col < 0
     then ""
     else
       let start = getPrevWs (fromIntegral col - 1) line'
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index aed9d4d06c..06a1975d80 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -47,7 +47,7 @@ import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
 import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
 import Language.PureScript.Renamer (renameInModule)
-import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv, desugarLsp)
+import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
@@ -139,71 +139,71 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
+  evalSupplyT nextVar'' $ codegen env' m renamed docs exts
   return exts
 
-rebuildModuleUsingDbEnv ::
-  forall m.
-  (MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
-  MakeActions m ->
-  Module ->
-  m ExternsFile
-rebuildModuleUsingDbEnv MakeActions {..} m@(Module _ _ moduleName _ _) = do
-  let withPrim = importPrim m
-  lint withPrim
-  ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
+-- rebuildModuleUsingDbEnv ::
+--   forall m.
+--   (MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+--   MakeActions m ->
+--   Module ->
+--   m ExternsFile
+-- rebuildModuleUsingDbEnv MakeActions {..} m@(Module _ _ moduleName _ _) = do
+--   let withPrim = importPrim m
+--   lint withPrim
+--   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
   
-    desugared <- desugarLsp withPrim
-    -- (desugared, (exEnv', usedImports)) <- runStateT (desugarLsp externs withPrim) (exEnv, mempty)
+--     desugared <- desugarLsp withPrim
+--     -- (desugared, (exEnv', usedImports)) <- runStateT (desugarLsp externs withPrim) (exEnv, mempty)
 
     
-    let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-    (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
-    let usedImports' =
-          foldl'
-            ( flip $ \(fromModuleName, newtypeCtorName) ->
-                M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
-            )
-            usedImports
-            checkConstructorImportsForCoercible
-    -- Imports cannot be linted before type checking because we need to
-    -- known which newtype constructors are used to solve Coercible
-    -- constraints in order to not report them as unused.
-    censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
-    return (checked, checkEnv)
-
-  -- desugar case declarations *after* type- and exhaustiveness checking
-  -- since pattern guards introduces cases which the exhaustiveness checker
-  -- reports as not-exhaustive.
-  (deguarded, nextVar') <- runSupplyT nextVar $ do
-    desugarCaseGuards elaborated
-
-  regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
-  let mod' = Module ss coms moduleName regrouped exps
-      corefn = CF.moduleToCoreFn env' mod'
-      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
-      (renamedIdents, renamed) = renameInModule optimized
-      exts = moduleToExternsFile mod' env' renamedIdents
-  ffiCodegen renamed
-  -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
-  -- but I have not done so for two reasons:
-  -- 1. This should never fail; any genuine errors in the code should have been
-  -- caught earlier in this function. Therefore if we do fail here it indicates
-  -- a bug in the compiler, which should be reported as such.
-  -- 2. We do not want to perform any extra work generating docs unless the
-  -- user has asked for docs to be generated.
-  let docs = undefined
-    -- case Docs.convertModule externs exEnv env' withPrim of
-    --     Left errs ->
-    --       internalError $
-    --         "Failed to produce docs for "
-    --           ++ T.unpack (runModuleName moduleName)
-    --           ++ "; details:\n"
-    --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
-    --     Right d -> d
-
-  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
-  return exts
+--     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
+--     (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+--     let usedImports' =
+--           foldl'
+--             ( flip $ \(fromModuleName, newtypeCtorName) ->
+--                 M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
+--             )
+--             usedImports
+--             checkConstructorImportsForCoercible
+--     -- Imports cannot be linted before type checking because we need to
+--     -- known which newtype constructors are used to solve Coercible
+--     -- constraints in order to not report them as unused.
+--     censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
+--     return (checked, checkEnv)
+
+--   -- desugar case declarations *after* type- and exhaustiveness checking
+--   -- since pattern guards introduces cases which the exhaustiveness checker
+--   -- reports as not-exhaustive.
+--   (deguarded, nextVar') <- runSupplyT nextVar $ do
+--     desugarCaseGuards elaborated
+
+--   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
+--   let mod' = Module ss coms moduleName regrouped exps
+--       corefn = CF.moduleToCoreFn env' mod'
+--       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
+--       (renamedIdents, renamed) = renameInModule optimized
+--       exts = moduleToExternsFile mod' env' renamedIdents
+--   ffiCodegen renamed
+--   -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
+--   -- but I have not done so for two reasons:
+--   -- 1. This should never fail; any genuine errors in the code should have been
+--   -- caught earlier in this function. Therefore if we do fail here it indicates
+--   -- a bug in the compiler, which should be reported as such.
+--   -- 2. We do not want to perform any extra work generating docs unless the
+--   -- user has asked for docs to be generated.
+--   let docs = undefined
+--     -- case Docs.convertModule externs exEnv env' withPrim of
+--     --     Left errs ->
+--     --       internalError $
+--     --         "Failed to produce docs for "
+--     --           ++ T.unpack (runModuleName moduleName)
+--     --           ++ "; details:\n"
+--     --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
+--     --     Right d -> d
+
+--   evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
+--   return exts
 
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index d9b4a0ec88..9c8e06fa60 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -305,16 +305,9 @@ insertEfExport conn moduleName' dr = do
   where
     span = P.declRefSourceSpan dr
 
-
-initDb' :: Connection -> IO ()
-initDb' conn = catchError (initDb conn) \err -> do 
-  print ("DB connection error: " :: Text)
-  print err
-  pure ()
-
 initDb :: Connection -> IO ()
 initDb conn = do
-  -- dropTables conn
+  dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"

From 9067b509db929c0396affe8ea6d5f9450fd2c00d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 6 Oct 2024 04:05:36 +0200
Subject: [PATCH 092/297] use typechecked module

---
 src/Language/PureScript/Make.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 06a1975d80..8efd376b62 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -139,7 +139,7 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env' m renamed docs exts
+  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
   return exts
 
 -- rebuildModuleUsingDbEnv ::

From e54dd0c6548c920ed9a11613eb64a3b01860dc89 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 6 Oct 2024 05:13:12 +0200
Subject: [PATCH 093/297] Async env: start

---
 src/Language/PureScript/Environment.hs        | 139 ++-
 .../PureScript/TypeChecker/Entailment.hs      |   6 +-
 .../TypeChecker/Entailment/Coercible.hs       | 942 +++++++++---------
 src/Language/PureScript/TypeChecker/Kinds.hs  | 107 +-
 src/Language/PureScript/TypeChecker/Monad.hs  | 579 +++++------
 .../PureScript/TypeChecker/Skolems.hs         |   6 +-
 .../PureScript/TypeChecker/Subsumption.hs     |   8 +-
 .../PureScript/TypeChecker/Synonyms.hs        |  92 +-
 src/Language/PureScript/TypeChecker/Unify.hs  |  14 +-
 9 files changed, 986 insertions(+), 907 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 9bb6838ccd..de858d00f0 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,76 +1,123 @@
 {-# LANGUAGE DeriveAnyClass #-}
-module Language.PureScript.Environment where
 
-import Prelude
+module Language.PureScript.Environment where
 
-import GHC.Generics (Generic)
+import Codec.Serialise (Serialise)
+import Codec.Serialise qualified as S
 import Control.DeepSeq (NFData)
 import Control.Monad (unless)
-import Codec.Serialise (Serialise)
-import Data.Aeson ((.=), (.:))
+import Data.Aeson ((.:), (.=))
 import Data.Aeson qualified as A
 import Data.Foldable (find, fold)
 import Data.Functor ((<&>))
 import Data.IntMap qualified as IM
 import Data.IntSet qualified as IS
+import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
-import Data.Set qualified as S
 import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Semigroup (First(..))
+import Data.Semigroup (First (..))
+import Data.Set qualified as S
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.List.NonEmpty qualified as NEL
-
+import GHC.Generics (Generic)
 import Language.PureScript.AST.SourcePos (nullSourceAnn)
+import Language.PureScript.Constants.Prim qualified as C
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName)
-import Language.PureScript.Roles (Role(..))
+import Language.PureScript.Names (Ident, ProperName (..), ProperNameType (..), Qualified, QualifiedBy, coerceProperName)
+import Language.PureScript.Roles (Role (..))
 import Language.PureScript.TypeClassDictionaries (NamedDict)
-import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables)
-import Language.PureScript.Constants.Prim qualified as C
-import Codec.Serialise qualified as S
+import Language.PureScript.Types (SourceConstraint, SourceType, Type (..), TypeVarVisibility (..), eqType, freeTypeVariables, srcTypeConstructor)
+import Protolude ((&))
+import Prelude
 
 -- | The @Environment@ defines all values and types which are currently in scope:
 data Environment = Environment
-  { names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
-  -- ^ Values currently in scope
-  , types :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-  -- ^ Type names currently in scope
-  , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
-  -- ^ Data constructors currently in scope, along with their associated type
-  -- constructor name, argument types and return type.
-  , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType)
-  -- ^ Type synonyms currently in scope
-  , typeClassDictionaries :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
-  -- ^ Available type class dictionaries. When looking up 'Nothing' in the
-  -- outer map, this returns the map of type class dictionaries in local
-  -- scope (ie dictionaries brought in by a constrained type).
-  , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
-  -- ^ Type classes
-  } deriving (Show, Generic, S.Serialise)
+  { -- | Values currently in scope
+    names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility),
+    -- | Type names currently in scope
+    types :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind),
+    -- | Data constructors currently in scope, along with their associated type
+    -- constructor name, argument types and return type.
+    dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]),
+    -- | Type synonyms currently in scope
+    typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType),
+    -- | Available type class dictionaries. When looking up 'Nothing' in the
+    -- outer map, this returns the map of type class dictionaries in local
+    -- scope (ie dictionaries brought in by a constrained type).
+    typeClassDictionaries :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))),
+    -- | Type classes
+    typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
+  }
+  deriving (Show, Generic, S.Serialise)
 
 instance NFData Environment
 
-
-data EnvironmentFn m = EnvironmentFn 
-  { namesFn :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
-  , typesFn :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
-  , dataConstructorsFn :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-  , typeSynonymsFn :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
-  , typeClassDictionariesFn :: QualifiedBy -> m (Maybe (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-  , typeClassesFn :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
+data EnvironmentAsync m = EnvironmentAsync
+  -- Functions allow env vars to be lazily loaded
+  { namesAsync :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility)),
+    typesAsync :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind)),
+    dataConstructorsAsync :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])),
+    typeSynonymsAsync :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType)),
+    typeClassDictionariesAsync :: QualifiedBy -> Qualified (ProperName 'ClassName) -> m (Maybe (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))),
+    typeClassesAsync :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
   }
 
-toEnvFn :: Applicative m => Environment -> EnvironmentFn m
-toEnvFn env = EnvironmentFn
-  { namesFn = \k -> pure $ M.lookup k (names env)
-  , typesFn = \k -> pure $ M.lookup k (types env)
-  , dataConstructorsFn = \k -> pure $ M.lookup k (dataConstructors env)
-  , typeSynonymsFn = \k -> pure $ M.lookup k (typeSynonyms env)
-  , typeClassDictionariesFn = \k -> pure $ M.lookup k (typeClassDictionaries env)
-  , typeClassesFn = \k -> pure $ M.lookup k (typeClasses env)
+nullAsyncEnv :: Applicative m => EnvironmentAsync m
+nullAsyncEnv =
+  EnvironmentAsync
+    { namesAsync = \_ -> pure Nothing,
+      typesAsync = \_ -> pure Nothing,
+      dataConstructorsAsync = \_ -> pure Nothing,
+      typeSynonymsAsync = \_ -> pure Nothing,
+      typeClassDictionariesAsync = \_ _ -> pure Nothing,
+      typeClassesAsync = \_ -> pure Nothing
+    }
+
+data EnvironmentWithAsync m = EnvironmentWithAsync
+  { envSync :: Environment,
+    envAsync :: EnvironmentAsync m
   }
 
+-- fromEnv :: (Ord t, Applicative f) => (Environment -> M.Map t a) -> (EnvironmentFn m -> t -> f (Maybe a)) -> t -> EnvironmentFn m -> f (Maybe a)
+
+fromEnv ::
+  (Ord k, Applicative f) =>
+  (Environment -> M.Map k a) ->
+  (EnvironmentAsync m -> k -> f (Maybe a)) ->
+  k ->
+  EnvironmentWithAsync m ->
+  f (Maybe a)
+fromEnv getMap getFn k env =
+  M.lookup k (getMap $ envSync env)
+    & maybe ((getFn $ envAsync env) k) (pure . Just)
+
+getName :: forall m. (Applicative m) => Qualified Ident -> EnvironmentWithAsync m -> m (Maybe (SourceType, NameKind, NameVisibility))
+getName = fromEnv names namesAsync
+
+getType :: forall m. (Applicative m) => Qualified (ProperName 'TypeName) -> EnvironmentWithAsync m -> m (Maybe (SourceType, TypeKind))
+getType = fromEnv types typesAsync
+
+getDataConstructor :: forall m. (Applicative m) => Qualified (ProperName 'ConstructorName) -> EnvironmentWithAsync m -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
+getDataConstructor = fromEnv dataConstructors dataConstructorsAsync
+
+getTypeSynonym :: forall m. (Applicative m) => Qualified (ProperName 'TypeName) -> EnvironmentWithAsync m -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
+getTypeSynonym = fromEnv typeSynonyms typeSynonymsAsync
+
+getTypeClassDictionary :: forall m. (Applicative m) => QualifiedBy -> Qualified (ProperName 'ClassName) -> EnvironmentWithAsync m -> m (Maybe (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
+getTypeClassDictionary qb name env = case M.lookup qb (typeClassDictionaries $ envSync env) >>= M.lookup name of
+  Nothing -> typeClassDictionariesAsync (envAsync env) qb name
+  Just x -> pure $ Just x
+
+getTypeClass :: forall m. (Applicative m) => Qualified (ProperName 'ClassName) -> EnvironmentWithAsync m -> m (Maybe TypeClassData)
+getTypeClass = fromEnv typeClasses typeClassesAsync
+
+withNullAsyncEnv :: Applicative m => Environment -> EnvironmentWithAsync m
+withNullAsyncEnv env =
+  EnvironmentWithAsync
+    { envSync = env,
+      envAsync = nullAsyncEnv
+    }
+
 -- | Information about a type class
 data TypeClassData = TypeClassData
   { typeClassArguments :: [(Text, Maybe SourceType)]
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 85bdfee4aa..1f59a96acf 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -113,7 +113,7 @@ combineContexts = M.unionWith (M.unionWith (M.unionWith (<>)))
 -- | Replace type class dictionary placeholders with inferred type class dictionaries
 replaceTypeClassDictionaries
   :: forall m
-   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+   . (MonadState (CheckState m) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
   => Bool
   -> Expr
   -> m (Expr, [(Ident, InstanceContext, SourceConstraint)])
@@ -181,7 +181,7 @@ instance Monoid t => Monoid (Matched t) where
 -- return a type class dictionary reference.
 entails
   :: forall m
-   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+   . (MonadState (CheckState m) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
   => SolverOptions
   -- ^ Solver options
   -> SourceConstraint
@@ -866,7 +866,7 @@ matches deps TypeClassDictionaryInScope{..} tys =
 -- | Add a dictionary for the constraint to the scope, and dictionaries
 -- for all implied superclass instances.
 newDictionaries
-  :: MonadState CheckState m
+  :: MonadState (CheckState m) m
   => [(Qualified (ProperName 'ClassName), Integer)]
   -> Qualified Ident
   -> SourceConstraint
diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
index 8abaac31ca..2e084f4587 100644
--- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
@@ -2,60 +2,56 @@
 
 -- |
 -- Interaction solver for Coercible constraints
---
 module Language.PureScript.TypeChecker.Entailment.Coercible
-  ( GivenSolverState(..)
-  , initialGivenSolverState
-  , solveGivens
-  , WantedSolverState(..)
-  , initialWantedSolverState
-  , solveWanteds
-  , insoluble
-  ) where
-
-import Prelude hiding (interact)
-
-import Control.Applicative ((<|>), empty)
+  ( GivenSolverState (..),
+    initialGivenSolverState,
+    solveGivens,
+    WantedSolverState (..),
+    initialWantedSolverState,
+    solveWanteds,
+    insoluble,
+  )
+where
+
+import Control.Applicative (empty, (<|>))
 import Control.Arrow ((&&&))
-import Control.Monad ((<=<), guard, unless, when)
+import Control.Monad (guard, unless, when, (<=<))
 import Control.Monad.Error.Class (MonadError, catchError, throwError)
 import Control.Monad.State (MonadState, StateT, get, gets, modify, put)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 import Control.Monad.Writer.Strict (MonadWriter, Writer, execWriter, runWriter, runWriterT, tell)
 import Data.Either (partitionEithers)
 import Data.Foldable (fold, foldl', for_, toList)
 import Data.Functor (($>))
 import Data.List (find)
-import Data.Maybe (fromMaybe, isJust)
-import Data.Monoid (Any(..))
-import Data.Text (Text)
-
 import Data.Map qualified as M
+import Data.Maybe (fromMaybe, isJust)
+import Data.Monoid (Any (..))
 import Data.Set qualified as S
-
+import Data.Text (Text)
+import Language.PureScript.Constants.Prim qualified as Prim
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds)
-import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..))
-import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName)
+import Language.PureScript.Environment (DataDeclType (..), Environment (..), TypeKind (..), unapplyKinds)
+import Language.PureScript.Errors (DeclarationRef (..), ErrorMessageHint (..), ExportSource, ImportDeclarationType (..), MultipleErrors, SimpleErrorMessage (..), SourceAnn, UnknownsHint (..), errorMessage, SourceSpan (SourceSpan))
+import Language.PureScript.Names (ModuleName, ProperName, ProperNameType (..), Qualified (..), byMaybeModuleName, toMaybeModuleName)
+import Language.PureScript.Roles (Role (..))
 import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds')
-import Language.PureScript.TypeChecker.Monad (CheckState(..))
+import Language.PureScript.TypeChecker.Monad (CheckState (..))
 import Language.PureScript.TypeChecker.Roles (lookupRoles)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, substituteType)
-import Language.PureScript.Roles (Role(..))
-import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes)
-import Language.PureScript.Constants.Prim qualified as Prim
+import Language.PureScript.Types (Constraint (..), SourceType, Type (..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes)
+import Prelude hiding (interact)
 
 -- | State of the given constraints solver.
-data GivenSolverState =
-  GivenSolverState
-    { inertGivens :: [(SourceType, SourceType, SourceType)]
-  -- ^ A set of irreducible given constraints which do not interact together.
-    , unsolvedGivens :: [(SourceType, SourceType)]
-  -- ^ Given constraints yet to be solved.
-    }
+data GivenSolverState = GivenSolverState
+  { -- | A set of irreducible given constraints which do not interact together.
+    inertGivens :: [(SourceType, SourceType, SourceType)],
+    -- | Given constraints yet to be solved.
+    unsolvedGivens :: [(SourceType, SourceType)]
+  }
 
 -- | Initialize the given constraints solver state with the givens to solve.
 initialGivenSolverState :: [(SourceType, SourceType)] -> GivenSolverState
@@ -117,56 +113,57 @@ initialGivenSolverState =
 --
 -- 3c. Otherwise canonicalization can succeed with derived constraints which we
 -- add to the unsolved queue and then go back to 1.
-solveGivens
-  :: MonadError MultipleErrors m
-  => MonadState CheckState m
-  => Environment
-  -> StateT GivenSolverState m ()
-solveGivens env = go (0 :: Int) where
-  go n = do
-    when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
-    gets unsolvedGivens >>= \case
-      [] -> pure ()
-      given : unsolved -> do
-        (k, a, b) <- lift $ unify given
-        GivenSolverState{..} <- get
-        lift (fst <$> runWriterT (canon env Nothing k a b `catchError` recover)) >>= \case
-          Irreducible -> case interact env (a, b) inertGivens of
-            Just (Simplified (a', b')) ->
-              put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. }
-            Just Discharged ->
-              put $ GivenSolverState { unsolvedGivens = unsolved, .. }
-            Nothing -> do
-              let (kickedOut, kept) = partitionEithers $ kicksOut env (a, b) <$> inertGivens
-              put $ GivenSolverState
-                { inertGivens = (k, a, b) : kept
-                , unsolvedGivens = kickedOut <> unsolved
-                }
-          Canonicalized deriveds ->
-            put $ GivenSolverState { unsolvedGivens = toList deriveds <> unsolved, .. }
-        go (n + 1)
-  recover _ = pure Irreducible
+solveGivens ::
+  (MonadError MultipleErrors m) =>
+  (MonadState (CheckState m) m) =>
+  Environment ->
+  StateT GivenSolverState m ()
+solveGivens env = go (0 :: Int)
+  where
+    go n = do
+      when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
+      gets unsolvedGivens >>= \case
+        [] -> pure ()
+        given : unsolved -> do
+          (k, a, b) <- lift $ unify given
+          GivenSolverState {..} <- get
+          lift (fst <$> runWriterT (canon env Nothing k a b `catchError` recover)) >>= \case
+            Irreducible -> case interact env (a, b) inertGivens of
+              Just (Simplified (a', b')) ->
+                put $ GivenSolverState {unsolvedGivens = (a', b') : unsolved, ..}
+              Just Discharged ->
+                put $ GivenSolverState {unsolvedGivens = unsolved, ..}
+              Nothing -> do
+                let (kickedOut, kept) = partitionEithers $ kicksOut env (a, b) <$> inertGivens
+                put $
+                  GivenSolverState
+                    { inertGivens = (k, a, b) : kept,
+                      unsolvedGivens = kickedOut <> unsolved
+                    }
+            Canonicalized deriveds ->
+              put $ GivenSolverState {unsolvedGivens = toList deriveds <> unsolved, ..}
+          go (n + 1)
+    recover _ = pure Irreducible
 
 -- | State of the wanted constraints solver.
-data WantedSolverState =
-  WantedSolverState
-    { inertGivens :: [(SourceType, SourceType, SourceType)]
-  -- ^ A set of irreducible given constraints which do not interact together,
-  -- but which could interact with the wanteds.
-    , inertWanteds :: [(SourceType, SourceType, SourceType)]
-  -- ^ A set of irreducible wanted constraints which do not interact together,
-  -- nor with any given.
-    , unsolvedWanteds :: [(SourceType, SourceType)]
-  -- ^ Wanted constraints yet to be solved.
-    }
+data WantedSolverState = WantedSolverState
+  { -- | A set of irreducible given constraints which do not interact together,
+    -- but which could interact with the wanteds.
+    inertGivens :: [(SourceType, SourceType, SourceType)],
+    -- | A set of irreducible wanted constraints which do not interact together,
+    -- nor with any given.
+    inertWanteds :: [(SourceType, SourceType, SourceType)],
+    -- | Wanted constraints yet to be solved.
+    unsolvedWanteds :: [(SourceType, SourceType)]
+  }
 
 -- | Initialize the wanted constraints solver state with an inert set of givens
 -- and the two parameters of the wanted to solve.
-initialWantedSolverState
-  :: [(SourceType, SourceType, SourceType)]
-  -> SourceType
-  -> SourceType
-  -> WantedSolverState
+initialWantedSolverState ::
+  [(SourceType, SourceType, SourceType)] ->
+  SourceType ->
+  SourceType ->
+  WantedSolverState
 initialWantedSolverState givens a b =
   WantedSolverState givens [] [(a, b)]
 
@@ -205,40 +202,42 @@ initialWantedSolverState givens a b =
 -- the irreducibles @Coercible a Boolean@ and @Coercible a Char@. Would we
 -- interact the latter with the former, we would report an insoluble
 -- @Coercible Boolean Char@.
-solveWanteds
-  :: MonadError MultipleErrors m
-  => MonadWriter [ErrorMessageHint] m
-  => MonadState CheckState m
-  => Environment
-  -> StateT WantedSolverState m ()
-solveWanteds env = go (0 :: Int) where
-  go n = do
-    when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
-    gets unsolvedWanteds >>= \case
-      [] -> pure ()
-      wanted : unsolved -> do
-        (k, a, b) <- lift $ unify wanted
-        WantedSolverState{..} <- get
-        lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case
-          Irreducible -> case interact env (a, b) inertGivens of
-            Just (Simplified (a', b')) ->
-              put $ WantedSolverState { unsolvedWanteds = (a', b') : unsolved, .. }
-            Just Discharged ->
-              put $ WantedSolverState { unsolvedWanteds = unsolved, .. }
-            Nothing ->
-              put $ WantedSolverState
-                { inertWanteds = (k, a, b) : inertWanteds
-                , unsolvedWanteds = unsolved
-                , ..
-                }
-          Canonicalized deriveds ->
-            put $ WantedSolverState { unsolvedWanteds = toList deriveds <> unsolved, .. }
-        go (n + 1)
-  recover wanted givens errors =
-    case interact env wanted givens of
-      Nothing -> throwError errors
-      Just (Simplified wanted') -> pure . Canonicalized $ S.singleton wanted'
-      Just Discharged -> pure $ Canonicalized mempty
+solveWanteds ::
+  (MonadError MultipleErrors m) =>
+  (MonadWriter [ErrorMessageHint] m) =>
+  (MonadState (CheckState m) m) =>
+  Environment ->
+  StateT WantedSolverState m ()
+solveWanteds env = go (0 :: Int)
+  where
+    go n = do
+      when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
+      gets unsolvedWanteds >>= \case
+        [] -> pure ()
+        wanted : unsolved -> do
+          (k, a, b) <- lift $ unify wanted
+          WantedSolverState {..} <- get
+          lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case
+            Irreducible -> case interact env (a, b) inertGivens of
+              Just (Simplified (a', b')) ->
+                put $ WantedSolverState {unsolvedWanteds = (a', b') : unsolved, ..}
+              Just Discharged ->
+                put $ WantedSolverState {unsolvedWanteds = unsolved, ..}
+              Nothing ->
+                put $
+                  WantedSolverState
+                    { inertWanteds = (k, a, b) : inertWanteds,
+                      unsolvedWanteds = unsolved,
+                      ..
+                    }
+            Canonicalized deriveds ->
+              put $ WantedSolverState {unsolvedWanteds = toList deriveds <> unsolved, ..}
+          go (n + 1)
+    recover wanted givens errors =
+      case interact env wanted givens of
+        Nothing -> throwError errors
+        Just (Simplified wanted') -> pure . Canonicalized $ S.singleton wanted'
+        Just Discharged -> pure $ Canonicalized mempty
 
 -- | Unifying constraints arguments kinds isn't strictly necessary but yields
 -- better error messages. For instance we cannot solve the constraint
@@ -270,50 +269,52 @@ solveWanteds env = go (0 :: Int) where
 -- so applying the substitution to @D \@k1@ and @D \@k2@ yields a
 -- @Coercible (D \@k) (D \@k)@ constraint which could be trivially solved by
 -- reflexivity instead of having to saturate the type constructors.
-unify
-  :: MonadError MultipleErrors m
-  => MonadState CheckState m
-  => (SourceType, SourceType)
-  -> m (SourceType, SourceType, SourceType)
+unify ::
+  (MonadError MultipleErrors m) =>
+  (MonadState (CheckState m) m) =>
+  (SourceType, SourceType) ->
+  m (SourceType, SourceType, SourceType)
 unify (a, b) = do
   let kindOf = sequence . (id &&& elaborateKind) <=< replaceAllTypeSynonyms
   (a', kind) <- kindOf a
   (b', kind') <- kindOf b
   unifyKinds' kind kind'
   subst <- gets checkSubstitution
-  pure ( substituteType subst kind
-       , substituteType subst a'
-       , substituteType subst b'
-       )
+  pure
+    ( substituteType subst kind,
+      substituteType subst a',
+      substituteType subst b'
+    )
 
 -- | A successful interaction between an irreducible constraint and an inert
 --  given constraint has two possible outcomes:
 data Interaction
-  = Simplified (SourceType, SourceType)
-  -- ^ The interaction can yield a derived constraint,
-  | Discharged
-  -- ^ or we can learn the irreducible constraint is redundant and discharge it.
+  = -- | The interaction can yield a derived constraint,
+    Simplified (SourceType, SourceType)
+  | -- | or we can learn the irreducible constraint is redundant and discharge it.
+    Discharged
 
 -- | Interact an irreducible constraint with an inert set of givens.
-interact
-  :: Environment
-  -> (SourceType, SourceType)
-  -> [(SourceType, SourceType, SourceType)]
-  -> Maybe Interaction
-interact env irred = go where
-  go [] = Nothing
-  go (inert : _)
-    | canDischarge inert irred = Just Discharged
-    | Just derived <- interactSameTyVar inert irred = Just $ Simplified derived
-    | Just derived <- interactDiffTyVar env inert irred = Just $ Simplified derived
-  go (_ : inerts) = go inerts
+interact ::
+  Environment ->
+  (SourceType, SourceType) ->
+  [(SourceType, SourceType, SourceType)] ->
+  Maybe Interaction
+interact env irred = go
+  where
+    go [] = Nothing
+    go (inert : _)
+      | canDischarge inert irred = Just Discharged
+      | Just derived <- interactSameTyVar inert irred = Just $ Simplified derived
+      | Just derived <- interactDiffTyVar env inert irred = Just $ Simplified derived
+    go (_ : inerts) = go inerts
 
 -- | A given constraint of the form @Coercible a b@ can discharge constraints
 -- of the form @Coercible a b@ and @Coercible b a@.
-canDischarge
-  :: (SourceType, SourceType, SourceType)
-  -> (SourceType, SourceType)
-  -> Bool
+canDischarge ::
+  (SourceType, SourceType, SourceType) ->
+  (SourceType, SourceType) ->
+  Bool
 canDischarge (_, a, b) constraint =
   (a, b) == constraint || (b, a) == constraint
 
@@ -335,13 +336,13 @@ canDischarge (_, a, b) constraint =
 -- right to yield @Coercible a (D (N a))@. Would it interact with the non
 -- canonical given @Coercible a (D a)@ it would give @Coercible (D a) (D (N a))@,
 -- then decompose back to @Coercible a (N a)@.
-interactSameTyVar
-  :: (SourceType, SourceType, SourceType)
-  -> (SourceType, SourceType)
-  -> Maybe (SourceType, SourceType)
+interactSameTyVar ::
+  (SourceType, SourceType, SourceType) ->
+  (SourceType, SourceType) ->
+  Maybe (SourceType, SourceType)
 interactSameTyVar (_, tv1, ty1) (tv2, ty2)
-  | tv1 == tv2 && isCanonicalTyVarEq (tv1, ty1) && isCanonicalTyVarEq (tv2, ty2)
-  = Just (ty1, ty2)
+  | tv1 == tv2 && isCanonicalTyVarEq (tv1, ty1) && isCanonicalTyVarEq (tv2, ty2) =
+      Just (ty1, ty2)
   | otherwise = Nothing
 
 -- | Two canonical constraints of the form @Coercible tv1 ty1@ and
@@ -360,15 +361,15 @@ interactSameTyVar (_, tv1, ty1) (tv2, ty2)
 -- yield an irreducible canonical wanted @Coercible a b@. Would it interact with
 -- the non canonical given @Coercible b (D b)@ it would give @Coercible a (D b)@,
 -- which would keep interacting indefinitely with the given.
-interactDiffTyVar
-  :: Environment
-  -> (SourceType, SourceType, SourceType)
-  -> (SourceType, SourceType)
-  -> Maybe (SourceType, SourceType)
+interactDiffTyVar ::
+  Environment ->
+  (SourceType, SourceType, SourceType) ->
+  (SourceType, SourceType) ->
+  Maybe (SourceType, SourceType)
 interactDiffTyVar env (_, tv1, ty1) (tv2, ty2)
-  | tv1 /= tv2 && isCanonicalTyVarEq (tv2, ty2)
-  , (ty2', Any True) <- runWriter $ rewrite env (tv1, ty1) ty2
-  = Just (tv2, ty2')
+  | tv1 /= tv2 && isCanonicalTyVarEq (tv2, ty2),
+    (ty2', Any True) <- runWriter $ rewrite env (tv1, ty1) ty2 =
+      Just (tv2, ty2')
   | otherwise = Nothing
 
 -- | A canonical constraint of the form @Coercible tv1 ty1@ can rewrite the
@@ -376,50 +377,56 @@ interactDiffTyVar env (_, tv1, ty1) (tv2, ty2)
 -- by substituting @ty1@ for every occurrence of @tv1@ at representational and
 -- phantom role in @ty2@. Nominal occurrences are left untouched.
 rewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Writer Any SourceType
-rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where
-  go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1
-  go ty2 | (Skolem{}, _, xs) <- unapplyTypes ty2, not $ null xs =
-    rewriteTyVarApp go ty2
-         | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do
-    rewriteTyConApp go (lookupRoles env tyName) ty2
-  go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k
-  go (ForAll sa vis tv k ty scope) = ForAll sa vis tv k <$> go ty <*> pure scope
-  go (ConstrainedType sa Constraint{..} ty) | s1 `S.notMember` foldMap skolems constraintArgs =
-    ConstrainedType sa Constraint{..} <$> go ty
-  go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest
-  go (KindedType sa ty k) = KindedType sa <$> go ty <*> pure k
-  go ty2 = pure ty2
+rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go
+  where
+    go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1
+    go ty2
+      | (Skolem {}, _, xs) <- unapplyTypes ty2,
+        not $ null xs =
+          rewriteTyVarApp go ty2
+      | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do
+          rewriteTyConApp go (lookupRoles env tyName) ty2
+    go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k
+    go (ForAll sa vis tv k ty scope) = ForAll sa vis tv k <$> go ty <*> pure scope
+    go (ConstrainedType sa Constraint {..} ty)
+      | s1 `S.notMember` foldMap skolems constraintArgs =
+          ConstrainedType sa Constraint {..} <$> go ty
+    go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest
+    go (KindedType sa ty k) = KindedType sa <$> go ty <*> pure k
+    go ty2 = pure ty2
 rewrite _ _ = pure
 
 -- | Rewrite the head of a type application of the form @tv a_0 .. a_n@.
-rewriteTyVarApp
-  :: Applicative m
-  => (SourceType -> m SourceType)
-  -> SourceType
-  -> m SourceType
-rewriteTyVarApp f = go where
-  go (TypeApp sa lhs rhs) =
-    TypeApp sa <$> go lhs <*> pure rhs
-  go (KindApp sa ty k) =
-    KindApp sa <$> go ty <*> pure k
-  go ty = f ty
+rewriteTyVarApp ::
+  (Applicative m) =>
+  (SourceType -> m SourceType) ->
+  SourceType ->
+  m SourceType
+rewriteTyVarApp f = go
+  where
+    go (TypeApp sa lhs rhs) =
+      TypeApp sa <$> go lhs <*> pure rhs
+    go (KindApp sa ty k) =
+      KindApp sa <$> go ty <*> pure k
+    go ty = f ty
 
 -- | Rewrite the representational and phantom arguments of a type application
 -- of the form @D a_0 .. a_n@.
-rewriteTyConApp
-  :: Applicative m
-  => (SourceType -> m SourceType)
-  -> [Role]
-  -> SourceType
-  -> m SourceType
-rewriteTyConApp f = go where
-  go (role : roles) (TypeApp sa lhs rhs) =
-    TypeApp sa <$> go roles lhs <*> case role of
-      Nominal -> pure rhs
-      _ -> f rhs
-  go roles (KindApp sa ty k) =
-    KindApp sa <$> go roles ty <*> pure k
-  go _ ty = pure ty
+rewriteTyConApp ::
+  (Applicative m) =>
+  (SourceType -> m SourceType) ->
+  [Role] ->
+  SourceType ->
+  m SourceType
+rewriteTyConApp f = go
+  where
+    go (role : roles) (TypeApp sa lhs rhs) =
+      TypeApp sa <$> go roles lhs <*> case role of
+        Nominal -> pure rhs
+        _ -> f rhs
+    go roles (KindApp sa ty k) =
+      KindApp sa <$> go roles ty <*> pure k
+    go _ ty = pure ty
 
 canRewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Bool
 canRewrite env irred = getAny . execWriter . rewrite env irred
@@ -440,14 +447,14 @@ canRewrite env irred = getAny . execWriter . rewrite env irred
 -- we not kick out the former when adding the latter to the inert set we would
 -- not be able to rewrite it to @Coercible a (g b)@ and discharge the wanted,
 -- but inverting the givens would work.
-kicksOut
-  :: Environment
-  -> (SourceType, SourceType)
-  -> (SourceType, SourceType, SourceType)
-  -> Either (SourceType, SourceType) (SourceType, SourceType, SourceType)
+kicksOut ::
+  Environment ->
+  (SourceType, SourceType) ->
+  (SourceType, SourceType, SourceType) ->
+  Either (SourceType, SourceType) (SourceType, SourceType, SourceType)
 kicksOut env irred (_, tv2, ty2)
-  | isCanonicalTyVarEq (tv2, ty2) && canRewrite env irred ty2
-  = Left (tv2, ty2)
+  | isCanonicalTyVarEq (tv2, ty2) && canRewrite env irred ty2 =
+      Left (tv2, ty2)
 kicksOut _ _ inert = Right inert
 
 -- | A constraint of the form @Coercible tv ty@ is canonical when @tv@ does not
@@ -457,91 +464,94 @@ isCanonicalTyVarEq (Skolem _ _ _ s _, ty) = not $ occurs s ty
 isCanonicalTyVarEq _ = False
 
 occurs :: Int -> SourceType -> Bool
-occurs s1 = everythingOnTypes (||) go where
-  go (Skolem _ _ _ s2 _) | s1 == s2 = True
-  go _ = False
+occurs s1 = everythingOnTypes (||) go
+  where
+    go (Skolem _ _ _ s2 _) | s1 == s2 = True
+    go _ = False
 
 skolems :: SourceType -> S.Set Int
-skolems = everythingOnTypes (<>) go where
-  go (Skolem _ _ _ s _) = S.singleton s
-  go _ = mempty
+skolems = everythingOnTypes (<>) go
+  where
+    go (Skolem _ _ _ s _) = S.singleton s
+    go _ = mempty
 
 -- | A successful canonicalization result has two possible outcomes:
 data Canonicalized
-  = Canonicalized (S.Set (SourceType, SourceType))
-  -- ^ Canonicalization can yield a set of derived constraints,
-  | Irreducible
-  -- ^ or we can learn the constraint is irreducible. Irreducibility is not
-  -- necessarily an error, we may make further progress by interacting with
-  -- inerts.
+  = -- | Canonicalization can yield a set of derived constraints,
+    Canonicalized (S.Set (SourceType, SourceType))
+  | -- | or we can learn the constraint is irreducible. Irreducibility is not
+    -- necessarily an error, we may make further progress by interacting with
+    -- inerts.
+    Irreducible
 
 -- | Canonicalization takes a wanted constraint and try to reduce it to a set of
 -- simpler constraints whose satisfaction will imply the goal.
-canon
-  :: MonadError MultipleErrors m
-  => MonadWriter [ErrorMessageHint] m
-  => MonadState CheckState m
-  => Environment
-  -> Maybe [(SourceType, SourceType, SourceType)]
-  -> SourceType
-  -> SourceType
-  -> SourceType
-  -> m Canonicalized
+canon ::
+  (MonadError MultipleErrors m) =>
+  (MonadWriter [ErrorMessageHint] m) =>
+  (MonadState (CheckState m) m) =>
+  Environment ->
+  Maybe [(SourceType, SourceType, SourceType)] ->
+  SourceType ->
+  SourceType ->
+  SourceType ->
+  m Canonicalized
 canon env givens k a b =
   maybe (throwError $ insoluble k a b) pure <=< runMaybeT $
-        canonRefl a b
-    <|> canonUnsaturatedHigherKindedType env a b
-    <|> canonRow a b
-    -- We unwrap newtypes before trying the decomposition rules because it let
-    -- us solve more constraints.
-    --
-    -- For instance the declarations:
-    --
-    -- @
-    -- newtype N f a = N (f a)
-    --
-    -- example :: forall a b. Coercible a b => N Maybe a -> N Maybe b
-    -- example = coerce
-    -- @
-    --
-    -- yield the wanted @Coercible (N Maybe a) (N Maybe b)@ which we cannot
-    -- decompose because the second parameter of @N@ is nominal. On the other
-    -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@
-    -- which we can then decompose to @Coercible a b@ and discharge with the
-    -- given.
-    <|> canonNewtypeLeft env a b
-    <|> canonNewtypeRight env a b
-    <|> canonDecomposition env a b
-    <|> canonDecompositionFailure env k a b
-    <|> canonNewtypeDecomposition env givens a b
-    <|> canonNewtypeDecompositionFailure a b
-    <|> canonTypeVars a b
-    <|> canonTypeVarLeft a b
-    <|> canonTypeVarRight a b
-    <|> canonApplicationLeft a b
-    <|> canonApplicationRight a b
-
-insoluble
-  :: SourceType
-  -> SourceType
-  -> SourceType
-  -> MultipleErrors
+    canonRefl a b
+      <|> canonUnsaturatedHigherKindedType env a b
+      <|> canonRow a b
+      -- We unwrap newtypes before trying the decomposition rules because it let
+      -- us solve more constraints.
+      --
+      -- For instance the declarations:
+      --
+      -- @
+      -- newtype N f a = N (f a)
+      --
+      -- example :: forall a b. Coercible a b => N Maybe a -> N Maybe b
+      -- example = coerce
+      -- @
+      --
+      -- yield the wanted @Coercible (N Maybe a) (N Maybe b)@ which we cannot
+      -- decompose because the second parameter of @N@ is nominal. On the other
+      -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@
+      -- which we can then decompose to @Coercible a b@ and discharge with the
+      -- given.
+      <|> canonNewtypeLeft env a b
+      <|> canonNewtypeRight env a b
+      <|> canonDecomposition env a b
+      <|> canonDecompositionFailure env k a b
+      <|> canonNewtypeDecomposition env givens a b
+      <|> canonNewtypeDecompositionFailure a b
+      <|> canonTypeVars a b
+      <|> canonTypeVarLeft a b
+      <|> canonTypeVarRight a b
+      <|> canonApplicationLeft a b
+      <|> canonApplicationRight a b
+
+insoluble ::
+  SourceType ->
+  SourceType ->
+  SourceType ->
+  MultipleErrors
 insoluble k a b =
   -- We can erase kind applications when determining whether to show the
   -- "Consider adding a type annotation" hint, because annotating kinds to
   -- instantiate unknowns in Coercible constraints should never resolve
   -- NoInstanceFound errors.
-  errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] 
-    $ if any containsUnknowns [a, b] then Unknowns else NoUnknowns
+  errorMessage $
+    NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] $
+      if any containsUnknowns [a, b] then Unknowns else NoUnknowns
 
 -- | Constraints of the form @Coercible a b@ can be solved if the two arguments
 -- are the same. Since we currently don't support higher-rank arguments in
 -- instance heads, term equality is a sufficient notion of "the same".
-canonRefl
-  :: Monad m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonRefl ::
+  (Monad m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonRefl a b =
   guard (a == b) $> Canonicalized mempty
 
@@ -549,25 +559,27 @@ canonRefl a b =
 -- both arguments have kind @k1 -> k2@, yield a constraint
 -- @Coercible (T1 a_0 .. a_n c_0 .. c_m) (T2 b_0 .. b_n c_0 .. c_m)@, where both
 -- arguments are fully saturated with the same unknowns and have kind @Type@.
-canonUnsaturatedHigherKindedType
-  :: MonadError MultipleErrors m
-  => MonadState CheckState m
-  => Environment
-  -> SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonUnsaturatedHigherKindedType ::
+  forall m.
+  (MonadError MultipleErrors m) =>
+  -- (MonadState (CheckState (MaybeT m)) m) =>
+  (MonadState (CheckState m) m) =>
+  Environment ->
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonUnsaturatedHigherKindedType env a b
-  | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a
-  , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env)
-  , (aks, _) <- unapplyKinds ak
-  , length axs < length aks = do
+  | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a,
+    (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env),
+    (aks, _) <- unapplyKinds ak,
+    length axs < length aks = do
       ak' <- lift $ do
         let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak
             instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps
-        unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs
+        unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> (freshKindWithKind :: SourceSpan -> SourceType -> m SourceType) ss k) $ drop (length akapps) kvs
         pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak'
       let (aks', _) = unapplyKinds ak'
-      tys <- traverse freshTypeWithKind $ drop (length axs) aks'
+      tys <- traverse (freshTypeWithKind ) $ drop (length axs) aks'
       let a' = foldl' srcTypeApp a tys
           b' = foldl' srcTypeApp b tys
       pure . Canonicalized $ S.singleton (a', b')
@@ -577,23 +589,23 @@ canonUnsaturatedHigherKindedType env a b
 -- @Coercible ( label_0 :: a_0, .. label_n :: a_n | r ) ( label_0 :: b_0, .. label_n :: b_n | s )@
 -- yield a constraint @Coercible r s@ and constraints on the types for each
 -- label in both rows. Labels exclusive to one row yield a failure.
-canonRow
-  :: MonadError MultipleErrors m
-  => MonadState CheckState m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonRow ::
+  (MonadError MultipleErrors m) =>
+  (MonadState (CheckState (MaybeT m)) m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonRow a b
-  | RCons{} <- a =
+  | RCons {} <- a =
       case alignRowsWith (const (,)) a b of
         -- We throw early when a bare unknown remains on either side after
         -- aligning the rows because we don't know how to canonicalize them yet
         -- and the unification error thrown when the rows are misaligned should
         -- not mention unknowns.
-        (_, (([], u@TUnknown{}), rl2)) -> do
+        (_, (([], u@TUnknown {}), rl2)) -> do
           k <- elaborateKind u
           throwError $ insoluble k u (rowFromList rl2)
-        (_, (rl1, ([], u@TUnknown{}))) -> do
+        (_, (rl1, ([], u@TUnknown {}))) -> do
           k <- elaborateKind u
           throwError $ insoluble k (rowFromList rl1) u
         (deriveds, (([], tail1), ([], tail2))) -> do
@@ -604,67 +616,68 @@ canonRow a b
 
 -- | Unwrapping a newtype can fails in two ways:
 data UnwrapNewtypeError
-  = CannotUnwrapInfiniteNewtypeChain
-  -- ^ The newtype might wrap an infinite newtype chain. We may think that this
-  -- is already handled by the solver depth check, but failing to unwrap
-  -- infinite chains of newtypes let us try other rules.
-  --
-  -- For instance the declarations:
-  --
-  -- @
-  -- newtype N a = N (N a)
-  -- type role N representational
-  --
-  -- example :: forall a b. Coercible a b => N a -> N b
-  -- example = coerce
-  -- @
-  --
-  -- yield a wanted @Coercible (N a) (N b)@ that we can decompose to
-  -- @Coercible a b@ then discharge with the given if the newtype
-  -- unwrapping rules do not apply.
-  | CannotUnwrapConstructor
-  -- ^ The constructor may not be in scope or may not belong to a newtype.
+  = -- | The newtype might wrap an infinite newtype chain. We may think that this
+    -- is already handled by the solver depth check, but failing to unwrap
+    -- infinite chains of newtypes let us try other rules.
+    --
+    -- For instance the declarations:
+    --
+    -- @
+    -- newtype N a = N (N a)
+    -- type role N representational
+    --
+    -- example :: forall a b. Coercible a b => N a -> N b
+    -- example = coerce
+    -- @
+    --
+    -- yield a wanted @Coercible (N a) (N b)@ that we can decompose to
+    -- @Coercible a b@ then discharge with the given if the newtype
+    -- unwrapping rules do not apply.
+    CannotUnwrapInfiniteNewtypeChain
+  | -- | The constructor may not be in scope or may not belong to a newtype.
+    CannotUnwrapConstructor
 
 -- | Unwraps a newtype and yields its underlying type with the newtype arguments
 -- substituted in (e.g. @N[D/a] = D@ given @newtype N a = N a@ and @data D = D@).
-unwrapNewtype
-  :: MonadState CheckState m
-  => MonadWriter [ErrorMessageHint] m
-  => Environment
-  -> SourceType
-  -> m (Either UnwrapNewtypeError SourceType)
-unwrapNewtype env = go (0 :: Int) where
-  go n ty = runExceptT $ do
-    when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain
-    (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports
-    case unapplyTypes ty of
-      (TypeConstructor _ newtypeName, ks, xs)
-        | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <-
-            lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName ks
-        -- We refuse to unwrap newtypes over polytypes because we don't know how
-        -- to canonicalize them yet and we'd rather try to make progress with
-        -- another rule.
-        , isMonoType wrappedTy -> do
-            unless inScope $ do
-              tell [MissingConstructorImportForCoercible newtypeCtorName]
-              throwError CannotUnwrapConstructor
-            for_ fromModuleName $ flip addConstructorImportForCoercible newtypeCtorName
-            let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy
-            ExceptT (go (n + 1) wrappedTySub) `catchError` \case
-              CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain
-              CannotUnwrapConstructor -> pure wrappedTySub
-      _ -> throwError CannotUnwrapConstructor
-  addConstructorImportForCoercible fromModuleName newtypeCtorName = modify $ \st ->
-    st { checkConstructorImportsForCoercible = S.insert (fromModuleName, newtypeCtorName) $ checkConstructorImportsForCoercible st }
+unwrapNewtype ::
+  (MonadState (CheckState m) m) =>
+  (MonadWriter [ErrorMessageHint] m) =>
+  Environment ->
+  SourceType ->
+  m (Either UnwrapNewtypeError SourceType)
+unwrapNewtype env = go (0 :: Int)
+  where
+    go n ty = runExceptT $ do
+      when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain
+      (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports
+      case unapplyTypes ty of
+        (TypeConstructor _ newtypeName, ks, xs)
+          | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <-
+              lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName ks,
+            -- We refuse to unwrap newtypes over polytypes because we don't know how
+            -- to canonicalize them yet and we'd rather try to make progress with
+            -- another rule.
+            isMonoType wrappedTy -> do
+              unless inScope $ do
+                tell [MissingConstructorImportForCoercible newtypeCtorName]
+                throwError CannotUnwrapConstructor
+              for_ fromModuleName $ flip addConstructorImportForCoercible newtypeCtorName
+              let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy
+              ExceptT (go (n + 1) wrappedTySub) `catchError` \case
+                CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain
+                CannotUnwrapConstructor -> pure wrappedTySub
+        _ -> throwError CannotUnwrapConstructor
+    addConstructorImportForCoercible fromModuleName newtypeCtorName = modify $ \st ->
+      st {checkConstructorImportsForCoercible = S.insert (fromModuleName, newtypeCtorName) $ checkConstructorImportsForCoercible st}
 
 -- | Looks up a given name and, if it names a newtype, returns the names of the
 -- type's parameters, the type the newtype wraps and the names of the type's
 -- fields.
-lookupNewtypeConstructor
-  :: Environment
-  -> Qualified (ProperName 'TypeName)
-  -> [SourceType]
-  -> Maybe ([Text], ProperName 'ConstructorName, SourceType)
+lookupNewtypeConstructor ::
+  Environment ->
+  Qualified (ProperName 'TypeName) ->
+  [SourceType] ->
+  Maybe ([Text], ProperName 'ConstructorName, SourceType)
 lookupNewtypeConstructor env qualifiedNewtypeName ks = do
   (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env)
   let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk
@@ -674,19 +687,19 @@ lookupNewtypeConstructor env qualifiedNewtypeName ks = do
 -- | Behaves like 'lookupNewtypeConstructor' but also returns whether the
 -- newtype constructor is in scope and the module from which it is imported, or
 -- 'Nothing' if it is defined in the current module.
-lookupNewtypeConstructorInScope
-  :: Environment
-  -> Maybe ModuleName
-  -> [ ( SourceAnn
-       , ModuleName
-       , ImportDeclarationType
-       , Maybe ModuleName
-       , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
-       )
-     ]
-  -> Qualified (ProperName 'TypeName)
-  -> [SourceType]
-  -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType)
+lookupNewtypeConstructorInScope ::
+  Environment ->
+  Maybe ModuleName ->
+  [ ( SourceAnn,
+      ModuleName,
+      ImportDeclarationType,
+      Maybe ModuleName,
+      M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
+    )
+  ] ->
+  Qualified (ProperName 'TypeName) ->
+  [SourceType] ->
+  Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType)
 lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do
   let fromModule = find isNewtypeCtorImported currentModuleImports
       fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule
@@ -697,27 +710,27 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali
   (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks
   pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy)
   where
-  isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) =
-    case M.lookup newtypeName exportedTypes of
-      Just ([_], _) -> case importDeclType of
-        Implicit -> True
-        Explicit refs -> any isNewtypeCtorRef refs
-        Hiding refs -> not $ any isNewtypeCtorRef refs
+    isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) =
+      case M.lookup newtypeName exportedTypes of
+        Just ([_], _) -> case importDeclType of
+          Implicit -> True
+          Explicit refs -> any isNewtypeCtorRef refs
+          Hiding refs -> not $ any isNewtypeCtorRef refs
+        _ -> False
+    isNewtypeCtorRef = \case
+      TypeRef _ importedTyName Nothing -> importedTyName == newtypeName
+      TypeRef _ importedTyName (Just [_]) -> importedTyName == newtypeName
       _ -> False
-  isNewtypeCtorRef = \case
-    TypeRef _ importedTyName Nothing -> importedTyName == newtypeName
-    TypeRef _ importedTyName (Just [_]) -> importedTyName == newtypeName
-    _ -> False
 
 -- | Constraints of the form @Coercible (N a_0 .. a_n) b@ yield a constraint
 -- @Coercible a b@ if unwrapping the newtype yields @a@.
-canonNewtypeLeft
-  :: MonadState CheckState m
-  => MonadWriter [ErrorMessageHint] m
-  => Environment
-  -> SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonNewtypeLeft ::
+  (MonadState (CheckState m) m) =>
+  (MonadWriter [ErrorMessageHint] m) =>
+  Environment ->
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonNewtypeLeft env a b =
   unwrapNewtype env a >>= \case
     Left CannotUnwrapInfiniteNewtypeChain -> empty
@@ -726,13 +739,13 @@ canonNewtypeLeft env a b =
 
 -- | Constraints of the form @Coercible a (N b_0 .. b_n)@ yield a constraint
 -- @Coercible a b@ if unwrapping the newtype yields @b@.
-canonNewtypeRight
-  :: MonadState CheckState m
-  => MonadWriter [ErrorMessageHint] m
-  => Environment
-  -> SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonNewtypeRight ::
+  (MonadState (CheckState m) m) =>
+  (MonadWriter [ErrorMessageHint] m) =>
+  Environment ->
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonNewtypeRight env =
   flip $ canonNewtypeLeft env
 
@@ -749,13 +762,13 @@ canonNewtypeRight env =
 --
 -- We can decompose @Coercible (D a b d) (D a c e)@ into @Coercible b c@, but
 -- decomposing @Coercible (D a c d) (D b c d)@ would fail.
-decompose
-  :: MonadError MultipleErrors m
-  => Environment
-  -> Qualified (ProperName 'TypeName)
-  -> [SourceType]
-  -> [SourceType]
-  -> m Canonicalized
+decompose ::
+  (MonadError MultipleErrors m) =>
+  Environment ->
+  Qualified (ProperName 'TypeName) ->
+  [SourceType] ->
+  [SourceType] ->
+  m Canonicalized
 decompose env tyName axs bxs = do
   let roles = lookupRoles env tyName
       f role ax bx = case role of
@@ -778,36 +791,36 @@ decompose env tyName axs bxs = do
 
 -- | Constraints of the form @Coercible (D a_0 .. a_n) (D b_0 .. b_n)@, where
 -- @D@ is not a newtype, yield constraints on their arguments.
-canonDecomposition
-  :: MonadError MultipleErrors m
-  => Environment
-  -> SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonDecomposition ::
+  (MonadError MultipleErrors m) =>
+  Environment ->
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonDecomposition env a b
-  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a
-  , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b
-  , aTyName == bTyName
-  , Nothing <- lookupNewtypeConstructor env aTyName [] =
+  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a,
+    (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b,
+    aTyName == bTyName,
+    Nothing <- lookupNewtypeConstructor env aTyName [] =
       decompose env aTyName axs bxs
   | otherwise = empty
 
 -- | Constraints of the form @Coercible (D1 a_0 .. a_n) (D2 b_0 .. b_n)@, where
 -- @D1@ and @D2@ are different type constructors and neither of them are
 -- newtypes, are insoluble.
-canonDecompositionFailure
-  :: MonadError MultipleErrors m
-  => Environment
-  -> SourceType
-  -> SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonDecompositionFailure ::
+  (MonadError MultipleErrors m) =>
+  Environment ->
+  SourceType ->
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonDecompositionFailure env k a b
-  | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a
-  , (TypeConstructor _ bTyName, _, _) <- unapplyTypes b
-  , aTyName /= bTyName
-  , Nothing <- lookupNewtypeConstructor env aTyName []
-  , Nothing <- lookupNewtypeConstructor env bTyName [] =
+  | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a,
+    (TypeConstructor _ bTyName, _, _) <- unapplyTypes b,
+    aTyName /= bTyName,
+    Nothing <- lookupNewtypeConstructor env aTyName [],
+    Nothing <- lookupNewtypeConstructor env bTyName [] =
       throwError $ insoluble k a b
   | otherwise = empty
 
@@ -844,18 +857,18 @@ canonDecompositionFailure env k a b
 -- is out of scope. Would we decompose the wanted
 -- @Coercible (Const a a) (Const a b)@ to @Coercible a b@ we would not be able
 -- to discharge it with the given.
-canonNewtypeDecomposition
-  :: MonadError MultipleErrors m
-  => Environment
-  -> Maybe [(SourceType, SourceType, SourceType)]
-  -> SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonNewtypeDecomposition ::
+  (MonadError MultipleErrors m) =>
+  Environment ->
+  Maybe [(SourceType, SourceType, SourceType)] ->
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonNewtypeDecomposition env (Just givens) a b
-  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a
-  , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b
-  , aTyName == bTyName
-  , Just _ <- lookupNewtypeConstructor env aTyName [] = do
+  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a,
+    (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b,
+    aTyName == bTyName,
+    Just _ <- lookupNewtypeConstructor env aTyName [] = do
       let givensCanDischarge = any (\given -> canDischarge given (a, b)) givens
       guard $ not givensCanDischarge
       decompose env aTyName axs bxs
@@ -864,15 +877,15 @@ canonNewtypeDecomposition _ _ _ _ = empty
 -- | Constraints of the form @Coercible (N1 a_0 .. a_n) (N2 b_0 .. b_n)@, where
 -- @N1@ and @N2@ are different type constructors and either of them is a
 -- newtype whose constructor is out of scope, are irreducible.
-canonNewtypeDecompositionFailure
-  :: Monad m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonNewtypeDecompositionFailure ::
+  (Monad m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonNewtypeDecompositionFailure a b
-  | (TypeConstructor{}, _, _) <- unapplyTypes a
-  , (TypeConstructor{}, _, _) <- unapplyTypes b
-  = pure Irreducible
+  | (TypeConstructor {}, _, _) <- unapplyTypes a,
+    (TypeConstructor {}, _, _) <- unapplyTypes b =
+      pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible tv1 tv2@ may be irreducibles, but only
@@ -889,58 +902,59 @@ canonNewtypeDecompositionFailure a b
 -- yields the irreducible givens @Coercible a b@ and @Coercible b a@ which would
 -- repeatedly kick each other out the inert set whereas reordering the latter to
 -- @Coercible a b@ makes it redundant and let us discharge it.
-canonTypeVars
-  :: Monad m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonTypeVars ::
+  (Monad m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonTypeVars a b
-  | Skolem _ tv1 _ _ _ <- a
-  , Skolem _ tv2 _ _ _ <- b
-  , tv2 < tv1
-  = pure . Canonicalized $ S.singleton (b, a)
-  | Skolem{} <- a, Skolem{} <- b
-  = pure Irreducible
+  | Skolem _ tv1 _ _ _ <- a,
+    Skolem _ tv2 _ _ _ <- b,
+    tv2 < tv1 =
+      pure . Canonicalized $ S.singleton (b, a)
+  | Skolem {} <- a,
+    Skolem {} <- b =
+      pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible tv ty@ are irreducibles.
-canonTypeVarLeft
-  :: Monad m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonTypeVarLeft ::
+  (Monad m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonTypeVarLeft a _
-  | Skolem{} <- a = pure Irreducible
+  | Skolem {} <- a = pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible ty tv@ are reordered to
 -- @Coercible tv ty@ to satisfy the canonicality requirement of having the type
 -- variable on the left.
-canonTypeVarRight
-  :: Monad m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonTypeVarRight ::
+  (Monad m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonTypeVarRight a b
-  | Skolem{} <- b = pure . Canonicalized $ S.singleton (b, a)
+  | Skolem {} <- b = pure . Canonicalized $ S.singleton (b, a)
   | otherwise = empty
 
 -- | Constraints of the form @Coercible (f a_0 .. a_n) b@ are irreducibles.
-canonApplicationLeft
-  :: Monad m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonApplicationLeft ::
+  (Monad m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonApplicationLeft a _
-  | TypeApp{} <- a = pure Irreducible
+  | TypeApp {} <- a = pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible a (f b_0 .. b_n) b@ are irreducibles.
-canonApplicationRight
-  :: Monad m
-  => SourceType
-  -> SourceType
-  -> MaybeT m Canonicalized
+canonApplicationRight ::
+  (Monad m) =>
+  SourceType ->
+  SourceType ->
+  MaybeT m Canonicalized
 canonApplicationRight _ b
-  | TypeApp{} <- b = pure Irreducible
+  | TypeApp {} <- b = pure Irreducible
   | otherwise = empty
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5be87c0057..01fae89b50 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -51,11 +51,12 @@ import Language.PureScript.Crash (HasCallStack, internalError)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Errors
 import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified)
-import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, getType, getTypeSynonym)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.Types
 import Language.PureScript.Pretty.Types (prettyPrintType)
+import Protolude (isNothing)
 
 generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType
 generalizeUnknowns unks ty =
@@ -87,7 +88,7 @@ unknownVarNames used unks =
   vars :: [Text]
   vars = fmap (("k" <>) . T.pack . show) ([1..] :: [Int])
 
-apply :: (MonadState CheckState m) => SourceType -> m SourceType
+apply :: (MonadState (CheckState m) m) => SourceType -> m SourceType
 apply ty = flip substituteType ty <$> gets checkSubstitution
 
 substituteType :: Substitution -> SourceType -> SourceType
@@ -100,22 +101,22 @@ substituteType sub = everywhereOnTypes $ \case
   other ->
     other
 
-freshUnknown :: (MonadState CheckState m) => m Unknown
+freshUnknown :: (MonadState (CheckState m) m) => m Unknown
 freshUnknown = do
   k <- gets checkNextType
   modify $ \st -> st { checkNextType = k + 1 }
   pure k
 
-freshKind :: (MonadState CheckState m) => SourceSpan -> m SourceType
+freshKind :: (MonadState (CheckState m) m) => SourceSpan -> m SourceType
 freshKind ss = freshKindWithKind ss E.kindType
 
-freshKindWithKind :: (MonadState CheckState m) => SourceSpan -> SourceType -> m SourceType
+freshKindWithKind :: (MonadState (CheckState m) m) => SourceSpan -> SourceType -> m SourceType
 freshKindWithKind ss kind = do
   u <- freshUnknown
   addUnsolved Nothing u kind
   pure $ TUnknown (ss, []) u
 
-addUnsolved :: (MonadState CheckState m) => Maybe UnkLevel -> Unknown -> SourceType -> m ()
+addUnsolved :: (MonadState (CheckState m) m) => Maybe UnkLevel -> Unknown -> SourceType -> m ()
 addUnsolved lvl unk kind = modify $ \st -> do
   let
     newLvl = UnkLevel $ case lvl of
@@ -125,7 +126,7 @@ addUnsolved lvl unk kind = modify $ \st -> do
     uns = M.insert unk (newLvl, kind) $ substUnsolved subs
   st { checkSubstitution = subs { substUnsolved = uns } }
 
-solve :: (MonadState CheckState m) => Unknown -> SourceType -> m ()
+solve :: (MonadState (CheckState m) m) => Unknown -> SourceType -> m ()
 solve unk solution = modify $ \st -> do
   let
     subs = checkSubstitution st
@@ -133,7 +134,7 @@ solve unk solution = modify $ \st -> do
   st { checkSubstitution = subs { substType = tys } }
 
 lookupUnsolved
-  :: (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack)
+  :: (MonadState (CheckState m) m, MonadError MultipleErrors m, HasCallStack)
   => Unknown
   -> m (UnkLevel, SourceType)
 lookupUnsolved u = do
@@ -143,7 +144,7 @@ lookupUnsolved u = do
     Just res -> return res
 
 unknownsWithKinds
-  :: forall m. (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack)
+  :: forall m. (MonadState (CheckState m) m, MonadError MultipleErrors m, HasCallStack)
   => [Unknown]
   -> m [(Unknown, SourceType)]
 unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) . traverse go
@@ -154,7 +155,7 @@ unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join)
     pure $ (lvl, (u, ty)) : rest
 
 inferKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> m (SourceType, SourceType)
 inferKind = \tyToInfer ->
@@ -164,8 +165,8 @@ inferKind = \tyToInfer ->
   where
   go = \case
     ty@(TypeConstructor ann v) -> do
-      env <- getEnv
-      case M.lookup v (E.types env) of
+      t <- getType v
+      case t of
         Nothing ->
           throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
         Just (kind, E.LocalTypeVariable) -> do
@@ -174,8 +175,8 @@ inferKind = \tyToInfer ->
         Just (kind, _) -> do
           pure (ty, kind $> ann)
     ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do
-      env <- getEnv
-      con' <- case M.lookup (coerceProperName <$> v) (E.types env) of
+      t <- getType (coerceProperName <$> v)
+      con' <- case t of
         Nothing ->
           throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v
         Just _ ->
@@ -242,7 +243,7 @@ inferKind = \tyToInfer ->
       internalError $ "inferKind: Unimplemented case \n" <> prettyPrintType 100 ty
 
 inferAppKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceAnn
   -> (SourceType, SourceType)
   -> SourceType
@@ -269,13 +270,13 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of
     cannotApplyTypeToType fn arg
   where
   requiresSynonymsToExpand = \case
-    TypeConstructor _ v -> M.notMember v . E.typeSynonyms <$> getEnv
+    TypeConstructor _ v -> isNothing <$> getTypeSynonym v
     TypeApp _ l _ -> requiresSynonymsToExpand l
     KindApp _ l _ -> requiresSynonymsToExpand l
     _ -> pure True
 
 cannotApplyTypeToType
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> SourceType
   -> m a
@@ -285,7 +286,7 @@ cannotApplyTypeToType fn arg = do
   internalCompilerError . T.pack $ "Cannot apply type to type: " <> debugType (srcTypeApp fn arg)
 
 cannotApplyKindToType
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> SourceType
   -> m a
@@ -296,7 +297,7 @@ cannotApplyKindToType poly arg = do
   internalCompilerError . T.pack $ "Cannot apply kind to type: " <> debugType (srcKindApp poly arg)
 
 checkKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> SourceType
   -> m SourceType
@@ -310,13 +311,13 @@ checkKind = checkKind' False
 -- error.
 --
 checkIsSaturatedType
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> m SourceType
 checkIsSaturatedType ty = checkKind' True ty E.kindType
 
 checkKind'
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => Bool
   -> SourceType
   -> SourceType
@@ -331,7 +332,7 @@ checkKind' requireSynonymsToExpand ty kind2 = do
         instantiateKind (ty', kind1') kind2'
 
 instantiateKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => (SourceType, SourceType)
   -> SourceType
   -> m SourceType
@@ -349,7 +350,7 @@ instantiateKind (ty, kind1) kind2 = case kind1 of
     _ -> False
 
 subsumesKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -380,7 +381,7 @@ subsumesKind = go
       unifyKinds a b
 
 unifyKinds
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -393,7 +394,7 @@ unifyKinds = unifyKindsWithFailure $ \w1 w2 ->
 -- | local position context. This is useful when invoking kind unification
 -- | outside of kind checker internals.
 unifyKinds'
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -404,7 +405,7 @@ unifyKinds' = unifyKindsWithFailure $ \w1 w2 ->
 
 -- | Check the kind of a type, failing if it is not of kind *.
 checkTypeKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -412,7 +413,7 @@ checkTypeKind ty kind =
   unifyKindsWithFailure (\_ _ -> throwError . errorMessage $ ExpectedType ty kind) kind E.kindType
 
 unifyKindsWithFailure
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => (SourceType -> SourceType -> m ())
   -> SourceType
   -> SourceType
@@ -464,7 +465,7 @@ unifyKindsWithFailure onFailure = go
       onFailure (rowFromList w1) (rowFromList w2)
 
 solveUnknown
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => Unknown
   -> SourceType
   -> m ()
@@ -475,7 +476,7 @@ solveUnknown a' p1 = do
   solve a' p2
 
 solveUnknownAsFunction
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceAnn
   -> Unknown
   -> m SourceType
@@ -490,7 +491,7 @@ solveUnknownAsFunction ann u = do
   pure uarr
 
 promoteKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => Unknown
   -> SourceType
   -> m SourceType
@@ -512,7 +513,7 @@ promoteKind u2 ty = do
       pure ty'
 
 elaborateKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> m SourceType
 elaborateKind = \case
@@ -521,8 +522,8 @@ elaborateKind = \case
   TypeLevelInt ann _ ->
     pure $ E.tyInt $> ann
   TypeConstructor ann v -> do
-    env <- getEnv
-    case M.lookup v (E.types env) of
+    t <- getType v
+    case t of
       Nothing ->
         throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
       Just (kind, _) ->
@@ -588,7 +589,7 @@ checkEscapedSkolems ty =
     errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty'
 
 kindOfWithUnknowns
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> m (([(Unknown, SourceType)], SourceType), SourceType)
 kindOfWithUnknowns ty = do
@@ -598,14 +599,14 @@ kindOfWithUnknowns ty = do
 
 -- | Infer the kind of a single type
 kindOf
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> m (SourceType, SourceType)
 kindOf = fmap (first snd) . kindOfWithScopedVars
 
 -- | Infer the kind of a single type, returning the kinds of any scoped type variables
 kindOfWithScopedVars
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
   => SourceType
   -> m (([(Text, SourceType)], SourceType), SourceType)
 kindOfWithScopedVars ty = do
@@ -628,7 +629,7 @@ type DataDeclarationResult =
   )
 
 kindOfData
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> DataDeclarationArgs
   -> m DataDeclarationResult
@@ -636,7 +637,7 @@ kindOfData moduleName dataDecl =
   head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] []
 
 inferDataDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> DataDeclarationArgs
   -> m [(DataConstructorDeclaration, SourceType)]
@@ -656,7 +657,7 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do
         fmap (fmap (addVisibility visibility . mkForAll ctorBinders)) . inferDataConstructor tyCtor'
 
 inferDataConstructor
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => SourceType
   -> DataConstructorDeclaration
   -> m (DataConstructorDeclaration, SourceType)
@@ -680,7 +681,7 @@ type TypeDeclarationResult =
   )
 
 kindOfTypeSynonym
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> TypeDeclarationArgs
   -> m TypeDeclarationResult
@@ -688,7 +689,7 @@ kindOfTypeSynonym moduleName typeDecl =
   head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] []
 
 inferTypeSynonym
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> TypeDeclarationArgs
   -> m SourceType
@@ -797,7 +798,7 @@ type ClassDeclarationResult =
   )
 
 kindOfClass
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> ClassDeclarationArgs
   -> m ClassDeclarationResult
@@ -805,7 +806,7 @@ kindOfClass moduleName clsDecl =
   head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl]
 
 inferClassDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> ClassDeclarationArgs
   -> m ([(Text, SourceType)], [SourceConstraint], [Declaration])
@@ -821,7 +822,7 @@ inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) =
         <*> for decls checkClassMemberDeclaration
 
 checkClassMemberDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => Declaration
   -> m Declaration
 checkClassMemberDeclaration = \case
@@ -830,7 +831,7 @@ checkClassMemberDeclaration = \case
   _ -> internalError "Invalid class member declaration"
 
 applyClassMemberDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => Declaration
   -> m Declaration
 applyClassMemberDeclaration = \case
@@ -846,7 +847,7 @@ mapTypeDeclaration f = \case
     other
 
 checkConstraint
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => SourceConstraint
   -> m SourceConstraint
 checkConstraint (Constraint ann clsName kinds args dat) = do
@@ -855,7 +856,7 @@ checkConstraint (Constraint ann clsName kinds args dat) = do
   pure $ Constraint ann clsName kinds' args' dat
 
 applyConstraint
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => SourceConstraint
   -> m SourceConstraint
 applyConstraint (Constraint ann clsName kinds args dat) = do
@@ -878,7 +879,7 @@ type InstanceDeclarationResult =
   )
 
 checkInstanceDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> InstanceDeclarationArgs
   -> m InstanceDeclarationResult
@@ -899,7 +900,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do
     pure (allConstraints, allKinds, allArgs, varKinds)
 
 checkKindDeclaration
-  :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> SourceType
   -> m SourceType
@@ -934,19 +935,19 @@ checkKindDeclaration _ ty = do
     other -> pure other
 
 existingSignatureOrFreshKind
-  :: forall m. MonadState CheckState m
+  :: forall m. MonadState (CheckState m) m
   => ModuleName
   -> SourceSpan
   -> ProperName 'TypeName
   -> m SourceType
 existingSignatureOrFreshKind moduleName ss name = do
-  env <- getEnv
-  case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of
+  t <- getType (Qualified (ByModuleName moduleName) name)
+  case t of
     Nothing -> freshKind ss
     Just (kind, _) -> pure kind
 
 kindsOfAll
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModuleName
   -> [TypeDeclarationArgs]
   -> [DataDeclarationArgs]
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index b6382e6707..fd2687ec51 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -2,32 +2,30 @@
 
 -- |
 -- Monads for type checking and type inference and associated data types
---
 module Language.PureScript.TypeChecker.Monad where
 
-import Prelude
-
 import Control.Arrow (second)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State (MonadState(..), StateT(..), gets, modify)
 import Control.Monad (forM_, guard, join, when, (<=<))
-import Control.Monad.Writer.Class (MonadWriter(..), censor)
-
-import Data.Maybe (fromMaybe)
+import Control.Monad.Error.Class (MonadError (..))
+import Control.Monad.State (MonadState (..), StateT (..), gets, modify)
+import Control.Monad.Writer.Class (MonadWriter (..), censor)
+import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
 import Data.Set qualified as S
 import Data.Text (Text, isPrefixOf, unpack)
-import Data.List.NonEmpty qualified as NEL
-
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..))
-import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition)
-import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName)
+import Language.PureScript.Environment (Environment (..), EnvironmentAsync (..), EnvironmentWithAsync (..), NameKind (..), NameVisibility (..), TypeClassData (..), TypeKind (..), withNullAsyncEnv)
+import Language.PureScript.Environment qualified as Env
+import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage (..), SourceAnn, SourceSpan (..), addHint, errorMessage, positionedError, rethrow, warnWithPosition)
+import Language.PureScript.Names (Ident (..), ModuleName, ProperName (..), ProperNameType (..), Qualified (..), QualifiedBy (..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName)
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Language.PureScript.Pretty.Values (prettyPrintValue)
-import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
-import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
+import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (..))
+import Language.PureScript.Types (Constraint (..), SourceType, Type (..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
+import Prelude
+import Protolude (isJust)
 
 newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown)
   deriving (Eq, Show)
@@ -38,33 +36,36 @@ instance Ord UnkLevel where
   compare (UnkLevel a) (UnkLevel b) =
     go (NEL.toList a) (NEL.toList b)
     where
-    go [] [] = EQ
-    go _  [] = LT
-    go [] _  = GT
-    go (x:xs) (y:ys) =
-      compare x y <> go xs ys
+      go [] [] = EQ
+      go _ [] = LT
+      go [] _ = GT
+      go (x : xs) (y : ys) =
+        compare x y <> go xs ys
 
 -- | A substitution of unification variables for types.
 data Substitution = Substitution
-  { substType :: M.Map Int SourceType
-  -- ^ Type substitution
-  , substUnsolved :: M.Map Int (UnkLevel, SourceType)
-  -- ^ Unsolved unification variables with their level (scope ordering) and kind
-  , substNames :: M.Map Int Text
-  -- ^ The original names of unknowns
+  { -- | Type substitution
+    substType :: M.Map Int SourceType,
+    -- | Unsolved unification variables with their level (scope ordering) and kind
+    substUnsolved :: M.Map Int (UnkLevel, SourceType),
+    -- | The original names of unknowns
+    substNames :: M.Map Int Text
   }
 
-insertUnkName :: (MonadState CheckState m) => Unknown -> Text -> m ()
+insertUnkName :: (MonadState (CheckState m) m) => Unknown -> Text -> m ()
 insertUnkName u t = do
-  modify (\s ->
-            s { checkSubstitution =
-                  (checkSubstitution s) { substNames =
-                                            M.insert u t $ substNames $ checkSubstitution s
-                                        }
-              }
-         )
-
-lookupUnkName :: (MonadState CheckState m) => Unknown -> m (Maybe Text)
+  modify
+    ( \s ->
+        s
+          { checkSubstitution =
+              (checkSubstitution s)
+                { substNames =
+                    M.insert u t $ substNames $ checkSubstitution s
+                }
+          }
+    )
+
+lookupUnkName :: (MonadState (CheckState m) m) => Unknown -> m (Maybe Text)
 lookupUnkName u = gets $ M.lookup u . substNames . checkSubstitution
 
 -- | An empty substitution
@@ -72,224 +73,241 @@ emptySubstitution :: Substitution
 emptySubstitution = Substitution M.empty M.empty M.empty
 
 -- | State required for type checking
-data CheckState = CheckState
-  { checkEnv :: Environment
-  -- ^ The current @Environment@
-  , checkNextType :: Int
-  -- ^ The next type unification variable
-  , checkNextSkolem :: Int
-  -- ^ The next skolem variable
-  , checkNextSkolemScope :: Int
-  -- ^ The next skolem scope constant
-  , checkCurrentModule :: Maybe ModuleName
-  -- ^ The current module
-  , checkCurrentModuleImports ::
-      [ ( SourceAnn
-        , ModuleName
-        , ImportDeclarationType
-        , Maybe ModuleName
-        , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
+data CheckState m = CheckState
+  { -- | The current @Environment@
+    checkEnv :: EnvironmentWithAsync m,
+    -- | The next type unification variable
+    checkNextType :: Int,
+    -- | The next skolem variable
+    checkNextSkolem :: Int,
+    -- | The next skolem scope constant
+    checkNextSkolemScope :: Int,
+    -- | The current module
+    checkCurrentModule :: Maybe ModuleName,
+    -- | The current module imports and their exported types.
+    -- Newtype constructors have to be in scope for some Coercible constraints to
+    -- be solvable, so we need to know which constructors are imported and whether
+    -- they are actually defined in or re-exported from the imported modules.
+    checkCurrentModuleImports ::
+      [ ( SourceAnn,
+          ModuleName,
+          ImportDeclarationType,
+          Maybe ModuleName,
+          M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
         )
-      ]
-  -- ^ The current module imports and their exported types.
-  -- Newtype constructors have to be in scope for some Coercible constraints to
-  -- be solvable, so we need to know which constructors are imported and whether
-  -- they are actually defined in or re-exported from the imported modules.
-  , checkSubstitution :: Substitution
-  -- ^ The current substitution
-  , checkHints :: [ErrorMessageHint]
-  -- ^ The current error message hint stack.
-  -- This goes into state, rather than using 'rethrow',
-  -- since this way, we can provide good error messages
-  -- during instance resolution.
-  , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
-  -- ^ Newtype constructors imports required to solve Coercible constraints.
-  -- We have to keep track of them so that we don't emit unused import warnings.
+      ],
+    -- | The current substitution
+    checkSubstitution :: Substitution,
+    -- | The current error message hint stack.
+    -- This goes into state, rather than using 'rethrow',
+    -- since this way, we can provide good error messages
+    -- during instance resolution.
+    checkHints :: [ErrorMessageHint],
+    -- | Newtype constructors imports required to solve Coercible constraints.
+    -- We have to keep track of them so that we don't emit unused import warnings.
+    checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
   }
 
 -- | Create an empty @CheckState@
-emptyCheckState :: Environment -> CheckState
-emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty
+emptyCheckState :: Applicative m =>  Environment -> CheckState m
+emptyCheckState env = CheckState (withNullAsyncEnv env) 0 0 0 Nothing [] emptySubstitution [] mempty
+
+-- | Get a name from the environment
+getName :: MonadState (CheckState m) m => Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
+getName t =  Env.getName t =<< gets checkEnv
+
+-- | Get a type from the environment
+getType :: MonadState (CheckState m) m => Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
+getType t =  Env.getType t =<< gets checkEnv
+
+getTypeSynonym :: MonadState (CheckState m) m => Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
+getTypeSynonym t =  Env.getTypeSynonym t =<< gets checkEnv
+
+-- | Get a type class from the environment
+getTypeClass :: MonadState (CheckState m) m => Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
+getTypeClass t =  Env.getTypeClass t =<< gets checkEnv
 
 -- | Unification variables
 type Unknown = Int
 
 -- | Temporarily bind a collection of names to values
-bindNames
-  :: MonadState CheckState m
-  => M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
-  -> m a
-  -> m a
+bindNames ::
+  (MonadState (CheckState m) m) =>
+  M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) ->
+  m a ->
+  m a
 bindNames newNames action = do
-  orig <- get
-  modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
+  orig <- getSyncEnv
+  modifyEnv $ \st -> st {names = newNames `M.union` (names  $ st)}
   a <- action
-  modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
+  modifyEnv $ \st -> st {names = names  $ orig}
   return a
 
 -- | Temporarily bind a collection of names to types
-bindTypes
-  :: MonadState CheckState m
-  => M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-  -> m a
-  -> m a
+bindTypes ::
+  (MonadState (CheckState m) m) =>
+  M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) ->
+  m a ->
+  m a
 bindTypes newNames action = do
-  orig <- get
-  modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
+  orig <- getSyncEnv
+  modifyEnv $ \env -> env {types = newNames `M.union` types env}
   a <- action
-  modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
+  modifyEnv $ \env -> env  {types = types orig}
   return a
 
 -- | Temporarily bind a collection of names to types
-withScopedTypeVars
-  :: (MonadState CheckState m, MonadWriter MultipleErrors m)
-  => ModuleName
-  -> [(Text, SourceType)]
-  -> m a
-  -> m a
+withScopedTypeVars ::
+  (MonadState (CheckState m) m, MonadWriter MultipleErrors m) =>
+  ModuleName ->
+  [(Text, SourceType)] ->
+  m a ->
+  m a
 withScopedTypeVars mn ks ma = do
-  orig <- get
-  forM_ ks $ \(name, _) ->
-    when (Qualified (ByModuleName mn) (ProperName name) `M.member` types (checkEnv orig)) $
-      tell . errorMessage $ ShadowedTypeVar name
+  forM_ ks $ \(name, _) -> do
+    shadow <- getType (Qualified (ByModuleName mn) (ProperName name))
+    when (isJust shadow) $
+      tell . errorMessage $
+        ShadowedTypeVar name
   bindTypes (M.fromList (map (\(name, k) -> (Qualified (ByModuleName mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma
 
-withErrorMessageHint
-  :: (MonadState CheckState m, MonadError MultipleErrors m)
-  => ErrorMessageHint
-  -> m a
-  -> m a
+withErrorMessageHint ::
+  (MonadState (CheckState m) m, MonadError MultipleErrors m) =>
+  ErrorMessageHint ->
+  m a ->
+  m a
 withErrorMessageHint hint action = do
   orig <- get
-  modify $ \st -> st { checkHints = hint : checkHints st }
+  modify $ \st -> st {checkHints = hint : checkHints st}
   -- Need to use 'rethrow' anyway, since we have to handle regular errors
   a <- rethrow (addHint hint) action
-  modify $ \st -> st { checkHints = checkHints orig }
+  modify $ \st -> st {checkHints = checkHints orig}
   return a
 
 -- | These hints are added at the front, so the most nested hint occurs
 -- at the front, but the simplifier assumes the reverse order.
-getHints :: MonadState CheckState m => m [ErrorMessageHint]
+getHints :: (MonadState (CheckState m) m) => m [ErrorMessageHint]
 getHints = gets (reverse . checkHints)
 
-rethrowWithPositionTC
-  :: (MonadState CheckState m, MonadError MultipleErrors m)
-  => SourceSpan
-  -> m a
-  -> m a
+rethrowWithPositionTC ::
+  (MonadState (CheckState m) m, MonadError MultipleErrors m) =>
+  SourceSpan ->
+  m a ->
+  m a
 rethrowWithPositionTC pos = withErrorMessageHint (positionedError pos)
 
-warnAndRethrowWithPositionTC
-  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
-  => SourceSpan
-  -> m a
-  -> m a
+warnAndRethrowWithPositionTC ::
+  (MonadState (CheckState m) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  SourceSpan ->
+  m a ->
+  m a
 warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition pos
 
 -- | Temporarily make a collection of type class dictionaries available
-withTypeClassDictionaries
-  :: MonadState CheckState m
-  => [NamedDict]
-  -> m a
-  -> m a
+withTypeClassDictionaries ::
+  (MonadState (CheckState m) m) =>
+  [NamedDict] ->
+  m a ->
+  m a
 withTypeClassDictionaries entries action = do
-  orig <- get
+  orig <- getSyncEnv
 
   let mentries =
-        M.fromListWith (M.unionWith (M.unionWith (<>)))
+        M.fromListWith
+          (M.unionWith (M.unionWith (<>)))
           [ (qb, M.singleton className (M.singleton tcdValue (pure entry)))
-          | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className }
-              <- entries
+            | entry@TypeClassDictionaryInScope {tcdValue = tcdValue@(Qualified qb _), tcdClassName = className} <-
+                entries
           ]
 
-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } }
+  modifyEnv $ \st -> st {typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries st) mentries}
   a <- action
-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
+  modifyEnv $ \st -> st {typeClassDictionaries = typeClassDictionaries orig}
   return a
 
--- | Get the currently available map of type class dictionaries
-getTypeClassDictionaries
-  :: (MonadState CheckState m)
-  => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv
+-- -- | Get the currently available map of type class dictionaries
+-- getTypeClassDictionaries ::
+--   (MonadState (CheckState m) m) =>
+--   m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
+-- getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv
 
 -- | Lookup type class dictionaries in a module.
-lookupTypeClassDictionaries
-  :: (MonadState CheckState m)
-  => QualifiedBy
-  -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
-lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv
+-- lookupTypeClassDictionaries ::
+--   (MonadState (CheckState m) m) =>
+--   QualifiedBy ->
+--   m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
+-- lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv
 
 -- | Lookup type class dictionaries in a module.
-lookupTypeClassDictionariesForClass
-  :: (MonadState CheckState m)
-  => QualifiedBy
-  -> Qualified (ProperName 'ClassName)
-  -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
-lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn
+lookupTypeClassDictionariesForClass ::
+  (MonadState (CheckState m) m) =>
+  QualifiedBy ->
+  Qualified (ProperName 'ClassName) ->
+  m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
+lookupTypeClassDictionariesForClass mn cn = fmap (fromMaybe mempty) <$> Env.getTypeClassDictionary mn cn  =<< gets checkEnv
 
 -- | Temporarily bind a collection of names to local variables
-bindLocalVariables
-  :: (MonadState CheckState m)
-  => [(SourceSpan, Ident, SourceType, NameVisibility)]
-  -> m a
-  -> m a
+bindLocalVariables ::
+  (MonadState (CheckState m) m) =>
+  [(SourceSpan, Ident, SourceType, NameVisibility)] ->
+  m a ->
+  m a
 bindLocalVariables bindings =
   bindNames (M.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (Qualified (BySourcePos $ spanStart ss) name, (ty, Private, visibility)))
 
 -- | Temporarily bind a collection of names to local type variables
-bindLocalTypeVariables
-  :: (MonadState CheckState m)
-  => ModuleName
-  -> [(ProperName 'TypeName, SourceType)]
-  -> m a
-  -> m a
+bindLocalTypeVariables ::
+  (MonadState (CheckState m) m) =>
+  ModuleName ->
+  [(ProperName 'TypeName, SourceType)] ->
+  m a ->
+  m a
 bindLocalTypeVariables moduleName bindings =
   bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (ByModuleName moduleName) pn, (kind, LocalTypeVariable)))
 
 -- | Update the visibility of all names to Defined
-makeBindingGroupVisible :: (MonadState CheckState m) => m ()
-makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
+makeBindingGroupVisible :: (MonadState (CheckState m) m) => m ()
+makeBindingGroupVisible = modifyEnv $ \e -> e {names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e)}
 
 -- | Update the visibility of all names to Defined in the scope of the provided action
-withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a
+withBindingGroupVisible :: (MonadState (CheckState m) m) => m a -> m a
 withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action
 
 -- | Perform an action while preserving the names from the @Environment@.
-preservingNames :: (MonadState CheckState m) => m a -> m a
+preservingNames :: (MonadState (CheckState m) m) => m a -> m a
 preservingNames action = do
-  orig <- gets (names . checkEnv)
+  orig <- gets (names . envSync . checkEnv)
   a <- action
-  modifyEnv $ \e -> e { names = orig }
+  modifyEnv $ \e -> e {names = orig}
   return a
 
 -- | Lookup the type of a value by name in the @Environment@
-lookupVariable
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
-  => Qualified Ident
-  -> m SourceType
+lookupVariable ::
+  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
+  Qualified Ident ->
+  m SourceType
 lookupVariable qual = do
-  env <- getEnv
-  case M.lookup qual (names env) of
+  name <- getName qual
+  case name of
     Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
     Just (ty, _, _) -> return ty
 
 -- | Lookup the visibility of a value by name in the @Environment@
-getVisibility
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
-  => Qualified Ident
-  -> m NameVisibility
+getVisibility ::
+  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
+  Qualified Ident ->
+  m NameVisibility
 getVisibility qual = do
-  env <- getEnv
-  case M.lookup qual (names env) of
+  name <- getName qual
+  case name of
     Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
     Just (_, _, vis) -> return vis
 
 -- | Assert that a name is visible
-checkVisibility
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
-  => Qualified Ident
-  -> m ()
+checkVisibility ::
+  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
+  Qualified Ident ->
+  m ()
 checkVisibility name@(Qualified _ var) = do
   vis <- getVisibility name
   case vis of
@@ -297,41 +315,44 @@ checkVisibility name@(Qualified _ var) = do
     _ -> return ()
 
 -- | Lookup the kind of a type by name in the @Environment@
-lookupTypeVariable
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
-  => ModuleName
-  -> Qualified (ProperName 'TypeName)
-  -> m SourceType
+lookupTypeVariable ::
+  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
+  ModuleName ->
+  Qualified (ProperName 'TypeName) ->
+  m SourceType
 lookupTypeVariable currentModule (Qualified qb name) = do
-  env <- getEnv
-  case M.lookup (Qualified qb' name) (types env) of
+  t <- getType (Qualified qb' name)  
+  case t of
     Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
     Just (k, _) -> return k
   where
-  qb' = ByModuleName $ case qb of
-    ByModuleName m -> m
-    BySourcePos _ -> currentModule
+    qb' = ByModuleName $ case qb of
+      ByModuleName m -> m
+      BySourcePos _ -> currentModule
 
 -- | Get the current @Environment@
-getEnv :: (MonadState CheckState m) => m Environment
-getEnv = gets checkEnv
+getSyncEnv :: (MonadState (CheckState m) m) => m Environment
+getSyncEnv = gets (envSync . checkEnv)
 
 -- | Get locally-bound names in context, to create an error message.
-getLocalContext :: MonadState CheckState m => m Context
+getLocalContext :: (MonadState (CheckState m) m) => m Context
 getLocalContext = do
-  env <- getEnv
-  return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ]
+  env <- getSyncEnv
+  return [(ident, ty') | (Qualified (BySourcePos _) ident@Ident {}, (ty', _, Defined)) <- M.toList (names env)]
 
 -- | Update the @Environment@
-putEnv :: (MonadState CheckState m) => Environment -> m ()
-putEnv env = modify (\s -> s { checkEnv = env })
+putEnv :: (MonadState (CheckState m) m) => Environment -> m ()
+putEnv env = modify (\s -> s {checkEnv = withNullAsyncEnv env})
+
+modifyEnvWithAsync :: (MonadState (CheckState m) m) => (EnvironmentWithAsync m -> EnvironmentWithAsync m) -> m ()
+modifyEnvWithAsync f = modify (\s -> s {checkEnv = f (checkEnv s)})
 
 -- | Modify the @Environment@
-modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
-modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
+modifyEnv :: (MonadState (CheckState m) m) => (Environment -> Environment) -> m ()
+modifyEnv f = modifyEnvWithAsync (\env -> env {envSync = f (envSync env)})
 
 -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.
-runCheck :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment)
+runCheck :: (Functor m) => CheckState m -> StateT (CheckState m) m a -> m (a, EnvironmentWithAsync m)
 runCheck st check = second checkEnv <$> runStateT check st
 
 -- | Make an assertion, failing with an error message
@@ -339,50 +360,52 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()
 guardWith _ True = return ()
 guardWith e False = throwError e
 
-capturingSubstitution
-  :: MonadState CheckState m
-  => (a -> Substitution -> b)
-  -> m a
-  -> m b
+capturingSubstitution ::
+  (MonadState (CheckState m) m) =>
+  (a -> Substitution -> b) ->
+  m a ->
+  m b
 capturingSubstitution f ma = do
   a <- ma
   subst <- gets checkSubstitution
   return (f a subst)
 
-withFreshSubstitution
-  :: MonadState CheckState m
-  => m a
-  -> m a
+withFreshSubstitution ::
+  (MonadState (CheckState m) m) =>
+  m a ->
+  m a
 withFreshSubstitution ma = do
   orig <- get
-  modify $ \st -> st { checkSubstitution = emptySubstitution }
+  modify $ \st -> st {checkSubstitution = emptySubstitution}
   a <- ma
-  modify $ \st -> st { checkSubstitution = checkSubstitution orig }
+  modify $ \st -> st {checkSubstitution = checkSubstitution orig}
   return a
 
-withoutWarnings
-  :: MonadWriter w m
-  => m a
-  -> m (a, w)
+withoutWarnings ::
+  (MonadWriter w m) =>
+  m a ->
+  m (a, w)
 withoutWarnings = censor (const mempty) . listen
 
-unsafeCheckCurrentModule
-  :: forall m
-   . (MonadError MultipleErrors m, MonadState CheckState m)
-  => m ModuleName
-unsafeCheckCurrentModule = gets checkCurrentModule >>= \case
-  Nothing -> internalError "No module name set in scope"
-  Just name -> pure name
+unsafeCheckCurrentModule ::
+  forall m.
+  (MonadError MultipleErrors m, MonadState (CheckState m) m) =>
+  m ModuleName
+unsafeCheckCurrentModule =
+  gets checkCurrentModule >>= \case
+    Nothing -> internalError "No module name set in scope"
+    Just name -> pure name
 
 debugEnv :: Environment -> [String]
-debugEnv env = join
-  [ debugTypes env
-  , debugTypeSynonyms env
-  , debugTypeClasses env
-  , debugTypeClassDictionaries env
-  , debugDataConstructors env
-  , debugNames env
-  ]
+debugEnv env =
+  join
+    [ debugTypes env,
+      debugTypeSynonyms env,
+      debugTypeClasses env,
+      debugTypeClassDictionaries env,
+      debugDataConstructors env,
+      debugNames env
+    ]
 
 debugType :: Type a -> String
 debugType = init . prettyPrintType 100
@@ -394,72 +417,66 @@ debugConstraint (Constraint ann clsName kinds args _) =
 debugTypes :: Environment -> [String]
 debugTypes = go <=< M.toList . types
   where
-  go (qual, (srcTy, which)) = do
-    let
-      ppTy = prettyPrintType 100 srcTy
-      name = showQualified runProperName qual
-      decl = case which of
-        DataType _ _ _    -> "data"
-        TypeSynonym       -> "type"
-        ExternData _      -> "extern"
-        LocalTypeVariable -> "local"
-        ScopedTypeVar     -> "scoped"
-    guard (not ("Prim" `isPrefixOf` name))
-    pure $ decl <> " " <> unpack name <> " :: " <> init ppTy
+    go (qual, (srcTy, which)) = do
+      let ppTy = prettyPrintType 100 srcTy
+          name = showQualified runProperName qual
+          decl = case which of
+            DataType _ _ _ -> "data"
+            TypeSynonym -> "type"
+            ExternData _ -> "extern"
+            LocalTypeVariable -> "local"
+            ScopedTypeVar -> "scoped"
+      guard (not ("Prim" `isPrefixOf` name))
+      pure $ decl <> " " <> unpack name <> " :: " <> init ppTy
 
 debugNames :: Environment -> [String]
 debugNames = fmap go . M.toList . names
   where
-  go (qual, (srcTy, _, _)) = do
-    let
-      ppTy = prettyPrintType 100 srcTy
-      name = showQualified runIdent qual
-    unpack name <> " :: " <> init ppTy
+    go (qual, (srcTy, _, _)) = do
+      let ppTy = prettyPrintType 100 srcTy
+          name = showQualified runIdent qual
+      unpack name <> " :: " <> init ppTy
 
 debugDataConstructors :: Environment -> [String]
 debugDataConstructors = fmap go . M.toList . dataConstructors
   where
-  go (qual, (_, _, ty, _)) = do
-    let
-      ppTy = prettyPrintType 100 ty
-      name = showQualified runProperName qual
-    unpack name <> " :: " <> init ppTy
+    go (qual, (_, _, ty, _)) = do
+      let ppTy = prettyPrintType 100 ty
+          name = showQualified runProperName qual
+      unpack name <> " :: " <> init ppTy
 
 debugTypeSynonyms :: Environment -> [String]
 debugTypeSynonyms = fmap go . M.toList . typeSynonyms
   where
-  go (qual, (binders, subTy)) = do
-    let
-      vars = unwords $ flip fmap binders $ \case
-               (v, Just k) -> "(" <> unpack v <> " :: " <> init (prettyPrintType 100 k) <> ")"
-               (v, Nothing) -> unpack v
-      ppTy = prettyPrintType 100 subTy
-      name = showQualified runProperName qual
-    "type " <> unpack name <> " " <> vars <> " = " <> init ppTy
+    go (qual, (binders, subTy)) = do
+      let vars = unwords $ flip fmap binders $ \case
+            (v, Just k) -> "(" <> unpack v <> " :: " <> init (prettyPrintType 100 k) <> ")"
+            (v, Nothing) -> unpack v
+          ppTy = prettyPrintType 100 subTy
+          name = showQualified runProperName qual
+      "type " <> unpack name <> " " <> vars <> " = " <> init ppTy
 
 debugTypeClassDictionaries :: Environment -> [String]
 debugTypeClassDictionaries = go . typeClassDictionaries
   where
-  go tcds = do
-    (mbModuleName, classes) <- M.toList tcds
-    (className, instances) <- M.toList classes
-    (ident, dicts) <- M.toList instances
-    let
-      moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") (toMaybeModuleName mbModuleName)
-      className' = showQualified runProperName className
-      ident' = showQualified runIdent ident
-      kds = unwords $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts
-      tys = unwords $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts
-    pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys
+    go tcds = do
+      (mbModuleName, classes) <- M.toList tcds
+      (className, instances) <- M.toList classes
+      (ident, dicts) <- M.toList instances
+      let moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") (toMaybeModuleName mbModuleName)
+          className' = showQualified runProperName className
+          ident' = showQualified runIdent ident
+          kds = unwords $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts
+          tys = unwords $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts
+      pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys
 
 debugTypeClasses :: Environment -> [String]
 debugTypeClasses = fmap go . M.toList . typeClasses
   where
-  go (className, tc) = do
-    let
-      className' = showQualified runProperName className
-      args = unwords $ (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") <$> typeClassArguments tc
-    "class " <> unpack className' <> " " <> args
+    go (className, tc) = do
+      let className' = showQualified runProperName className
+          args = unwords $ (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") <$> typeClassArguments tc
+      "class " <> unpack className' <> " " <> args
 
 debugValue :: Expr -> String
 debugValue = init . render . prettyPrintValue 100
@@ -467,19 +484,19 @@ debugValue = init . render . prettyPrintValue 100
 debugSubstitution :: Substitution -> [String]
 debugSubstitution (Substitution solved unsolved names) =
   concat
-    [ fmap go1 (M.toList solved)
-    , fmap go2 (M.toList unsolved')
-    , fmap go3 (M.toList names)
+    [ fmap go1 (M.toList solved),
+      fmap go2 (M.toList unsolved'),
+      fmap go3 (M.toList names)
     ]
   where
-  unsolved' =
-    M.filterWithKey (\k _ -> M.notMember k solved) unsolved
+    unsolved' =
+      M.filterWithKey (\k _ -> M.notMember k solved) unsolved
 
-  go1 (u, ty) =
-    "?" <> show u <> " = " <> debugType ty
+    go1 (u, ty) =
+      "?" <> show u <> " = " <> debugType ty
 
-  go2 (u, (_, k)) =
-    "?" <> show u <> " :: " <> debugType k
+    go2 (u, (_, k)) =
+      "?" <> show u <> " :: " <> debugType k
 
-  go3 (u, t) =
-    unpack t <> show u
+    go3 (u, t) =
+      unpack t <> show u
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index aa49997fd6..92a601dff4 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -24,21 +24,21 @@ import Language.PureScript.TypeChecker.Monad (CheckState(..))
 import Language.PureScript.Types (SkolemScope(..), SourceType, Type(..), everythingOnTypes, everywhereOnTypesM, replaceTypeVars)
 
 -- | Generate a new skolem constant
-newSkolemConstant :: MonadState CheckState m => m Int
+newSkolemConstant :: MonadState (CheckState m) m => m Int
 newSkolemConstant = do
   s <- gets checkNextSkolem
   modify $ \st -> st { checkNextSkolem = s + 1 }
   return s
 
 -- | Introduce skolem scope at every occurrence of a ForAll
-introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a)
+introduceSkolemScope :: MonadState (CheckState m) m => Type a -> m (Type a)
 introduceSkolemScope = everywhereOnTypesM go
   where
   go (ForAll ann vis ident mbK ty Nothing) = ForAll ann vis ident mbK ty <$> (Just <$> newSkolemScope)
   go other = return other
 
 -- | Generate a new skolem scope
-newSkolemScope :: MonadState CheckState m => m SkolemScope
+newSkolemScope :: MonadState (CheckState m) m => m SkolemScope
 newSkolemScope = do
   s <- gets checkNextSkolemScope
   modify $ \st -> st { checkNextSkolemScope = s + 1 }
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 26da5e980f..f847e6573a 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -20,7 +20,7 @@ import Language.PureScript.AST (ErrorMessageHint(..), Expr(..), pattern NullSour
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (tyFunction, tyRecord)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, internalCompilerError)
-import Language.PureScript.TypeChecker.Monad (CheckState, getHints, getTypeClassDictionaries, withErrorMessageHint)
+import Language.PureScript.TypeChecker.Monad (CheckState, getHints, withErrorMessageHint)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize)
 import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, unifyTypes)
 import Language.PureScript.Types (RowListItem(..), SourceType, Type(..), eqType, isREmpty, replaceTypeVars, rowFromList)
@@ -59,7 +59,7 @@ defaultCoercion SNoElaborate = ()
 
 -- | Check that one type subsumes another, rethrowing errors to provide a better error message
 subsumes
-  :: (MonadError MultipleErrors m, MonadState CheckState m)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => SourceType
   -> SourceType
   -> m (Expr -> Expr)
@@ -69,7 +69,7 @@ subsumes ty1 ty2 =
 
 -- | Check that one type subsumes another
 subsumes'
-  :: (MonadError MultipleErrors m, MonadState CheckState m)
+  :: (MonadError MultipleErrors m, MonadState (CheckState m) m)
   => ModeSing mode
   -> SourceType
   -> SourceType
@@ -97,7 +97,7 @@ subsumes' mode ty1 (KindedType _ ty2 _) =
 -- Only check subsumption for constrained types when elaborating.
 -- Otherwise fall back to unification.
 subsumes' SElaborate (ConstrainedType _ con ty1) ty2 = do
-  dicts <- getTypeClassDictionaries
+  -- dicts <- getTypeClassDictionaries
   hints <- getHints
   elaborate <- subsumes' SElaborate ty1 ty2
   let addDicts val = App val (TypeClassDictionary con dicts hints)
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 567ae415ef..71f97cdf18 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -2,61 +2,61 @@
 
 -- |
 -- Functions for replacing fully applied type synonyms
---
 module Language.PureScript.TypeChecker.Synonyms
-  ( SynonymMap
-  , KindMap
-  , replaceAllTypeSynonyms
-  ) where
-
-import Prelude
-
-import Control.Monad.Error.Class (MonadError(..))
+  ( SynonymMap,
+    KindMap,
+    replaceAllTypeSynonyms,
+  )
+where
+
+import Control.Monad.Error.Class (MonadError (..))
+import Control.Monad.Except (ExceptT, runExceptT, MonadTrans (lift))
 import Control.Monad.State (MonadState)
-import Data.Maybe (fromMaybe)
 import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import Language.PureScript.Environment (Environment(..), TypeKind)
-import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage')
-import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified)
-import Language.PureScript.TypeChecker.Monad (CheckState, getEnv)
-import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars)
+import Language.PureScript.Environment (TypeKind)
+import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), SourceSpan, errorMessage')
+import Language.PureScript.Names (ProperName, ProperNameType (..), Qualified)
+import Language.PureScript.TypeChecker.Monad (CheckState, getTypeSynonym, getType)
+import Language.PureScript.Types (SourceType, Type (..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars)
+import Prelude
 
 -- | Type synonym information (arguments with kinds, aliased type), indexed by name
 type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType)
 
 type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
 
-replaceAllTypeSynonyms'
-  :: SynonymMap
-  -> KindMap
-  -> SourceType
-  -> Either MultipleErrors SourceType
-replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try
-  where
-  try :: SourceType -> Either MultipleErrors SourceType
-  try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
-
-  go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType)
-  go ss c kargs args (TypeConstructor _ ctor)
-    | Just (synArgs, body) <- M.lookup ctor syns
-    , c == length synArgs
-    , kindArgs <- lookupKindArgs ctor
-    , length kargs == length kindArgs
-    = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
-      in Just <$> try repl
-    | Just (synArgs, _) <- M.lookup ctor syns
-    , length synArgs > c
-    = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
-  go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
-  go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
-  go _ _ _ _ _ = return Nothing
-
-  lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text]
-  lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds
-
 -- | Replace fully applied type synonyms
-replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType
+replaceAllTypeSynonyms :: forall m e. (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) => SourceType -> m SourceType
 replaceAllTypeSynonyms d = do
-  env <- getEnv
-  either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d
+  either throwError return =<< runExceptT (replaceAllTypeSynonyms' d)
+  where
+    replaceAllTypeSynonyms' :: SourceType -> ExceptT MultipleErrors m SourceType
+    replaceAllTypeSynonyms' = everywhereOnTypesTopDownM try
+
+    try :: SourceType -> ExceptT MultipleErrors m SourceType
+    try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
+
+    go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> ExceptT MultipleErrors m (Maybe SourceType)
+    go  ss c kargs args (TypeConstructor _ ctor) = do
+      synMb <- lift $ getTypeSynonym ctor
+      kindArgs <- lookupKindArgs ctor
+      case synMb of
+        Just (synArgs, body) | c == length synArgs && length kargs == length kindArgs -> do
+          let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
+          Just <$> try repl
+        Just (synArgs, _) | length synArgs > c -> throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
+        _ -> return Nothing
+
+    go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
+    go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
+    go _ _ _ _ _ = return Nothing
+
+    lookupKindArgs :: Qualified (ProperName 'TypeName) ->  ExceptT MultipleErrors m [Text]
+    lookupKindArgs ctor = do
+      kindMb <- lift $ getType ctor
+      case kindMb of
+        Just (kind, _) -> return $ maybe [] (fmap (fst . snd) . fst) (completeBinderList kind)
+        _ -> return []
+
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index e4f1040ebf..47aa4ea592 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -35,7 +35,7 @@ import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize)
 import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown)
 
 -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible.
-freshType :: (MonadState CheckState m) => m SourceType
+freshType :: (MonadState (CheckState m) m) => m SourceType
 freshType = state $ \st -> do
   let
     t = checkNextType st
@@ -50,7 +50,7 @@ freshType = state $ \st -> do
   (srcTUnknown (t + 1), st')
 
 -- | Generate a fresh type variable with a known kind.
-freshTypeWithKind :: (MonadState CheckState m) => SourceType -> m SourceType
+freshTypeWithKind :: (MonadState (CheckState m) m) => SourceType -> m SourceType
 freshTypeWithKind kind = state $ \st -> do
   let
     t = checkNextType st
@@ -61,7 +61,7 @@ freshTypeWithKind kind = state $ \st -> do
   (srcTUnknown t, st')
 
 -- | Update the substitution to solve a type constraint
-solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m ()
+solveType :: (MonadError MultipleErrors m, MonadState (CheckState m) m) => Int -> SourceType -> m ()
 solveType u t = rethrow (onErrorMessages withoutPosition) $ do
   -- We strip the position so that any errors get rethrown with the position of
   -- the original unification constraint. Otherwise errors may arise from arbitrary
@@ -106,7 +106,7 @@ unknownsInType t = everythingOnTypes (.) go t []
   go _ = id
 
 -- | Unify two types, updating the current substitution
-unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m ()
+unifyTypes :: (MonadError MultipleErrors m, MonadState (CheckState m) m) => SourceType -> SourceType -> m ()
 unifyTypes t1 t2 = do
   sub <- gets checkSubstitution
   withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)
@@ -160,7 +160,7 @@ unifyTypes t1 t2 = do
 --
 -- Common labels are identified and unified. Remaining labels and types are unified with a
 -- trailing row unification variable, if appropriate.
-unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m ()
+unifyRows :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m) => SourceType -> SourceType -> m ()
 unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where
   unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2
 
@@ -184,7 +184,7 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where
 -- |
 -- Replace type wildcards with unknowns
 --
-replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => SourceType -> m SourceType
+replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState (CheckState m) m) => SourceType -> m SourceType
 replaceTypeWildcards = everywhereOnTypesM replace
   where
   replace (TypeWildcard ann wdata) = do
@@ -201,7 +201,7 @@ replaceTypeWildcards = everywhereOnTypesM replace
 -- |
 -- Replace outermost unsolved unification variables with named type variables
 --
-varIfUnknown :: forall m. (MonadState CheckState m) => [(Unknown, SourceType)] -> SourceType -> m SourceType
+varIfUnknown :: forall m. (MonadState (CheckState m) m) => [(Unknown, SourceType)] -> SourceType -> m SourceType
 varIfUnknown unks ty = do
   bn' <- traverse toBinding unks
   ty' <- go ty

From 0366387fc07e71c478e9827c9b4bffb5c3111200 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 6 Oct 2024 05:51:38 +0200
Subject: [PATCH 094/297] Revert "Async env: start"

This reverts commit e54dd0c6548c920ed9a11613eb64a3b01860dc89.
---
 src/Language/PureScript/Environment.hs        | 139 +--
 .../PureScript/TypeChecker/Entailment.hs      |   6 +-
 .../TypeChecker/Entailment/Coercible.hs       | 942 +++++++++---------
 src/Language/PureScript/TypeChecker/Kinds.hs  | 107 +-
 src/Language/PureScript/TypeChecker/Monad.hs  | 579 ++++++-----
 .../PureScript/TypeChecker/Skolems.hs         |   6 +-
 .../PureScript/TypeChecker/Subsumption.hs     |   8 +-
 .../PureScript/TypeChecker/Synonyms.hs        |  92 +-
 src/Language/PureScript/TypeChecker/Unify.hs  |  14 +-
 9 files changed, 907 insertions(+), 986 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index de858d00f0..9bb6838ccd 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -1,122 +1,75 @@
 {-# LANGUAGE DeriveAnyClass #-}
-
 module Language.PureScript.Environment where
 
-import Codec.Serialise (Serialise)
-import Codec.Serialise qualified as S
+import Prelude
+
+import GHC.Generics (Generic)
 import Control.DeepSeq (NFData)
 import Control.Monad (unless)
-import Data.Aeson ((.:), (.=))
+import Codec.Serialise (Serialise)
+import Data.Aeson ((.=), (.:))
 import Data.Aeson qualified as A
 import Data.Foldable (find, fold)
 import Data.Functor ((<&>))
 import Data.IntMap qualified as IM
 import Data.IntSet qualified as IS
-import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Semigroup (First (..))
 import Data.Set qualified as S
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Semigroup (First(..))
 import Data.Text (Text)
 import Data.Text qualified as T
-import GHC.Generics (Generic)
+import Data.List.NonEmpty qualified as NEL
+
 import Language.PureScript.AST.SourcePos (nullSourceAnn)
-import Language.PureScript.Constants.Prim qualified as C
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Names (Ident, ProperName (..), ProperNameType (..), Qualified, QualifiedBy, coerceProperName)
-import Language.PureScript.Roles (Role (..))
+import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName)
+import Language.PureScript.Roles (Role(..))
 import Language.PureScript.TypeClassDictionaries (NamedDict)
-import Language.PureScript.Types (SourceConstraint, SourceType, Type (..), TypeVarVisibility (..), eqType, freeTypeVariables, srcTypeConstructor)
-import Protolude ((&))
-import Prelude
+import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables)
+import Language.PureScript.Constants.Prim qualified as C
+import Codec.Serialise qualified as S
 
 -- | The @Environment@ defines all values and types which are currently in scope:
 data Environment = Environment
-  { -- | Values currently in scope
-    names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility),
-    -- | Type names currently in scope
-    types :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind),
-    -- | Data constructors currently in scope, along with their associated type
-    -- constructor name, argument types and return type.
-    dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]),
-    -- | Type synonyms currently in scope
-    typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType),
-    -- | Available type class dictionaries. When looking up 'Nothing' in the
-    -- outer map, this returns the map of type class dictionaries in local
-    -- scope (ie dictionaries brought in by a constrained type).
-    typeClassDictionaries :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))),
-    -- | Type classes
-    typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
-  }
-  deriving (Show, Generic, S.Serialise)
+  { names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
+  -- ^ Values currently in scope
+  , types :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
+  -- ^ Type names currently in scope
+  , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
+  -- ^ Data constructors currently in scope, along with their associated type
+  -- constructor name, argument types and return type.
+  , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType)
+  -- ^ Type synonyms currently in scope
+  , typeClassDictionaries :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
+  -- ^ Available type class dictionaries. When looking up 'Nothing' in the
+  -- outer map, this returns the map of type class dictionaries in local
+  -- scope (ie dictionaries brought in by a constrained type).
+  , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
+  -- ^ Type classes
+  } deriving (Show, Generic, S.Serialise)
 
 instance NFData Environment
 
-data EnvironmentAsync m = EnvironmentAsync
-  -- Functions allow env vars to be lazily loaded
-  { namesAsync :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility)),
-    typesAsync :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind)),
-    dataConstructorsAsync :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])),
-    typeSynonymsAsync :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType)),
-    typeClassDictionariesAsync :: QualifiedBy -> Qualified (ProperName 'ClassName) -> m (Maybe (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))),
-    typeClassesAsync :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
-  }
 
-nullAsyncEnv :: Applicative m => EnvironmentAsync m
-nullAsyncEnv =
-  EnvironmentAsync
-    { namesAsync = \_ -> pure Nothing,
-      typesAsync = \_ -> pure Nothing,
-      dataConstructorsAsync = \_ -> pure Nothing,
-      typeSynonymsAsync = \_ -> pure Nothing,
-      typeClassDictionariesAsync = \_ _ -> pure Nothing,
-      typeClassesAsync = \_ -> pure Nothing
-    }
-
-data EnvironmentWithAsync m = EnvironmentWithAsync
-  { envSync :: Environment,
-    envAsync :: EnvironmentAsync m
+data EnvironmentFn m = EnvironmentFn 
+  { namesFn :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
+  , typesFn :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
+  , dataConstructorsFn :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
+  , typeSynonymsFn :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
+  , typeClassDictionariesFn :: QualifiedBy -> m (Maybe (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
+  , typeClassesFn :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
   }
 
--- fromEnv :: (Ord t, Applicative f) => (Environment -> M.Map t a) -> (EnvironmentFn m -> t -> f (Maybe a)) -> t -> EnvironmentFn m -> f (Maybe a)
-
-fromEnv ::
-  (Ord k, Applicative f) =>
-  (Environment -> M.Map k a) ->
-  (EnvironmentAsync m -> k -> f (Maybe a)) ->
-  k ->
-  EnvironmentWithAsync m ->
-  f (Maybe a)
-fromEnv getMap getFn k env =
-  M.lookup k (getMap $ envSync env)
-    & maybe ((getFn $ envAsync env) k) (pure . Just)
-
-getName :: forall m. (Applicative m) => Qualified Ident -> EnvironmentWithAsync m -> m (Maybe (SourceType, NameKind, NameVisibility))
-getName = fromEnv names namesAsync
-
-getType :: forall m. (Applicative m) => Qualified (ProperName 'TypeName) -> EnvironmentWithAsync m -> m (Maybe (SourceType, TypeKind))
-getType = fromEnv types typesAsync
-
-getDataConstructor :: forall m. (Applicative m) => Qualified (ProperName 'ConstructorName) -> EnvironmentWithAsync m -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-getDataConstructor = fromEnv dataConstructors dataConstructorsAsync
-
-getTypeSynonym :: forall m. (Applicative m) => Qualified (ProperName 'TypeName) -> EnvironmentWithAsync m -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
-getTypeSynonym = fromEnv typeSynonyms typeSynonymsAsync
-
-getTypeClassDictionary :: forall m. (Applicative m) => QualifiedBy -> Qualified (ProperName 'ClassName) -> EnvironmentWithAsync m -> m (Maybe (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
-getTypeClassDictionary qb name env = case M.lookup qb (typeClassDictionaries $ envSync env) >>= M.lookup name of
-  Nothing -> typeClassDictionariesAsync (envAsync env) qb name
-  Just x -> pure $ Just x
-
-getTypeClass :: forall m. (Applicative m) => Qualified (ProperName 'ClassName) -> EnvironmentWithAsync m -> m (Maybe TypeClassData)
-getTypeClass = fromEnv typeClasses typeClassesAsync
-
-withNullAsyncEnv :: Applicative m => Environment -> EnvironmentWithAsync m
-withNullAsyncEnv env =
-  EnvironmentWithAsync
-    { envSync = env,
-      envAsync = nullAsyncEnv
-    }
+toEnvFn :: Applicative m => Environment -> EnvironmentFn m
+toEnvFn env = EnvironmentFn
+  { namesFn = \k -> pure $ M.lookup k (names env)
+  , typesFn = \k -> pure $ M.lookup k (types env)
+  , dataConstructorsFn = \k -> pure $ M.lookup k (dataConstructors env)
+  , typeSynonymsFn = \k -> pure $ M.lookup k (typeSynonyms env)
+  , typeClassDictionariesFn = \k -> pure $ M.lookup k (typeClassDictionaries env)
+  , typeClassesFn = \k -> pure $ M.lookup k (typeClasses env)
+  }
 
 -- | Information about a type class
 data TypeClassData = TypeClassData
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 1f59a96acf..85bdfee4aa 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -113,7 +113,7 @@ combineContexts = M.unionWith (M.unionWith (M.unionWith (<>)))
 -- | Replace type class dictionary placeholders with inferred type class dictionaries
 replaceTypeClassDictionaries
   :: forall m
-   . (MonadState (CheckState m) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
   => Bool
   -> Expr
   -> m (Expr, [(Ident, InstanceContext, SourceConstraint)])
@@ -181,7 +181,7 @@ instance Monoid t => Monoid (Matched t) where
 -- return a type class dictionary reference.
 entails
   :: forall m
-   . (MonadState (CheckState m) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
   => SolverOptions
   -- ^ Solver options
   -> SourceConstraint
@@ -866,7 +866,7 @@ matches deps TypeClassDictionaryInScope{..} tys =
 -- | Add a dictionary for the constraint to the scope, and dictionaries
 -- for all implied superclass instances.
 newDictionaries
-  :: MonadState (CheckState m) m
+  :: MonadState CheckState m
   => [(Qualified (ProperName 'ClassName), Integer)]
   -> Qualified Ident
   -> SourceConstraint
diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
index 2e084f4587..8abaac31ca 100644
--- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
@@ -2,56 +2,60 @@
 
 -- |
 -- Interaction solver for Coercible constraints
+--
 module Language.PureScript.TypeChecker.Entailment.Coercible
-  ( GivenSolverState (..),
-    initialGivenSolverState,
-    solveGivens,
-    WantedSolverState (..),
-    initialWantedSolverState,
-    solveWanteds,
-    insoluble,
-  )
-where
-
-import Control.Applicative (empty, (<|>))
+  ( GivenSolverState(..)
+  , initialGivenSolverState
+  , solveGivens
+  , WantedSolverState(..)
+  , initialWantedSolverState
+  , solveWanteds
+  , insoluble
+  ) where
+
+import Prelude hiding (interact)
+
+import Control.Applicative ((<|>), empty)
 import Control.Arrow ((&&&))
-import Control.Monad (guard, unless, when, (<=<))
+import Control.Monad ((<=<), guard, unless, when)
 import Control.Monad.Error.Class (MonadError, catchError, throwError)
 import Control.Monad.State (MonadState, StateT, get, gets, modify, put)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
 import Control.Monad.Writer.Strict (MonadWriter, Writer, execWriter, runWriter, runWriterT, tell)
 import Data.Either (partitionEithers)
 import Data.Foldable (fold, foldl', for_, toList)
 import Data.Functor (($>))
 import Data.List (find)
-import Data.Map qualified as M
 import Data.Maybe (fromMaybe, isJust)
-import Data.Monoid (Any (..))
-import Data.Set qualified as S
+import Data.Monoid (Any(..))
 import Data.Text (Text)
-import Language.PureScript.Constants.Prim qualified as Prim
+
+import Data.Map qualified as M
+import Data.Set qualified as S
+
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (DataDeclType (..), Environment (..), TypeKind (..), unapplyKinds)
-import Language.PureScript.Errors (DeclarationRef (..), ErrorMessageHint (..), ExportSource, ImportDeclarationType (..), MultipleErrors, SimpleErrorMessage (..), SourceAnn, UnknownsHint (..), errorMessage, SourceSpan (SourceSpan))
-import Language.PureScript.Names (ModuleName, ProperName, ProperNameType (..), Qualified (..), byMaybeModuleName, toMaybeModuleName)
-import Language.PureScript.Roles (Role (..))
+import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds)
+import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..))
+import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName)
 import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds')
-import Language.PureScript.TypeChecker.Monad (CheckState (..))
+import Language.PureScript.TypeChecker.Monad (CheckState(..))
 import Language.PureScript.TypeChecker.Roles (lookupRoles)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, substituteType)
-import Language.PureScript.Types (Constraint (..), SourceType, Type (..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes)
-import Prelude hiding (interact)
+import Language.PureScript.Roles (Role(..))
+import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes)
+import Language.PureScript.Constants.Prim qualified as Prim
 
 -- | State of the given constraints solver.
-data GivenSolverState = GivenSolverState
-  { -- | A set of irreducible given constraints which do not interact together.
-    inertGivens :: [(SourceType, SourceType, SourceType)],
-    -- | Given constraints yet to be solved.
-    unsolvedGivens :: [(SourceType, SourceType)]
-  }
+data GivenSolverState =
+  GivenSolverState
+    { inertGivens :: [(SourceType, SourceType, SourceType)]
+  -- ^ A set of irreducible given constraints which do not interact together.
+    , unsolvedGivens :: [(SourceType, SourceType)]
+  -- ^ Given constraints yet to be solved.
+    }
 
 -- | Initialize the given constraints solver state with the givens to solve.
 initialGivenSolverState :: [(SourceType, SourceType)] -> GivenSolverState
@@ -113,57 +117,56 @@ initialGivenSolverState =
 --
 -- 3c. Otherwise canonicalization can succeed with derived constraints which we
 -- add to the unsolved queue and then go back to 1.
-solveGivens ::
-  (MonadError MultipleErrors m) =>
-  (MonadState (CheckState m) m) =>
-  Environment ->
-  StateT GivenSolverState m ()
-solveGivens env = go (0 :: Int)
-  where
-    go n = do
-      when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
-      gets unsolvedGivens >>= \case
-        [] -> pure ()
-        given : unsolved -> do
-          (k, a, b) <- lift $ unify given
-          GivenSolverState {..} <- get
-          lift (fst <$> runWriterT (canon env Nothing k a b `catchError` recover)) >>= \case
-            Irreducible -> case interact env (a, b) inertGivens of
-              Just (Simplified (a', b')) ->
-                put $ GivenSolverState {unsolvedGivens = (a', b') : unsolved, ..}
-              Just Discharged ->
-                put $ GivenSolverState {unsolvedGivens = unsolved, ..}
-              Nothing -> do
-                let (kickedOut, kept) = partitionEithers $ kicksOut env (a, b) <$> inertGivens
-                put $
-                  GivenSolverState
-                    { inertGivens = (k, a, b) : kept,
-                      unsolvedGivens = kickedOut <> unsolved
-                    }
-            Canonicalized deriveds ->
-              put $ GivenSolverState {unsolvedGivens = toList deriveds <> unsolved, ..}
-          go (n + 1)
-    recover _ = pure Irreducible
+solveGivens
+  :: MonadError MultipleErrors m
+  => MonadState CheckState m
+  => Environment
+  -> StateT GivenSolverState m ()
+solveGivens env = go (0 :: Int) where
+  go n = do
+    when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
+    gets unsolvedGivens >>= \case
+      [] -> pure ()
+      given : unsolved -> do
+        (k, a, b) <- lift $ unify given
+        GivenSolverState{..} <- get
+        lift (fst <$> runWriterT (canon env Nothing k a b `catchError` recover)) >>= \case
+          Irreducible -> case interact env (a, b) inertGivens of
+            Just (Simplified (a', b')) ->
+              put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. }
+            Just Discharged ->
+              put $ GivenSolverState { unsolvedGivens = unsolved, .. }
+            Nothing -> do
+              let (kickedOut, kept) = partitionEithers $ kicksOut env (a, b) <$> inertGivens
+              put $ GivenSolverState
+                { inertGivens = (k, a, b) : kept
+                , unsolvedGivens = kickedOut <> unsolved
+                }
+          Canonicalized deriveds ->
+            put $ GivenSolverState { unsolvedGivens = toList deriveds <> unsolved, .. }
+        go (n + 1)
+  recover _ = pure Irreducible
 
 -- | State of the wanted constraints solver.
-data WantedSolverState = WantedSolverState
-  { -- | A set of irreducible given constraints which do not interact together,
-    -- but which could interact with the wanteds.
-    inertGivens :: [(SourceType, SourceType, SourceType)],
-    -- | A set of irreducible wanted constraints which do not interact together,
-    -- nor with any given.
-    inertWanteds :: [(SourceType, SourceType, SourceType)],
-    -- | Wanted constraints yet to be solved.
-    unsolvedWanteds :: [(SourceType, SourceType)]
-  }
+data WantedSolverState =
+  WantedSolverState
+    { inertGivens :: [(SourceType, SourceType, SourceType)]
+  -- ^ A set of irreducible given constraints which do not interact together,
+  -- but which could interact with the wanteds.
+    , inertWanteds :: [(SourceType, SourceType, SourceType)]
+  -- ^ A set of irreducible wanted constraints which do not interact together,
+  -- nor with any given.
+    , unsolvedWanteds :: [(SourceType, SourceType)]
+  -- ^ Wanted constraints yet to be solved.
+    }
 
 -- | Initialize the wanted constraints solver state with an inert set of givens
 -- and the two parameters of the wanted to solve.
-initialWantedSolverState ::
-  [(SourceType, SourceType, SourceType)] ->
-  SourceType ->
-  SourceType ->
-  WantedSolverState
+initialWantedSolverState
+  :: [(SourceType, SourceType, SourceType)]
+  -> SourceType
+  -> SourceType
+  -> WantedSolverState
 initialWantedSolverState givens a b =
   WantedSolverState givens [] [(a, b)]
 
@@ -202,42 +205,40 @@ initialWantedSolverState givens a b =
 -- the irreducibles @Coercible a Boolean@ and @Coercible a Char@. Would we
 -- interact the latter with the former, we would report an insoluble
 -- @Coercible Boolean Char@.
-solveWanteds ::
-  (MonadError MultipleErrors m) =>
-  (MonadWriter [ErrorMessageHint] m) =>
-  (MonadState (CheckState m) m) =>
-  Environment ->
-  StateT WantedSolverState m ()
-solveWanteds env = go (0 :: Int)
-  where
-    go n = do
-      when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
-      gets unsolvedWanteds >>= \case
-        [] -> pure ()
-        wanted : unsolved -> do
-          (k, a, b) <- lift $ unify wanted
-          WantedSolverState {..} <- get
-          lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case
-            Irreducible -> case interact env (a, b) inertGivens of
-              Just (Simplified (a', b')) ->
-                put $ WantedSolverState {unsolvedWanteds = (a', b') : unsolved, ..}
-              Just Discharged ->
-                put $ WantedSolverState {unsolvedWanteds = unsolved, ..}
-              Nothing ->
-                put $
-                  WantedSolverState
-                    { inertWanteds = (k, a, b) : inertWanteds,
-                      unsolvedWanteds = unsolved,
-                      ..
-                    }
-            Canonicalized deriveds ->
-              put $ WantedSolverState {unsolvedWanteds = toList deriveds <> unsolved, ..}
-          go (n + 1)
-    recover wanted givens errors =
-      case interact env wanted givens of
-        Nothing -> throwError errors
-        Just (Simplified wanted') -> pure . Canonicalized $ S.singleton wanted'
-        Just Discharged -> pure $ Canonicalized mempty
+solveWanteds
+  :: MonadError MultipleErrors m
+  => MonadWriter [ErrorMessageHint] m
+  => MonadState CheckState m
+  => Environment
+  -> StateT WantedSolverState m ()
+solveWanteds env = go (0 :: Int) where
+  go n = do
+    when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
+    gets unsolvedWanteds >>= \case
+      [] -> pure ()
+      wanted : unsolved -> do
+        (k, a, b) <- lift $ unify wanted
+        WantedSolverState{..} <- get
+        lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case
+          Irreducible -> case interact env (a, b) inertGivens of
+            Just (Simplified (a', b')) ->
+              put $ WantedSolverState { unsolvedWanteds = (a', b') : unsolved, .. }
+            Just Discharged ->
+              put $ WantedSolverState { unsolvedWanteds = unsolved, .. }
+            Nothing ->
+              put $ WantedSolverState
+                { inertWanteds = (k, a, b) : inertWanteds
+                , unsolvedWanteds = unsolved
+                , ..
+                }
+          Canonicalized deriveds ->
+            put $ WantedSolverState { unsolvedWanteds = toList deriveds <> unsolved, .. }
+        go (n + 1)
+  recover wanted givens errors =
+    case interact env wanted givens of
+      Nothing -> throwError errors
+      Just (Simplified wanted') -> pure . Canonicalized $ S.singleton wanted'
+      Just Discharged -> pure $ Canonicalized mempty
 
 -- | Unifying constraints arguments kinds isn't strictly necessary but yields
 -- better error messages. For instance we cannot solve the constraint
@@ -269,52 +270,50 @@ solveWanteds env = go (0 :: Int)
 -- so applying the substitution to @D \@k1@ and @D \@k2@ yields a
 -- @Coercible (D \@k) (D \@k)@ constraint which could be trivially solved by
 -- reflexivity instead of having to saturate the type constructors.
-unify ::
-  (MonadError MultipleErrors m) =>
-  (MonadState (CheckState m) m) =>
-  (SourceType, SourceType) ->
-  m (SourceType, SourceType, SourceType)
+unify
+  :: MonadError MultipleErrors m
+  => MonadState CheckState m
+  => (SourceType, SourceType)
+  -> m (SourceType, SourceType, SourceType)
 unify (a, b) = do
   let kindOf = sequence . (id &&& elaborateKind) <=< replaceAllTypeSynonyms
   (a', kind) <- kindOf a
   (b', kind') <- kindOf b
   unifyKinds' kind kind'
   subst <- gets checkSubstitution
-  pure
-    ( substituteType subst kind,
-      substituteType subst a',
-      substituteType subst b'
-    )
+  pure ( substituteType subst kind
+       , substituteType subst a'
+       , substituteType subst b'
+       )
 
 -- | A successful interaction between an irreducible constraint and an inert
 --  given constraint has two possible outcomes:
 data Interaction
-  = -- | The interaction can yield a derived constraint,
-    Simplified (SourceType, SourceType)
-  | -- | or we can learn the irreducible constraint is redundant and discharge it.
-    Discharged
+  = Simplified (SourceType, SourceType)
+  -- ^ The interaction can yield a derived constraint,
+  | Discharged
+  -- ^ or we can learn the irreducible constraint is redundant and discharge it.
 
 -- | Interact an irreducible constraint with an inert set of givens.
-interact ::
-  Environment ->
-  (SourceType, SourceType) ->
-  [(SourceType, SourceType, SourceType)] ->
-  Maybe Interaction
-interact env irred = go
-  where
-    go [] = Nothing
-    go (inert : _)
-      | canDischarge inert irred = Just Discharged
-      | Just derived <- interactSameTyVar inert irred = Just $ Simplified derived
-      | Just derived <- interactDiffTyVar env inert irred = Just $ Simplified derived
-    go (_ : inerts) = go inerts
+interact
+  :: Environment
+  -> (SourceType, SourceType)
+  -> [(SourceType, SourceType, SourceType)]
+  -> Maybe Interaction
+interact env irred = go where
+  go [] = Nothing
+  go (inert : _)
+    | canDischarge inert irred = Just Discharged
+    | Just derived <- interactSameTyVar inert irred = Just $ Simplified derived
+    | Just derived <- interactDiffTyVar env inert irred = Just $ Simplified derived
+  go (_ : inerts) = go inerts
 
 -- | A given constraint of the form @Coercible a b@ can discharge constraints
 -- of the form @Coercible a b@ and @Coercible b a@.
-canDischarge ::
-  (SourceType, SourceType, SourceType) ->
-  (SourceType, SourceType) ->
-  Bool
+canDischarge
+  :: (SourceType, SourceType, SourceType)
+  -> (SourceType, SourceType)
+  -> Bool
 canDischarge (_, a, b) constraint =
   (a, b) == constraint || (b, a) == constraint
 
@@ -336,13 +335,13 @@ canDischarge (_, a, b) constraint =
 -- right to yield @Coercible a (D (N a))@. Would it interact with the non
 -- canonical given @Coercible a (D a)@ it would give @Coercible (D a) (D (N a))@,
 -- then decompose back to @Coercible a (N a)@.
-interactSameTyVar ::
-  (SourceType, SourceType, SourceType) ->
-  (SourceType, SourceType) ->
-  Maybe (SourceType, SourceType)
+interactSameTyVar
+  :: (SourceType, SourceType, SourceType)
+  -> (SourceType, SourceType)
+  -> Maybe (SourceType, SourceType)
 interactSameTyVar (_, tv1, ty1) (tv2, ty2)
-  | tv1 == tv2 && isCanonicalTyVarEq (tv1, ty1) && isCanonicalTyVarEq (tv2, ty2) =
-      Just (ty1, ty2)
+  | tv1 == tv2 && isCanonicalTyVarEq (tv1, ty1) && isCanonicalTyVarEq (tv2, ty2)
+  = Just (ty1, ty2)
   | otherwise = Nothing
 
 -- | Two canonical constraints of the form @Coercible tv1 ty1@ and
@@ -361,15 +360,15 @@ interactSameTyVar (_, tv1, ty1) (tv2, ty2)
 -- yield an irreducible canonical wanted @Coercible a b@. Would it interact with
 -- the non canonical given @Coercible b (D b)@ it would give @Coercible a (D b)@,
 -- which would keep interacting indefinitely with the given.
-interactDiffTyVar ::
-  Environment ->
-  (SourceType, SourceType, SourceType) ->
-  (SourceType, SourceType) ->
-  Maybe (SourceType, SourceType)
+interactDiffTyVar
+  :: Environment
+  -> (SourceType, SourceType, SourceType)
+  -> (SourceType, SourceType)
+  -> Maybe (SourceType, SourceType)
 interactDiffTyVar env (_, tv1, ty1) (tv2, ty2)
-  | tv1 /= tv2 && isCanonicalTyVarEq (tv2, ty2),
-    (ty2', Any True) <- runWriter $ rewrite env (tv1, ty1) ty2 =
-      Just (tv2, ty2')
+  | tv1 /= tv2 && isCanonicalTyVarEq (tv2, ty2)
+  , (ty2', Any True) <- runWriter $ rewrite env (tv1, ty1) ty2
+  = Just (tv2, ty2')
   | otherwise = Nothing
 
 -- | A canonical constraint of the form @Coercible tv1 ty1@ can rewrite the
@@ -377,56 +376,50 @@ interactDiffTyVar env (_, tv1, ty1) (tv2, ty2)
 -- by substituting @ty1@ for every occurrence of @tv1@ at representational and
 -- phantom role in @ty2@. Nominal occurrences are left untouched.
 rewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Writer Any SourceType
-rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go
-  where
-    go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1
-    go ty2
-      | (Skolem {}, _, xs) <- unapplyTypes ty2,
-        not $ null xs =
-          rewriteTyVarApp go ty2
-      | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do
-          rewriteTyConApp go (lookupRoles env tyName) ty2
-    go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k
-    go (ForAll sa vis tv k ty scope) = ForAll sa vis tv k <$> go ty <*> pure scope
-    go (ConstrainedType sa Constraint {..} ty)
-      | s1 `S.notMember` foldMap skolems constraintArgs =
-          ConstrainedType sa Constraint {..} <$> go ty
-    go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest
-    go (KindedType sa ty k) = KindedType sa <$> go ty <*> pure k
-    go ty2 = pure ty2
+rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where
+  go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1
+  go ty2 | (Skolem{}, _, xs) <- unapplyTypes ty2, not $ null xs =
+    rewriteTyVarApp go ty2
+         | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do
+    rewriteTyConApp go (lookupRoles env tyName) ty2
+  go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k
+  go (ForAll sa vis tv k ty scope) = ForAll sa vis tv k <$> go ty <*> pure scope
+  go (ConstrainedType sa Constraint{..} ty) | s1 `S.notMember` foldMap skolems constraintArgs =
+    ConstrainedType sa Constraint{..} <$> go ty
+  go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest
+  go (KindedType sa ty k) = KindedType sa <$> go ty <*> pure k
+  go ty2 = pure ty2
 rewrite _ _ = pure
 
 -- | Rewrite the head of a type application of the form @tv a_0 .. a_n@.
-rewriteTyVarApp ::
-  (Applicative m) =>
-  (SourceType -> m SourceType) ->
-  SourceType ->
-  m SourceType
-rewriteTyVarApp f = go
-  where
-    go (TypeApp sa lhs rhs) =
-      TypeApp sa <$> go lhs <*> pure rhs
-    go (KindApp sa ty k) =
-      KindApp sa <$> go ty <*> pure k
-    go ty = f ty
+rewriteTyVarApp
+  :: Applicative m
+  => (SourceType -> m SourceType)
+  -> SourceType
+  -> m SourceType
+rewriteTyVarApp f = go where
+  go (TypeApp sa lhs rhs) =
+    TypeApp sa <$> go lhs <*> pure rhs
+  go (KindApp sa ty k) =
+    KindApp sa <$> go ty <*> pure k
+  go ty = f ty
 
 -- | Rewrite the representational and phantom arguments of a type application
 -- of the form @D a_0 .. a_n@.
-rewriteTyConApp ::
-  (Applicative m) =>
-  (SourceType -> m SourceType) ->
-  [Role] ->
-  SourceType ->
-  m SourceType
-rewriteTyConApp f = go
-  where
-    go (role : roles) (TypeApp sa lhs rhs) =
-      TypeApp sa <$> go roles lhs <*> case role of
-        Nominal -> pure rhs
-        _ -> f rhs
-    go roles (KindApp sa ty k) =
-      KindApp sa <$> go roles ty <*> pure k
-    go _ ty = pure ty
+rewriteTyConApp
+  :: Applicative m
+  => (SourceType -> m SourceType)
+  -> [Role]
+  -> SourceType
+  -> m SourceType
+rewriteTyConApp f = go where
+  go (role : roles) (TypeApp sa lhs rhs) =
+    TypeApp sa <$> go roles lhs <*> case role of
+      Nominal -> pure rhs
+      _ -> f rhs
+  go roles (KindApp sa ty k) =
+    KindApp sa <$> go roles ty <*> pure k
+  go _ ty = pure ty
 
 canRewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Bool
 canRewrite env irred = getAny . execWriter . rewrite env irred
@@ -447,14 +440,14 @@ canRewrite env irred = getAny . execWriter . rewrite env irred
 -- we not kick out the former when adding the latter to the inert set we would
 -- not be able to rewrite it to @Coercible a (g b)@ and discharge the wanted,
 -- but inverting the givens would work.
-kicksOut ::
-  Environment ->
-  (SourceType, SourceType) ->
-  (SourceType, SourceType, SourceType) ->
-  Either (SourceType, SourceType) (SourceType, SourceType, SourceType)
+kicksOut
+  :: Environment
+  -> (SourceType, SourceType)
+  -> (SourceType, SourceType, SourceType)
+  -> Either (SourceType, SourceType) (SourceType, SourceType, SourceType)
 kicksOut env irred (_, tv2, ty2)
-  | isCanonicalTyVarEq (tv2, ty2) && canRewrite env irred ty2 =
-      Left (tv2, ty2)
+  | isCanonicalTyVarEq (tv2, ty2) && canRewrite env irred ty2
+  = Left (tv2, ty2)
 kicksOut _ _ inert = Right inert
 
 -- | A constraint of the form @Coercible tv ty@ is canonical when @tv@ does not
@@ -464,94 +457,91 @@ isCanonicalTyVarEq (Skolem _ _ _ s _, ty) = not $ occurs s ty
 isCanonicalTyVarEq _ = False
 
 occurs :: Int -> SourceType -> Bool
-occurs s1 = everythingOnTypes (||) go
-  where
-    go (Skolem _ _ _ s2 _) | s1 == s2 = True
-    go _ = False
+occurs s1 = everythingOnTypes (||) go where
+  go (Skolem _ _ _ s2 _) | s1 == s2 = True
+  go _ = False
 
 skolems :: SourceType -> S.Set Int
-skolems = everythingOnTypes (<>) go
-  where
-    go (Skolem _ _ _ s _) = S.singleton s
-    go _ = mempty
+skolems = everythingOnTypes (<>) go where
+  go (Skolem _ _ _ s _) = S.singleton s
+  go _ = mempty
 
 -- | A successful canonicalization result has two possible outcomes:
 data Canonicalized
-  = -- | Canonicalization can yield a set of derived constraints,
-    Canonicalized (S.Set (SourceType, SourceType))
-  | -- | or we can learn the constraint is irreducible. Irreducibility is not
-    -- necessarily an error, we may make further progress by interacting with
-    -- inerts.
-    Irreducible
+  = Canonicalized (S.Set (SourceType, SourceType))
+  -- ^ Canonicalization can yield a set of derived constraints,
+  | Irreducible
+  -- ^ or we can learn the constraint is irreducible. Irreducibility is not
+  -- necessarily an error, we may make further progress by interacting with
+  -- inerts.
 
 -- | Canonicalization takes a wanted constraint and try to reduce it to a set of
 -- simpler constraints whose satisfaction will imply the goal.
-canon ::
-  (MonadError MultipleErrors m) =>
-  (MonadWriter [ErrorMessageHint] m) =>
-  (MonadState (CheckState m) m) =>
-  Environment ->
-  Maybe [(SourceType, SourceType, SourceType)] ->
-  SourceType ->
-  SourceType ->
-  SourceType ->
-  m Canonicalized
+canon
+  :: MonadError MultipleErrors m
+  => MonadWriter [ErrorMessageHint] m
+  => MonadState CheckState m
+  => Environment
+  -> Maybe [(SourceType, SourceType, SourceType)]
+  -> SourceType
+  -> SourceType
+  -> SourceType
+  -> m Canonicalized
 canon env givens k a b =
   maybe (throwError $ insoluble k a b) pure <=< runMaybeT $
-    canonRefl a b
-      <|> canonUnsaturatedHigherKindedType env a b
-      <|> canonRow a b
-      -- We unwrap newtypes before trying the decomposition rules because it let
-      -- us solve more constraints.
-      --
-      -- For instance the declarations:
-      --
-      -- @
-      -- newtype N f a = N (f a)
-      --
-      -- example :: forall a b. Coercible a b => N Maybe a -> N Maybe b
-      -- example = coerce
-      -- @
-      --
-      -- yield the wanted @Coercible (N Maybe a) (N Maybe b)@ which we cannot
-      -- decompose because the second parameter of @N@ is nominal. On the other
-      -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@
-      -- which we can then decompose to @Coercible a b@ and discharge with the
-      -- given.
-      <|> canonNewtypeLeft env a b
-      <|> canonNewtypeRight env a b
-      <|> canonDecomposition env a b
-      <|> canonDecompositionFailure env k a b
-      <|> canonNewtypeDecomposition env givens a b
-      <|> canonNewtypeDecompositionFailure a b
-      <|> canonTypeVars a b
-      <|> canonTypeVarLeft a b
-      <|> canonTypeVarRight a b
-      <|> canonApplicationLeft a b
-      <|> canonApplicationRight a b
-
-insoluble ::
-  SourceType ->
-  SourceType ->
-  SourceType ->
-  MultipleErrors
+        canonRefl a b
+    <|> canonUnsaturatedHigherKindedType env a b
+    <|> canonRow a b
+    -- We unwrap newtypes before trying the decomposition rules because it let
+    -- us solve more constraints.
+    --
+    -- For instance the declarations:
+    --
+    -- @
+    -- newtype N f a = N (f a)
+    --
+    -- example :: forall a b. Coercible a b => N Maybe a -> N Maybe b
+    -- example = coerce
+    -- @
+    --
+    -- yield the wanted @Coercible (N Maybe a) (N Maybe b)@ which we cannot
+    -- decompose because the second parameter of @N@ is nominal. On the other
+    -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@
+    -- which we can then decompose to @Coercible a b@ and discharge with the
+    -- given.
+    <|> canonNewtypeLeft env a b
+    <|> canonNewtypeRight env a b
+    <|> canonDecomposition env a b
+    <|> canonDecompositionFailure env k a b
+    <|> canonNewtypeDecomposition env givens a b
+    <|> canonNewtypeDecompositionFailure a b
+    <|> canonTypeVars a b
+    <|> canonTypeVarLeft a b
+    <|> canonTypeVarRight a b
+    <|> canonApplicationLeft a b
+    <|> canonApplicationRight a b
+
+insoluble
+  :: SourceType
+  -> SourceType
+  -> SourceType
+  -> MultipleErrors
 insoluble k a b =
   -- We can erase kind applications when determining whether to show the
   -- "Consider adding a type annotation" hint, because annotating kinds to
   -- instantiate unknowns in Coercible constraints should never resolve
   -- NoInstanceFound errors.
-  errorMessage $
-    NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] $
-      if any containsUnknowns [a, b] then Unknowns else NoUnknowns
+  errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] 
+    $ if any containsUnknowns [a, b] then Unknowns else NoUnknowns
 
 -- | Constraints of the form @Coercible a b@ can be solved if the two arguments
 -- are the same. Since we currently don't support higher-rank arguments in
 -- instance heads, term equality is a sufficient notion of "the same".
-canonRefl ::
-  (Monad m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonRefl
+  :: Monad m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonRefl a b =
   guard (a == b) $> Canonicalized mempty
 
@@ -559,27 +549,25 @@ canonRefl a b =
 -- both arguments have kind @k1 -> k2@, yield a constraint
 -- @Coercible (T1 a_0 .. a_n c_0 .. c_m) (T2 b_0 .. b_n c_0 .. c_m)@, where both
 -- arguments are fully saturated with the same unknowns and have kind @Type@.
-canonUnsaturatedHigherKindedType ::
-  forall m.
-  (MonadError MultipleErrors m) =>
-  -- (MonadState (CheckState (MaybeT m)) m) =>
-  (MonadState (CheckState m) m) =>
-  Environment ->
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonUnsaturatedHigherKindedType
+  :: MonadError MultipleErrors m
+  => MonadState CheckState m
+  => Environment
+  -> SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonUnsaturatedHigherKindedType env a b
-  | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a,
-    (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env),
-    (aks, _) <- unapplyKinds ak,
-    length axs < length aks = do
+  | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a
+  , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env)
+  , (aks, _) <- unapplyKinds ak
+  , length axs < length aks = do
       ak' <- lift $ do
         let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak
             instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps
-        unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> (freshKindWithKind :: SourceSpan -> SourceType -> m SourceType) ss k) $ drop (length akapps) kvs
+        unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs
         pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak'
       let (aks', _) = unapplyKinds ak'
-      tys <- traverse (freshTypeWithKind ) $ drop (length axs) aks'
+      tys <- traverse freshTypeWithKind $ drop (length axs) aks'
       let a' = foldl' srcTypeApp a tys
           b' = foldl' srcTypeApp b tys
       pure . Canonicalized $ S.singleton (a', b')
@@ -589,23 +577,23 @@ canonUnsaturatedHigherKindedType env a b
 -- @Coercible ( label_0 :: a_0, .. label_n :: a_n | r ) ( label_0 :: b_0, .. label_n :: b_n | s )@
 -- yield a constraint @Coercible r s@ and constraints on the types for each
 -- label in both rows. Labels exclusive to one row yield a failure.
-canonRow ::
-  (MonadError MultipleErrors m) =>
-  (MonadState (CheckState (MaybeT m)) m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonRow
+  :: MonadError MultipleErrors m
+  => MonadState CheckState m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonRow a b
-  | RCons {} <- a =
+  | RCons{} <- a =
       case alignRowsWith (const (,)) a b of
         -- We throw early when a bare unknown remains on either side after
         -- aligning the rows because we don't know how to canonicalize them yet
         -- and the unification error thrown when the rows are misaligned should
         -- not mention unknowns.
-        (_, (([], u@TUnknown {}), rl2)) -> do
+        (_, (([], u@TUnknown{}), rl2)) -> do
           k <- elaborateKind u
           throwError $ insoluble k u (rowFromList rl2)
-        (_, (rl1, ([], u@TUnknown {}))) -> do
+        (_, (rl1, ([], u@TUnknown{}))) -> do
           k <- elaborateKind u
           throwError $ insoluble k (rowFromList rl1) u
         (deriveds, (([], tail1), ([], tail2))) -> do
@@ -616,68 +604,67 @@ canonRow a b
 
 -- | Unwrapping a newtype can fails in two ways:
 data UnwrapNewtypeError
-  = -- | The newtype might wrap an infinite newtype chain. We may think that this
-    -- is already handled by the solver depth check, but failing to unwrap
-    -- infinite chains of newtypes let us try other rules.
-    --
-    -- For instance the declarations:
-    --
-    -- @
-    -- newtype N a = N (N a)
-    -- type role N representational
-    --
-    -- example :: forall a b. Coercible a b => N a -> N b
-    -- example = coerce
-    -- @
-    --
-    -- yield a wanted @Coercible (N a) (N b)@ that we can decompose to
-    -- @Coercible a b@ then discharge with the given if the newtype
-    -- unwrapping rules do not apply.
-    CannotUnwrapInfiniteNewtypeChain
-  | -- | The constructor may not be in scope or may not belong to a newtype.
-    CannotUnwrapConstructor
+  = CannotUnwrapInfiniteNewtypeChain
+  -- ^ The newtype might wrap an infinite newtype chain. We may think that this
+  -- is already handled by the solver depth check, but failing to unwrap
+  -- infinite chains of newtypes let us try other rules.
+  --
+  -- For instance the declarations:
+  --
+  -- @
+  -- newtype N a = N (N a)
+  -- type role N representational
+  --
+  -- example :: forall a b. Coercible a b => N a -> N b
+  -- example = coerce
+  -- @
+  --
+  -- yield a wanted @Coercible (N a) (N b)@ that we can decompose to
+  -- @Coercible a b@ then discharge with the given if the newtype
+  -- unwrapping rules do not apply.
+  | CannotUnwrapConstructor
+  -- ^ The constructor may not be in scope or may not belong to a newtype.
 
 -- | Unwraps a newtype and yields its underlying type with the newtype arguments
 -- substituted in (e.g. @N[D/a] = D@ given @newtype N a = N a@ and @data D = D@).
-unwrapNewtype ::
-  (MonadState (CheckState m) m) =>
-  (MonadWriter [ErrorMessageHint] m) =>
-  Environment ->
-  SourceType ->
-  m (Either UnwrapNewtypeError SourceType)
-unwrapNewtype env = go (0 :: Int)
-  where
-    go n ty = runExceptT $ do
-      when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain
-      (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports
-      case unapplyTypes ty of
-        (TypeConstructor _ newtypeName, ks, xs)
-          | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <-
-              lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName ks,
-            -- We refuse to unwrap newtypes over polytypes because we don't know how
-            -- to canonicalize them yet and we'd rather try to make progress with
-            -- another rule.
-            isMonoType wrappedTy -> do
-              unless inScope $ do
-                tell [MissingConstructorImportForCoercible newtypeCtorName]
-                throwError CannotUnwrapConstructor
-              for_ fromModuleName $ flip addConstructorImportForCoercible newtypeCtorName
-              let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy
-              ExceptT (go (n + 1) wrappedTySub) `catchError` \case
-                CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain
-                CannotUnwrapConstructor -> pure wrappedTySub
-        _ -> throwError CannotUnwrapConstructor
-    addConstructorImportForCoercible fromModuleName newtypeCtorName = modify $ \st ->
-      st {checkConstructorImportsForCoercible = S.insert (fromModuleName, newtypeCtorName) $ checkConstructorImportsForCoercible st}
+unwrapNewtype
+  :: MonadState CheckState m
+  => MonadWriter [ErrorMessageHint] m
+  => Environment
+  -> SourceType
+  -> m (Either UnwrapNewtypeError SourceType)
+unwrapNewtype env = go (0 :: Int) where
+  go n ty = runExceptT $ do
+    when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain
+    (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports
+    case unapplyTypes ty of
+      (TypeConstructor _ newtypeName, ks, xs)
+        | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <-
+            lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName ks
+        -- We refuse to unwrap newtypes over polytypes because we don't know how
+        -- to canonicalize them yet and we'd rather try to make progress with
+        -- another rule.
+        , isMonoType wrappedTy -> do
+            unless inScope $ do
+              tell [MissingConstructorImportForCoercible newtypeCtorName]
+              throwError CannotUnwrapConstructor
+            for_ fromModuleName $ flip addConstructorImportForCoercible newtypeCtorName
+            let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy
+            ExceptT (go (n + 1) wrappedTySub) `catchError` \case
+              CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain
+              CannotUnwrapConstructor -> pure wrappedTySub
+      _ -> throwError CannotUnwrapConstructor
+  addConstructorImportForCoercible fromModuleName newtypeCtorName = modify $ \st ->
+    st { checkConstructorImportsForCoercible = S.insert (fromModuleName, newtypeCtorName) $ checkConstructorImportsForCoercible st }
 
 -- | Looks up a given name and, if it names a newtype, returns the names of the
 -- type's parameters, the type the newtype wraps and the names of the type's
 -- fields.
-lookupNewtypeConstructor ::
-  Environment ->
-  Qualified (ProperName 'TypeName) ->
-  [SourceType] ->
-  Maybe ([Text], ProperName 'ConstructorName, SourceType)
+lookupNewtypeConstructor
+  :: Environment
+  -> Qualified (ProperName 'TypeName)
+  -> [SourceType]
+  -> Maybe ([Text], ProperName 'ConstructorName, SourceType)
 lookupNewtypeConstructor env qualifiedNewtypeName ks = do
   (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env)
   let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk
@@ -687,19 +674,19 @@ lookupNewtypeConstructor env qualifiedNewtypeName ks = do
 -- | Behaves like 'lookupNewtypeConstructor' but also returns whether the
 -- newtype constructor is in scope and the module from which it is imported, or
 -- 'Nothing' if it is defined in the current module.
-lookupNewtypeConstructorInScope ::
-  Environment ->
-  Maybe ModuleName ->
-  [ ( SourceAnn,
-      ModuleName,
-      ImportDeclarationType,
-      Maybe ModuleName,
-      M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
-    )
-  ] ->
-  Qualified (ProperName 'TypeName) ->
-  [SourceType] ->
-  Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType)
+lookupNewtypeConstructorInScope
+  :: Environment
+  -> Maybe ModuleName
+  -> [ ( SourceAnn
+       , ModuleName
+       , ImportDeclarationType
+       , Maybe ModuleName
+       , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
+       )
+     ]
+  -> Qualified (ProperName 'TypeName)
+  -> [SourceType]
+  -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType)
 lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do
   let fromModule = find isNewtypeCtorImported currentModuleImports
       fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule
@@ -710,27 +697,27 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali
   (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks
   pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy)
   where
-    isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) =
-      case M.lookup newtypeName exportedTypes of
-        Just ([_], _) -> case importDeclType of
-          Implicit -> True
-          Explicit refs -> any isNewtypeCtorRef refs
-          Hiding refs -> not $ any isNewtypeCtorRef refs
-        _ -> False
-    isNewtypeCtorRef = \case
-      TypeRef _ importedTyName Nothing -> importedTyName == newtypeName
-      TypeRef _ importedTyName (Just [_]) -> importedTyName == newtypeName
+  isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) =
+    case M.lookup newtypeName exportedTypes of
+      Just ([_], _) -> case importDeclType of
+        Implicit -> True
+        Explicit refs -> any isNewtypeCtorRef refs
+        Hiding refs -> not $ any isNewtypeCtorRef refs
       _ -> False
+  isNewtypeCtorRef = \case
+    TypeRef _ importedTyName Nothing -> importedTyName == newtypeName
+    TypeRef _ importedTyName (Just [_]) -> importedTyName == newtypeName
+    _ -> False
 
 -- | Constraints of the form @Coercible (N a_0 .. a_n) b@ yield a constraint
 -- @Coercible a b@ if unwrapping the newtype yields @a@.
-canonNewtypeLeft ::
-  (MonadState (CheckState m) m) =>
-  (MonadWriter [ErrorMessageHint] m) =>
-  Environment ->
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonNewtypeLeft
+  :: MonadState CheckState m
+  => MonadWriter [ErrorMessageHint] m
+  => Environment
+  -> SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonNewtypeLeft env a b =
   unwrapNewtype env a >>= \case
     Left CannotUnwrapInfiniteNewtypeChain -> empty
@@ -739,13 +726,13 @@ canonNewtypeLeft env a b =
 
 -- | Constraints of the form @Coercible a (N b_0 .. b_n)@ yield a constraint
 -- @Coercible a b@ if unwrapping the newtype yields @b@.
-canonNewtypeRight ::
-  (MonadState (CheckState m) m) =>
-  (MonadWriter [ErrorMessageHint] m) =>
-  Environment ->
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonNewtypeRight
+  :: MonadState CheckState m
+  => MonadWriter [ErrorMessageHint] m
+  => Environment
+  -> SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonNewtypeRight env =
   flip $ canonNewtypeLeft env
 
@@ -762,13 +749,13 @@ canonNewtypeRight env =
 --
 -- We can decompose @Coercible (D a b d) (D a c e)@ into @Coercible b c@, but
 -- decomposing @Coercible (D a c d) (D b c d)@ would fail.
-decompose ::
-  (MonadError MultipleErrors m) =>
-  Environment ->
-  Qualified (ProperName 'TypeName) ->
-  [SourceType] ->
-  [SourceType] ->
-  m Canonicalized
+decompose
+  :: MonadError MultipleErrors m
+  => Environment
+  -> Qualified (ProperName 'TypeName)
+  -> [SourceType]
+  -> [SourceType]
+  -> m Canonicalized
 decompose env tyName axs bxs = do
   let roles = lookupRoles env tyName
       f role ax bx = case role of
@@ -791,36 +778,36 @@ decompose env tyName axs bxs = do
 
 -- | Constraints of the form @Coercible (D a_0 .. a_n) (D b_0 .. b_n)@, where
 -- @D@ is not a newtype, yield constraints on their arguments.
-canonDecomposition ::
-  (MonadError MultipleErrors m) =>
-  Environment ->
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonDecomposition
+  :: MonadError MultipleErrors m
+  => Environment
+  -> SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonDecomposition env a b
-  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a,
-    (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b,
-    aTyName == bTyName,
-    Nothing <- lookupNewtypeConstructor env aTyName [] =
+  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a
+  , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b
+  , aTyName == bTyName
+  , Nothing <- lookupNewtypeConstructor env aTyName [] =
       decompose env aTyName axs bxs
   | otherwise = empty
 
 -- | Constraints of the form @Coercible (D1 a_0 .. a_n) (D2 b_0 .. b_n)@, where
 -- @D1@ and @D2@ are different type constructors and neither of them are
 -- newtypes, are insoluble.
-canonDecompositionFailure ::
-  (MonadError MultipleErrors m) =>
-  Environment ->
-  SourceType ->
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonDecompositionFailure
+  :: MonadError MultipleErrors m
+  => Environment
+  -> SourceType
+  -> SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonDecompositionFailure env k a b
-  | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a,
-    (TypeConstructor _ bTyName, _, _) <- unapplyTypes b,
-    aTyName /= bTyName,
-    Nothing <- lookupNewtypeConstructor env aTyName [],
-    Nothing <- lookupNewtypeConstructor env bTyName [] =
+  | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a
+  , (TypeConstructor _ bTyName, _, _) <- unapplyTypes b
+  , aTyName /= bTyName
+  , Nothing <- lookupNewtypeConstructor env aTyName []
+  , Nothing <- lookupNewtypeConstructor env bTyName [] =
       throwError $ insoluble k a b
   | otherwise = empty
 
@@ -857,18 +844,18 @@ canonDecompositionFailure env k a b
 -- is out of scope. Would we decompose the wanted
 -- @Coercible (Const a a) (Const a b)@ to @Coercible a b@ we would not be able
 -- to discharge it with the given.
-canonNewtypeDecomposition ::
-  (MonadError MultipleErrors m) =>
-  Environment ->
-  Maybe [(SourceType, SourceType, SourceType)] ->
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonNewtypeDecomposition
+  :: MonadError MultipleErrors m
+  => Environment
+  -> Maybe [(SourceType, SourceType, SourceType)]
+  -> SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonNewtypeDecomposition env (Just givens) a b
-  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a,
-    (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b,
-    aTyName == bTyName,
-    Just _ <- lookupNewtypeConstructor env aTyName [] = do
+  | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a
+  , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b
+  , aTyName == bTyName
+  , Just _ <- lookupNewtypeConstructor env aTyName [] = do
       let givensCanDischarge = any (\given -> canDischarge given (a, b)) givens
       guard $ not givensCanDischarge
       decompose env aTyName axs bxs
@@ -877,15 +864,15 @@ canonNewtypeDecomposition _ _ _ _ = empty
 -- | Constraints of the form @Coercible (N1 a_0 .. a_n) (N2 b_0 .. b_n)@, where
 -- @N1@ and @N2@ are different type constructors and either of them is a
 -- newtype whose constructor is out of scope, are irreducible.
-canonNewtypeDecompositionFailure ::
-  (Monad m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonNewtypeDecompositionFailure
+  :: Monad m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonNewtypeDecompositionFailure a b
-  | (TypeConstructor {}, _, _) <- unapplyTypes a,
-    (TypeConstructor {}, _, _) <- unapplyTypes b =
-      pure Irreducible
+  | (TypeConstructor{}, _, _) <- unapplyTypes a
+  , (TypeConstructor{}, _, _) <- unapplyTypes b
+  = pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible tv1 tv2@ may be irreducibles, but only
@@ -902,59 +889,58 @@ canonNewtypeDecompositionFailure a b
 -- yields the irreducible givens @Coercible a b@ and @Coercible b a@ which would
 -- repeatedly kick each other out the inert set whereas reordering the latter to
 -- @Coercible a b@ makes it redundant and let us discharge it.
-canonTypeVars ::
-  (Monad m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonTypeVars
+  :: Monad m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonTypeVars a b
-  | Skolem _ tv1 _ _ _ <- a,
-    Skolem _ tv2 _ _ _ <- b,
-    tv2 < tv1 =
-      pure . Canonicalized $ S.singleton (b, a)
-  | Skolem {} <- a,
-    Skolem {} <- b =
-      pure Irreducible
+  | Skolem _ tv1 _ _ _ <- a
+  , Skolem _ tv2 _ _ _ <- b
+  , tv2 < tv1
+  = pure . Canonicalized $ S.singleton (b, a)
+  | Skolem{} <- a, Skolem{} <- b
+  = pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible tv ty@ are irreducibles.
-canonTypeVarLeft ::
-  (Monad m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonTypeVarLeft
+  :: Monad m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonTypeVarLeft a _
-  | Skolem {} <- a = pure Irreducible
+  | Skolem{} <- a = pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible ty tv@ are reordered to
 -- @Coercible tv ty@ to satisfy the canonicality requirement of having the type
 -- variable on the left.
-canonTypeVarRight ::
-  (Monad m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonTypeVarRight
+  :: Monad m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonTypeVarRight a b
-  | Skolem {} <- b = pure . Canonicalized $ S.singleton (b, a)
+  | Skolem{} <- b = pure . Canonicalized $ S.singleton (b, a)
   | otherwise = empty
 
 -- | Constraints of the form @Coercible (f a_0 .. a_n) b@ are irreducibles.
-canonApplicationLeft ::
-  (Monad m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonApplicationLeft
+  :: Monad m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonApplicationLeft a _
-  | TypeApp {} <- a = pure Irreducible
+  | TypeApp{} <- a = pure Irreducible
   | otherwise = empty
 
 -- | Constraints of the form @Coercible a (f b_0 .. b_n) b@ are irreducibles.
-canonApplicationRight ::
-  (Monad m) =>
-  SourceType ->
-  SourceType ->
-  MaybeT m Canonicalized
+canonApplicationRight
+  :: Monad m
+  => SourceType
+  -> SourceType
+  -> MaybeT m Canonicalized
 canonApplicationRight _ b
-  | TypeApp {} <- b = pure Irreducible
+  | TypeApp{} <- b = pure Irreducible
   | otherwise = empty
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 01fae89b50..5be87c0057 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -51,12 +51,11 @@ import Language.PureScript.Crash (HasCallStack, internalError)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Errors
 import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified)
-import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, getType, getTypeSynonym)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.Types
 import Language.PureScript.Pretty.Types (prettyPrintType)
-import Protolude (isNothing)
 
 generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType
 generalizeUnknowns unks ty =
@@ -88,7 +87,7 @@ unknownVarNames used unks =
   vars :: [Text]
   vars = fmap (("k" <>) . T.pack . show) ([1..] :: [Int])
 
-apply :: (MonadState (CheckState m) m) => SourceType -> m SourceType
+apply :: (MonadState CheckState m) => SourceType -> m SourceType
 apply ty = flip substituteType ty <$> gets checkSubstitution
 
 substituteType :: Substitution -> SourceType -> SourceType
@@ -101,22 +100,22 @@ substituteType sub = everywhereOnTypes $ \case
   other ->
     other
 
-freshUnknown :: (MonadState (CheckState m) m) => m Unknown
+freshUnknown :: (MonadState CheckState m) => m Unknown
 freshUnknown = do
   k <- gets checkNextType
   modify $ \st -> st { checkNextType = k + 1 }
   pure k
 
-freshKind :: (MonadState (CheckState m) m) => SourceSpan -> m SourceType
+freshKind :: (MonadState CheckState m) => SourceSpan -> m SourceType
 freshKind ss = freshKindWithKind ss E.kindType
 
-freshKindWithKind :: (MonadState (CheckState m) m) => SourceSpan -> SourceType -> m SourceType
+freshKindWithKind :: (MonadState CheckState m) => SourceSpan -> SourceType -> m SourceType
 freshKindWithKind ss kind = do
   u <- freshUnknown
   addUnsolved Nothing u kind
   pure $ TUnknown (ss, []) u
 
-addUnsolved :: (MonadState (CheckState m) m) => Maybe UnkLevel -> Unknown -> SourceType -> m ()
+addUnsolved :: (MonadState CheckState m) => Maybe UnkLevel -> Unknown -> SourceType -> m ()
 addUnsolved lvl unk kind = modify $ \st -> do
   let
     newLvl = UnkLevel $ case lvl of
@@ -126,7 +125,7 @@ addUnsolved lvl unk kind = modify $ \st -> do
     uns = M.insert unk (newLvl, kind) $ substUnsolved subs
   st { checkSubstitution = subs { substUnsolved = uns } }
 
-solve :: (MonadState (CheckState m) m) => Unknown -> SourceType -> m ()
+solve :: (MonadState CheckState m) => Unknown -> SourceType -> m ()
 solve unk solution = modify $ \st -> do
   let
     subs = checkSubstitution st
@@ -134,7 +133,7 @@ solve unk solution = modify $ \st -> do
   st { checkSubstitution = subs { substType = tys } }
 
 lookupUnsolved
-  :: (MonadState (CheckState m) m, MonadError MultipleErrors m, HasCallStack)
+  :: (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack)
   => Unknown
   -> m (UnkLevel, SourceType)
 lookupUnsolved u = do
@@ -144,7 +143,7 @@ lookupUnsolved u = do
     Just res -> return res
 
 unknownsWithKinds
-  :: forall m. (MonadState (CheckState m) m, MonadError MultipleErrors m, HasCallStack)
+  :: forall m. (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack)
   => [Unknown]
   -> m [(Unknown, SourceType)]
 unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) . traverse go
@@ -155,7 +154,7 @@ unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join)
     pure $ (lvl, (u, ty)) : rest
 
 inferKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> m (SourceType, SourceType)
 inferKind = \tyToInfer ->
@@ -165,8 +164,8 @@ inferKind = \tyToInfer ->
   where
   go = \case
     ty@(TypeConstructor ann v) -> do
-      t <- getType v
-      case t of
+      env <- getEnv
+      case M.lookup v (E.types env) of
         Nothing ->
           throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
         Just (kind, E.LocalTypeVariable) -> do
@@ -175,8 +174,8 @@ inferKind = \tyToInfer ->
         Just (kind, _) -> do
           pure (ty, kind $> ann)
     ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do
-      t <- getType (coerceProperName <$> v)
-      con' <- case t of
+      env <- getEnv
+      con' <- case M.lookup (coerceProperName <$> v) (E.types env) of
         Nothing ->
           throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v
         Just _ ->
@@ -243,7 +242,7 @@ inferKind = \tyToInfer ->
       internalError $ "inferKind: Unimplemented case \n" <> prettyPrintType 100 ty
 
 inferAppKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceAnn
   -> (SourceType, SourceType)
   -> SourceType
@@ -270,13 +269,13 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of
     cannotApplyTypeToType fn arg
   where
   requiresSynonymsToExpand = \case
-    TypeConstructor _ v -> isNothing <$> getTypeSynonym v
+    TypeConstructor _ v -> M.notMember v . E.typeSynonyms <$> getEnv
     TypeApp _ l _ -> requiresSynonymsToExpand l
     KindApp _ l _ -> requiresSynonymsToExpand l
     _ -> pure True
 
 cannotApplyTypeToType
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> SourceType
   -> m a
@@ -286,7 +285,7 @@ cannotApplyTypeToType fn arg = do
   internalCompilerError . T.pack $ "Cannot apply type to type: " <> debugType (srcTypeApp fn arg)
 
 cannotApplyKindToType
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> SourceType
   -> m a
@@ -297,7 +296,7 @@ cannotApplyKindToType poly arg = do
   internalCompilerError . T.pack $ "Cannot apply kind to type: " <> debugType (srcKindApp poly arg)
 
 checkKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> SourceType
   -> m SourceType
@@ -311,13 +310,13 @@ checkKind = checkKind' False
 -- error.
 --
 checkIsSaturatedType
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> m SourceType
 checkIsSaturatedType ty = checkKind' True ty E.kindType
 
 checkKind'
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => Bool
   -> SourceType
   -> SourceType
@@ -332,7 +331,7 @@ checkKind' requireSynonymsToExpand ty kind2 = do
         instantiateKind (ty', kind1') kind2'
 
 instantiateKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => (SourceType, SourceType)
   -> SourceType
   -> m SourceType
@@ -350,7 +349,7 @@ instantiateKind (ty, kind1) kind2 = case kind1 of
     _ -> False
 
 subsumesKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -381,7 +380,7 @@ subsumesKind = go
       unifyKinds a b
 
 unifyKinds
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -394,7 +393,7 @@ unifyKinds = unifyKindsWithFailure $ \w1 w2 ->
 -- | local position context. This is useful when invoking kind unification
 -- | outside of kind checker internals.
 unifyKinds'
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -405,7 +404,7 @@ unifyKinds' = unifyKindsWithFailure $ \w1 w2 ->
 
 -- | Check the kind of a type, failing if it is not of kind *.
 checkTypeKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> SourceType
   -> m ()
@@ -413,7 +412,7 @@ checkTypeKind ty kind =
   unifyKindsWithFailure (\_ _ -> throwError . errorMessage $ ExpectedType ty kind) kind E.kindType
 
 unifyKindsWithFailure
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => (SourceType -> SourceType -> m ())
   -> SourceType
   -> SourceType
@@ -465,7 +464,7 @@ unifyKindsWithFailure onFailure = go
       onFailure (rowFromList w1) (rowFromList w2)
 
 solveUnknown
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => Unknown
   -> SourceType
   -> m ()
@@ -476,7 +475,7 @@ solveUnknown a' p1 = do
   solve a' p2
 
 solveUnknownAsFunction
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceAnn
   -> Unknown
   -> m SourceType
@@ -491,7 +490,7 @@ solveUnknownAsFunction ann u = do
   pure uarr
 
 promoteKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => Unknown
   -> SourceType
   -> m SourceType
@@ -513,7 +512,7 @@ promoteKind u2 ty = do
       pure ty'
 
 elaborateKind
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> m SourceType
 elaborateKind = \case
@@ -522,8 +521,8 @@ elaborateKind = \case
   TypeLevelInt ann _ ->
     pure $ E.tyInt $> ann
   TypeConstructor ann v -> do
-    t <- getType v
-    case t of
+    env <- getEnv
+    case M.lookup v (E.types env) of
       Nothing ->
         throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
       Just (kind, _) ->
@@ -589,7 +588,7 @@ checkEscapedSkolems ty =
     errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty'
 
 kindOfWithUnknowns
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> m (([(Unknown, SourceType)], SourceType), SourceType)
 kindOfWithUnknowns ty = do
@@ -599,14 +598,14 @@ kindOfWithUnknowns ty = do
 
 -- | Infer the kind of a single type
 kindOf
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> m (SourceType, SourceType)
 kindOf = fmap (first snd) . kindOfWithScopedVars
 
 -- | Infer the kind of a single type, returning the kinds of any scoped type variables
 kindOfWithScopedVars
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
   => SourceType
   -> m (([(Text, SourceType)], SourceType), SourceType)
 kindOfWithScopedVars ty = do
@@ -629,7 +628,7 @@ type DataDeclarationResult =
   )
 
 kindOfData
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> DataDeclarationArgs
   -> m DataDeclarationResult
@@ -637,7 +636,7 @@ kindOfData moduleName dataDecl =
   head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] []
 
 inferDataDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> DataDeclarationArgs
   -> m [(DataConstructorDeclaration, SourceType)]
@@ -657,7 +656,7 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do
         fmap (fmap (addVisibility visibility . mkForAll ctorBinders)) . inferDataConstructor tyCtor'
 
 inferDataConstructor
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => SourceType
   -> DataConstructorDeclaration
   -> m (DataConstructorDeclaration, SourceType)
@@ -681,7 +680,7 @@ type TypeDeclarationResult =
   )
 
 kindOfTypeSynonym
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> TypeDeclarationArgs
   -> m TypeDeclarationResult
@@ -689,7 +688,7 @@ kindOfTypeSynonym moduleName typeDecl =
   head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] []
 
 inferTypeSynonym
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> TypeDeclarationArgs
   -> m SourceType
@@ -798,7 +797,7 @@ type ClassDeclarationResult =
   )
 
 kindOfClass
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> ClassDeclarationArgs
   -> m ClassDeclarationResult
@@ -806,7 +805,7 @@ kindOfClass moduleName clsDecl =
   head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl]
 
 inferClassDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> ClassDeclarationArgs
   -> m ([(Text, SourceType)], [SourceConstraint], [Declaration])
@@ -822,7 +821,7 @@ inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) =
         <*> for decls checkClassMemberDeclaration
 
 checkClassMemberDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => Declaration
   -> m Declaration
 checkClassMemberDeclaration = \case
@@ -831,7 +830,7 @@ checkClassMemberDeclaration = \case
   _ -> internalError "Invalid class member declaration"
 
 applyClassMemberDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => Declaration
   -> m Declaration
 applyClassMemberDeclaration = \case
@@ -847,7 +846,7 @@ mapTypeDeclaration f = \case
     other
 
 checkConstraint
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => SourceConstraint
   -> m SourceConstraint
 checkConstraint (Constraint ann clsName kinds args dat) = do
@@ -856,7 +855,7 @@ checkConstraint (Constraint ann clsName kinds args dat) = do
   pure $ Constraint ann clsName kinds' args' dat
 
 applyConstraint
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => SourceConstraint
   -> m SourceConstraint
 applyConstraint (Constraint ann clsName kinds args dat) = do
@@ -879,7 +878,7 @@ type InstanceDeclarationResult =
   )
 
 checkInstanceDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> InstanceDeclarationArgs
   -> m InstanceDeclarationResult
@@ -900,7 +899,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do
     pure (allConstraints, allKinds, allArgs, varKinds)
 
 checkKindDeclaration
-  :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> SourceType
   -> m SourceType
@@ -935,19 +934,19 @@ checkKindDeclaration _ ty = do
     other -> pure other
 
 existingSignatureOrFreshKind
-  :: forall m. MonadState (CheckState m) m
+  :: forall m. MonadState CheckState m
   => ModuleName
   -> SourceSpan
   -> ProperName 'TypeName
   -> m SourceType
 existingSignatureOrFreshKind moduleName ss name = do
-  t <- getType (Qualified (ByModuleName moduleName) name)
-  case t of
+  env <- getEnv
+  case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of
     Nothing -> freshKind ss
     Just (kind, _) -> pure kind
 
 kindsOfAll
-  :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
   => ModuleName
   -> [TypeDeclarationArgs]
   -> [DataDeclarationArgs]
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index fd2687ec51..b6382e6707 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -2,30 +2,32 @@
 
 -- |
 -- Monads for type checking and type inference and associated data types
+--
 module Language.PureScript.TypeChecker.Monad where
 
+import Prelude
+
 import Control.Arrow (second)
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.State (MonadState(..), StateT(..), gets, modify)
 import Control.Monad (forM_, guard, join, when, (<=<))
-import Control.Monad.Error.Class (MonadError (..))
-import Control.Monad.State (MonadState (..), StateT (..), gets, modify)
-import Control.Monad.Writer.Class (MonadWriter (..), censor)
-import Data.List.NonEmpty qualified as NEL
-import Data.Map qualified as M
+import Control.Monad.Writer.Class (MonadWriter(..), censor)
+
 import Data.Maybe (fromMaybe)
+import Data.Map qualified as M
 import Data.Set qualified as S
 import Data.Text (Text, isPrefixOf, unpack)
+import Data.List.NonEmpty qualified as NEL
+
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (Environment (..), EnvironmentAsync (..), EnvironmentWithAsync (..), NameKind (..), NameVisibility (..), TypeClassData (..), TypeKind (..), withNullAsyncEnv)
-import Language.PureScript.Environment qualified as Env
-import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage (..), SourceAnn, SourceSpan (..), addHint, errorMessage, positionedError, rethrow, warnWithPosition)
-import Language.PureScript.Names (Ident (..), ModuleName, ProperName (..), ProperNameType (..), Qualified (..), QualifiedBy (..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName)
+import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..))
+import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition)
+import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName)
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Language.PureScript.Pretty.Values (prettyPrintValue)
-import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (..))
-import Language.PureScript.Types (Constraint (..), SourceType, Type (..), srcKindedType, srcTypeVar)
+import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
+import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
-import Prelude
-import Protolude (isJust)
 
 newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown)
   deriving (Eq, Show)
@@ -36,36 +38,33 @@ instance Ord UnkLevel where
   compare (UnkLevel a) (UnkLevel b) =
     go (NEL.toList a) (NEL.toList b)
     where
-      go [] [] = EQ
-      go _ [] = LT
-      go [] _ = GT
-      go (x : xs) (y : ys) =
-        compare x y <> go xs ys
+    go [] [] = EQ
+    go _  [] = LT
+    go [] _  = GT
+    go (x:xs) (y:ys) =
+      compare x y <> go xs ys
 
 -- | A substitution of unification variables for types.
 data Substitution = Substitution
-  { -- | Type substitution
-    substType :: M.Map Int SourceType,
-    -- | Unsolved unification variables with their level (scope ordering) and kind
-    substUnsolved :: M.Map Int (UnkLevel, SourceType),
-    -- | The original names of unknowns
-    substNames :: M.Map Int Text
+  { substType :: M.Map Int SourceType
+  -- ^ Type substitution
+  , substUnsolved :: M.Map Int (UnkLevel, SourceType)
+  -- ^ Unsolved unification variables with their level (scope ordering) and kind
+  , substNames :: M.Map Int Text
+  -- ^ The original names of unknowns
   }
 
-insertUnkName :: (MonadState (CheckState m) m) => Unknown -> Text -> m ()
+insertUnkName :: (MonadState CheckState m) => Unknown -> Text -> m ()
 insertUnkName u t = do
-  modify
-    ( \s ->
-        s
-          { checkSubstitution =
-              (checkSubstitution s)
-                { substNames =
-                    M.insert u t $ substNames $ checkSubstitution s
-                }
-          }
-    )
-
-lookupUnkName :: (MonadState (CheckState m) m) => Unknown -> m (Maybe Text)
+  modify (\s ->
+            s { checkSubstitution =
+                  (checkSubstitution s) { substNames =
+                                            M.insert u t $ substNames $ checkSubstitution s
+                                        }
+              }
+         )
+
+lookupUnkName :: (MonadState CheckState m) => Unknown -> m (Maybe Text)
 lookupUnkName u = gets $ M.lookup u . substNames . checkSubstitution
 
 -- | An empty substitution
@@ -73,241 +72,224 @@ emptySubstitution :: Substitution
 emptySubstitution = Substitution M.empty M.empty M.empty
 
 -- | State required for type checking
-data CheckState m = CheckState
-  { -- | The current @Environment@
-    checkEnv :: EnvironmentWithAsync m,
-    -- | The next type unification variable
-    checkNextType :: Int,
-    -- | The next skolem variable
-    checkNextSkolem :: Int,
-    -- | The next skolem scope constant
-    checkNextSkolemScope :: Int,
-    -- | The current module
-    checkCurrentModule :: Maybe ModuleName,
-    -- | The current module imports and their exported types.
-    -- Newtype constructors have to be in scope for some Coercible constraints to
-    -- be solvable, so we need to know which constructors are imported and whether
-    -- they are actually defined in or re-exported from the imported modules.
-    checkCurrentModuleImports ::
-      [ ( SourceAnn,
-          ModuleName,
-          ImportDeclarationType,
-          Maybe ModuleName,
-          M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
+data CheckState = CheckState
+  { checkEnv :: Environment
+  -- ^ The current @Environment@
+  , checkNextType :: Int
+  -- ^ The next type unification variable
+  , checkNextSkolem :: Int
+  -- ^ The next skolem variable
+  , checkNextSkolemScope :: Int
+  -- ^ The next skolem scope constant
+  , checkCurrentModule :: Maybe ModuleName
+  -- ^ The current module
+  , checkCurrentModuleImports ::
+      [ ( SourceAnn
+        , ModuleName
+        , ImportDeclarationType
+        , Maybe ModuleName
+        , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
         )
-      ],
-    -- | The current substitution
-    checkSubstitution :: Substitution,
-    -- | The current error message hint stack.
-    -- This goes into state, rather than using 'rethrow',
-    -- since this way, we can provide good error messages
-    -- during instance resolution.
-    checkHints :: [ErrorMessageHint],
-    -- | Newtype constructors imports required to solve Coercible constraints.
-    -- We have to keep track of them so that we don't emit unused import warnings.
-    checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
+      ]
+  -- ^ The current module imports and their exported types.
+  -- Newtype constructors have to be in scope for some Coercible constraints to
+  -- be solvable, so we need to know which constructors are imported and whether
+  -- they are actually defined in or re-exported from the imported modules.
+  , checkSubstitution :: Substitution
+  -- ^ The current substitution
+  , checkHints :: [ErrorMessageHint]
+  -- ^ The current error message hint stack.
+  -- This goes into state, rather than using 'rethrow',
+  -- since this way, we can provide good error messages
+  -- during instance resolution.
+  , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
+  -- ^ Newtype constructors imports required to solve Coercible constraints.
+  -- We have to keep track of them so that we don't emit unused import warnings.
   }
 
 -- | Create an empty @CheckState@
-emptyCheckState :: Applicative m =>  Environment -> CheckState m
-emptyCheckState env = CheckState (withNullAsyncEnv env) 0 0 0 Nothing [] emptySubstitution [] mempty
-
--- | Get a name from the environment
-getName :: MonadState (CheckState m) m => Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
-getName t =  Env.getName t =<< gets checkEnv
-
--- | Get a type from the environment
-getType :: MonadState (CheckState m) m => Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
-getType t =  Env.getType t =<< gets checkEnv
-
-getTypeSynonym :: MonadState (CheckState m) m => Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
-getTypeSynonym t =  Env.getTypeSynonym t =<< gets checkEnv
-
--- | Get a type class from the environment
-getTypeClass :: MonadState (CheckState m) m => Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
-getTypeClass t =  Env.getTypeClass t =<< gets checkEnv
+emptyCheckState :: Environment -> CheckState
+emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty
 
 -- | Unification variables
 type Unknown = Int
 
 -- | Temporarily bind a collection of names to values
-bindNames ::
-  (MonadState (CheckState m) m) =>
-  M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) ->
-  m a ->
-  m a
+bindNames
+  :: MonadState CheckState m
+  => M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
+  -> m a
+  -> m a
 bindNames newNames action = do
-  orig <- getSyncEnv
-  modifyEnv $ \st -> st {names = newNames `M.union` (names  $ st)}
+  orig <- get
+  modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
   a <- action
-  modifyEnv $ \st -> st {names = names  $ orig}
+  modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
   return a
 
 -- | Temporarily bind a collection of names to types
-bindTypes ::
-  (MonadState (CheckState m) m) =>
-  M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) ->
-  m a ->
-  m a
+bindTypes
+  :: MonadState CheckState m
+  => M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
+  -> m a
+  -> m a
 bindTypes newNames action = do
-  orig <- getSyncEnv
-  modifyEnv $ \env -> env {types = newNames `M.union` types env}
+  orig <- get
+  modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
   a <- action
-  modifyEnv $ \env -> env  {types = types orig}
+  modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
   return a
 
 -- | Temporarily bind a collection of names to types
-withScopedTypeVars ::
-  (MonadState (CheckState m) m, MonadWriter MultipleErrors m) =>
-  ModuleName ->
-  [(Text, SourceType)] ->
-  m a ->
-  m a
+withScopedTypeVars
+  :: (MonadState CheckState m, MonadWriter MultipleErrors m)
+  => ModuleName
+  -> [(Text, SourceType)]
+  -> m a
+  -> m a
 withScopedTypeVars mn ks ma = do
-  forM_ ks $ \(name, _) -> do
-    shadow <- getType (Qualified (ByModuleName mn) (ProperName name))
-    when (isJust shadow) $
-      tell . errorMessage $
-        ShadowedTypeVar name
+  orig <- get
+  forM_ ks $ \(name, _) ->
+    when (Qualified (ByModuleName mn) (ProperName name) `M.member` types (checkEnv orig)) $
+      tell . errorMessage $ ShadowedTypeVar name
   bindTypes (M.fromList (map (\(name, k) -> (Qualified (ByModuleName mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma
 
-withErrorMessageHint ::
-  (MonadState (CheckState m) m, MonadError MultipleErrors m) =>
-  ErrorMessageHint ->
-  m a ->
-  m a
+withErrorMessageHint
+  :: (MonadState CheckState m, MonadError MultipleErrors m)
+  => ErrorMessageHint
+  -> m a
+  -> m a
 withErrorMessageHint hint action = do
   orig <- get
-  modify $ \st -> st {checkHints = hint : checkHints st}
+  modify $ \st -> st { checkHints = hint : checkHints st }
   -- Need to use 'rethrow' anyway, since we have to handle regular errors
   a <- rethrow (addHint hint) action
-  modify $ \st -> st {checkHints = checkHints orig}
+  modify $ \st -> st { checkHints = checkHints orig }
   return a
 
 -- | These hints are added at the front, so the most nested hint occurs
 -- at the front, but the simplifier assumes the reverse order.
-getHints :: (MonadState (CheckState m) m) => m [ErrorMessageHint]
+getHints :: MonadState CheckState m => m [ErrorMessageHint]
 getHints = gets (reverse . checkHints)
 
-rethrowWithPositionTC ::
-  (MonadState (CheckState m) m, MonadError MultipleErrors m) =>
-  SourceSpan ->
-  m a ->
-  m a
+rethrowWithPositionTC
+  :: (MonadState CheckState m, MonadError MultipleErrors m)
+  => SourceSpan
+  -> m a
+  -> m a
 rethrowWithPositionTC pos = withErrorMessageHint (positionedError pos)
 
-warnAndRethrowWithPositionTC ::
-  (MonadState (CheckState m) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
-  SourceSpan ->
-  m a ->
-  m a
+warnAndRethrowWithPositionTC
+  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  => SourceSpan
+  -> m a
+  -> m a
 warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition pos
 
 -- | Temporarily make a collection of type class dictionaries available
-withTypeClassDictionaries ::
-  (MonadState (CheckState m) m) =>
-  [NamedDict] ->
-  m a ->
-  m a
+withTypeClassDictionaries
+  :: MonadState CheckState m
+  => [NamedDict]
+  -> m a
+  -> m a
 withTypeClassDictionaries entries action = do
-  orig <- getSyncEnv
+  orig <- get
 
   let mentries =
-        M.fromListWith
-          (M.unionWith (M.unionWith (<>)))
+        M.fromListWith (M.unionWith (M.unionWith (<>)))
           [ (qb, M.singleton className (M.singleton tcdValue (pure entry)))
-            | entry@TypeClassDictionaryInScope {tcdValue = tcdValue@(Qualified qb _), tcdClassName = className} <-
-                entries
+          | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className }
+              <- entries
           ]
 
-  modifyEnv $ \st -> st {typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries st) mentries}
+  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } }
   a <- action
-  modifyEnv $ \st -> st {typeClassDictionaries = typeClassDictionaries orig}
+  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
   return a
 
--- -- | Get the currently available map of type class dictionaries
--- getTypeClassDictionaries ::
---   (MonadState (CheckState m) m) =>
---   m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
--- getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv
+-- | Get the currently available map of type class dictionaries
+getTypeClassDictionaries
+  :: (MonadState CheckState m)
+  => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
+getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv
 
 -- | Lookup type class dictionaries in a module.
--- lookupTypeClassDictionaries ::
---   (MonadState (CheckState m) m) =>
---   QualifiedBy ->
---   m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
--- lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv
+lookupTypeClassDictionaries
+  :: (MonadState CheckState m)
+  => QualifiedBy
+  -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
+lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv
 
 -- | Lookup type class dictionaries in a module.
-lookupTypeClassDictionariesForClass ::
-  (MonadState (CheckState m) m) =>
-  QualifiedBy ->
-  Qualified (ProperName 'ClassName) ->
-  m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
-lookupTypeClassDictionariesForClass mn cn = fmap (fromMaybe mempty) <$> Env.getTypeClassDictionary mn cn  =<< gets checkEnv
+lookupTypeClassDictionariesForClass
+  :: (MonadState CheckState m)
+  => QualifiedBy
+  -> Qualified (ProperName 'ClassName)
+  -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
+lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn
 
 -- | Temporarily bind a collection of names to local variables
-bindLocalVariables ::
-  (MonadState (CheckState m) m) =>
-  [(SourceSpan, Ident, SourceType, NameVisibility)] ->
-  m a ->
-  m a
+bindLocalVariables
+  :: (MonadState CheckState m)
+  => [(SourceSpan, Ident, SourceType, NameVisibility)]
+  -> m a
+  -> m a
 bindLocalVariables bindings =
   bindNames (M.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (Qualified (BySourcePos $ spanStart ss) name, (ty, Private, visibility)))
 
 -- | Temporarily bind a collection of names to local type variables
-bindLocalTypeVariables ::
-  (MonadState (CheckState m) m) =>
-  ModuleName ->
-  [(ProperName 'TypeName, SourceType)] ->
-  m a ->
-  m a
+bindLocalTypeVariables
+  :: (MonadState CheckState m)
+  => ModuleName
+  -> [(ProperName 'TypeName, SourceType)]
+  -> m a
+  -> m a
 bindLocalTypeVariables moduleName bindings =
   bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (ByModuleName moduleName) pn, (kind, LocalTypeVariable)))
 
 -- | Update the visibility of all names to Defined
-makeBindingGroupVisible :: (MonadState (CheckState m) m) => m ()
-makeBindingGroupVisible = modifyEnv $ \e -> e {names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e)}
+makeBindingGroupVisible :: (MonadState CheckState m) => m ()
+makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
 
 -- | Update the visibility of all names to Defined in the scope of the provided action
-withBindingGroupVisible :: (MonadState (CheckState m) m) => m a -> m a
+withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a
 withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action
 
 -- | Perform an action while preserving the names from the @Environment@.
-preservingNames :: (MonadState (CheckState m) m) => m a -> m a
+preservingNames :: (MonadState CheckState m) => m a -> m a
 preservingNames action = do
-  orig <- gets (names . envSync . checkEnv)
+  orig <- gets (names . checkEnv)
   a <- action
-  modifyEnv $ \e -> e {names = orig}
+  modifyEnv $ \e -> e { names = orig }
   return a
 
 -- | Lookup the type of a value by name in the @Environment@
-lookupVariable ::
-  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
-  Qualified Ident ->
-  m SourceType
+lookupVariable
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  => Qualified Ident
+  -> m SourceType
 lookupVariable qual = do
-  name <- getName qual
-  case name of
+  env <- getEnv
+  case M.lookup qual (names env) of
     Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
     Just (ty, _, _) -> return ty
 
 -- | Lookup the visibility of a value by name in the @Environment@
-getVisibility ::
-  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
-  Qualified Ident ->
-  m NameVisibility
+getVisibility
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  => Qualified Ident
+  -> m NameVisibility
 getVisibility qual = do
-  name <- getName qual
-  case name of
+  env <- getEnv
+  case M.lookup qual (names env) of
     Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
     Just (_, _, vis) -> return vis
 
 -- | Assert that a name is visible
-checkVisibility ::
-  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
-  Qualified Ident ->
-  m ()
+checkVisibility
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  => Qualified Ident
+  -> m ()
 checkVisibility name@(Qualified _ var) = do
   vis <- getVisibility name
   case vis of
@@ -315,44 +297,41 @@ checkVisibility name@(Qualified _ var) = do
     _ -> return ()
 
 -- | Lookup the kind of a type by name in the @Environment@
-lookupTypeVariable ::
-  (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) =>
-  ModuleName ->
-  Qualified (ProperName 'TypeName) ->
-  m SourceType
+lookupTypeVariable
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  => ModuleName
+  -> Qualified (ProperName 'TypeName)
+  -> m SourceType
 lookupTypeVariable currentModule (Qualified qb name) = do
-  t <- getType (Qualified qb' name)  
-  case t of
+  env <- getEnv
+  case M.lookup (Qualified qb' name) (types env) of
     Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
     Just (k, _) -> return k
   where
-    qb' = ByModuleName $ case qb of
-      ByModuleName m -> m
-      BySourcePos _ -> currentModule
+  qb' = ByModuleName $ case qb of
+    ByModuleName m -> m
+    BySourcePos _ -> currentModule
 
 -- | Get the current @Environment@
-getSyncEnv :: (MonadState (CheckState m) m) => m Environment
-getSyncEnv = gets (envSync . checkEnv)
+getEnv :: (MonadState CheckState m) => m Environment
+getEnv = gets checkEnv
 
 -- | Get locally-bound names in context, to create an error message.
-getLocalContext :: (MonadState (CheckState m) m) => m Context
+getLocalContext :: MonadState CheckState m => m Context
 getLocalContext = do
-  env <- getSyncEnv
-  return [(ident, ty') | (Qualified (BySourcePos _) ident@Ident {}, (ty', _, Defined)) <- M.toList (names env)]
+  env <- getEnv
+  return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ]
 
 -- | Update the @Environment@
-putEnv :: (MonadState (CheckState m) m) => Environment -> m ()
-putEnv env = modify (\s -> s {checkEnv = withNullAsyncEnv env})
-
-modifyEnvWithAsync :: (MonadState (CheckState m) m) => (EnvironmentWithAsync m -> EnvironmentWithAsync m) -> m ()
-modifyEnvWithAsync f = modify (\s -> s {checkEnv = f (checkEnv s)})
+putEnv :: (MonadState CheckState m) => Environment -> m ()
+putEnv env = modify (\s -> s { checkEnv = env })
 
 -- | Modify the @Environment@
-modifyEnv :: (MonadState (CheckState m) m) => (Environment -> Environment) -> m ()
-modifyEnv f = modifyEnvWithAsync (\env -> env {envSync = f (envSync env)})
+modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
+modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
 
 -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.
-runCheck :: (Functor m) => CheckState m -> StateT (CheckState m) m a -> m (a, EnvironmentWithAsync m)
+runCheck :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment)
 runCheck st check = second checkEnv <$> runStateT check st
 
 -- | Make an assertion, failing with an error message
@@ -360,52 +339,50 @@ guardWith :: (MonadError e m) => e -> Bool -> m ()
 guardWith _ True = return ()
 guardWith e False = throwError e
 
-capturingSubstitution ::
-  (MonadState (CheckState m) m) =>
-  (a -> Substitution -> b) ->
-  m a ->
-  m b
+capturingSubstitution
+  :: MonadState CheckState m
+  => (a -> Substitution -> b)
+  -> m a
+  -> m b
 capturingSubstitution f ma = do
   a <- ma
   subst <- gets checkSubstitution
   return (f a subst)
 
-withFreshSubstitution ::
-  (MonadState (CheckState m) m) =>
-  m a ->
-  m a
+withFreshSubstitution
+  :: MonadState CheckState m
+  => m a
+  -> m a
 withFreshSubstitution ma = do
   orig <- get
-  modify $ \st -> st {checkSubstitution = emptySubstitution}
+  modify $ \st -> st { checkSubstitution = emptySubstitution }
   a <- ma
-  modify $ \st -> st {checkSubstitution = checkSubstitution orig}
+  modify $ \st -> st { checkSubstitution = checkSubstitution orig }
   return a
 
-withoutWarnings ::
-  (MonadWriter w m) =>
-  m a ->
-  m (a, w)
+withoutWarnings
+  :: MonadWriter w m
+  => m a
+  -> m (a, w)
 withoutWarnings = censor (const mempty) . listen
 
-unsafeCheckCurrentModule ::
-  forall m.
-  (MonadError MultipleErrors m, MonadState (CheckState m) m) =>
-  m ModuleName
-unsafeCheckCurrentModule =
-  gets checkCurrentModule >>= \case
-    Nothing -> internalError "No module name set in scope"
-    Just name -> pure name
+unsafeCheckCurrentModule
+  :: forall m
+   . (MonadError MultipleErrors m, MonadState CheckState m)
+  => m ModuleName
+unsafeCheckCurrentModule = gets checkCurrentModule >>= \case
+  Nothing -> internalError "No module name set in scope"
+  Just name -> pure name
 
 debugEnv :: Environment -> [String]
-debugEnv env =
-  join
-    [ debugTypes env,
-      debugTypeSynonyms env,
-      debugTypeClasses env,
-      debugTypeClassDictionaries env,
-      debugDataConstructors env,
-      debugNames env
-    ]
+debugEnv env = join
+  [ debugTypes env
+  , debugTypeSynonyms env
+  , debugTypeClasses env
+  , debugTypeClassDictionaries env
+  , debugDataConstructors env
+  , debugNames env
+  ]
 
 debugType :: Type a -> String
 debugType = init . prettyPrintType 100
@@ -417,66 +394,72 @@ debugConstraint (Constraint ann clsName kinds args _) =
 debugTypes :: Environment -> [String]
 debugTypes = go <=< M.toList . types
   where
-    go (qual, (srcTy, which)) = do
-      let ppTy = prettyPrintType 100 srcTy
-          name = showQualified runProperName qual
-          decl = case which of
-            DataType _ _ _ -> "data"
-            TypeSynonym -> "type"
-            ExternData _ -> "extern"
-            LocalTypeVariable -> "local"
-            ScopedTypeVar -> "scoped"
-      guard (not ("Prim" `isPrefixOf` name))
-      pure $ decl <> " " <> unpack name <> " :: " <> init ppTy
+  go (qual, (srcTy, which)) = do
+    let
+      ppTy = prettyPrintType 100 srcTy
+      name = showQualified runProperName qual
+      decl = case which of
+        DataType _ _ _    -> "data"
+        TypeSynonym       -> "type"
+        ExternData _      -> "extern"
+        LocalTypeVariable -> "local"
+        ScopedTypeVar     -> "scoped"
+    guard (not ("Prim" `isPrefixOf` name))
+    pure $ decl <> " " <> unpack name <> " :: " <> init ppTy
 
 debugNames :: Environment -> [String]
 debugNames = fmap go . M.toList . names
   where
-    go (qual, (srcTy, _, _)) = do
-      let ppTy = prettyPrintType 100 srcTy
-          name = showQualified runIdent qual
-      unpack name <> " :: " <> init ppTy
+  go (qual, (srcTy, _, _)) = do
+    let
+      ppTy = prettyPrintType 100 srcTy
+      name = showQualified runIdent qual
+    unpack name <> " :: " <> init ppTy
 
 debugDataConstructors :: Environment -> [String]
 debugDataConstructors = fmap go . M.toList . dataConstructors
   where
-    go (qual, (_, _, ty, _)) = do
-      let ppTy = prettyPrintType 100 ty
-          name = showQualified runProperName qual
-      unpack name <> " :: " <> init ppTy
+  go (qual, (_, _, ty, _)) = do
+    let
+      ppTy = prettyPrintType 100 ty
+      name = showQualified runProperName qual
+    unpack name <> " :: " <> init ppTy
 
 debugTypeSynonyms :: Environment -> [String]
 debugTypeSynonyms = fmap go . M.toList . typeSynonyms
   where
-    go (qual, (binders, subTy)) = do
-      let vars = unwords $ flip fmap binders $ \case
-            (v, Just k) -> "(" <> unpack v <> " :: " <> init (prettyPrintType 100 k) <> ")"
-            (v, Nothing) -> unpack v
-          ppTy = prettyPrintType 100 subTy
-          name = showQualified runProperName qual
-      "type " <> unpack name <> " " <> vars <> " = " <> init ppTy
+  go (qual, (binders, subTy)) = do
+    let
+      vars = unwords $ flip fmap binders $ \case
+               (v, Just k) -> "(" <> unpack v <> " :: " <> init (prettyPrintType 100 k) <> ")"
+               (v, Nothing) -> unpack v
+      ppTy = prettyPrintType 100 subTy
+      name = showQualified runProperName qual
+    "type " <> unpack name <> " " <> vars <> " = " <> init ppTy
 
 debugTypeClassDictionaries :: Environment -> [String]
 debugTypeClassDictionaries = go . typeClassDictionaries
   where
-    go tcds = do
-      (mbModuleName, classes) <- M.toList tcds
-      (className, instances) <- M.toList classes
-      (ident, dicts) <- M.toList instances
-      let moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") (toMaybeModuleName mbModuleName)
-          className' = showQualified runProperName className
-          ident' = showQualified runIdent ident
-          kds = unwords $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts
-          tys = unwords $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts
-      pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys
+  go tcds = do
+    (mbModuleName, classes) <- M.toList tcds
+    (className, instances) <- M.toList classes
+    (ident, dicts) <- M.toList instances
+    let
+      moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") (toMaybeModuleName mbModuleName)
+      className' = showQualified runProperName className
+      ident' = showQualified runIdent ident
+      kds = unwords $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts
+      tys = unwords $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts
+    pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys
 
 debugTypeClasses :: Environment -> [String]
 debugTypeClasses = fmap go . M.toList . typeClasses
   where
-    go (className, tc) = do
-      let className' = showQualified runProperName className
-          args = unwords $ (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") <$> typeClassArguments tc
-      "class " <> unpack className' <> " " <> args
+  go (className, tc) = do
+    let
+      className' = showQualified runProperName className
+      args = unwords $ (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") <$> typeClassArguments tc
+    "class " <> unpack className' <> " " <> args
 
 debugValue :: Expr -> String
 debugValue = init . render . prettyPrintValue 100
@@ -484,19 +467,19 @@ debugValue = init . render . prettyPrintValue 100
 debugSubstitution :: Substitution -> [String]
 debugSubstitution (Substitution solved unsolved names) =
   concat
-    [ fmap go1 (M.toList solved),
-      fmap go2 (M.toList unsolved'),
-      fmap go3 (M.toList names)
+    [ fmap go1 (M.toList solved)
+    , fmap go2 (M.toList unsolved')
+    , fmap go3 (M.toList names)
     ]
   where
-    unsolved' =
-      M.filterWithKey (\k _ -> M.notMember k solved) unsolved
+  unsolved' =
+    M.filterWithKey (\k _ -> M.notMember k solved) unsolved
 
-    go1 (u, ty) =
-      "?" <> show u <> " = " <> debugType ty
+  go1 (u, ty) =
+    "?" <> show u <> " = " <> debugType ty
 
-    go2 (u, (_, k)) =
-      "?" <> show u <> " :: " <> debugType k
+  go2 (u, (_, k)) =
+    "?" <> show u <> " :: " <> debugType k
 
-    go3 (u, t) =
-      unpack t <> show u
+  go3 (u, t) =
+    unpack t <> show u
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index 92a601dff4..aa49997fd6 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -24,21 +24,21 @@ import Language.PureScript.TypeChecker.Monad (CheckState(..))
 import Language.PureScript.Types (SkolemScope(..), SourceType, Type(..), everythingOnTypes, everywhereOnTypesM, replaceTypeVars)
 
 -- | Generate a new skolem constant
-newSkolemConstant :: MonadState (CheckState m) m => m Int
+newSkolemConstant :: MonadState CheckState m => m Int
 newSkolemConstant = do
   s <- gets checkNextSkolem
   modify $ \st -> st { checkNextSkolem = s + 1 }
   return s
 
 -- | Introduce skolem scope at every occurrence of a ForAll
-introduceSkolemScope :: MonadState (CheckState m) m => Type a -> m (Type a)
+introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a)
 introduceSkolemScope = everywhereOnTypesM go
   where
   go (ForAll ann vis ident mbK ty Nothing) = ForAll ann vis ident mbK ty <$> (Just <$> newSkolemScope)
   go other = return other
 
 -- | Generate a new skolem scope
-newSkolemScope :: MonadState (CheckState m) m => m SkolemScope
+newSkolemScope :: MonadState CheckState m => m SkolemScope
 newSkolemScope = do
   s <- gets checkNextSkolemScope
   modify $ \st -> st { checkNextSkolemScope = s + 1 }
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index f847e6573a..26da5e980f 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -20,7 +20,7 @@ import Language.PureScript.AST (ErrorMessageHint(..), Expr(..), pattern NullSour
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (tyFunction, tyRecord)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, internalCompilerError)
-import Language.PureScript.TypeChecker.Monad (CheckState, getHints, withErrorMessageHint)
+import Language.PureScript.TypeChecker.Monad (CheckState, getHints, getTypeClassDictionaries, withErrorMessageHint)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize)
 import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, unifyTypes)
 import Language.PureScript.Types (RowListItem(..), SourceType, Type(..), eqType, isREmpty, replaceTypeVars, rowFromList)
@@ -59,7 +59,7 @@ defaultCoercion SNoElaborate = ()
 
 -- | Check that one type subsumes another, rethrowing errors to provide a better error message
 subsumes
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: (MonadError MultipleErrors m, MonadState CheckState m)
   => SourceType
   -> SourceType
   -> m (Expr -> Expr)
@@ -69,7 +69,7 @@ subsumes ty1 ty2 =
 
 -- | Check that one type subsumes another
 subsumes'
-  :: (MonadError MultipleErrors m, MonadState (CheckState m) m)
+  :: (MonadError MultipleErrors m, MonadState CheckState m)
   => ModeSing mode
   -> SourceType
   -> SourceType
@@ -97,7 +97,7 @@ subsumes' mode ty1 (KindedType _ ty2 _) =
 -- Only check subsumption for constrained types when elaborating.
 -- Otherwise fall back to unification.
 subsumes' SElaborate (ConstrainedType _ con ty1) ty2 = do
-  -- dicts <- getTypeClassDictionaries
+  dicts <- getTypeClassDictionaries
   hints <- getHints
   elaborate <- subsumes' SElaborate ty1 ty2
   let addDicts val = App val (TypeClassDictionary con dicts hints)
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 71f97cdf18..567ae415ef 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -2,61 +2,61 @@
 
 -- |
 -- Functions for replacing fully applied type synonyms
+--
 module Language.PureScript.TypeChecker.Synonyms
-  ( SynonymMap,
-    KindMap,
-    replaceAllTypeSynonyms,
-  )
-where
-
-import Control.Monad.Error.Class (MonadError (..))
-import Control.Monad.Except (ExceptT, runExceptT, MonadTrans (lift))
+  ( SynonymMap
+  , KindMap
+  , replaceAllTypeSynonyms
+  ) where
+
+import Prelude
+
+import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.State (MonadState)
-import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
+import Data.Map qualified as M
 import Data.Text (Text)
-import Language.PureScript.Environment (TypeKind)
-import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), SourceSpan, errorMessage')
-import Language.PureScript.Names (ProperName, ProperNameType (..), Qualified)
-import Language.PureScript.TypeChecker.Monad (CheckState, getTypeSynonym, getType)
-import Language.PureScript.Types (SourceType, Type (..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars)
-import Prelude
+import Language.PureScript.Environment (Environment(..), TypeKind)
+import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage')
+import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified)
+import Language.PureScript.TypeChecker.Monad (CheckState, getEnv)
+import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars)
 
 -- | Type synonym information (arguments with kinds, aliased type), indexed by name
 type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType)
 
 type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
 
--- | Replace fully applied type synonyms
-replaceAllTypeSynonyms :: forall m e. (e ~ MultipleErrors, MonadState (CheckState m) m, MonadError e m) => SourceType -> m SourceType
-replaceAllTypeSynonyms d = do
-  either throwError return =<< runExceptT (replaceAllTypeSynonyms' d)
+replaceAllTypeSynonyms'
+  :: SynonymMap
+  -> KindMap
+  -> SourceType
+  -> Either MultipleErrors SourceType
+replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try
   where
-    replaceAllTypeSynonyms' :: SourceType -> ExceptT MultipleErrors m SourceType
-    replaceAllTypeSynonyms' = everywhereOnTypesTopDownM try
-
-    try :: SourceType -> ExceptT MultipleErrors m SourceType
-    try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
-
-    go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> ExceptT MultipleErrors m (Maybe SourceType)
-    go  ss c kargs args (TypeConstructor _ ctor) = do
-      synMb <- lift $ getTypeSynonym ctor
-      kindArgs <- lookupKindArgs ctor
-      case synMb of
-        Just (synArgs, body) | c == length synArgs && length kargs == length kindArgs -> do
-          let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
-          Just <$> try repl
-        Just (synArgs, _) | length synArgs > c -> throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
-        _ -> return Nothing
-
-    go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
-    go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
-    go _ _ _ _ _ = return Nothing
-
-    lookupKindArgs :: Qualified (ProperName 'TypeName) ->  ExceptT MultipleErrors m [Text]
-    lookupKindArgs ctor = do
-      kindMb <- lift $ getType ctor
-      case kindMb of
-        Just (kind, _) -> return $ maybe [] (fmap (fst . snd) . fst) (completeBinderList kind)
-        _ -> return []
+  try :: SourceType -> Either MultipleErrors SourceType
+  try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
+
+  go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType)
+  go ss c kargs args (TypeConstructor _ ctor)
+    | Just (synArgs, body) <- M.lookup ctor syns
+    , c == length synArgs
+    , kindArgs <- lookupKindArgs ctor
+    , length kargs == length kindArgs
+    = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
+      in Just <$> try repl
+    | Just (synArgs, _) <- M.lookup ctor syns
+    , length synArgs > c
+    = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
+  go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
+  go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
+  go _ _ _ _ _ = return Nothing
+
+  lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text]
+  lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds
 
+-- | Replace fully applied type synonyms
+replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType
+replaceAllTypeSynonyms d = do
+  env <- getEnv
+  either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 47aa4ea592..e4f1040ebf 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -35,7 +35,7 @@ import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize)
 import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown)
 
 -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible.
-freshType :: (MonadState (CheckState m) m) => m SourceType
+freshType :: (MonadState CheckState m) => m SourceType
 freshType = state $ \st -> do
   let
     t = checkNextType st
@@ -50,7 +50,7 @@ freshType = state $ \st -> do
   (srcTUnknown (t + 1), st')
 
 -- | Generate a fresh type variable with a known kind.
-freshTypeWithKind :: (MonadState (CheckState m) m) => SourceType -> m SourceType
+freshTypeWithKind :: (MonadState CheckState m) => SourceType -> m SourceType
 freshTypeWithKind kind = state $ \st -> do
   let
     t = checkNextType st
@@ -61,7 +61,7 @@ freshTypeWithKind kind = state $ \st -> do
   (srcTUnknown t, st')
 
 -- | Update the substitution to solve a type constraint
-solveType :: (MonadError MultipleErrors m, MonadState (CheckState m) m) => Int -> SourceType -> m ()
+solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m ()
 solveType u t = rethrow (onErrorMessages withoutPosition) $ do
   -- We strip the position so that any errors get rethrown with the position of
   -- the original unification constraint. Otherwise errors may arise from arbitrary
@@ -106,7 +106,7 @@ unknownsInType t = everythingOnTypes (.) go t []
   go _ = id
 
 -- | Unify two types, updating the current substitution
-unifyTypes :: (MonadError MultipleErrors m, MonadState (CheckState m) m) => SourceType -> SourceType -> m ()
+unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m ()
 unifyTypes t1 t2 = do
   sub <- gets checkSubstitution
   withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)
@@ -160,7 +160,7 @@ unifyTypes t1 t2 = do
 --
 -- Common labels are identified and unified. Remaining labels and types are unified with a
 -- trailing row unification variable, if appropriate.
-unifyRows :: forall m. (MonadError MultipleErrors m, MonadState (CheckState m) m) => SourceType -> SourceType -> m ()
+unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m ()
 unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where
   unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2
 
@@ -184,7 +184,7 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where
 -- |
 -- Replace type wildcards with unknowns
 --
-replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState (CheckState m) m) => SourceType -> m SourceType
+replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => SourceType -> m SourceType
 replaceTypeWildcards = everywhereOnTypesM replace
   where
   replace (TypeWildcard ann wdata) = do
@@ -201,7 +201,7 @@ replaceTypeWildcards = everywhereOnTypesM replace
 -- |
 -- Replace outermost unsolved unification variables with named type variables
 --
-varIfUnknown :: forall m. (MonadState (CheckState m) m) => [(Unknown, SourceType)] -> SourceType -> m SourceType
+varIfUnknown :: forall m. (MonadState CheckState m) => [(Unknown, SourceType)] -> SourceType -> m SourceType
 varIfUnknown unks ty = do
   bn' <- traverse toBinding unks
   ty' <- go ty

From 943d4e873082f673d6a5bd87ec9ff46a36a3a882 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 15:45:14 +0200
Subject: [PATCH 095/297] adds desugarLsp

---
 src/Language/PureScript/Sugar.hs             |  65 +-
 src/Language/PureScript/Sugar/Operators.hs   | 755 ++++++++++---------
 src/Language/PureScript/Sugar/TypeClasses.hs |  29 +-
 3 files changed, 455 insertions(+), 394 deletions(-)

diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 07b175e39e..d093af4573 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -1,23 +1,22 @@
 -- |
 -- Desugaring passes
---
 module Language.PureScript.Sugar (desugar, desugarLsp, module S) where
 
 import Control.Category ((>>>))
-import Control.Monad ((>=>))
-import Control.Monad.Error.Class (MonadError)
 import Control.Monad.Supply.Class (MonadSupply)
-import Control.Monad.State.Class (MonadState)
 import Control.Monad.Writer.Class (MonadWriter)
-
+import Data.Map qualified as M
 import Language.PureScript.AST (Module)
+import Language.PureScript.Environment (Environment)
+import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors (MultipleErrors)
-import Language.PureScript.Externs (ExternsFile)
+import Language.PureScript.Externs (ExternsFile, ExternsFixity, ExternsTypeFixity)
 import Language.PureScript.Linter.Imports (UsedImports)
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Sugar.AdoNotation as S
 import Language.PureScript.Sugar.BindingGroups as S
 import Language.PureScript.Sugar.CaseDeclarations as S
 import Language.PureScript.Sugar.DoNotation as S
-import Language.PureScript.Sugar.AdoNotation as S
 import Language.PureScript.Sugar.LetPattern as S
 import Language.PureScript.Sugar.Names as S
 import Language.PureScript.Sugar.ObjectWildcards as S
@@ -25,6 +24,7 @@ import Language.PureScript.Sugar.Operators as S
 import Language.PureScript.Sugar.TypeClasses as S
 import Language.PureScript.Sugar.TypeClasses.Deriving as S
 import Language.PureScript.Sugar.TypeDeclarations as S
+import Protolude
 
 -- |
 -- The desugaring pipeline proceeds as follows:
@@ -50,15 +50,14 @@ import Language.PureScript.Sugar.TypeDeclarations as S
 --  * Introduce newtypes for type class dictionaries and value declarations for instances
 --
 --  * Group mutually recursive value and data declarations into binding groups.
---
-desugar
-  :: MonadSupply m
-  => MonadError MultipleErrors m
-  => MonadWriter MultipleErrors m
-  => MonadState (Env, UsedImports) m
-  => [ExternsFile]
-  -> Module
-  -> m Module
+desugar ::
+  (MonadSupply m) =>
+  (MonadError MultipleErrors m) =>
+  (MonadWriter MultipleErrors m) =>
+  (MonadState (Env, UsedImports) m) =>
+  [ExternsFile] ->
+  Module ->
+  m Module
 desugar externs =
   desugarSignedLiterals
     >>> desugarObjectConstructors
@@ -74,13 +73,17 @@ desugar externs =
     >=> desugarTypeClasses externs
     >=> createBindingGroupsModule
 
--- TODO: add desugarImports, rebracket and desugarTypeClasses but getting externs and used imports from the DB
-desugarLsp
-  :: MonadSupply m
-  => MonadError MultipleErrors m
-  => Module
-  -> m Module
-desugarLsp  =
+desugarLsp ::
+  (MonadSupply m) =>
+  (MonadWriter MultipleErrors m) =>
+  (MonadError MultipleErrors m) =>
+  (MonadState (Env, UsedImports) m) =>
+  [(P.ModuleName, [ExternsFixity])] ->
+  [(P.ModuleName, [ExternsTypeFixity])] ->
+  Environment ->
+  Module ->
+  m Module
+desugarLsp fixities typeFixities env =
   desugarSignedLiterals
     >>> desugarObjectConstructors
     >=> desugarDoModule
@@ -88,6 +91,22 @@ desugarLsp  =
     >=> desugarLetPatternModule
     >>> desugarCasesModule
     >=> desugarTypeDeclarationsModule
+    >=> desugarImports
+    >=> rebracketFixitiesOnly fixities typeFixities
     >=> checkFixityExports
     >=> deriveInstances
+    >=> desugarTypeClassesUsingMemberMap typeClassData
     >=> createBindingGroupsModule
+  where
+    typeClassData =
+      P.typeClasses env
+        & M.toList
+        & mapMaybe addModuleName
+        & M.fromList
+
+addModuleName ::
+  (P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData) ->
+  Maybe ((P.ModuleName, P.ProperName 'P.ClassName), P.TypeClassData)
+addModuleName = \case
+  (P.Qualified (P.ByModuleName mn) pn, tcd) -> Just ((mn, pn), tcd)
+  _ -> Nothing
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 93028d7e22..5f0a785c80 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -4,99 +4,126 @@
 --
 -- The value parser ignores fixity data when parsing binary operator applications, so
 -- it is necessary to reorder them here.
---
 module Language.PureScript.Sugar.Operators
-  ( desugarSignedLiterals
-  , RebracketCaller(..)
-  , rebracket
-  , rebracketFiltered
-  , checkFixityExports
-  ) where
-
-import Prelude
-
-import Language.PureScript.AST
-import Language.PureScript.Crash (internalError)
-import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition)
-import Language.PureScript.Externs (ExternsFile(..), ExternsFixity(..), ExternsTypeFixity(..))
-import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent')
-import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators)
-import Language.PureScript.Sugar.Operators.Expr (matchExprOperators)
-import Language.PureScript.Sugar.Operators.Types (matchTypeOperators)
-import Language.PureScript.Traversals (defS, sndM)
-import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everywhereOnTypesTopDownM, overConstraintArgs)
+  ( desugarSignedLiterals,
+    RebracketCaller (..),
+    rebracket,
+    rebracketFixitiesOnly,
+    rebracketFiltered,
+    checkFixityExports,
+  )
+where
 
 import Control.Monad (unless, (<=<))
-import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Error.Class (MonadError (..))
 import Control.Monad.Supply.Class (MonadSupply)
-
 import Data.Either (partitionEithers)
 import Data.Foldable (for_, traverse_)
 import Data.Function (on)
 import Data.Functor (($>))
-import Data.Functor.Identity (Identity(..), runIdentity)
+import Data.Functor.Identity (Identity (..), runIdentity)
 import Data.List (groupBy, sortOn)
-import Data.Maybe (mapMaybe, listToMaybe)
 import Data.Map qualified as M
-import Data.Ord (Down(..))
-
+import Data.Maybe (listToMaybe, mapMaybe)
+import Data.Ord (Down (..))
+import Language.PureScript.AST
 import Language.PureScript.Constants.Libs qualified as C
+import Language.PureScript.Crash (internalError)
+import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition)
+import Language.PureScript.Externs (ExternsFile (..), ExternsFixity (..), ExternsTypeFixity (..))
+import Language.PureScript.Names (Ident (..), Name (..), OpName, OpNameType (..), ProperName, ProperNameType (..), Qualified (..), QualifiedBy (..), freshIdent', pattern ByNullSourcePos)
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators)
+import Language.PureScript.Sugar.Operators.Expr (matchExprOperators)
+import Language.PureScript.Sugar.Operators.Types (matchTypeOperators)
+import Language.PureScript.Traversals (defS, sndM)
+import Language.PureScript.Types (Constraint (..), SourceType, Type (..), everywhereOnTypesTopDownM, overConstraintArgs)
+import Prelude
 
 -- |
 -- Removes unary negation operators and replaces them with calls to `negate`.
---
 desugarSignedLiterals :: Module -> Module
 desugarSignedLiterals (Module ss coms mn ds exts) =
   Module ss coms mn (map f' ds) exts
   where
-  (f', _, _) = everywhereOnValues id go id
-  go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.S_negate))) val
-  go other = other
+    (f', _, _) = everywhereOnValues id go id
+    go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.S_negate))) val
+    go other = other
 
 -- |
 -- An operator associated with its declaration position, fixity, and the name
 -- of the function or data constructor it is an alias for.
---
 type FixityRecord op alias = (Qualified op, SourceSpan, Fixity, Qualified alias)
+
 type ValueFixityRecord = FixityRecord (OpName 'ValueOpName) (Either Ident (ProperName 'ConstructorName))
+
 type TypeFixityRecord = FixityRecord (OpName 'TypeOpName) (ProperName 'TypeName)
 
 -- |
 -- Remove explicit parentheses and reorder binary operator applications.
 --
 -- This pass requires name desugaring and export elaboration to have run first.
---
-rebracket
-  :: forall m
-   . MonadError MultipleErrors m
-  => MonadSupply m
-  => [ExternsFile]
-  -> Module
-  -> m Module
+rebracket ::
+  forall m.
+  (MonadError MultipleErrors m) =>
+  (MonadSupply m) =>
+  [ExternsFile] ->
+  Module ->
+  m Module
 rebracket =
   rebracketFiltered CalledByCompile (const True)
 
+-- | rebracket that takes the fixities without the other externs fields
+rebracketFixitiesOnly ::
+  forall m.
+  (MonadError MultipleErrors m) =>
+  (MonadSupply m) =>
+  [(P.ModuleName, [ExternsFixity])] ->
+  [(P.ModuleName, [ExternsTypeFixity])] ->
+  Module ->
+  m Module
+rebracketFixitiesOnly exFixities exTypeFixities =
+  rebracketFiltered' CalledByCompile (const False) $
+    fixities <> typeFixities
+
+  where 
+    fixities = concatMap (\(mName, fs) -> fmap (fromFixity mName) fs) exFixities
+    typeFixities = concatMap (\(mName, fs) -> fmap (fromTypeFixity mName) fs) exTypeFixities
+      -- >>= \(name, fs, tFs) ->
+      --   externsFixities' name fs tFs
+
 -- |
 -- A version of `rebracket` which allows you to choose which declarations
 -- should be affected. This is used in docs generation, where we want to
 -- desugar type operators in instance declarations to ensure that instances are
 -- paired up with their types correctly, but we don't want to desugar type
 -- operators in value declarations.
---
-rebracketFiltered
-  :: forall m
-   . MonadError MultipleErrors m
-  => MonadSupply m
-  => RebracketCaller
-  -> (Declaration -> Bool)
-  -> [ExternsFile]
-  -> Module
-  -> m Module
+rebracketFiltered ::
+  forall m.
+  (MonadError MultipleErrors m) =>
+  (MonadSupply m) =>
+  RebracketCaller ->
+  (Declaration -> Bool) ->
+  [ExternsFile] ->
+  Module ->
+  m Module
 rebracketFiltered !caller pred_ externs m = do
+  rebracketFiltered' caller pred_ (concatMap externsFixities externs) m
+
+rebracketFiltered' ::
+  forall m.
+  (MonadError MultipleErrors m) =>
+  (MonadSupply m) =>
+  RebracketCaller ->
+  (Declaration -> Bool) ->
+  [Either ValueFixityRecord TypeFixityRecord] ->
+  Module ->
+  m Module
+rebracketFiltered' !caller pred_ fixities m = do
   let (valueFixities, typeFixities) =
-        partitionEithers
-          $ concatMap externsFixities externs
-          ++ collectFixities m
+        partitionEithers $
+          fixities
+            ++ collectFixities m
 
   ensureNoDuplicates' MultipleValueOpFixities valueFixities
   ensureNoDuplicates' MultipleTypeOpFixities typeFixities
@@ -106,80 +133,78 @@ rebracketFiltered !caller pred_ externs m = do
   let typeOpTable = customOperatorTable' typeFixities
   let typeAliased = M.fromList (map makeLookupEntry typeFixities)
 
-  rebracketModule caller pred_ valueOpTable typeOpTable m >>=
-    renameAliasedOperators valueAliased typeAliased
-
+  rebracketModule caller pred_ valueOpTable typeOpTable m
+    >>= renameAliasedOperators valueAliased typeAliased
   where
-
-  ensureNoDuplicates'
-    :: Ord op
-    => (op -> SimpleErrorMessage)
-    -> [FixityRecord op alias]
-    -> m ()
-  ensureNoDuplicates' toError =
-    ensureNoDuplicates toError . map (\(i, pos, _, _) -> (i, pos))
-
-  customOperatorTable'
-    :: [FixityRecord op alias]
-    -> [[(Qualified op, Associativity)]]
-  customOperatorTable' = customOperatorTable . map (\(i, _, f, _) -> (i, f))
-
-  makeLookupEntry :: FixityRecord op alias -> (Qualified op, Qualified alias)
-  makeLookupEntry (qname, _, _, alias) = (qname, alias)
-
-  renameAliasedOperators
-    :: M.Map (Qualified (OpName 'ValueOpName)) (Qualified (Either Ident (ProperName 'ConstructorName)))
-    -> M.Map (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName))
-    -> Module
-    -> m Module
-  renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =
-    Module ss coms mn <$> mapM (usingPredicate pred_ f') ds <*> pure exts
-    where
-    (goDecl', goExpr', goBinder') = updateTypes goType
-    (f', _, _, _, _, _) =
-      everywhereWithContextOnValuesM
-        ss
-        (\_ d -> (declSourceSpan d,) <$> goDecl' d)
-        (\pos -> uncurry goExpr <=< goExpr' pos)
-        (\pos -> uncurry goBinder <=< goBinder' pos)
-        defS
-        defS
-        defS
-
-    goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
-    goExpr _ e@(PositionedValue pos _ _) = return (pos, e)
-    goExpr _ (Op pos op) =
-      (pos,) <$> case op `M.lookup` valueAliased of
-        Just (Qualified mn' (Left alias)) ->
-          return $ Var pos (Qualified mn' alias)
-        Just (Qualified mn' (Right alias)) ->
-          return $ Constructor pos (Qualified mn' alias)
-        Nothing ->
-          throwError . errorMessage' pos . UnknownName $ fmap ValOpName op
-    goExpr pos other = return (pos, other)
-
-    goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
-    goBinder _ b@(PositionedBinder pos _ _) = return (pos, b)
-    goBinder _ (BinaryNoParensBinder (OpBinder pos op) lhs rhs) =
-      case op `M.lookup` valueAliased of
-        Just (Qualified mn' (Left alias)) ->
-          throwError . errorMessage' pos $ InvalidOperatorInBinder op (Qualified mn' alias)
-        Just (Qualified mn' (Right alias)) ->
-          return (pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs])
-        Nothing ->
-          throwError . errorMessage' pos . UnknownName $ fmap ValOpName op
-    goBinder _ BinaryNoParensBinder{} =
-      internalError "BinaryNoParensBinder has no OpBinder"
-    goBinder pos other = return (pos, other)
-
-    goType :: SourceSpan -> SourceType -> m SourceType
-    goType pos (TypeOp ann2 op) =
-      case op `M.lookup` typeAliased of
-        Just alias ->
-          return $ TypeConstructor ann2 alias
-        Nothing ->
-          throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op
-    goType _ other = return other
+    ensureNoDuplicates' ::
+      (Ord op) =>
+      (op -> SimpleErrorMessage) ->
+      [FixityRecord op alias] ->
+      m ()
+    ensureNoDuplicates' toError =
+      ensureNoDuplicates toError . map (\(i, pos, _, _) -> (i, pos))
+
+    customOperatorTable' ::
+      [FixityRecord op alias] ->
+      [[(Qualified op, Associativity)]]
+    customOperatorTable' = customOperatorTable . map (\(i, _, f, _) -> (i, f))
+
+    makeLookupEntry :: FixityRecord op alias -> (Qualified op, Qualified alias)
+    makeLookupEntry (qname, _, _, alias) = (qname, alias)
+
+    renameAliasedOperators ::
+      M.Map (Qualified (OpName 'ValueOpName)) (Qualified (Either Ident (ProperName 'ConstructorName))) ->
+      M.Map (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName)) ->
+      Module ->
+      m Module
+    renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =
+      Module ss coms mn <$> mapM (usingPredicate pred_ f') ds <*> pure exts
+      where
+        (goDecl', goExpr', goBinder') = updateTypes goType
+        (f', _, _, _, _, _) =
+          everywhereWithContextOnValuesM
+            ss
+            (\_ d -> (declSourceSpan d,) <$> goDecl' d)
+            (\pos -> uncurry goExpr <=< goExpr' pos)
+            (\pos -> uncurry goBinder <=< goBinder' pos)
+            defS
+            defS
+            defS
+
+        goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
+        goExpr _ e@(PositionedValue pos _ _) = return (pos, e)
+        goExpr _ (Op pos op) =
+          (pos,) <$> case op `M.lookup` valueAliased of
+            Just (Qualified mn' (Left alias)) ->
+              return $ Var pos (Qualified mn' alias)
+            Just (Qualified mn' (Right alias)) ->
+              return $ Constructor pos (Qualified mn' alias)
+            Nothing ->
+              throwError . errorMessage' pos . UnknownName $ fmap ValOpName op
+        goExpr pos other = return (pos, other)
+
+        goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
+        goBinder _ b@(PositionedBinder pos _ _) = return (pos, b)
+        goBinder _ (BinaryNoParensBinder (OpBinder pos op) lhs rhs) =
+          case op `M.lookup` valueAliased of
+            Just (Qualified mn' (Left alias)) ->
+              throwError . errorMessage' pos $ InvalidOperatorInBinder op (Qualified mn' alias)
+            Just (Qualified mn' (Right alias)) ->
+              return (pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs])
+            Nothing ->
+              throwError . errorMessage' pos . UnknownName $ fmap ValOpName op
+        goBinder _ BinaryNoParensBinder {} =
+          internalError "BinaryNoParensBinder has no OpBinder"
+        goBinder pos other = return (pos, other)
+
+        goType :: SourceSpan -> SourceType -> m SourceType
+        goType pos (TypeOp ann2 op) =
+          case op `M.lookup` typeAliased of
+            Just alias ->
+              return $ TypeConstructor ann2 alias
+            Nothing ->
+              throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op
+        goType _ other = return other
 
 -- | Indicates whether the `rebracketModule`
 -- is being called with the full desugar pass
@@ -194,39 +219,39 @@ data RebracketCaller
   | CalledByDocs
   deriving (Eq, Show)
 
-rebracketModule
-  :: forall m
-   . (MonadError MultipleErrors m)
-  => MonadSupply m
-  => RebracketCaller
-  -> (Declaration -> Bool)
-  -> [[(Qualified (OpName 'ValueOpName), Associativity)]]
-  -> [[(Qualified (OpName 'TypeOpName), Associativity)]]
-  -> Module
-  -> m Module
+rebracketModule ::
+  forall m.
+  (MonadError MultipleErrors m) =>
+  (MonadSupply m) =>
+  RebracketCaller ->
+  (Declaration -> Bool) ->
+  [[(Qualified (OpName 'ValueOpName), Associativity)]] ->
+  [[(Qualified (OpName 'TypeOpName), Associativity)]] ->
+  Module ->
+  m Module
 rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) =
   Module ss coms mn <$> f' ds <*> pure exts
   where
-  f' :: [Declaration] -> m [Declaration]
-  f' =
-    fmap (map (\d -> if pred_ d then removeParens d else d)) .
-    flip parU (usingPredicate pred_ h)
-
-  -- The AST will run through all the desugar passes when compiling
-  -- and only some of the desugar passes when generating docs.
-  -- When generating docs, `case _ of` syntax used in an instance declaration
-  -- can trigger the `IncorrectAnonymousArgument` error because it does not
-  -- run the same passes that the compile desugaring does. Since `purs docs`
-  -- will only succeed once `purs compile` succeeds, we can ignore this check
-  -- when running `purs docs`.
-  -- See https://github.com/purescript/purescript/issues/4274#issuecomment-1087730651=
-  -- for more info.
-  h :: Declaration -> m Declaration
-  h = case caller of
-    CalledByDocs -> f
-    CalledByCompile -> g <=< f
-
-  (f, _, _, _, _, _) =
+    f' :: [Declaration] -> m [Declaration]
+    f' =
+      fmap (map (\d -> if pred_ d then removeParens d else d))
+        . flip parU (usingPredicate pred_ h)
+
+    -- The AST will run through all the desugar passes when compiling
+    -- and only some of the desugar passes when generating docs.
+    -- When generating docs, `case _ of` syntax used in an instance declaration
+    -- can trigger the `IncorrectAnonymousArgument` error because it does not
+    -- run the same passes that the compile desugaring does. Since `purs docs`
+    -- will only succeed once `purs compile` succeeds, we can ignore this check
+    -- when running `purs docs`.
+    -- See https://github.com/purescript/purescript/issues/4274#issuecomment-1087730651=
+    -- for more info.
+    h :: Declaration -> m Declaration
+    h = case caller of
+      CalledByDocs -> f
+      CalledByCompile -> g <=< f
+
+    (f, _, _, _, _, _) =
       everywhereWithContextOnValuesM
         ss
         (\_ d -> (declSourceSpan d,) <$> goDecl d)
@@ -236,27 +261,30 @@ rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds ext
         defS
         defS
 
-  (g, _, _) = everywhereOnValuesTopDownM pure removeBinaryNoParens pure
+    (g, _, _) = everywhereOnValuesTopDownM pure removeBinaryNoParens pure
 
-  (goDecl, goExpr', goBinder') = updateTypes goType
+    (goDecl, goExpr', goBinder') = updateTypes goType
 
-  goType :: SourceSpan -> SourceType -> m SourceType
-  goType = flip matchTypeOperators typeOpTable
+    goType :: SourceSpan -> SourceType -> m SourceType
+    goType = flip matchTypeOperators typeOpTable
 
-  wrap :: (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a)
-  wrap go (ss', a) = (ss',) <$> go a
+    wrap :: (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a)
+    wrap go (ss', a) = (ss',) <$> go a
 
 removeBinaryNoParens :: (MonadError MultipleErrors m, MonadSupply m) => Expr -> m Expr
 removeBinaryNoParens u
   | isAnonymousArgument u = case u of
-                              PositionedValue p _ _ -> rethrowWithPosition p err
-                              _ -> err
-                            where err = throwError . errorMessage $ IncorrectAnonymousArgument
+      PositionedValue p _ _ -> rethrowWithPosition p err
+      _ -> err
+  where
+    err = throwError . errorMessage $ IncorrectAnonymousArgument
 removeBinaryNoParens (Parens (stripPositionInfo -> BinaryNoParens op l r))
-  | isAnonymousArgument r = do arg <- freshIdent'
-                               return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (Qualified ByNullSourcePos arg))
-  | isAnonymousArgument l = do arg <- freshIdent'
-                               return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified ByNullSourcePos arg))) r
+  | isAnonymousArgument r = do
+      arg <- freshIdent'
+      return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (Qualified ByNullSourcePos arg))
+  | isAnonymousArgument l = do
+      arg <- freshIdent'
+      return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified ByNullSourcePos arg))) r
 removeBinaryNoParens (BinaryNoParens op l r) = return $ App (App op l) r
 removeBinaryNoParens e = return e
 
@@ -267,230 +295,233 @@ stripPositionInfo e = e
 removeParens :: Declaration -> Declaration
 removeParens = f
   where
-  (f, _, _) =
+    (f, _, _) =
       everywhereOnValues
         (runIdentity . goDecl)
         (goExpr . decontextify goExpr')
         (goBinder . decontextify goBinder')
 
-  (goDecl, goExpr', goBinder') = updateTypes (\_ -> return . goType)
+    (goDecl, goExpr', goBinder') = updateTypes (\_ -> return . goType)
 
-  goExpr :: Expr -> Expr
-  goExpr (Parens val) = goExpr val
-  goExpr val = val
+    goExpr :: Expr -> Expr
+    goExpr (Parens val) = goExpr val
+    goExpr val = val
 
-  goBinder :: Binder -> Binder
-  goBinder (ParensInBinder b) = goBinder b
-  goBinder b = b
+    goBinder :: Binder -> Binder
+    goBinder (ParensInBinder b) = goBinder b
+    goBinder b = b
 
-  goType :: Type a -> Type a
-  goType (ParensInType _ t) = goType t
-  goType t = t
+    goType :: Type a -> Type a
+    goType (ParensInType _ t) = goType t
+    goType t = t
 
-  decontextify
-    :: (SourceSpan -> a -> Identity (SourceSpan, a))
-    -> a
-    -> a
-  decontextify ctxf = snd . runIdentity . ctxf (internalError "attempted to use SourceSpan in removeParens")
+    decontextify ::
+      (SourceSpan -> a -> Identity (SourceSpan, a)) ->
+      a ->
+      a
+    decontextify ctxf = snd . runIdentity . ctxf (internalError "attempted to use SourceSpan in removeParens")
 
 externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord]
-externsFixities ExternsFile{..} =
-  map fromFixity efFixities ++ map fromTypeFixity efTypeFixities
-  where
-
-  fromFixity
-    :: ExternsFixity
-    -> Either ValueFixityRecord TypeFixityRecord
-  fromFixity (ExternsFixity assoc prec op name) =
-    Left
-      ( Qualified (ByModuleName efModuleName) op
-      , internalModuleSourceSpan ""
-      , Fixity assoc prec
-      , name
-      )
-
-  fromTypeFixity
-    :: ExternsTypeFixity
-    -> Either ValueFixityRecord TypeFixityRecord
-  fromTypeFixity (ExternsTypeFixity assoc prec op name) =
-    Right
-      ( Qualified (ByModuleName efModuleName) op
-      , internalModuleSourceSpan ""
-      , Fixity assoc prec
-      , name
-      )
+externsFixities ExternsFile {..} =
+  map (fromFixity efModuleName) efFixities ++ map (fromTypeFixity efModuleName) efTypeFixities
+
+
+fromFixity ::
+  P.ModuleName ->
+  ExternsFixity ->
+  Either ValueFixityRecord TypeFixityRecord
+fromFixity mName (ExternsFixity assoc prec op name) =
+  Left
+    ( Qualified (ByModuleName mName) op,
+      internalModuleSourceSpan "",
+      Fixity assoc prec,
+      name
+    )
+
+fromTypeFixity ::
+  P.ModuleName ->
+  ExternsTypeFixity ->
+  Either ValueFixityRecord TypeFixityRecord
+fromTypeFixity mName (ExternsTypeFixity assoc prec op name) =
+  Right
+    ( Qualified (ByModuleName mName) op,
+      internalModuleSourceSpan "",
+      Fixity assoc prec,
+      name
+    )
 
 collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord]
 collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
   where
-  collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord]
-  collect (ValueFixityDeclaration (ss, _) fixity name op) =
-    [Left (Qualified (ByModuleName moduleName) op, ss, fixity, name)]
-  collect (TypeFixityDeclaration (ss, _) fixity name op) =
-    [Right (Qualified (ByModuleName moduleName) op, ss, fixity, name)]
-  collect _ = []
-
-ensureNoDuplicates
-  :: (Ord a, MonadError MultipleErrors m)
-  => (a -> SimpleErrorMessage)
-  -> [(Qualified a, SourceSpan)]
-  -> m ()
+    collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord]
+    collect (ValueFixityDeclaration (ss, _) fixity name op) =
+      [Left (Qualified (ByModuleName moduleName) op, ss, fixity, name)]
+    collect (TypeFixityDeclaration (ss, _) fixity name op) =
+      [Right (Qualified (ByModuleName moduleName) op, ss, fixity, name)]
+    collect _ = []
+
+ensureNoDuplicates ::
+  (Ord a, MonadError MultipleErrors m) =>
+  (a -> SimpleErrorMessage) ->
+  [(Qualified a, SourceSpan)] ->
+  m ()
 ensureNoDuplicates toError m = go $ sortOn fst m
   where
-  go [] = return ()
-  go [_] = return ()
-  go ((x@(Qualified (ByModuleName mn) op), _) : (y, pos) : _) | x == y =
-    rethrow (addHint (ErrorInModule mn)) $
-      rethrowWithPosition pos $ throwError . errorMessage $ toError op
-  go (_ : rest) = go rest
-
-customOperatorTable
-  :: [(Qualified op, Fixity)]
-  -> [[(Qualified op, Associativity)]]
+    go [] = return ()
+    go [_] = return ()
+    go ((x@(Qualified (ByModuleName mn) op), _) : (y, pos) : _)
+      | x == y =
+          rethrow (addHint (ErrorInModule mn)) $
+            rethrowWithPosition pos $
+              throwError . errorMessage $
+                toError op
+    go (_ : rest) = go rest
+
+customOperatorTable ::
+  [(Qualified op, Fixity)] ->
+  [[(Qualified op, Associativity)]]
 customOperatorTable fixities =
-  let
-    userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities
-    sorted = sortOn (Down . (\(_, p, _) -> p)) userOps
-    groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted
-  in
-    map (map (\(name, _, a) -> (name, a))) groups
-
-updateTypes
-  :: forall m
-   . Monad m
-  => (SourceSpan -> SourceType -> m SourceType)
-  -> ( Declaration -> m Declaration
-     , SourceSpan -> Expr -> m (SourceSpan, Expr)
-     , SourceSpan -> Binder -> m (SourceSpan, Binder)
-     )
+  let userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities
+      sorted = sortOn (Down . (\(_, p, _) -> p)) userOps
+      groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted
+   in map (map (\(name, _, a) -> (name, a))) groups
+
+updateTypes ::
+  forall m.
+  (Monad m) =>
+  (SourceSpan -> SourceType -> m SourceType) ->
+  ( Declaration -> m Declaration,
+    SourceSpan -> Expr -> m (SourceSpan, Expr),
+    SourceSpan -> Binder -> m (SourceSpan, Binder)
+  )
 updateTypes goType = (goDecl, goExpr, goBinder)
   where
+    goType' :: SourceSpan -> SourceType -> m SourceType
+    goType' = everywhereOnTypesTopDownM . goType
+
+    goDecl :: Declaration -> m Declaration
+    goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) =
+      DataDeclaration sa ddt name
+        <$> traverse (traverse (traverse (goType' ss))) args
+        <*> traverse (traverseDataCtorFields (traverse (sndM (goType' ss)))) dctors
+    goDecl (ExternDeclaration sa@(ss, _) name ty) =
+      ExternDeclaration sa name <$> goType' ss ty
+    goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do
+      implies' <- traverse (overConstraintArgs (traverse (goType' ss))) implies
+      args' <- traverse (traverse (traverse (goType' ss))) args
+      return $ TypeClassDeclaration sa name args' implies' deps decls
+    goDecl (TypeInstanceDeclaration sa@(ss, _) na ch idx name cs className tys impls) = do
+      cs' <- traverse (overConstraintArgs (traverse (goType' ss))) cs
+      tys' <- traverse (goType' ss) tys
+      return $ TypeInstanceDeclaration sa na ch idx name cs' className tys' impls
+    goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) =
+      TypeSynonymDeclaration sa name
+        <$> traverse (traverse (traverse (goType' ss))) args
+        <*> goType' ss ty
+    goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) =
+      TypeDeclaration . TypeDeclarationData sa expr <$> goType' ss ty
+    goDecl (KindDeclaration sa@(ss, _) sigFor name ty) =
+      KindDeclaration sa sigFor name <$> goType' ss ty
+    goDecl (ExternDataDeclaration sa@(ss, _) name ty) =
+      ExternDataDeclaration sa name <$> goType' ss ty
+    goDecl other =
+      return other
 
-  goType' :: SourceSpan -> SourceType -> m SourceType
-  goType' = everywhereOnTypesTopDownM . goType
-
-  goDecl :: Declaration -> m Declaration
-  goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) =
-    DataDeclaration sa ddt name
-      <$> traverse (traverse (traverse (goType' ss))) args
-      <*> traverse (traverseDataCtorFields (traverse (sndM (goType' ss)))) dctors
-  goDecl (ExternDeclaration sa@(ss, _) name ty) =
-    ExternDeclaration sa name <$> goType' ss ty
-  goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do
-    implies' <- traverse (overConstraintArgs (traverse (goType' ss))) implies
-    args' <- traverse (traverse (traverse (goType' ss))) args
-    return $ TypeClassDeclaration sa name args' implies' deps decls
-  goDecl (TypeInstanceDeclaration sa@(ss, _) na ch idx name cs className tys impls) = do
-    cs' <- traverse (overConstraintArgs (traverse (goType' ss))) cs
-    tys' <- traverse (goType' ss) tys
-    return $ TypeInstanceDeclaration sa na ch idx name cs' className tys' impls
-  goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) =
-    TypeSynonymDeclaration sa name
-      <$> traverse (traverse (traverse (goType' ss))) args
-      <*> goType' ss ty
-  goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) =
-    TypeDeclaration . TypeDeclarationData sa expr <$> goType' ss ty
-  goDecl (KindDeclaration sa@(ss, _) sigFor name ty) =
-    KindDeclaration sa sigFor name <$> goType' ss ty
-  goDecl (ExternDataDeclaration sa@(ss, _) name ty) =
-    ExternDataDeclaration sa name <$> goType' ss ty
-  goDecl other =
-    return other
-
-  goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
-  goExpr _ e@(PositionedValue pos _ _) = return (pos, e)
-  goExpr pos (TypeClassDictionary (Constraint ann name kinds tys info) dicts hints) = do
-    kinds' <- traverse (goType' pos) kinds
-    tys' <- traverse (goType' pos) tys
-    return (pos, TypeClassDictionary (Constraint ann name kinds' tys' info) dicts hints)
-  goExpr pos (DeferredDictionary cls tys) = do
-    tys' <- traverse (goType' pos) tys
-    return (pos, DeferredDictionary cls tys')
-  goExpr pos (TypedValue check v ty) = do
-    ty' <- goType' pos ty
-    return (pos, TypedValue check v ty')
-  goExpr pos (VisibleTypeApp v ty) = do
-    ty' <- goType' pos ty
-    return (pos, VisibleTypeApp v ty')
-  goExpr pos other = return (pos, other)
-
-  goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
-  goBinder _ e@(PositionedBinder pos _ _) = return (pos, e)
-  goBinder pos (TypedBinder ty b) = do
-    ty' <- goType' pos ty
-    return (pos, TypedBinder ty' b)
-  goBinder pos other = return (pos, other)
+    goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr)
+    goExpr _ e@(PositionedValue pos _ _) = return (pos, e)
+    goExpr pos (TypeClassDictionary (Constraint ann name kinds tys info) dicts hints) = do
+      kinds' <- traverse (goType' pos) kinds
+      tys' <- traverse (goType' pos) tys
+      return (pos, TypeClassDictionary (Constraint ann name kinds' tys' info) dicts hints)
+    goExpr pos (DeferredDictionary cls tys) = do
+      tys' <- traverse (goType' pos) tys
+      return (pos, DeferredDictionary cls tys')
+    goExpr pos (TypedValue check v ty) = do
+      ty' <- goType' pos ty
+      return (pos, TypedValue check v ty')
+    goExpr pos (VisibleTypeApp v ty) = do
+      ty' <- goType' pos ty
+      return (pos, VisibleTypeApp v ty')
+    goExpr pos other = return (pos, other)
+
+    goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder)
+    goBinder _ e@(PositionedBinder pos _ _) = return (pos, e)
+    goBinder pos (TypedBinder ty b) = do
+      ty' <- goType' pos ty
+      return (pos, TypedBinder ty' b)
+    goBinder pos other = return (pos, other)
 
 -- |
 -- Checks all the fixity exports within a module to ensure that members aliased
 -- by the operators are also exported from the module.
 --
 -- This pass requires name desugaring and export elaboration to have run first.
---
-checkFixityExports
-  :: forall m
-   . MonadError MultipleErrors m
-  => Module
-  -> m Module
+checkFixityExports ::
+  forall m.
+  (MonadError MultipleErrors m) =>
+  Module ->
+  m Module
 checkFixityExports (Module _ _ _ _ Nothing) =
   internalError "exports should have been elaborated before checkFixityExports"
 checkFixityExports m@(Module ss _ mn ds (Just exps)) =
-  rethrow (addHint (ErrorInModule mn))
-    $ rethrowWithPosition ss (traverse_ checkRef exps)
-    $> m
+  rethrow (addHint (ErrorInModule mn)) $
+    rethrowWithPosition ss (traverse_ checkRef exps)
+      $> m
   where
-
-  checkRef :: DeclarationRef -> m ()
-  checkRef dr@(ValueOpRef ss' op) =
-    for_ (getValueOpAlias op) $ \case
-      Left ident ->
-        unless (ValueRef ss' ident `elem` exps)
-          . throwError . errorMessage' ss'
-          $ TransitiveExportError dr [ValueRef ss' ident]
-      Right ctor ->
-        unless (anyTypeRef (maybe False (elem ctor) . snd))
-          . throwError . errorMessage' ss
-          $ TransitiveDctorExportError dr [ctor]
-  checkRef dr@(TypeOpRef ss' op) =
-    for_ (getTypeOpAlias op) $ \ty ->
-      unless (anyTypeRef ((== ty) . fst))
-        . throwError . errorMessage' ss'
-        $ TransitiveExportError dr [TypeRef ss' ty Nothing]
-  checkRef _ = return ()
-
-  -- Finds the name associated with a type operator when that type is also
-  -- defined in the current module.
-  getTypeOpAlias :: OpName 'TypeOpName -> Maybe (ProperName 'TypeName)
-  getTypeOpAlias op =
-    listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds)
-    where
-    go (TypeFixity _ (Qualified (ByModuleName mn') ident) op')
-      | mn == mn' && op == op' = Just ident
-    go _ = Nothing
-
-  -- Finds the value or data constructor associated with an operator when that
-  -- declaration is also in the current module.
-  getValueOpAlias
-    :: OpName 'ValueOpName
-    -> Maybe (Either Ident (ProperName 'ConstructorName))
-  getValueOpAlias op =
-    listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds)
-    where
-    go (ValueFixity _ (Qualified (ByModuleName mn') ident) op')
-      | mn == mn' && op == op' = Just ident
-    go _ = Nothing
-
-  -- Tests the exported `TypeRef` entries with a predicate.
-  anyTypeRef
-    :: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool)
-    -> Bool
-  anyTypeRef f = any (maybe False f . getTypeRef) exps
-
-usingPredicate
-  :: forall f a
-   . Applicative f
-  => (a -> Bool)
-  -> (a -> f a)
-  -> (a -> f a)
+    checkRef :: DeclarationRef -> m ()
+    checkRef dr@(ValueOpRef ss' op) =
+      for_ (getValueOpAlias op) $ \case
+        Left ident ->
+          unless (ValueRef ss' ident `elem` exps)
+            . throwError
+            . errorMessage' ss'
+            $ TransitiveExportError dr [ValueRef ss' ident]
+        Right ctor ->
+          unless (anyTypeRef (maybe False (elem ctor) . snd))
+            . throwError
+            . errorMessage' ss
+            $ TransitiveDctorExportError dr [ctor]
+    checkRef dr@(TypeOpRef ss' op) =
+      for_ (getTypeOpAlias op) $ \ty ->
+        unless (anyTypeRef ((== ty) . fst))
+          . throwError
+          . errorMessage' ss'
+          $ TransitiveExportError dr [TypeRef ss' ty Nothing]
+    checkRef _ = return ()
+
+    -- Finds the name associated with a type operator when that type is also
+    -- defined in the current module.
+    getTypeOpAlias :: OpName 'TypeOpName -> Maybe (ProperName 'TypeName)
+    getTypeOpAlias op =
+      listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds)
+      where
+        go (TypeFixity _ (Qualified (ByModuleName mn') ident) op')
+          | mn == mn' && op == op' = Just ident
+        go _ = Nothing
+
+    -- Finds the value or data constructor associated with an operator when that
+    -- declaration is also in the current module.
+    getValueOpAlias ::
+      OpName 'ValueOpName ->
+      Maybe (Either Ident (ProperName 'ConstructorName))
+    getValueOpAlias op =
+      listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds)
+      where
+        go (ValueFixity _ (Qualified (ByModuleName mn') ident) op')
+          | mn == mn' && op == op' = Just ident
+        go _ = Nothing
+
+    -- Tests the exported `TypeRef` entries with a predicate.
+    anyTypeRef ::
+      ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool) ->
+      Bool
+    anyTypeRef f = any (maybe False f . getTypeRef) exps
+
+usingPredicate ::
+  forall f a.
+  (Applicative f) =>
+  (a -> Bool) ->
+  (a -> f a) ->
+  (a -> f a)
 usingPredicate p f x =
   if p x then f x else pure x
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 4f3129baf8..cf39dfd173 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -4,6 +4,7 @@
 --
 module Language.PureScript.Sugar.TypeClasses
   ( desugarTypeClasses
+  , desugarTypeClassesUsingMemberMap
   , typeClassMemberName
   , superClassDictionaryNames
   ) where
@@ -49,7 +50,23 @@ desugarTypeClasses
   => [ExternsFile]
   -> Module
   -> m Module
-desugarTypeClasses externs = flip evalStateT initialState . desugarModule
+desugarTypeClasses externs = desugarTypeClassesUsingMemberMap 
+    $ M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
+  where 
+  fromExternsDecl
+    :: ModuleName
+    -> ExternsDeclaration
+    -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
+  fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty) = Just ((mn, name), typeClass) where
+    typeClass = makeTypeClassData args members implies deps tcIsEmpty
+  fromExternsDecl _ _ = Nothing
+  
+desugarTypeClassesUsingMemberMap
+  :: (MonadSupply m, MonadError MultipleErrors m)
+  => MemberMap
+  -> Module
+  -> m Module
+desugarTypeClassesUsingMemberMap classes = flip evalStateT initialState . desugarModule
   where
   initialState :: MemberMap
   initialState =
@@ -61,16 +78,10 @@ desugarTypeClasses externs = flip evalStateT initialState . desugarModule
       , M.mapKeys (qualify C.M_Prim_Symbol) primSymbolClasses
       , M.mapKeys (qualify C.M_Prim_Int) primIntClasses
       , M.mapKeys (qualify C.M_Prim_TypeError) primTypeErrorClasses
-      , M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
+      , classes
       ]
 
-  fromExternsDecl
-    :: ModuleName
-    -> ExternsDeclaration
-    -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
-  fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty) = Just ((mn, name), typeClass) where
-    typeClass = makeTypeClassData args members implies deps tcIsEmpty
-  fromExternsDecl _ _ = Nothing
+
 
 desugarModule
   :: (MonadSupply m, MonadError MultipleErrors m)

From 8ae18c473078ef123ba3a64679d3ce564d7c6e68 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 15:45:34 +0200
Subject: [PATCH 096/297] get externs from sqlite ordered

---
 src/Language/PureScript/Lsp/Cache.hs | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 1687a638fe..e968a5c0e4 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -29,7 +29,7 @@ selectAllExterns = do
   DB.query_ (Query "SELECT value FROM externs") <&> fmap (deserialise . fromOnly)
 
 selectDependenciesMap :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m (Map P.ModuleName ExternsFile)
-selectDependenciesMap importedModuleNames = do
+selectDependenciesMap importedModuleNames =
   Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectDependencies importedModuleNames
 
 selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m [ExternsFile]
@@ -51,11 +51,12 @@ selectDependencies (P.Module _ _ _ decls _) = do
           " select imported_module, max(level) as level",
           " from graph group by imported_module",
           "),",
-          "module_names as (select distinct(module_name)",
+          "module_names as (select distinct(module_name), level",
           "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
           "order by level desc)",
           "select value from externs ",
-          "join module_names on externs.module_name = module_names.module_name;"
+          "join module_names on externs.module_name = module_names.module_name ",
+          "order by level desc, module_names.module_name desc;"
         ]
 
     importedModuleNames =

From 9f33f1891f235830d76dd764a17d55cd0bdd7004 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 15:46:04 +0200
Subject: [PATCH 097/297] adds rebuildModuleWithProvidedEnv

---
 src/Language/PureScript/Make.hs | 86 +++++++++++++++++++++++++++++----
 1 file changed, 77 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 8efd376b62..2692ce3f45 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 module Language.PureScript.Make
   ( -- * Make API
     rebuildModule,
@@ -16,9 +17,9 @@ import Control.Monad (foldM, unless, when, (<=<))
 import Control.Monad.Base (MonadBase (liftBase))
 import Control.Monad.Error.Class (MonadError (..))
 import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
+import Control.Monad.Supply (SupplyT, evalSupplyT, runSupply, runSupplyT)
 import Control.Monad.Trans.Control (MonadBaseControl (..))
-import Control.Monad.Trans.State (runStateT)
+import Control.Monad.Trans.State (StateT, runStateT)
 import Control.Monad.Writer.Class (MonadWriter (..), censor)
 import Control.Monad.Writer.Strict (runWriterT)
 import Data.Foldable (fold, for_)
@@ -35,7 +36,8 @@ import Language.PureScript.CST qualified as CST
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Docs.Convert qualified as Docs
-import Language.PureScript.Environment (initEnvironment)
+import Language.PureScript.Docs.Types qualified as Docs
+import Language.PureScript.Environment (Environment, initEnvironment)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
 import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile)
 import Language.PureScript.Linter (Name (..), lint, lintImports)
@@ -45,7 +47,7 @@ import Language.PureScript.Make.BuildPlan qualified as BuildPlan
 import Language.PureScript.Make.Cache qualified as Cache
 import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
-import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
+import Language.PureScript.Names (ModuleName, Qualified, isBuiltinModuleName, runModuleName)
 import Language.PureScript.Renamer (renameInModule)
 import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
@@ -77,6 +79,7 @@ rebuildModule' ::
   m ExternsFile
 rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
 
+
 rebuildModuleWithIndex ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
@@ -91,7 +94,6 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
       withPrim = importPrim m
   lint withPrim
-
   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
     (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
@@ -122,7 +124,6 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
       (renamedIdents, renamed) = renameInModule optimized
       exts = moduleToExternsFile mod' env' renamedIdents
   ffiCodegen renamed
-
   -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
   -- but I have not done so for two reasons:
   -- 1. This should never fail; any genuine errors in the code should have been
@@ -141,6 +142,75 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
 
   evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
   return exts
+  
+rebuildModuleWithProvidedEnv ::
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  (Module -> StateT (Env, M.Map ModuleName [Qualified Name]) (SupplyT m) Module) ->
+  (Module -> Either MultipleErrors Docs.Module) ->
+  MakeActions m ->
+  Env ->
+  Environment ->
+  Module ->
+  Maybe (Int, Int) ->
+  m (ExternsFile, Environment)
+rebuildModuleWithProvidedEnv desugar' convertDocsModule MakeActions {..} exEnv env m@(Module _ _ moduleName _ _) moduleIndex = do
+  progress $ CompilingModule moduleName moduleIndex
+  let withPrim = importPrim m
+  lint withPrim
+  ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
+    (desugared, (exEnv', usedImports)) <- runStateT (desugar' withPrim) (exEnv, mempty)
+    let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
+    (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+    let usedImports' =
+          foldl'
+            ( flip $ \(fromModuleName, newtypeCtorName) ->
+                M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
+            )
+            usedImports
+            checkConstructorImportsForCoercible
+    -- Imports cannot be linted before type checking because we need to
+    -- known which newtype constructors are used to solve Coercible
+    -- constraints in order to not report them as unused.
+    censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
+    return (checked, checkEnv)
+
+  -- desugar case declarations *after* type- and exhaustiveness checking
+  -- since pattern guards introduces cases which the exhaustiveness checker
+  -- reports as not-exhaustive.
+  (deguarded, nextVar') <- runSupplyT nextVar $ do
+    desugarCaseGuards elaborated
+
+  regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
+  let mod' = Module ss coms moduleName regrouped exps
+      corefn = CF.moduleToCoreFn env' mod'
+      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
+      (renamedIdents, renamed) = renameInModule optimized
+      exts = moduleToExternsFile mod' env' renamedIdents
+  ffiCodegen renamed
+  -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
+  -- but I have not done so for two reasons:
+  -- 1. This should never fail; any genuine errors in the code should have been
+  -- caught earlier in this function. Therefore if we do fail here it indicates
+  -- a bug in the compiler, which should be reported as such.
+  -- 2. We do not want to perform any extra work generating docs unless the
+  -- user has asked for docs to be generated.
+  let docs = case convertDocsModule withPrim of
+        Left errs ->
+          internalError $
+            "Failed to produce docs for "
+              ++ T.unpack (runModuleName moduleName)
+              ++ "; details:\n"
+              ++ prettyPrintMultipleErrors defaultPPEOptions errs
+        Right d -> d
+
+  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
+  return (exts, env')
+
+-- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
+-- but I have not done so for two reasons:
+-- 1. This should never fail; any genuine errors in the code should have been
+-- caught earlier in this function. Therefore if we
 
 -- rebuildModuleUsingDbEnv ::
 --   forall m.
@@ -152,11 +222,10 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
 --   let withPrim = importPrim m
 --   lint withPrim
 --   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
-  
+
 --     desugared <- desugarLsp withPrim
 --     -- (desugared, (exEnv', usedImports)) <- runStateT (desugarLsp externs withPrim) (exEnv, mempty)
 
-    
 --     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
 --     (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
 --     let usedImports' =
@@ -205,7 +274,6 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
 --   evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
 --   return exts
 
-
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
 --
 -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without

From 6dfbafe71e596809e8ccb68aa8751087c04dc7c7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 15:46:14 +0200
Subject: [PATCH 098/297] remove comments

---
 src/Language/PureScript/Environment.hs | 19 -------------------
 1 file changed, 19 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 9bb6838ccd..560055d334 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -52,25 +52,6 @@ data Environment = Environment
 instance NFData Environment
 
 
-data EnvironmentFn m = EnvironmentFn 
-  { namesFn :: Qualified Ident -> m (Maybe (SourceType, NameKind, NameVisibility))
-  , typesFn :: Qualified (ProperName 'TypeName) -> m (Maybe (SourceType, TypeKind))
-  , dataConstructorsFn :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-  , typeSynonymsFn :: Qualified (ProperName 'TypeName) -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
-  , typeClassDictionariesFn :: QualifiedBy -> m (Maybe (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-  , typeClassesFn :: Qualified (ProperName 'ClassName) -> m (Maybe TypeClassData)
-  }
-
-toEnvFn :: Applicative m => Environment -> EnvironmentFn m
-toEnvFn env = EnvironmentFn
-  { namesFn = \k -> pure $ M.lookup k (names env)
-  , typesFn = \k -> pure $ M.lookup k (types env)
-  , dataConstructorsFn = \k -> pure $ M.lookup k (dataConstructors env)
-  , typeSynonymsFn = \k -> pure $ M.lookup k (typeSynonyms env)
-  , typeClassDictionariesFn = \k -> pure $ M.lookup k (typeClassDictionaries env)
-  , typeClassesFn = \k -> pure $ M.lookup k (typeClasses env)
-  }
-
 -- | Information about a type class
 data TypeClassData = TypeClassData
   { typeClassArguments :: [(Text, Maybe SourceType)]

From 71b25d2b1a14a551072d40e2d774ca86ddb577e1 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 15:46:20 +0200
Subject: [PATCH 099/297] adds perf logs

---
 src/Language/PureScript/Lsp/Log.hs     | 17 ++++++++
 src/Language/PureScript/Lsp/Rebuild.hs | 58 +++++++++++++-------------
 2 files changed, 46 insertions(+), 29 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index adda0a5a6c..b34fa39a78 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -4,6 +4,8 @@ import Data.Text qualified as T
 import Data.Time (UTCTime (utctDayTime), defaultTimeLocale, formatTime, getCurrentTime)
 import Language.PureScript.Lsp.Types (LspConfig (confLogLevel), LspEnvironment (lspConfig), LspLogLevel (..))
 import Protolude
+import System.Clock (TimeSpec, getTime, Clock (Monotonic), diffTimeSpec)
+import Language.PureScript.Ide.Logging (displayTimeSpec)
 
 infoLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
 infoLsp = logLsp LogMsgInfo
@@ -35,6 +37,21 @@ logLsp msgLogLevel msg = do
             <> show msg
         )
 
+logPerfStandard :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m t -> m t
+logPerfStandard label f = logPerf (labelTimespec label) f
+
+logPerf :: (MonadIO m, MonadReader LspEnvironment m) => (TimeSpec -> Text) -> m t -> m t
+logPerf format f = do
+  start <- liftIO (getTime Monotonic)
+  result <- f
+  end <- liftIO (getTime Monotonic)
+  perfLsp (format (diffTimeSpec start end))
+  pure result
+
+
+labelTimespec :: Text -> TimeSpec -> Text
+labelTimespec label duration = label <> ": " <> displayTimeSpec duration
+
 data LogMsgSeverity
   = LogMsgInfo
   | LogMsgWarning
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 39e8afefb0..edb8a05bdd 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -19,7 +19,8 @@ import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
-import Language.PureScript.Lsp.Cache (selectDependenciesMap)
+import Language.PureScript.Lsp.Cache (selectDependencies)
+import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.ReadFile (lspReadFile)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make (ffiCodegen')
@@ -37,7 +38,7 @@ rebuildFile ::
   ) =>
   FilePath ->
   m (Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors))
-rebuildFile srcPath = do
+rebuildFile srcPath = logPerfStandard ("Rebuild file " <> T.pack srcPath) do
   (fp, input) <-
     case List.stripPrefix "data:" srcPath of
       Just source -> pure ("", T.pack source)
@@ -47,31 +48,30 @@ rebuildFile srcPath = do
       pure $ Left ([(fp, input)], CST.toMultipleErrors fp parseError)
     Right (pwarnings, m) -> do
       let moduleName = P.getModuleName m
-      externsResult <- sortExterns m =<< selectDependenciesMap m
-      case externsResult of
-        Left err -> pure $ Left ([], err)
-        Right externs -> do
-          outputDirectory <- asks (confOutputPath . lspConfig)
-          let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
-          let pureRebuild = fp == ""
-          let modulePath = if pureRebuild then fp else srcPath
-          foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
-          conn <- asks lspDbConnection
-          let makeEnv =
-                P.buildMakeActions outputDirectory filePathMap foreigns False
-                  & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
-                  & shushProgress
-                  & addAllIndexing conn
-          (result, warnings) <- liftIO $ P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-            newExterns <- P.rebuildModule makeEnv externs m
-            unless pureRebuild $
-              updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
-            pure newExterns
-          case result of
-            Left errors ->
-              pure (Left ([(fp, input)], errors))
-            Right newExterns -> do
-              pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
+      !externs <- logPerfStandard "Select depenencies" $ selectDependencies m
+      outputDirectory <- asks (confOutputPath . lspConfig)
+      let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+      let pureRebuild = fp == ""
+      let modulePath = if pureRebuild then fp else srcPath
+      foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
+      conn <- asks lspDbConnection
+      let makeEnv =
+            P.buildMakeActions outputDirectory filePathMap foreigns False
+              & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
+              & shushProgress
+              & addAllIndexing conn
+      (!result, warnings) <- logPerfStandard ("Rebuild Module " <> T.pack srcPath) $ fmap force $ liftIO $ do
+        P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+          newExterns <- P.rebuildModule makeEnv externs m
+          unless pureRebuild $
+            updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
+          pure newExterns
+      case result of
+        Left errors ->
+          pure (Left ([(fp, input)], errors))
+        Right newExterns -> do
+          pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
+
 codegenTargets :: Set P.CodegenTarget
 codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
@@ -101,10 +101,10 @@ enableForeignCheck foreigns codegenTargets' ma =
     }
 
 -- | Returns a topologically sorted list of dependent ExternsFiles for the given
--- module. Throws an error if there is a cyclic dependency within the
+-- module. Returns an error if there is a cyclic dependency within the
 -- ExternsFiles
 sortExterns ::
-  (MonadThrow m) =>
+  (Monad m) =>
   P.Module ->
   ModuleMap P.ExternsFile ->
   m (Either MultipleErrors [P.ExternsFile])

From 08a46134fcc9bc07698a82963cf322e989a3f1b7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 18:20:56 +0200
Subject: [PATCH 100/297] only search in available srcs

---
 src/Language/PureScript/Lsp/Cache/Query.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index e6d5ecf556..9b21affe54 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -152,7 +152,9 @@ getAstDeclarationsStartingWith ::
   m [CompletionResult]
 getAstDeclarationsStartingWith limit offset moduleName' prefix = do
   DB.queryNamed
-    "SELECT name, printed_type, module_name FROM ast_declarations \
+    "SELECT ast_declarations.name, ast_declarations.printed_type, ast_declarations.module_name FROM ast_declarations \
+    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.name \
+    \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
     \WHERE (module_name = :module_name OR exported) \
     \AND name GLOB :prefix \
     \ORDER BY name ASC \

From 17a490dc6d8057fa213b233955003ede22d3e8ea Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 18:23:55 +0200
Subject: [PATCH 101/297] add ast modules for paths

---
 src/Language/PureScript/Make/Index.hs | 68 +++++++++++++++------------
 1 file changed, 38 insertions(+), 30 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 9c8e06fa60..3c65181de2 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -38,7 +38,7 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
-import Language.PureScript.Lsp.Print (printEfDeclName, printName, printDeclarationType)
+import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printName)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
 import Language.PureScript.Make (ffiCodegen')
@@ -55,8 +55,8 @@ addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions
 addAllIndexing conn ma =
   addAstModuleIndexing conn $
     -- addEnvIndexing conn $
-      addCoreFnIndexing conn $
-        addExternIndexing conn ma
+    addCoreFnIndexing conn $
+      addExternIndexing conn ma
 
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
@@ -66,17 +66,24 @@ addAstModuleIndexing conn ma =
 
 indexAstModule :: (MonadIO m) => Connection -> P.Module -> m ()
 indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) = liftIO do
+  path <- makeAbsolute $ P.spanName (P.getModuleSourceSpan m)
+  SQL.executeNamed
+    conn
+    (SQL.Query "INSERT OR REPLACE INTO ast_modules (module_name, path) VALUES (:module_name, :path)")
+    [ ":module_name" := P.runModuleName name,
+      ":path" := path
+    ]
   SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
   SQL.execute conn "DELETE FROM ast_expressions WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
-  
+
   let exports = Set.fromList $ P.exportedDeclarations m
 
   forM_ decls \decl -> do
     let (ss, _) = P.declSourceAnn decl
     let start = P.spanStart ss
         end = P.spanEnd ss
-    SQL.executeNamed 
-      conn 
+    SQL.executeNamed
+      conn
       (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, printed_type, start_line, end_line, start_col, end_col, lines, cols, exported) VALUES (:module_name, :name, :value, :printed_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
       [ ":module_name" := P.runModuleName name,
         ":name" := printName <$> P.declName decl,
@@ -90,33 +97,32 @@ indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) = liftIO do
         ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
         ":exported" := Set.member decl exports
       ]
-      
 
-insertDeclExprs :: (MonadIO m) => Connection -> P.ModuleName ->  P.Declaration -> m ()
+insertDeclExprs :: (MonadIO m) => Connection -> P.ModuleName -> P.Declaration -> m ()
 insertDeclExprs conn name decl = liftIO $ void $ handleDecl decl
   where
-      (handleDecl, _, _) =
-        P.everywhereOnValuesM
-          pure
-          (\e -> e <$ insertAstExpr e)
-          pure
+    (handleDecl, _, _) =
+      P.everywhereOnValuesM
+        pure
+        (\e -> e <$ insertAstExpr e)
+        pure
 
-      insertAstExpr :: P.Expr -> IO ()
-      insertAstExpr expr =
-        SQL.execute
-          conn
-          (SQL.Query "INSERT INTO ast_expressions (module_name, value, shown, start_line, end_line, start_col, end_col, length) VALUES (?, ?, ?, ?, ?, ?, ?, ?)")
-          ( P.runModuleName name,
-            serialise expr,
-            show expr :: Text,
-            fmap (P.sourcePosLine . P.spanStart) ss,
-            fmap (P.sourcePosLine . P.spanEnd) ss,
-            fmap (P.sourcePosColumn . P.spanStart) ss,
-            fmap (P.sourcePosColumn . P.spanEnd) ss,
-            T.length (show expr :: Text)
-          )
-        where
-          ss = exprSourceSpan expr
+    insertAstExpr :: P.Expr -> IO ()
+    insertAstExpr expr =
+      SQL.execute
+        conn
+        (SQL.Query "INSERT INTO ast_expressions (module_name, value, shown, start_line, end_line, start_col, end_col, length) VALUES (?, ?, ?, ?, ?, ?, ?, ?)")
+        ( P.runModuleName name,
+          serialise expr,
+          show expr :: Text,
+          fmap (P.sourcePosLine . P.spanStart) ss,
+          fmap (P.sourcePosLine . P.spanEnd) ss,
+          fmap (P.sourcePosColumn . P.spanStart) ss,
+          fmap (P.sourcePosColumn . P.spanEnd) ss,
+          T.length (show expr :: Text)
+        )
+      where
+        ss = exprSourceSpan expr
 
 addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addEnvIndexing conn ma =
@@ -310,6 +316,7 @@ initDb conn = do
   dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
@@ -322,6 +329,8 @@ initDb conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT references externs(module_name) ON DELETE CASCADE, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT references externs(module_name) ON DELETE CASCADE, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
 
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
+
   addDbIndexes conn
 
 addDbIndexes :: Connection -> IO ()
@@ -558,4 +567,3 @@ dropTables conn = do
 --             (SkS {rss = 2})
 --         )
 --     )
-

From 8a188994c0e6aa1b32621dbd5908115401f23bcf Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 18:24:21 +0200
Subject: [PATCH 102/297] update available srcs on init

---
 src/Language/PureScript/Lsp/Handlers.hs | 19 ++++++-------------
 1 file changed, 6 insertions(+), 13 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 4f75c16b6f..4e6b373a10 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -26,9 +26,8 @@ import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.DB (dbFile)
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors qualified as Errors
-import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
+import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName, updateAvailableSrcs)
 import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
@@ -36,7 +35,7 @@ import Language.PureScript.Lsp.Imports (addImportToTextEdit)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
-import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confGlobs, confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
+import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Make.Index (initDb)
 import Language.PureScript.Names (disqualify, runIdent)
@@ -50,7 +49,9 @@ type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 handlers :: Server.Handlers (HandlerM ())
 handlers =
   mconcat
-    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> sendInfoMsg "Lsp initialized",
+    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do 
+        void updateAvailableSrcs
+        sendInfoMsg "Lsp initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
         debugLsp "TextDocumentDidOpen"
         let uri :: Uri
@@ -344,15 +345,7 @@ handlers =
         config <- asks lspConfig
         conn <- asks lspDbConnection
         liftIO $ initDb conn
-        input <-
-          liftIO $
-            toInputGlobs $
-              PSCGlobs
-                { pscInputGlobs = confGlobs config,
-                  pscInputGlobsFromFile = Nothing,
-                  pscExcludeGlobs = [],
-                  pscWarnFileTypeNotFound = warnFileTypeNotFound "lsp server"
-                }
+        input <- updateAvailableSrcs
         moduleFiles <- liftIO $ readUTF8FilesT input
         (result, warnings) <-
           liftIO $

From f56f1df3cb3aa40d752eaf663358d6221df5e21d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 18:24:46 +0200
Subject: [PATCH 103/297] add update available srcs function

---
 app/Command/Lsp.hs                   |  3 ++-
 src/Language/PureScript/Lsp/Cache.hs | 21 +++++++++++++++++++++
 src/Language/PureScript/Lsp/Types.hs |  1 +
 3 files changed, 24 insertions(+), 1 deletion(-)

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index 82be5b376e..d7f92396b6 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -32,7 +32,7 @@ command = Opts.helper <*> subcommands
         ]
 
     server :: ServerOptions -> IO ()
-    server opts'@(ServerOptions dir globs _globsFromFile _globsExcluded outputPath logLevel) = do
+    server opts'@(ServerOptions dir globs globsFromFile _globsExcluded outputPath logLevel) = do
       when
         (logLevel == LogDebug || logLevel == LogAll)
         (hPutStrLn stderr ("Parsed Options:" :: Text) *> hPutStrLn stderr (show opts' :: Text))
@@ -41,6 +41,7 @@ command = Opts.helper <*> subcommands
             LspConfig
               { confOutputPath = outputPath,
                 confGlobs = globs,
+                confInputSrcFromFile = globsFromFile,
                 confLogLevel = logLevel
               }
       env <- mkEnv conf
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index e968a5c0e4..9a7608f61f 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -10,6 +10,7 @@ import Database.SQLite.Simple
 import Language.PureScript.AST.Declarations as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
+import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
@@ -101,3 +102,23 @@ findAvailableExterns = do
       | otherwise = do
           let file = oDir </> d </> P.externsFileName
           doesFileExist file
+
+updateAvailableSrcs :: (MonadIO m, MonadReader LspEnvironment m) => m [FilePath]
+updateAvailableSrcs = do
+  DB.execute_ "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
+  DB.execute_ (Query "DELETE FROM available_srcs")
+  config <- asks lspConfig
+  srcs <-
+    liftIO $
+      toInputGlobs $
+        PSCGlobs
+          { pscInputGlobs = confGlobs config,
+            pscInputGlobsFromFile = confInputSrcFromFile config,
+            pscExcludeGlobs = [],
+            pscWarnFileTypeNotFound = warnFileTypeNotFound "lsp server"
+          }
+  forM_ srcs $ \src -> do
+    absPath <- liftIO $ makeAbsolute src
+    DB.executeNamed (Query "INSERT INTO available_srcs (path) VALUES (:path)") [":path" := absPath]
+
+  pure srcs
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index daea9ac198..41227488a9 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -33,6 +33,7 @@ mkEnv conf = do
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
     confGlobs :: [FilePath],
+    confInputSrcFromFile :: Maybe FilePath,
     confLogLevel :: LspLogLevel
   }
   deriving (Show)

From 8c493a36ed5e052e4533c1b51528921ce3dfded7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 22:12:32 +0200
Subject: [PATCH 104/297] find definitions is fast

---
 src/Language/PureScript/Lsp/Cache.hs       | 12 ++++++++----
 src/Language/PureScript/Lsp/Cache/Query.hs |  4 ++--
 src/Language/PureScript/Lsp/Handlers.hs    | 15 +++++++++------
 src/Language/PureScript/Lsp/Log.hs         |  6 ++++--
 src/Language/PureScript/Make/Index.hs      | 12 +++++++-----
 5 files changed, 30 insertions(+), 19 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 9a7608f61f..bbbbb0b7d5 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -16,8 +16,9 @@ import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Names qualified as P
 import Protolude
-import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute)
+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute, canonicalizePath)
 import System.FilePath (normalise, (</>))
+import Language.PureScript.Lsp.Log (logPerfStandard)
 
 -- import Language.PureScript.Lsp.Prim (primExterns)
 
@@ -104,7 +105,7 @@ findAvailableExterns = do
           doesFileExist file
 
 updateAvailableSrcs :: (MonadIO m, MonadReader LspEnvironment m) => m [FilePath]
-updateAvailableSrcs = do
+updateAvailableSrcs = logPerfStandard "updateAvailableSrcs" $ do
   DB.execute_ "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
   DB.execute_ (Query "DELETE FROM available_srcs")
   config <- asks lspConfig
@@ -117,8 +118,11 @@ updateAvailableSrcs = do
             pscExcludeGlobs = [],
             pscWarnFileTypeNotFound = warnFileTypeNotFound "lsp server"
           }
-  forM_ srcs $ \src -> do
+  for_ srcs $ \src -> do
+    canonPath <- liftIO $ canonicalizePath src
+    DB.executeNamed (Query "INSERT INTO available_srcs (path) VALUES (:path)") [":path" := canonPath]
     absPath <- liftIO $ makeAbsolute src
-    DB.executeNamed (Query "INSERT INTO available_srcs (path) VALUES (:path)") [":path" := absPath]
+    when (absPath /= canonPath) $
+      DB.executeNamed (Query "INSERT INTO available_srcs (path) VALUES (:path)") [":path" := absPath]
 
   pure srcs
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 9b21affe54..b8f177c273 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -153,9 +153,9 @@ getAstDeclarationsStartingWith ::
 getAstDeclarationsStartingWith limit offset moduleName' prefix = do
   DB.queryNamed
     "SELECT ast_declarations.name, ast_declarations.printed_type, ast_declarations.module_name FROM ast_declarations \
-    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.name \
+    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
     \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
-    \WHERE (module_name = :module_name OR exported) \
+    \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
     \AND name GLOB :prefix \
     \ORDER BY name ASC \
     \LIMIT :limit \
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 4e6b373a10..9487df252c 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -32,7 +32,7 @@ import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName,
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit)
-import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Log (debugLsp, getPerfTime, labelTimespec, logPerfStandard, perfLsp)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
@@ -40,6 +40,7 @@ import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getName
 import Language.PureScript.Make.Index (initDb)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
+import System.Clock (diffTimeSpec)
 import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
 import System.FilePath ((</>))
 import System.IO.UTF8 (readUTF8FilesT)
@@ -49,7 +50,7 @@ type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 handlers :: Server.Handlers (HandlerM ())
 handlers =
   mconcat
-    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do 
+    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
         void updateAvailableSrcs
         sendInfoMsg "Lsp initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
@@ -242,7 +243,7 @@ handlers =
                         P.BySourcePos srcPos ->
                           locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
                     _ -> nullRes,
-      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
+      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> logPerfStandard "SMethod_TextDocumentCompletion" do
         debugLsp "SMethod_TextDocumentCompletion"
         let Types.CompletionParams docIdent pos _prog _prog' _completionCtx = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
@@ -272,7 +273,7 @@ handlers =
                 debugLsp $ "Module name: " <> show mNameMb
                 forLsp mNameMb \mName -> do
                   let limit = 50
-                  decls <- getAstDeclarationsStartingWith limit 0 mName word
+                  decls <- logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith limit 0 mName word
                   debugLsp $ "Found decls: " <> show (length decls)
                   res $
                     Right $
@@ -287,7 +288,7 @@ handlers =
                                         Just $
                                           Types.CompletionItemLabelDetails
                                             (Just $ " " <> crType cr)
-                                            (Just $ " " <> P.runModuleName (crModule cr)),
+                                            (Just $ P.runModuleName (crModule cr)),
                                       _kind = Nothing, --  Maybe Types.CompletionItemKind TODO: add kind
                                       _tags = Nothing,
                                       _detail = Nothing,
@@ -306,7 +307,9 @@ handlers =
                                       _commitCharacters = Nothing, --  Maybe [Text]
                                       _command = Nothing, --  Maybe Types.Command
                                       _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word
-                                    },
+                                    }
+                  t5 <- getPerfTime
+                  perfLsp (labelTimespec "t5" (diffTimeSpec t4 t5)),
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         debugLsp "SMethod_CompletionItemResolve"
         let completionItem = req ^. LSP.params
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index b34fa39a78..025fc5649a 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -42,12 +42,14 @@ logPerfStandard label f = logPerf (labelTimespec label) f
 
 logPerf :: (MonadIO m, MonadReader LspEnvironment m) => (TimeSpec -> Text) -> m t -> m t
 logPerf format f = do
-  start <- liftIO (getTime Monotonic)
+  start <- getPerfTime
   result <- f
-  end <- liftIO (getTime Monotonic)
+  end <- getPerfTime
   perfLsp (format (diffTimeSpec start end))
   pure result
 
+getPerfTime :: MonadIO m => m TimeSpec
+getPerfTime = liftIO (getTime Monotonic)
 
 labelTimespec :: Text -> TimeSpec -> Text
 labelTimespec label duration = label <> ": " <> displayTimeSpec duration
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 3c65181de2..d575bb856c 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -61,12 +61,12 @@ addAllIndexing conn ma =
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \env astM m docs ext -> lift (indexAstModule conn astM) <* P.codegen ma env astM m docs ext
+    { P.codegen = \env astM m docs ext -> lift (indexAstModule conn astM ext) <* P.codegen ma env astM m docs ext
     }
 
-indexAstModule :: (MonadIO m) => Connection -> P.Module -> m ()
-indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) = liftIO do
-  path <- makeAbsolute $ P.spanName (P.getModuleSourceSpan m)
+indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> m ()
+indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) extern = liftIO do
+  path <- makeAbsolute externPath
   SQL.executeNamed
     conn
     (SQL.Query "INSERT OR REPLACE INTO ast_modules (module_name, path) VALUES (:module_name, :path)")
@@ -97,6 +97,8 @@ indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) = liftIO do
         ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
         ":exported" := Set.member decl exports
       ]
+  where
+    externPath = P.spanName (P.efSourceSpan extern)
 
 insertDeclExprs :: (MonadIO m) => Connection -> P.ModuleName -> P.Declaration -> m ()
 insertDeclExprs conn name decl = liftIO $ void $ handleDecl decl
@@ -313,7 +315,7 @@ insertEfExport conn moduleName' dr = do
 
 initDb :: Connection -> IO ()
 initDb conn = do
-  dropTables conn
+  -- dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"

From e054cb2059b75257845f4f9fcfc3508b6ffc92c5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 7 Oct 2024 22:13:08 +0200
Subject: [PATCH 105/297] remove perf log

---
 src/Language/PureScript/Lsp/Handlers.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 9487df252c..d9fe4684ea 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -307,9 +307,7 @@ handlers =
                                       _commitCharacters = Nothing, --  Maybe [Text]
                                       _command = Nothing, --  Maybe Types.Command
                                       _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word
-                                    }
-                  t5 <- getPerfTime
-                  perfLsp (labelTimespec "t5" (diffTimeSpec t4 t5)),
+                                    },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         debugLsp "SMethod_CompletionItemResolve"
         let completionItem = req ^. LSP.params

From 2ca741df3af250147bfb78e10b09d2560be2b3eb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 00:22:50 +0200
Subject: [PATCH 106/297] adds cancellation to request

---
 src/Language/PureScript/LSP.hs             | 34 +++++++++++++++++-----
 src/Language/PureScript/Lsp/Diagnostics.hs | 11 ++++++-
 src/Language/PureScript/Lsp/Handlers.hs    | 12 ++++++--
 src/Language/PureScript/Lsp/State.hs       | 28 ++++++++++++++++++
 src/Language/PureScript/Lsp/Types.hs       |  3 +-
 5 files changed, 75 insertions(+), 13 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index cb164efed1..9ef7811392 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
@@ -10,6 +11,8 @@ import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server as LSP.Server
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Handlers (HandlerM, handlers)
+import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.State (requestIsCancelled)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 
@@ -42,7 +45,7 @@ syncOptions =
       Types._change = Just Types.TextDocumentSyncKind_Incremental,
       Types._willSave = Just False,
       Types._willSaveWaitUntil = Just False,
-      Types._save = Just $ Types.InR $ Types.SaveOptions $ Just False
+      Types._save = Just $ Types.InL True
     }
 
 lspOptions :: Server.Options
@@ -71,16 +74,31 @@ reactor inp = do
 -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
 -- input into the reactor
 lspHandlers :: LspEnvironment -> TChan ReactorInput -> Handlers (HandlerM ())
-lspHandlers lspEnv rin = mapHandlers goReq goNot handlers
+lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
   where
     goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
-    goReq f msg k = do
-      env <- getLspEnv
-      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg k)
+    goReq f msg@(LSP.TRequestMessage _ id method _) k = do
+      let reqId = case id of
+            LSP.IdInt i -> Left i
+            LSP.IdString t -> Right t
+      debugLsp $ "Request: " <> show method <> " " <> show reqId
+      writeToChannel $
+        ifM
+          (requestIsCancelled reqId)
+          (k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing)
+          (writeToChannel (f msg k))
+
+
+    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
+    goNotification f msg@(LSP.TNotificationMessage _ LSP.SMethod_CancelRequest _) = do
+      f msg -- cancel requests skip the queue
+    goNotification f msg = do
+      writeToChannel (f msg)
+
+    writeToChannel = writeToChannelWith writeTChan
 
-    goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
-    goNot f msg = do
+    writeToChannelWith fn a = do
       env <- getLspEnv
-      liftIO $ atomically $ writeTChan rin $ ReactorAction (runHandler env $ f msg)
+      liftIO $ atomically $ fn rin $ ReactorAction (runHandler env a)
 
     runHandler env a = runLspT env $ runReaderT a lspEnv
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 9de48073a0..abf044b2b7 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -19,7 +19,16 @@ import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
 
-getFileDiagnotics :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 Uri, MonadIO m, MonadThrow m, MonadReader LspEnvironment m) => s -> m ([ErrorMessage], [Diagnostic])
+getFileDiagnotics ::
+  ( LSP.HasParams s a1,
+    LSP.HasTextDocument a1 a2,
+    LSP.HasUri a2 Uri,
+    MonadIO m,
+    MonadThrow m,
+    MonadReader LspEnvironment m
+  ) =>
+  s ->
+  m ([ErrorMessage], [Diagnostic])
 getFileDiagnotics msg = do
   let uri :: Uri
       uri = getMsgUri msg
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index d9fe4684ea..8900e9253d 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -32,7 +32,7 @@ import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName,
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit)
-import Language.PureScript.Lsp.Log (debugLsp, getPerfTime, labelTimespec, logPerfStandard, perfLsp)
+import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
@@ -40,10 +40,10 @@ import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getName
 import Language.PureScript.Make.Index (initDb)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
-import System.Clock (diffTimeSpec)
 import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
 import System.FilePath ((</>))
 import System.IO.UTF8 (readUTF8FilesT)
+import Language.PureScript.Lsp.State (cancelRequest)
 
 type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
@@ -60,7 +60,7 @@ handlers =
             fileName = Types.uriToFilePath uri
 
         traverse_ rebuildFile fileName,
-      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> debugLsp "TextDocumentDidChange",
+      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> debugLsp "SMethod_TextDocumentDidChange",
       Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
         debugLsp "SMethod_TextDocumentDidSave"
         let uri :: Uri
@@ -71,6 +71,10 @@ handlers =
         cfg <- getConfig
         debugLsp $ "Config changed: " <> show cfg,
       Server.notificationHandler Message.SMethod_SetTrace $ \_msg -> debugLsp "SMethod_SetTrace",
+      Server.notificationHandler Message.SMethod_CancelRequest $ \req -> do
+        let reqId = req ^. LSP.params . LSP.id
+        debugLsp $ "SMethod_CancelRequest " <> show reqId
+        cancelRequest reqId,
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
         debugLsp "SMethod_TextDocumentDiagnostic"
         (_errs, diagnostics) <- getFileDiagnotics req
@@ -79,6 +83,7 @@ handlers =
             Types.DocumentDiagnosticReport $
               Types.InL $
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
+
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
@@ -107,6 +112,7 @@ handlers =
                         Nothing
                         Nothing,
       Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+        
         debugLsp "SMethod_TextDocumentHover"
         let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 7753d98714..24cba647f3 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Language.PureScript.Lsp.State where
 
@@ -8,6 +9,10 @@ import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFile (..))
 import Language.PureScript.Lsp.Types
 import Protolude hiding (moduleName, unzip)
+import Data.Set qualified as Set
+import Language.LSP.Protocol.Types (type (|?)(..))
+import Language.PureScript.Lsp.Log (debugLsp)
+-- import Language.LSP.Protocol.Types ((InL))
 
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> P.Module -> P.Environment -> m ()
@@ -24,3 +29,26 @@ cachedRebuild = do
   liftIO . atomically $ do
     st' <- readTVar st
     pure $ currentFile st'
+
+
+cancelRequest :: (MonadReader LspEnvironment m, MonadIO m) => (Int32 |? Text) -> m ()
+cancelRequest requestId = do 
+  st <- lspStateVar <$> ask
+  liftIO . atomically . modifyTVar st $ \x ->
+    x
+      { cancelledRequests = Set.insert eitherId (cancelledRequests x)
+      }
+  where 
+    eitherId = case requestId of 
+      InL i -> Left i
+      InR t -> Right t
+
+
+requestIsCancelled :: (MonadReader LspEnvironment m, MonadIO m) => Either Int32 Text -> m Bool
+requestIsCancelled requestId = do
+  st <- lspStateVar <$> ask
+  cancelled <- liftIO . atomically $ do
+    st' <- readTVar st
+    pure $ requestId `Set.member` cancelledRequests st'
+  debugLsp $ "Request " <> show requestId <> " is cancelled " <> show cancelled
+  pure cancelled
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 41227488a9..2a66c49234 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -27,7 +27,7 @@ mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do
   createDirectoryIfMissing True $ confOutputPath conf
   connection <- mkConnection $ confOutputPath conf
-  st <- newTVarIO (LspState Nothing)
+  st <- newTVarIO (LspState Nothing mempty)
   pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
@@ -40,6 +40,7 @@ data LspConfig = LspConfig
 
 data LspState = LspState
   { currentFile :: Maybe CurrentFile
+  , cancelledRequests :: Set (Either Int32 Text)
   }
   deriving (Show)
 

From abc381d3030fb0759456ca485c28b95be925888b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 04:20:38 +0200
Subject: [PATCH 107/297] search for module names on type

---
 src/Language/PureScript/Lsp/Cache/Query.hs | 50 +++++++++++++++
 src/Language/PureScript/Lsp/Handlers.hs    | 28 ++++++---
 src/Language/PureScript/Lsp/Imports.hs     | 72 ++++++++++++++++------
 src/Language/PureScript/Lsp/Types.hs       |  4 +-
 src/Language/PureScript/Lsp/Util.hs        | 18 +++---
 5 files changed, 133 insertions(+), 39 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index b8f177c273..ba0f632edc 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -165,6 +165,56 @@ getAstDeclarationsStartingWith limit offset moduleName' prefix = do
       ":limit" := limit,
       ":offset" := offset
     ]
+    
+
+getAstDeclarationsStartingWithAndSearchingModuleNames ::
+  (MonadIO m, MonadReader LspEnvironment m) =>
+  Int ->
+  Int ->
+  P.ModuleName ->
+  P.ModuleName ->
+  Text ->
+  m [CompletionResult]
+getAstDeclarationsStartingWithAndSearchingModuleNames limit offset moduleName' moduleNameContains prefix = do
+  DB.queryNamed
+    "SELECT ast_declarations.name, ast_declarations.printed_type, ast_declarations.module_name FROM ast_declarations \
+    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
+    \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
+    \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
+    \AND ast_declarations.module_name GLOB :module_name_contains \
+    \AND name GLOB :prefix \
+    \ORDER BY name ASC \
+    \LIMIT :limit \
+    \OFFSET :offset"
+    [ ":module_name" := P.runModuleName moduleName',
+      ":prefix" := prefix <> "*",
+      ":module_name_contains" :=  "*" <> P.runModuleName moduleNameContains <> "*",
+      ":limit" := limit,
+      ":offset" := offset
+    ]
+
+getAstDeclarationsStartingWithOnlyInModule ::
+  (MonadIO m, MonadReader LspEnvironment m) =>
+  Int ->
+  Int ->
+  P.ModuleName ->
+  Text ->
+  m [CompletionResult]
+getAstDeclarationsStartingWithOnlyInModule limit offset moduleName' prefix = do
+  DB.queryNamed
+    "SELECT ast_declarations.name, ast_declarations.printed_type, ast_declarations.module_name FROM ast_declarations \
+    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
+    \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
+    \WHERE ast_declarations.module_name = :module_name \
+    \AND name GLOB :prefix \
+    \ORDER BY name ASC \
+    \LIMIT :limit \
+    \OFFSET :offset"
+    [ ":module_name" := P.runModuleName moduleName',
+      ":prefix" := prefix <> "*",
+      ":limit" := limit,
+      ":offset" := offset
+    ]
 
 data CompletionResult = CompletionResult
   { crName :: Text,
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 8900e9253d..b22317d8fb 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -27,14 +27,16 @@ import Language.PureScript.DB (dbFile)
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
+import Language.PureScript.Ide.Imports (Import (..))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName, updateAvailableSrcs)
-import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationInModule, getAstDeclarationsStartingWith, getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationInModule, getAstDeclarationsStartingWith, getAstDeclarationsStartingWithOnlyInModule, getCoreFnExprAt, getEfDeclarationInModule, getAstDeclarationsStartingWithAndSearchingModuleNames)
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
-import Language.PureScript.Lsp.Imports (addImportToTextEdit)
+import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
+import Language.PureScript.Lsp.State (cancelRequest)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Make.Index (initDb)
@@ -43,7 +45,6 @@ import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
 import System.FilePath ((</>))
 import System.IO.UTF8 (readUTF8FilesT)
-import Language.PureScript.Lsp.State (cancelRequest)
 
 type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
@@ -83,7 +84,6 @@ handlers =
             Types.DocumentDiagnosticReport $
               Types.InL $
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
-
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
@@ -112,7 +112,6 @@ handlers =
                         Nothing
                         Nothing,
       Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-        
         debugLsp "SMethod_TextDocumentHover"
         let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
@@ -270,8 +269,8 @@ handlers =
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
-            let word = getWordAt (VFS._file_text vf) pos
-            debugLsp $ "Word len " <> show (T.length word)
+            let (range, word) = getWordAt (VFS._file_text vf) pos
+            debugLsp $ "Word " <> show word
             if T.length word < 2
               then nullRes
               else do
@@ -279,7 +278,16 @@ handlers =
                 debugLsp $ "Module name: " <> show mNameMb
                 forLsp mNameMb \mName -> do
                   let limit = 50
-                  decls <- logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith limit 0 mName word
+                      withQualifier = getIdentModuleQualifier word
+                      wordWithoutQual = maybe word snd withQualifier
+                  matchingImport <- maybe (pure Nothing) (getMatchingImport filePath . fst) withQualifier
+                  -- matchingImport =
+                  debugLsp $ "wordWithoutQual " <> show wordWithoutQual
+                  decls <- case (matchingImport, withQualifier) of
+                    (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule limit 0 importModuleName wordWithoutQual
+                    (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames limit 0 mName wordModuleName wordWithoutQual
+                    _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith limit 0 mName wordWithoutQual
+                  -- Just
                   debugLsp $ "Found decls: " <> show (length decls)
                   res $
                     Right $
@@ -312,7 +320,7 @@ handlers =
                                       _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
                                       _commitCharacters = Nothing, --  Maybe [Text]
                                       _command = Nothing, --  Maybe Types.Command
-                                      _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word
+                                      _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word range
                                     },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         debugLsp "SMethod_CompletionItemResolve"
@@ -320,7 +328,7 @@ handlers =
             result = completionItem ^. LSP.data_ & decodeCompleteItemData
 
         case result of
-          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _)) -> do
+          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _ _)) -> do
             docsMb <- readDeclarationDocsAsMarkdown declModule label
             withImports <- addImportToTextEdit completionItem cid
             let addDocs :: Types.CompletionItem -> Types.CompletionItem
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 166cd4b586..f01193d65d 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -2,6 +2,7 @@ module Language.PureScript.Lsp.Imports where
 
 import Control.Lens (set)
 import Control.Monad.Catch (MonadThrow)
+import Data.List (init, last)
 import Data.Maybe as Maybe
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
@@ -9,12 +10,22 @@ import Language.LSP.Protocol.Types as LSP
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
 import Language.PureScript.Lsp.Log (errorLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFile)
 import Language.PureScript.Lsp.Types (CompleteItemData (..), LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
+
+getMatchingImport :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => FilePath -> P.ModuleName -> m (Maybe Import)
+getMatchingImport path moduleName' = do
+  parseRes <- parseImportsFromFile path
+  case parseRes of
+    Left err -> do
+      errorLsp $ "In " <> T.pack path <> " failed to parse imports from file: " <> err
+      pure Nothing
+    Right (_mn, _before, imports, _after) -> do
+      pure $ find (\(Import _ _ mn) -> Just moduleName' == mn) imports
 
 addImportToTextEdit :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompletionItem -> CompleteItemData -> m CompletionItem
 addImportToTextEdit completionItem completeItemData = do
@@ -22,7 +33,7 @@ addImportToTextEdit completionItem completeItemData = do
   pure $ set LSP.additionalTextEdits importEdits completionItem
 
 getImportEdits :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit])
-getImportEdits (CompleteItemData path moduleName' importedModuleName name _word) = do
+getImportEdits (CompleteItemData path moduleName' importedModuleName name word (Range wordStart _)) = do
   parseRes <- parseImportsFromFile path
   case parseRes of
     Left err -> do
@@ -35,29 +46,50 @@ getImportEdits (CompleteItemData path moduleName' importedModuleName name _word)
           errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> name
           pure Nothing
         Just decl -> do
-          addDeclarationToImports moduleName' importedModuleName decl imports
-            <&> pure . importsToTextEdit before
-            & pure
+          case addDeclarationToImports moduleName' importedModuleName wordQualifierMb decl imports of
+            Nothing -> pure Nothing
+            Just (newImports, moduleQualifier) -> do
+              let importEdits = importsToTextEdit before newImports
+                  qualifierEdits = case moduleQualifier of
+                    Just qual | isNothing wordQualifierMb -> [TextEdit (Range wordStart wordStart) (P.runModuleName qual <> ".")]
+                    _ -> []
+
+              pure $ Just $ [importEdits] <> qualifierEdits
+  where
+    wordQualifierMb = fst <$> getIdentModuleQualifier word
+
+getIdentModuleQualifier :: Text -> Maybe (P.ModuleName, Text)
+getIdentModuleQualifier word =
+  case T.splitOn "." word of
+    [] -> Nothing
+    [_] -> Nothing
+    xs -> Just (P.ModuleName $ T.intercalate "." $ init xs, last xs)
 
-addDeclarationToImports :: P.ModuleName -> P.ModuleName -> P.Declaration -> [Import] -> Maybe [Import]
-addDeclarationToImports moduleName' importedModuleName decl imports
+addDeclarationToImports :: P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> P.Declaration -> [Import] -> Maybe ([Import], Maybe P.ModuleName)
+addDeclarationToImports moduleName' importedModuleName wordQualifierMb decl imports
   | importingSelf = Nothing
   | Just existing <- alreadyImportedModuleMb,
     Just ref <- refMb = case existing of
-      Import _ (P.Explicit refs') _ ->
-        if ref `notElem` refs'
-          then Just $ Import importedModuleName (P.Explicit (refs' <> [ref])) Nothing : withoutOldImport
-          else Nothing
-      Import _ P.Implicit _ -> Nothing
-      Import _ (P.Hiding refs') _ ->
-        if ref `elem` refs'
-          then Just $ Import importedModuleName (P.Hiding (filter (/= ref) refs')) Nothing : withoutOldImport
-          else Nothing
-  | otherwise = Just $ Import importedModuleName (P.Explicit refs) Nothing : imports
+      Import _ (P.Explicit refs') mName
+        | wordQualifierMb == mName ->
+            if ref `notElem` refs'
+              then Just (Import importedModuleName (P.Explicit (refs' <> [ref])) Nothing : withoutOldImport, mName)
+              else Nothing
+        | otherwise -> Just (imports, mName)
+      Import _ P.Implicit mName -> Just (imports, mName)
+      Import _ (P.Hiding refs') mName
+        | wordQualifierMb == mName ->
+            if ref `elem` refs'
+              then Just (Import importedModuleName (P.Hiding (filter (/= ref) refs')) Nothing : withoutOldImport, mName)
+              else Nothing
+        | otherwise -> Just (imports, mName)
+  | isJust wordQualifierMb = Just (Import importedModuleName P.Implicit wordQualifierMb : imports, wordQualifierMb)
+  | otherwise = addExplicitNewImport
   where
+    addExplicitNewImport = Just (Import importedModuleName (P.Explicit refs) wordQualifierMb : imports, wordQualifierMb)
     withoutOldImport :: [Import]
-    withoutOldImport =  maybe identity (\im -> filter (/= im)) alreadyImportedModuleMb imports  
-      
+    withoutOldImport = maybe identity (\im -> filter (/= im)) alreadyImportedModuleMb imports
+
     refs :: [P.DeclarationRef]
     refs = toList refMb
 
@@ -82,7 +114,7 @@ importsToTextEdit before imports =
   TextEdit
     ( LSP.Range
         (LSP.Position beforeLine 0)
-        (LSP.Position (beforeLine + fromIntegral (length printed)) 0)
+        (LSP.Position (beforeLine + fromIntegral (length printed) + 1) 0)
     )
     (T.unlines printed)
   where
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 2a66c49234..b4fbf3aad2 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -16,6 +16,7 @@ import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude
 import System.Directory (createDirectoryIfMissing)
+import Language.LSP.Protocol.Types (Range)
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -57,7 +58,8 @@ data CompleteItemData = CompleteItemData
     cidModuleName :: P.ModuleName,
     cidImportedModuleName :: P.ModuleName,
     cidName :: Text,
-    cidWord :: Text
+    cidWord :: Text, 
+    wordRange :: Range
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 22ba2bfe6f..6687158cc6 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -44,24 +44,26 @@ posInSpan (Types.Position line col) (Errors.SourceSpan _ (Errors.SourcePos start
 getDeclarationAtPos :: Types.Position -> [P.Declaration] -> Maybe P.Declaration
 getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn)
 
-getWordAt :: Rope -> Types.Position -> Text
-getWordAt file Types.Position {..} =
+getWordAt :: Rope -> Types.Position -> (Types.Range, Text)
+getWordAt file pos@(Types.Position {..}) =
   if Rope.lengthInLines file < fromIntegral _line || _line < 0
-    then ""
+    then (Types.Range pos pos, "")
     else
       let (_, after) = splitAtLine (fromIntegral _line) file
           (ropeLine, _) = splitAtLine 1 after
           line' = Rope.toText ropeLine
-       in getWordOnLine line' _character
+          (wordStartCol, wordEndCol, _word) = getWordOnLine line' _character
+       in (Types.Range (Types.Position _line $ fromIntegral wordStartCol) (Types.Position _line $ fromIntegral wordEndCol), _word)
 
-getWordOnLine :: Text -> UInt -> Text
+
+getWordOnLine :: Text -> UInt -> (Int, Int, Text)
 getWordOnLine line' col =
   if T.length line' < fromIntegral col || col < 0
-    then ""
+    then (fromIntegral col, fromIntegral col, "")
     else
       let start = getPrevWs (fromIntegral col - 1) line'
           end = getNextWs (fromIntegral col) line'
-       in T.strip $ T.take (end - start) $ T.drop start line'
+       in (start, end, T.strip $ T.take (end - start) $ T.drop start line')
   where
     getNextWs :: Int -> Text -> Int
     getNextWs idx txt | idx >= T.length txt = idx
@@ -80,7 +82,7 @@ getWordOnLine line' col =
 
 getNamesAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
 getNamesAtPosition pos moduleName' src = do
-  let search = getWordAt src pos
+  let (_, search) = getWordAt src pos
   debugLsp $ "Looking up " <> search <> " in module " <> P.runModuleName moduleName'
   decls <- getAstDeclarationsAtSrcPos moduleName' (positionToSourcePos pos)
   debugLsp $ "Found declarations: " <> T.pack (show $ length decls)

From 5eaa17f492cf3c9daa874c2a188aea5ea35e7f50 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 04:42:28 +0200
Subject: [PATCH 108/297] put each request on a separate thread and catch
 errors

---
 src/Language/PureScript/LSP.hs | 32 ++++++++++++++++++++------------
 1 file changed, 20 insertions(+), 12 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 9ef7811392..39ebed873f 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
@@ -59,8 +60,11 @@ lspOptions =
 -- LSP client, so they can be sent to the backend compiler one at a time, and a
 -- reply sent.
 
-newtype ReactorInput
-  = ReactorAction (IO ())
+data ReactorInput = ReactorAction
+  { riId :: Maybe (Either Int32 Text),
+    riMethod :: Text,
+    riAction :: IO ()
+  }
 
 -- | The single point that all events flow through, allowing management of state
 -- to stitch replies and requests together from the two asynchronous sides: lsp
@@ -68,8 +72,12 @@ newtype ReactorInput
 reactor :: TChan ReactorInput -> IO ()
 reactor inp = do
   forever $ do
-    ReactorAction act <- atomically $ readTChan inp
-    act
+    ReactorAction reqId method act <- atomically $ readTChan inp
+    withAsync act \a -> do
+      res <- waitCatch a
+      case res of
+        Left e -> putErrLn $ "Request failed. Method: " <> method <> ". id: " <> show reqId <> ". Error: " <> show e
+        Right _ -> pure ()
 
 -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
 -- input into the reactor
@@ -82,23 +90,23 @@ lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
             LSP.IdInt i -> Left i
             LSP.IdString t -> Right t
       debugLsp $ "Request: " <> show method <> " " <> show reqId
-      writeToChannel $
+      writeToChannel (Just reqId) (show reqId) $
         ifM
           (requestIsCancelled reqId)
           (k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing)
-          (writeToChannel (f msg k))
-
+          (f msg k)
 
     goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
     goNotification f msg@(LSP.TNotificationMessage _ LSP.SMethod_CancelRequest _) = do
-      f msg -- cancel requests skip the queue
-    goNotification f msg = do
-      writeToChannel (f msg)
+      f msg -- cancel requests skip the queue and are handled immediately on the main thread
+    goNotification f msg@(LSP.TNotificationMessage _ method _) = do
+      writeToChannel Nothing (show method) (f msg)
 
+    -- writeToChannel :: Either Int Text -> HandlerM () () -> IO ()
     writeToChannel = writeToChannelWith writeTChan
 
-    writeToChannelWith fn a = do
+    writeToChannelWith fn reqId method a = do
       env <- getLspEnv
-      liftIO $ atomically $ fn rin $ ReactorAction (runHandler env a)
+      liftIO $ atomically $ fn rin $ ReactorAction reqId method (runHandler env a)
 
     runHandler env a = runLspT env $ runReaderT a lspEnv

From a800bfc8b9554e323a091b6dd2311f8418160c12 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 10:43:54 +0200
Subject: [PATCH 109/297] fix imports length

---
 src/Language/PureScript/LSP.hs             | 8 ++++++++
 src/Language/PureScript/Lsp/Cache/Query.hs | 3 +++
 src/Language/PureScript/Lsp/Imports.hs     | 6 +++++-
 3 files changed, 16 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 39ebed873f..cb62c53bd5 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Lsp (main, serverDefinition) where
 
@@ -56,6 +57,13 @@ lspOptions =
       Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
     }
 
+-- data ReactorInputs = ReactorInputs
+--   { risMain :: TChan ReactorInput,
+--     risCompletion :: TChan ReactorInput, 
+--     risHover :: TChan ReactorInput,
+--     ris
+--   }
+
 -- The reactor is a process that serialises and buffers all requests from the
 -- LSP client, so they can be sent to the backend compiler one at a time, and a
 -- reply sent.
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index ba0f632edc..ce3b226108 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -192,6 +192,7 @@ getAstDeclarationsStartingWithAndSearchingModuleNames limit offset moduleName' m
       ":limit" := limit,
       ":offset" := offset
     ]
+    
 
 getAstDeclarationsStartingWithOnlyInModule ::
   (MonadIO m, MonadReader LspEnvironment m) =>
@@ -216,6 +217,8 @@ getAstDeclarationsStartingWithOnlyInModule limit offset moduleName' prefix = do
       ":offset" := offset
     ]
 
+-- getPrintedType
+
 data CompletionResult = CompletionResult
   { crName :: Text,
     crType :: Text,
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index f01193d65d..b1a1a472d8 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -114,7 +114,11 @@ importsToTextEdit before imports =
   TextEdit
     ( LSP.Range
         (LSP.Position beforeLine 0)
-        (LSP.Position (beforeLine + fromIntegral (length printed) + 1) 0)
+        ( LSP.Position
+            ( beforeLine + fromIntegral (length printed) - 1
+            )
+            (maybe 0 (fromIntegral . T.length) $ lastMay printed)
+        )
     )
     (T.unlines printed)
   where

From 1003e09ad7baa68b66c4d3a21ff9d5df4de0a63b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 12:43:45 +0200
Subject: [PATCH 110/297] better type displays

---
 purescript.cabal                            |   1 +
 src/Language/PureScript/LSP.hs              |  30 +++---
 src/Language/PureScript/Lsp/Cache/Query.hs  | 110 ++++++++++++--------
 src/Language/PureScript/Lsp/Handlers.hs     |  39 +++----
 src/Language/PureScript/Lsp/ServerConfig.hs |  57 ++++++++++
 src/Language/PureScript/Lsp/Types.hs        |  33 +++++-
 6 files changed, 184 insertions(+), 86 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/ServerConfig.hs

diff --git a/purescript.cabal b/purescript.cabal
index 71f20fe41d..d06b1e2126 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -354,6 +354,7 @@ library
     Language.PureScript.Lsp.Print
     Language.PureScript.Lsp.ReadFile
     Language.PureScript.Lsp.Rebuild
+    Language.PureScript.Lsp.ServerConfig
     Language.PureScript.Lsp.State
     Language.PureScript.Lsp.Types
     Language.PureScript.Lsp.Util
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index cb62c53bd5..896d423921 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -8,27 +8,31 @@ module Language.PureScript.Lsp (main, serverDefinition) where
 
 import Control.Concurrent.STM.TChan
 import Control.Monad.IO.Unlift
+import Data.Aeson qualified as A
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server as LSP.Server
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Handlers (HandlerM, handlers)
-import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultFromEnv)
 import Language.PureScript.Lsp.State (requestIsCancelled)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
+import Data.Aeson.Types qualified as A
+import Data.Text qualified as T
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
   rin <- atomically newTChan :: IO (TChan ReactorInput)
   Server.runServer $ serverDefinition lspEnv rin
 
-serverDefinition :: LspEnvironment -> TChan ReactorInput -> ServerDefinition ()
+serverDefinition :: LspEnvironment -> TChan ReactorInput -> ServerDefinition ServerConfig
 serverDefinition lspEnv rin =
   Server.ServerDefinition
-    { parseConfig = const $ const $ Right (),
+    { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = const $ pure (),
-      defaultConfig = (),
+      defaultConfig = defaultFromEnv lspEnv,
       configSection = "oa-purescript-lsp",
       doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env),
       staticHandlers = \_caps -> lspHandlers lspEnv rin,
@@ -57,13 +61,6 @@ lspOptions =
       Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
     }
 
--- data ReactorInputs = ReactorInputs
---   { risMain :: TChan ReactorInput,
---     risCompletion :: TChan ReactorInput, 
---     risHover :: TChan ReactorInput,
---     ris
---   }
-
 -- The reactor is a process that serialises and buffers all requests from the
 -- LSP client, so they can be sent to the backend compiler one at a time, and a
 -- reply sent.
@@ -89,28 +86,27 @@ reactor inp = do
 
 -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
 -- input into the reactor
-lspHandlers :: LspEnvironment -> TChan ReactorInput -> Handlers (HandlerM ())
+lspHandlers :: LspEnvironment -> TChan ReactorInput -> Handlers (HandlerM ServerConfig)
 lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
   where
-    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
+    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (HandlerM ServerConfig) a -> LSP.Server.Handler (HandlerM ServerConfig) a
     goReq f msg@(LSP.TRequestMessage _ id method _) k = do
       let reqId = case id of
             LSP.IdInt i -> Left i
             LSP.IdString t -> Right t
-      debugLsp $ "Request: " <> show method <> " " <> show reqId
       writeToChannel (Just reqId) (show reqId) $
         ifM
           (requestIsCancelled reqId)
           (k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing)
-          (f msg k)
+          (logPerfStandard ("Request " <> show method) $ f msg k)
 
-    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ()) a -> LSP.Server.Handler (HandlerM ()) a
+    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ServerConfig) a -> LSP.Server.Handler (HandlerM ServerConfig) a
     goNotification f msg@(LSP.TNotificationMessage _ LSP.SMethod_CancelRequest _) = do
       f msg -- cancel requests skip the queue and are handled immediately on the main thread
     goNotification f msg@(LSP.TNotificationMessage _ method _) = do
       writeToChannel Nothing (show method) (f msg)
 
-    -- writeToChannel :: Either Int Text -> HandlerM () () -> IO ()
+    -- writeToChannel :: Either Int Text -> HandlerM ServerConfig () -> IO ()
     writeToChannel = writeToChannelWith writeTChan
 
     writeToChannelWith fn reqId method a = do
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index ce3b226108..cbdbb049c1 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE PackageImports #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Language.PureScript.Lsp.Cache.Query where
@@ -13,6 +12,7 @@ import Data.Map qualified as Map
 import Database.SQLite.Simple (NamedParam ((:=)), fromOnly)
 import Database.SQLite.Simple qualified as SQL
 import Language.LSP.Protocol.Types qualified as LSP
+import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.SourcePos (SourcePos (SourcePos))
 import Language.PureScript.CoreFn qualified as CF
@@ -20,6 +20,7 @@ import Language.PureScript.CoreFn.Expr as CF
 import Language.PureScript.CoreFn.FromJSON qualified as CF
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.DB qualified as DB
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, getMaxTypeLength)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
@@ -144,80 +145,105 @@ getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
   pure $ deserialise . fromOnly <$> decls
 
 getAstDeclarationsStartingWith ::
-  (MonadIO m, MonadReader LspEnvironment m) =>
-  Int ->
-  Int ->
+  (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
   P.ModuleName ->
   Text ->
   m [CompletionResult]
-getAstDeclarationsStartingWith limit offset moduleName' prefix = do
+getAstDeclarationsStartingWith moduleName' prefix = do
+  limit <- getMaxCompletions
+  typeLen <- getMaxTypeLength
+  let offset = 0 :: Int
   DB.queryNamed
-    "SELECT ast_declarations.name, ast_declarations.printed_type, ast_declarations.module_name FROM ast_declarations \
-    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
-    \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
-    \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
-    \AND name GLOB :prefix \
-    \ORDER BY name ASC \
-    \LIMIT :limit \
-    \OFFSET :offset"
+    ( SQL.Query $
+        "SELECT ast_declarations.name, "
+          <> printedTypeTruncated typeLen
+          <> "ast_declarations.module_name FROM ast_declarations \
+             \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
+             \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
+             \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
+             \AND (name == :prefix OR name GLOB :prefix) \
+             \ORDER BY name ASC \
+             \LIMIT :limit \
+             \OFFSET :offset"
+    )
     [ ":module_name" := P.runModuleName moduleName',
       ":prefix" := prefix <> "*",
       ":limit" := limit,
       ":offset" := offset
     ]
-    
 
 getAstDeclarationsStartingWithAndSearchingModuleNames ::
-  (MonadIO m, MonadReader LspEnvironment m) =>
-  Int ->
-  Int ->
+  (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
   P.ModuleName ->
   P.ModuleName ->
   Text ->
   m [CompletionResult]
-getAstDeclarationsStartingWithAndSearchingModuleNames limit offset moduleName' moduleNameContains prefix = do
+getAstDeclarationsStartingWithAndSearchingModuleNames moduleName' moduleNameContains prefix = do
+  limit <- getMaxCompletions
+  typeLen <- getMaxTypeLength
+  let offset = 0 :: Int
   DB.queryNamed
-    "SELECT ast_declarations.name, ast_declarations.printed_type, ast_declarations.module_name FROM ast_declarations \
-    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
-    \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
-    \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
-    \AND ast_declarations.module_name GLOB :module_name_contains \
-    \AND name GLOB :prefix \
-    \ORDER BY name ASC \
-    \LIMIT :limit \
-    \OFFSET :offset"
+    ( SQL.Query $
+        "SELECT ast_declarations.name, "
+          <> printedTypeTruncated typeLen
+          <> "ast_declarations.module_name FROM ast_declarations \
+             \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
+             \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
+             \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
+             \AND ast_declarations.module_name like :module_name_contains \
+             \AND (name == :prefix OR name GLOB :prefix) \
+             \ORDER BY name ASC \
+             \LIMIT :limit \
+             \OFFSET :offset"
+    )
     [ ":module_name" := P.runModuleName moduleName',
       ":prefix" := prefix <> "*",
-      ":module_name_contains" :=  "*" <> P.runModuleName moduleNameContains <> "*",
+      ":module_name_contains" := "%" <> P.runModuleName moduleNameContains <> "%",
       ":limit" := limit,
       ":offset" := offset
     ]
-    
 
 getAstDeclarationsStartingWithOnlyInModule ::
-  (MonadIO m, MonadReader LspEnvironment m) =>
-  Int ->
-  Int ->
+  (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
   P.ModuleName ->
   Text ->
   m [CompletionResult]
-getAstDeclarationsStartingWithOnlyInModule limit offset moduleName' prefix = do
+getAstDeclarationsStartingWithOnlyInModule moduleName' prefix = do
+  limit <- getMaxCompletions
+  typeLen <- getMaxTypeLength
+  let offset = 0 :: Int
   DB.queryNamed
-    "SELECT ast_declarations.name, ast_declarations.printed_type, ast_declarations.module_name FROM ast_declarations \
-    \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
-    \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
-    \WHERE ast_declarations.module_name = :module_name \
-    \AND name GLOB :prefix \
-    \ORDER BY name ASC \
-    \LIMIT :limit \
-    \OFFSET :offset"
+    ( SQL.Query $
+        "SELECT ast_declarations.name, "
+          <> printedTypeTruncated typeLen
+          <> "ast_declarations.module_name FROM ast_declarations \
+             \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
+             \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
+             \WHERE ast_declarations.module_name = :module_name \
+             \AND (name == :prefix OR name GLOB :prefix)\
+             \ORDER BY name ASC \
+             \LIMIT :limit \
+             \OFFSET :offset"
+    )
     [ ":module_name" := P.runModuleName moduleName',
       ":prefix" := prefix <> "*",
       ":limit" := limit,
       ":offset" := offset
     ]
 
--- getPrintedType
+printedTypeTruncated :: Int -> Text
+printedTypeTruncated typeLen =
+  " CASE \
+  \WHEN LENGTH (ast_declarations.printed_type) > "
+    <> show typeLen
+    <> " THEN substr (ast_declarations.printed_type, 1, "
+    <> show (typeLen `div` 2)
+    <> ") || '...' "
+    <> " || substr (ast_declarations.printed_type, -"
+    <> show (typeLen `div` 2)
+    <> ") \
+       \ELSE ast_declarations.printed_type \
+       \END printed_type, "
 
 data CompletionResult = CompletionResult
   { crName :: Text,
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index b22317d8fb..2ab6543ad3 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -29,13 +29,14 @@ import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Ide.Imports (Import (..))
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName, updateAvailableSrcs)
-import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationInModule, getAstDeclarationsStartingWith, getAstDeclarationsStartingWithOnlyInModule, getCoreFnExprAt, getEfDeclarationInModule, getAstDeclarationsStartingWithAndSearchingModuleNames)
+import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationInModule, getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, setTraceValue, getMaxCompletions)
 import Language.PureScript.Lsp.State (cancelRequest)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
@@ -48,22 +49,19 @@ import System.IO.UTF8 (readUTF8FilesT)
 
 type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
-handlers :: Server.Handlers (HandlerM ())
+handlers :: Server.Handlers (HandlerM ServerConfig)
 handlers =
   mconcat
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
         void updateAvailableSrcs
         sendInfoMsg "Lsp initialized",
       Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        debugLsp "TextDocumentDidOpen"
         let uri :: Uri
             uri = getMsgUri msg
             fileName = Types.uriToFilePath uri
 
         traverse_ rebuildFile fileName,
-      Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> debugLsp "SMethod_TextDocumentDidChange",
       Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
-        debugLsp "SMethod_TextDocumentDidSave"
         let uri :: Uri
             uri = getMsgUri msg
             fileName = Types.uriToFilePath uri
@@ -71,13 +69,13 @@ handlers =
       Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
         cfg <- getConfig
         debugLsp $ "Config changed: " <> show cfg,
-      Server.notificationHandler Message.SMethod_SetTrace $ \_msg -> debugLsp "SMethod_SetTrace",
-      Server.notificationHandler Message.SMethod_CancelRequest $ \req -> do
-        let reqId = req ^. LSP.params . LSP.id
+      Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
+        setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
+      Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
+        let reqId = msg ^. LSP.params . LSP.id
         debugLsp $ "SMethod_CancelRequest " <> show reqId
         cancelRequest reqId,
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
-        debugLsp "SMethod_TextDocumentDiagnostic"
         (_errs, diagnostics) <- getFileDiagnotics req
         res $
           Right $
@@ -112,7 +110,6 @@ handlers =
                         Nothing
                         Nothing,
       Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-        debugLsp "SMethod_TextDocumentHover"
         let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             docUri =
@@ -121,10 +118,10 @@ handlers =
                   . to Types.toNormalizedUri
             nullRes = res $ Right $ Types.InR Types.Null
 
-            markdownRes :: Text -> HandlerM () ()
+            markdownRes :: Text -> HandlerM ServerConfig ()
             markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
 
-            markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM () ()
+            markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM ServerConfig ()
             markdownTypeRes word type' comments =
               markdownRes $ pursTypeStr word type' comments
 
@@ -140,7 +137,7 @@ handlers =
                   Just t -> " :: " <> t
                   Nothing -> ""
 
-            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
             forLsp val f = maybe nullRes f val
 
         forLsp filePathMb \filePath -> do
@@ -179,7 +176,6 @@ handlers =
                         forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
                       Just docs -> markdownRes docs,
       Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-        debugLsp "SMethod_TextDocumentDefinition"
         let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             uri :: Types.NormalizedUri
@@ -194,9 +190,8 @@ handlers =
 
             locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
 
-            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
             forLsp val f = maybe nullRes f val
-        debugLsp $ "filePathMb: " <> show filePathMb
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
@@ -262,7 +257,7 @@ handlers =
 
             nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
 
-            forLsp :: Maybe a -> (a -> HandlerM () ()) -> HandlerM () ()
+            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
             forLsp val f = maybe nullRes f val
 
         debugLsp $ "filePathMb: " <> show filePathMb
@@ -277,16 +272,16 @@ handlers =
                 mNameMb <- selectExternModuleNameFromFilePath filePath
                 debugLsp $ "Module name: " <> show mNameMb
                 forLsp mNameMb \mName -> do
-                  let limit = 50
-                      withQualifier = getIdentModuleQualifier word
+                  let withQualifier = getIdentModuleQualifier word
                       wordWithoutQual = maybe word snd withQualifier
+                  limit <- getMaxCompletions
                   matchingImport <- maybe (pure Nothing) (getMatchingImport filePath . fst) withQualifier
                   -- matchingImport =
                   debugLsp $ "wordWithoutQual " <> show wordWithoutQual
                   decls <- case (matchingImport, withQualifier) of
-                    (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule limit 0 importModuleName wordWithoutQual
-                    (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames limit 0 mName wordModuleName wordWithoutQual
-                    _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith limit 0 mName wordWithoutQual
+                    (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
+                    (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
+                    _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith mName wordWithoutQual
                   -- Just
                   debugLsp $ "Found decls: " <> show (length decls)
                   res $
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
new file mode 100644
index 0000000000..f7d7f256ec
--- /dev/null
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Language.PureScript.Lsp.ServerConfig where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Language.LSP.Protocol.Types (TraceValue (..))
+import Language.LSP.Server (MonadLsp, getConfig, setConfig)
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (..), LspLogLevel (..))
+import Protolude
+
+data ServerConfig = ServerConfig
+  { outputPath :: FilePath,
+    globs :: [FilePath],
+    inputSrcFromFile :: Maybe FilePath,
+    logLevel :: LspLogLevel,
+    traceValue :: TraceValue,
+    maxTypeLength :: Maybe Int,
+    maxCompletions :: Maybe Int
+  }
+  deriving (Show, Eq, Generic, ToJSON, FromJSON)
+
+defaultFromEnv :: LspEnvironment -> ServerConfig
+defaultFromEnv env =
+  ServerConfig
+    { outputPath = confOutputPath $ lspConfig env,
+      globs = confGlobs $ lspConfig env,
+      inputSrcFromFile = confInputSrcFromFile $ lspConfig env,
+      logLevel = logLevel,
+      traceValue = case logLevel of
+        LogDebug -> TraceValue_Verbose
+        LogAll -> TraceValue_Verbose
+        LogWarning -> TraceValue_Messages
+        _ -> TraceValue_Off,
+      maxTypeLength = Nothing,
+      maxCompletions = Nothing
+    }
+  where
+    logLevel = confLogLevel $ lspConfig env
+
+setTraceValue :: (MonadLsp ServerConfig m) => TraceValue -> m ()
+setTraceValue tv = do
+  config <- getConfig
+  setConfig (config {traceValue = tv})
+
+defaultMaxTypeLength :: Int
+defaultMaxTypeLength = 100
+
+defaultMaxCompletions :: Int
+defaultMaxCompletions = 50
+
+getMaxTypeLength :: (MonadLsp ServerConfig m) => m Int
+getMaxTypeLength =
+  fromMaybe defaultMaxTypeLength . maxTypeLength <$> getConfig
+
+getMaxCompletions :: (MonadLsp ServerConfig m) => m Int
+getMaxCompletions =
+  fromMaybe defaultMaxCompletions . maxCompletions <$> getConfig
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index b4fbf3aad2..b76c1c00e9 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -9,6 +9,7 @@ import Control.Concurrent.STM (TVar, newTVarIO)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as A
 import Database.SQLite.Simple (Connection)
+import Language.LSP.Protocol.Types (Range)
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
@@ -16,7 +17,7 @@ import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude
 import System.Directory (createDirectoryIfMissing)
-import Language.LSP.Protocol.Types (Range)
+import Data.Aeson.Types qualified as AT
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -40,8 +41,8 @@ data LspConfig = LspConfig
   deriving (Show)
 
 data LspState = LspState
-  { currentFile :: Maybe CurrentFile
-  , cancelledRequests :: Set (Either Int32 Text)
+  { currentFile :: Maybe CurrentFile,
+    cancelledRequests :: Set (Either Int32 Text)
   }
   deriving (Show)
 
@@ -58,7 +59,7 @@ data CompleteItemData = CompleteItemData
     cidModuleName :: P.ModuleName,
     cidImportedModuleName :: P.ModuleName,
     cidName :: Text,
-    cidWord :: Text, 
+    cidWord :: Text,
     wordRange :: Range
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
@@ -71,7 +72,29 @@ data LspLogLevel
   | LogWarning
   | LogError
   | LogNone
-  deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON)
+  deriving (Show, Eq, Ord, Generic)
+
+instance A.ToJSON LspLogLevel where
+  toJSON = \case
+    LogAll -> A.String "all"
+    LogDebug -> A.String "debug"
+    LogPerf -> A.String "perf"
+    LogInfo -> A.String "info"
+    LogWarning -> A.String "warning"
+    LogError -> A.String "error"
+    LogNone -> A.String "none"
+
+instance FromJSON LspLogLevel where
+  parseJSON v = case v of 
+    A.String "all" -> pure LogAll
+    A.String "debug" -> pure LogDebug
+    A.String "perf" -> pure LogPerf
+    A.String "info" -> pure LogInfo
+    A.String "warning" -> pure LogWarning
+    A.String "error" -> pure LogError
+    A.String "none" -> pure LogNone
+    A.String _ -> AT.unexpected v
+    _ -> AT.typeMismatch "String" v
 
 decodeCompleteItemData :: Maybe A.Value -> A.Result (Maybe CompleteItemData)
 decodeCompleteItemData Nothing = pure Nothing

From 6da5ce66324a851b754faa39effb220f3159c3b7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 14:46:08 +0200
Subject: [PATCH 111/297] adds method to errors

---
 src/Language/PureScript/LSP.hs | 19 +++++++++++++++----
 1 file changed, 15 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 896d423921..3c2c4fb717 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
@@ -9,6 +10,8 @@ module Language.PureScript.Lsp (main, serverDefinition) where
 import Control.Concurrent.STM.TChan
 import Control.Monad.IO.Unlift
 import Data.Aeson qualified as A
+import Data.Aeson.Types qualified as A
+import Data.Text qualified as T
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server as LSP.Server
@@ -19,8 +22,6 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultFromEnv)
 import Language.PureScript.Lsp.State (requestIsCancelled)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
-import Data.Aeson.Types qualified as A
-import Data.Text qualified as T
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
@@ -81,7 +82,16 @@ reactor inp = do
     withAsync act \a -> do
       res <- waitCatch a
       case res of
-        Left e -> putErrLn $ "Request failed. Method: " <> method <> ". id: " <> show reqId <> ". Error: " <> show e
+        Left e ->
+          putErrLn
+            ( "Request failed. Method: "
+                <> show method
+                <> ". id: "
+                <> show reqId
+                <> ". Error: "
+                <> show e ::
+                Text
+            )
         Right _ -> pure ()
 
 -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
@@ -94,7 +104,8 @@ lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
       let reqId = case id of
             LSP.IdInt i -> Left i
             LSP.IdString t -> Right t
-      writeToChannel (Just reqId) (show reqId) $
+
+      writeToChannel (Just reqId) (show method) $
         ifM
           (requestIsCancelled reqId)
           (k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing)

From e6e4d0eea1a52ecce2cd03b3c42da15614247698 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 14:47:55 +0200
Subject: [PATCH 112/297] delete comment

---
 src/Language/PureScript/LSP.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 3c2c4fb717..b124f4ded5 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -117,7 +117,6 @@ lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
     goNotification f msg@(LSP.TNotificationMessage _ method _) = do
       writeToChannel Nothing (show method) (f msg)
 
-    -- writeToChannel :: Either Int Text -> HandlerM ServerConfig () -> IO ()
     writeToChannel = writeToChannelWith writeTChan
 
     writeToChannelWith fn reqId method a = do

From 0162ad88bf1d9b82e0031b9b73c60caee592fa6b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 14:51:14 +0200
Subject: [PATCH 113/297] remove logs

---
 src/Language/PureScript/Lsp/Handlers.hs | 33 +++----------------------
 src/Language/PureScript/Lsp/State.hs    |  8 ++----
 src/Language/PureScript/Lsp/Util.hs     |  5 ----
 3 files changed, 6 insertions(+), 40 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 2ab6543ad3..673315457f 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -33,7 +33,7 @@ import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName,
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
-import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
+import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, setTraceValue, getMaxCompletions)
@@ -67,13 +67,11 @@ handlers =
             fileName = Types.uriToFilePath uri
         traverse_ rebuildFile fileName,
       Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
-        cfg <- getConfig
-        debugLsp $ "Config changed: " <> show cfg,
+        pure (),
       Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
         setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
       Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
         let reqId = msg ^. LSP.params . LSP.id
-        debugLsp $ "SMethod_CancelRequest " <> show reqId
         cancelRequest reqId,
       Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
         (_errs, diagnostics) <- getFileDiagnotics req
@@ -196,41 +194,30 @@ handlers =
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
             mNameMb <- selectExternModuleNameFromFilePath filePath
-            debugLsp $ "Module name: " <> show mNameMb
-            debugLsp $ "Pos: " <> show pos
             forLsp mNameMb \mName -> do
               names <- getNamesAtPosition pos mName (VFS._file_text vf)
-              debugLsp $ "Found names: " <> show (length names)
 
               case head names of
                 Just name -> do
-                  debugLsp $ "Found name: " <> show name
                   spanMb <- readQualifiedNameDocsSourceSpan name
-                  debugLsp $ "Found docs span: " <> show spanMb
                   case spanMb of
                     _ -> do
                       case name of
                         P.Qualified (P.BySourcePos pos') _ -> do
-                          debugLsp $ "Found source pos: " <> show pos'
                           locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
                         P.Qualified (P.ByModuleName nameModule) ident -> do
-                          debugLsp $ "Found module name: " <> show nameModule
                           declMb <- getAstDeclarationInModule nameModule (printName ident)
-                          debugLsp $ "Found decl: " <> show (isJust declMb)
                           forLsp declMb \decl -> do
                             modFpMb <- selectExternPathFromModuleName nameModule
                             forLsp modFpMb \modFp -> do
-                              debugLsp $ "Found modFp: " <> show modFp
                               let sourceSpan = P.declSourceSpan decl
-                              debugLsp $ "Found decl sourceSpan: " <> show sourceSpan
                               locationRes modFp (spanToRange sourceSpan)
                     Just span ->
                       locationRes (P.spanName span) (spanToRange span)
                 _ -> do
                   corefnExprMb <- getCoreFnExprAt filePath pos
                   case corefnExprMb of
-                    Just (CF.Var (ss, _comments, _meta) (P.Qualified qb ident)) -> do
-                      debugLsp $ "Found Corefn Var source span: " <> show ss
+                    Just (CF.Var (_ss, _comments, _meta) (P.Qualified qb ident)) -> do
                       let name = P.runIdent ident
                       case qb of
                         P.ByModuleName coreMName -> do
@@ -243,8 +230,7 @@ handlers =
                         P.BySourcePos srcPos ->
                           locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
                     _ -> nullRes,
-      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> logPerfStandard "SMethod_TextDocumentCompletion" do
-        debugLsp "SMethod_TextDocumentCompletion"
+      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
         let Types.CompletionParams docIdent pos _prog _prog' _completionCtx = req ^. LSP.params
             filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
             uri :: Types.NormalizedUri
@@ -260,30 +246,25 @@ handlers =
             forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
             forLsp val f = maybe nullRes f val
 
-        debugLsp $ "filePathMb: " <> show filePathMb
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
             let (range, word) = getWordAt (VFS._file_text vf) pos
-            debugLsp $ "Word " <> show word
             if T.length word < 2
               then nullRes
               else do
                 mNameMb <- selectExternModuleNameFromFilePath filePath
-                debugLsp $ "Module name: " <> show mNameMb
                 forLsp mNameMb \mName -> do
                   let withQualifier = getIdentModuleQualifier word
                       wordWithoutQual = maybe word snd withQualifier
                   limit <- getMaxCompletions
                   matchingImport <- maybe (pure Nothing) (getMatchingImport filePath . fst) withQualifier
                   -- matchingImport =
-                  debugLsp $ "wordWithoutQual " <> show wordWithoutQual
                   decls <- case (matchingImport, withQualifier) of
                     (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
                     (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
                     _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith mName wordWithoutQual
                   -- Just
-                  debugLsp $ "Found decls: " <> show (length decls)
                   res $
                     Right $
                       Types.InR $
@@ -318,7 +299,6 @@ handlers =
                                       _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word range
                                     },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
-        debugLsp "SMethod_CompletionItemResolve"
         let completionItem = req ^. LSP.params
             result = completionItem ^. LSP.data_ & decodeCompleteItemData
 
@@ -338,20 +318,15 @@ handlers =
                   & addDocs
           _ -> res $ Right completionItem,
       Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete output") $ \_req res -> do
-        debugLsp "SMethod_CustomMethod delete output"
         outDir <- asks (confOutputPath . lspConfig)
-        debugLsp $ "Deleting output directory: " <> show outDir
         liftIO $ createDirectoryIfMissing True outDir
         contents <- liftIO $ listDirectory outDir
         for_ contents \f -> do
-          debugLsp $ T.pack f
           unless (f == dbFile || dbFile `isPrefixOf` f) do
             let path = outDir </> f
-            debugLsp $ "Deleting: " <> show f
             liftIO $ removePathForcibly path
         res $ Right A.Null,
       Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
-        debugLsp "SMethod_CustomMethod build"
         config <- asks lspConfig
         conn <- asks lspDbConnection
         liftIO $ initDb conn
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 24cba647f3..a7fe2186ac 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -11,8 +11,6 @@ import Language.PureScript.Lsp.Types
 import Protolude hiding (moduleName, unzip)
 import Data.Set qualified as Set
 import Language.LSP.Protocol.Types (type (|?)(..))
-import Language.PureScript.Lsp.Log (debugLsp)
--- import Language.LSP.Protocol.Types ((InL))
 
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> P.Module -> P.Environment -> m ()
@@ -47,8 +45,6 @@ cancelRequest requestId = do
 requestIsCancelled :: (MonadReader LspEnvironment m, MonadIO m) => Either Int32 Text -> m Bool
 requestIsCancelled requestId = do
   st <- lspStateVar <$> ask
-  cancelled <- liftIO . atomically $ do
+  liftIO . atomically $ do
     st' <- readTVar st
-    pure $ requestId `Set.member` cancelledRequests st'
-  debugLsp $ "Request " <> show requestId <> " is cancelled " <> show cancelled
-  pure cancelled
\ No newline at end of file
+    pure $ requestId `Set.member` cancelledRequests st'
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 6687158cc6..f3fc2e0f45 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -26,7 +26,6 @@ import Language.PureScript.Linter qualified as P
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
 -- import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
 
-import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (CurrentFile (currentEnv), LspEnvironment)
@@ -83,9 +82,7 @@ getWordOnLine line' col =
 getNamesAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
 getNamesAtPosition pos moduleName' src = do
   let (_, search) = getWordAt src pos
-  debugLsp $ "Looking up " <> search <> " in module " <> P.runModuleName moduleName'
   decls <- getAstDeclarationsAtSrcPos moduleName' (positionToSourcePos pos)
-  debugLsp $ "Found declarations: " <> T.pack (show $ length decls)
   pure $
     mconcat $
       decls <&> \decl -> do
@@ -145,8 +142,6 @@ getNamesAtPosition pos moduleName' src = do
 lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => P.Qualified P.Name -> m (Maybe P.SourceType)
 lookupTypeInEnv (P.Qualified qb name) = do
   envMb :: Maybe P.Environment <- fmap currentEnv <$> cachedRebuild
-  debugLsp $ "Looking up " <> show name <> " in environment"
-  -- debugLsp $ "Environment: " <> show envMb
   pure $
     envMb
       >>= ( \(P.Environment {..}) -> case name of

From e45665f4f8af8a3ebf09fa943695b74bbb57f73f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 14:55:53 +0200
Subject: [PATCH 114/297] remove unused import

---
 src/Language/PureScript/Lsp/Handlers.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 673315457f..8c26e3175f 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -17,7 +17,6 @@ import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Uri)
 import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
-import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P

From d7cedc9f01a71393755bd84a1724f3d45e4f38d7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 15:32:17 +0200
Subject: [PATCH 115/297] move to map env

---
 src/Language/PureScript/Lsp/Handlers.hs |  2 +-
 src/Language/PureScript/Lsp/Rebuild.hs  | 48 ++-----------------------
 src/Language/PureScript/Lsp/State.hs    | 26 +++++++-------
 src/Language/PureScript/Lsp/Types.hs    | 14 ++++----
 src/Language/PureScript/Lsp/Util.hs     | 10 +++---
 src/Language/PureScript/Make.hs         |  2 +-
 6 files changed, 27 insertions(+), 75 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 8c26e3175f..42b87f1375 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -169,7 +169,7 @@ handlers =
                     docsMb <- readQualifiedNameDocsAsMarkdown name
                     case docsMb of
                       Nothing -> do
-                        typeMb <- lookupTypeInEnv name
+                        typeMb <- lookupTypeInEnv filePath name
                         forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
                       Just docs -> markdownRes docs,
       Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index edb8a05bdd..8d5a0edf5d 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -2,23 +2,18 @@
 {-# LANGUAGE PackageImports #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
 
-module Language.PureScript.Lsp.Rebuild where
+module Language.PureScript.Lsp.Rebuild (rebuildFile, codegenTargets) where
 
 import Control.Monad.Catch (MonadThrow)
 import Data.List qualified as List
 import Data.Map.Lazy qualified as M
-import Data.Maybe (fromJust)
 import Data.Set qualified as S
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Language.PureScript (MultipleErrors)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors qualified as P
-import Language.PureScript.Externs (ExternsFile (efModuleName))
-import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
-import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.ReadFile (lspReadFile)
@@ -26,7 +21,6 @@ import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig,
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
-import Language.PureScript.ModuleDependencies qualified as P
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
@@ -48,7 +42,7 @@ rebuildFile srcPath = logPerfStandard ("Rebuild file " <> T.pack srcPath) do
       pure $ Left ([(fp, input)], CST.toMultipleErrors fp parseError)
     Right (pwarnings, m) -> do
       let moduleName = P.getModuleName m
-      !externs <- logPerfStandard "Select depenencies" $ selectDependencies m
+      externs <- logPerfStandard "Select depenencies" $ selectDependencies m
       outputDirectory <- asks (confOutputPath . lspConfig)
       let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
       let pureRebuild = fp == ""
@@ -70,6 +64,7 @@ rebuildFile srcPath = logPerfStandard ("Rebuild file " <> T.pack srcPath) do
         Left errors ->
           pure (Left ([(fp, input)], errors))
         Right newExterns -> do
+          -- cacheRebuild srcPath newExterns
           pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
 
 codegenTargets :: Set P.CodegenTarget
@@ -88,7 +83,6 @@ shushCodegen ma =
       P.ffiCodegen = \_ -> pure ()
     }
 
--- add
 
 enableForeignCheck ::
   M.Map P.ModuleName FilePath ->
@@ -100,39 +94,3 @@ enableForeignCheck foreigns codegenTargets' ma =
     { P.ffiCodegen = ffiCodegen' foreigns codegenTargets' Nothing
     }
 
--- | Returns a topologically sorted list of dependent ExternsFiles for the given
--- module. Returns an error if there is a cyclic dependency within the
--- ExternsFiles
-sortExterns ::
-  (Monad m) =>
-  P.Module ->
-  ModuleMap P.ExternsFile ->
-  m (Either MultipleErrors [P.ExternsFile])
-sortExterns m ex = do
-  sorted' <-
-    runExceptT
-      . P.sortModules P.Transitive P.moduleSignature
-      . (:) m
-      . map mkShallowModule
-      . M.elems
-      . M.delete (P.getModuleName m)
-      $ ex
-  case sorted' of
-    Left err ->
-      pure $ Left err
-    Right (sorted, graph) -> do
-      let deps = fromJust (List.lookup (P.getModuleName m) graph)
-      pure $ Right $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
-  where
-    mkShallowModule P.ExternsFile {..} =
-      P.Module (P.internalModuleSourceSpan "<rebuild>") [] efModuleName (map mkImport efImports) Nothing
-    mkImport (P.ExternsImport mn it iq) =
-      P.ImportDeclaration (P.internalModuleSourceSpan "<rebuild>", []) mn it iq
-    getExtern mn = M.lookup mn ex
-    -- Sort a list so its elements appear in the same order as in another list.
-    inOrderOf :: (Ord a) => [a] -> [a] -> [a]
-    inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
-
--- | Removes a modules export list.
-openModuleExports :: P.Module -> P.Module
-openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index a7fe2186ac..7e69e96b46 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -4,44 +4,42 @@
 module Language.PureScript.Lsp.State where
 
 import Control.Concurrent.STM (modifyTVar, readTVar)
-import Language.PureScript.AST.Declarations qualified as P
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+import Language.LSP.Protocol.Types (type (|?) (..))
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFile (..))
 import Language.PureScript.Lsp.Types
 import Protolude hiding (moduleName, unzip)
-import Data.Set qualified as Set
-import Language.LSP.Protocol.Types (type (|?)(..))
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> P.Module -> P.Environment -> m ()
-cacheRebuild ef module' env = do
+cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> ExternsFile -> P.Environment -> m ()
+cacheRebuild fp ef env = do
   st <- lspStateVar <$> ask
   liftIO . atomically . modifyTVar st $ \x ->
     x
-      { currentFile = Just $ CurrentFile (efModuleName ef) module' ef env
+      { openFiles = Map.insert fp (OpenFile (efModuleName ef) ef env) (openFiles x)
       }
 
-cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => m (Maybe CurrentFile)
-cachedRebuild = do
+cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe OpenFile)
+cachedRebuild fp = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ do
     st' <- readTVar st
-    pure $ currentFile st'
-
+    pure $ Map.lookup fp $ openFiles st'
 
 cancelRequest :: (MonadReader LspEnvironment m, MonadIO m) => (Int32 |? Text) -> m ()
-cancelRequest requestId = do 
+cancelRequest requestId = do
   st <- lspStateVar <$> ask
   liftIO . atomically . modifyTVar st $ \x ->
     x
       { cancelledRequests = Set.insert eitherId (cancelledRequests x)
       }
-  where 
-    eitherId = case requestId of 
+  where
+    eitherId = case requestId of
       InL i -> Left i
       InR t -> Right t
 
-
 requestIsCancelled :: (MonadReader LspEnvironment m, MonadIO m) => Either Int32 Text -> m Bool
 requestIsCancelled requestId = do
   st <- lspStateVar <$> ask
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index b76c1c00e9..d513675099 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -10,7 +10,6 @@ import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as A
 import Database.SQLite.Simple (Connection)
 import Language.LSP.Protocol.Types (Range)
-import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
@@ -29,7 +28,7 @@ mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do
   createDirectoryIfMissing True $ confOutputPath conf
   connection <- mkConnection $ confOutputPath conf
-  st <- newTVarIO (LspState Nothing mempty)
+  st <- newTVarIO (LspState mempty mempty)
   pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
@@ -41,16 +40,15 @@ data LspConfig = LspConfig
   deriving (Show)
 
 data LspState = LspState
-  { currentFile :: Maybe CurrentFile,
+  { openFiles :: Map FilePath OpenFile,
     cancelledRequests :: Set (Either Int32 Text)
   }
   deriving (Show)
 
-data CurrentFile = CurrentFile
-  { currentModuleName :: P.ModuleName,
-    currentModule :: P.Module,
-    currentExternsFile :: P.ExternsFile,
-    currentEnv :: P.Environment
+data OpenFile = OpenFile
+  { ofModuleName :: P.ModuleName,
+    ofExternsFile :: P.ExternsFile,
+    ofEnv :: P.Environment
   }
   deriving (Show)
 
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index f3fc2e0f45..3f06489161 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -28,7 +28,7 @@ import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
 
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
-import Language.PureScript.Lsp.Types (CurrentFile (currentEnv), LspEnvironment)
+import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (ofEnv))
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
@@ -137,11 +137,9 @@ getNamesAtPosition pos moduleName' src = do
 
         Set.filter ((==) search . printName . P.disqualify) exprNames
 
--- <> Set.map (flip P.mkQualified moduleName' . P.TyName) typeNames
-
-lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => P.Qualified P.Name -> m (Maybe P.SourceType)
-lookupTypeInEnv (P.Qualified qb name) = do
-  envMb :: Maybe P.Environment <- fmap currentEnv <$> cachedRebuild
+lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> P.Qualified P.Name -> m (Maybe P.SourceType)
+lookupTypeInEnv fp (P.Qualified qb name) = do
+  envMb :: Maybe P.Environment <- fmap ofEnv <$> cachedRebuild fp
   pure $
     envMb
       >>= ( \(P.Environment {..}) -> case name of
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 2692ce3f45..3cb49b260d 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -153,7 +153,7 @@ rebuildModuleWithProvidedEnv ::
   Environment ->
   Module ->
   Maybe (Int, Int) ->
-  m (ExternsFile, Environment)
+  m (ExternsFile,  Environment)
 rebuildModuleWithProvidedEnv desugar' convertDocsModule MakeActions {..} exEnv env m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m

From 821b355527ff275409de6c7b1d5b5b1873961f79 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 18:42:21 +0200
Subject: [PATCH 116/297] only load required files into export env

---
 src/Language/PureScript/Lsp/Rebuild.hs      |  17 ++-
 src/Language/PureScript/Lsp/ServerConfig.hs |  12 ++-
 src/Language/PureScript/Lsp/State.hs        | 108 ++++++++++++++++++--
 src/Language/PureScript/Lsp/Types.hs        |  12 ++-
 src/Language/PureScript/Make.hs             |  77 +++-----------
 5 files changed, 142 insertions(+), 84 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 8d5a0edf5d..ebe0c7152d 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -17,13 +17,15 @@ import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.ReadFile (lspReadFile)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection))
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection), LspState)
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
+import Language.PureScript.Lsp.State (buildExportEnvCache, addExternToExportEnv)
+import Control.Concurrent.STM (TVar)
 
 rebuildFile ::
   ( MonadIO m,
@@ -54,9 +56,10 @@ rebuildFile srcPath = logPerfStandard ("Rebuild file " <> T.pack srcPath) do
               & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
               & shushProgress
               & addAllIndexing conn
+      !exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
       (!result, warnings) <- logPerfStandard ("Rebuild Module " <> T.pack srcPath) $ fmap force $ liftIO $ do
         P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-          newExterns <- P.rebuildModule makeEnv externs m
+          newExterns <- P.rebuildModule' makeEnv exportEnv externs m
           unless pureRebuild $
             updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
           pure newExterns
@@ -64,7 +67,7 @@ rebuildFile srcPath = logPerfStandard ("Rebuild file " <> T.pack srcPath) do
         Left errors ->
           pure (Left ([(fp, input)], errors))
         Right newExterns -> do
-          -- cacheRebuild srcPath newExterns
+          addExternToExportEnv newExterns
           pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
 
 codegenTargets :: Set P.CodegenTarget
@@ -94,3 +97,11 @@ enableForeignCheck foreigns codegenTargets' ma =
     { P.ffiCodegen = ffiCodegen' foreigns codegenTargets' Nothing
     }
 
+
+cacheEnv :: TVar LspState -> P.MakeActions P.Make -> P.MakeActions P.Make
+cacheEnv stVar ma =
+  ma
+    { P.readCacheDb = \_ -> do
+        st <- liftIO $ readTVarIO stVar
+        pure $ P.CacheDb (P.cacheDb st)
+    }
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index f7d7f256ec..f4a3b32fbb 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -15,7 +15,8 @@ data ServerConfig = ServerConfig
     logLevel :: LspLogLevel,
     traceValue :: TraceValue,
     maxTypeLength :: Maybe Int,
-    maxCompletions :: Maybe Int
+    maxCompletions :: Maybe Int, 
+    maxFilesInCache :: Maybe Int
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
@@ -48,10 +49,17 @@ defaultMaxTypeLength = 100
 defaultMaxCompletions :: Int
 defaultMaxCompletions = 50
 
+defaultMaxFilesInCache :: Int
+defaultMaxFilesInCache = 16
+
 getMaxTypeLength :: (MonadLsp ServerConfig m) => m Int
 getMaxTypeLength =
   fromMaybe defaultMaxTypeLength . maxTypeLength <$> getConfig
 
 getMaxCompletions :: (MonadLsp ServerConfig m) => m Int
 getMaxCompletions =
-  fromMaybe defaultMaxCompletions . maxCompletions <$> getConfig
\ No newline at end of file
+  fromMaybe defaultMaxCompletions . maxCompletions <$> getConfig
+
+getMaxFilesInCache :: (MonadLsp ServerConfig m) => m Int
+getMaxFilesInCache =
+  fromMaybe defaultMaxFilesInCache . maxFilesInCache <$> getConfig
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 7e69e96b46..394e4913ed 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -1,32 +1,118 @@
-{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Language.PureScript.Lsp.State where
+module Language.PureScript.Lsp.State
+  ( cacheRebuild,
+    cacheRebuild',
+    cachedRebuild,
+    removedCachedRebuild,
+    buildExportEnvCache,
+    addExternToExportEnv,
+    getExportEnv,
+    requestIsCancelled,
+    cancelRequest,
+  )
+where
 
-import Control.Concurrent.STM (modifyTVar, readTVar)
+import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar)
+import Control.Monad.Catch (MonadThrow (throwM))
+import Control.Monad.Trans.Writer (WriterT (runWriterT))
+import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Set qualified as Set
+import Data.Text qualified as T
 import Language.LSP.Protocol.Types (type (|?) (..))
+import Language.LSP.Server (MonadLsp)
+import Language.PureScript (MultipleErrors, prettyPrintMultipleErrors)
 import Language.PureScript.Environment qualified as P
+import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (..))
+import Language.PureScript.Externs qualified as P
+import Language.PureScript.Lsp.Log (errorLsp)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
 import Language.PureScript.Lsp.Types
+import Language.PureScript.Sugar.Names (externsEnv)
+import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> ExternsFile -> P.Environment -> m ()
-cacheRebuild fp ef env = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => FilePath -> ExternsFile -> [ExternsFile] -> P.Environment -> m ()
+cacheRebuild fp ef deps env = do
   st <- lspStateVar <$> ask
-  liftIO . atomically . modifyTVar st $ \x ->
-    x
-      { openFiles = Map.insert fp (OpenFile (efModuleName ef) ef env) (openFiles x)
-      }
+  maxFiles <- getMaxFilesInCache
+  liftIO $ cacheRebuild' st maxFiles fp ef deps env
+
+cacheRebuild' :: TVar LspState -> Int -> FilePath -> ExternsFile -> [P.ExternsFile] -> P.Environment -> IO ()
+cacheRebuild' st maxFiles fp ef deps env = atomically . modifyTVar st $ \x ->
+  x
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps env) : filter ((/= fp) . fst) (openFiles x)
+    }
 
 cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe OpenFile)
 cachedRebuild fp = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ do
     st' <- readTVar st
-    pure $ Map.lookup fp $ openFiles st'
+    pure $ List.lookup fp $ openFiles st'
+
+removedCachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m ()
+removedCachedRebuild fp = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically . modifyTVar st $ \x ->
+    x
+      { openFiles = filter ((/= fp) . fst) (openFiles x)
+      }
+
+buildExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => P.Module -> [ExternsFile] -> m P.Env
+buildExportEnvCache module' externs = do
+  st <- lspStateVar <$> ask
+  result <- liftIO . atomically $ do
+    st' <- readTVar st
+    if Map.member (P.getModuleName module') (exportEnv st')
+      then pure $ Right $ exportEnv st'
+      else do
+        let notInEnv :: ExternsFile -> Bool
+            notInEnv = flip Map.notMember (exportEnv st') . efModuleName
+        result <- addExterns (exportEnv st') (filter notInEnv externs)
+        case result of
+          Left err -> pure $ Left err
+          Right newEnv -> do
+            writeTVar st $ st' {exportEnv = newEnv}
+            pure $ Right newEnv
+
+  case result of
+    Left err -> throwM $ BuildEnvCacheException $ printBuildErrors err
+    Right env -> pure env
+
+data BuildEnvCacheException = BuildEnvCacheException Text
+  deriving (Show)
+
+instance Exception BuildEnvCacheException
+
+addExterns :: (Foldable t, Monad f) => P.Env -> t ExternsFile -> f (Either MultipleErrors P.Env)
+addExterns env externs = fmap fst . runWriterT $ runExceptT $ foldM externsEnv env externs
+
+logBuildErrors :: (MonadIO m, MonadReader LspEnvironment m) => MultipleErrors -> m ()
+logBuildErrors = errorLsp . printBuildErrors
+
+printBuildErrors :: MultipleErrors -> Text
+printBuildErrors = T.pack . prettyPrintMultipleErrors P.noColorPPEOptions
+
+addExternToExportEnv :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> m ()
+addExternToExportEnv ef = do
+  stVar <- lspStateVar <$> ask
+  error <- liftIO $ atomically $ do
+    st <- readTVar stVar
+    result <- addExterns (exportEnv st) [ef]
+    case result of
+      Left err -> pure $ Just err
+      Right newEnv -> do
+        writeTVar stVar $ st {exportEnv = newEnv}
+        pure Nothing
+
+  for_ error logBuildErrors
+
+getExportEnv :: (MonadReader LspEnvironment m, MonadIO m) => m P.Env
+getExportEnv = exportEnv <$> (liftIO . readTVarIO =<< lspStateVar <$> ask)
 
 cancelRequest :: (MonadReader LspEnvironment m, MonadIO m) => (Int32 |? Text) -> m ()
 cancelRequest requestId = do
@@ -45,4 +131,4 @@ requestIsCancelled requestId = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ do
     st' <- readTVar st
-    pure $ requestId `Set.member` cancelledRequests st'
\ No newline at end of file
+    pure $ requestId `Set.member` cancelledRequests st'
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index d513675099..46be6e3c63 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -8,15 +8,17 @@ import Control.Concurrent.STM (TVar, newTVarIO)
 
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as A
+import Data.Aeson.Types qualified as AT
 import Database.SQLite.Simple (Connection)
 import Language.LSP.Protocol.Types (Range)
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Names qualified as P
+import Language.PureScript.Sugar.Names (Env)
+import Language.PureScript.Sugar.Names qualified as P
 import Protolude
 import System.Directory (createDirectoryIfMissing)
-import Data.Aeson.Types qualified as AT
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -28,7 +30,7 @@ mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do
   createDirectoryIfMissing True $ confOutputPath conf
   connection <- mkConnection $ confOutputPath conf
-  st <- newTVarIO (LspState mempty mempty)
+  st <- newTVarIO (LspState mempty P.primEnv mempty)
   pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
@@ -40,7 +42,8 @@ data LspConfig = LspConfig
   deriving (Show)
 
 data LspState = LspState
-  { openFiles :: Map FilePath OpenFile,
+  { openFiles :: [(FilePath, OpenFile)],
+    exportEnv :: Env,
     cancelledRequests :: Set (Either Int32 Text)
   }
   deriving (Show)
@@ -48,6 +51,7 @@ data LspState = LspState
 data OpenFile = OpenFile
   { ofModuleName :: P.ModuleName,
     ofExternsFile :: P.ExternsFile,
+    ofDependencies :: [P.ExternsFile],
     ofEnv :: P.Environment
   }
   deriving (Show)
@@ -83,7 +87,7 @@ instance A.ToJSON LspLogLevel where
     LogNone -> A.String "none"
 
 instance FromJSON LspLogLevel where
-  parseJSON v = case v of 
+  parseJSON v = case v of
     A.String "all" -> pure LogAll
     A.String "debug" -> pure LogDebug
     A.String "perf" -> pure LogPerf
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 3cb49b260d..5d217fd899 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,8 +1,10 @@
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module Language.PureScript.Make
   ( -- * Make API
     rebuildModule,
     rebuildModule',
+    rebuildModuleWithProvidedEnv,
     make,
     inferForeignModules,
     module Monad,
@@ -17,9 +19,9 @@ import Control.Monad (foldM, unless, when, (<=<))
 import Control.Monad.Base (MonadBase (liftBase))
 import Control.Monad.Error.Class (MonadError (..))
 import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Supply (SupplyT, evalSupplyT, runSupply, runSupplyT)
+import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
 import Control.Monad.Trans.Control (MonadBaseControl (..))
-import Control.Monad.Trans.State (StateT, runStateT)
+import Control.Monad.Trans.State (runStateT)
 import Control.Monad.Writer.Class (MonadWriter (..), censor)
 import Control.Monad.Writer.Strict (runWriterT)
 import Data.Foldable (fold, for_)
@@ -36,7 +38,6 @@ import Language.PureScript.CST qualified as CST
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Docs.Convert qualified as Docs
-import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (Environment, initEnvironment)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
 import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile)
@@ -47,7 +48,7 @@ import Language.PureScript.Make.BuildPlan qualified as BuildPlan
 import Language.PureScript.Make.Cache qualified as Cache
 import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
-import Language.PureScript.Names (ModuleName, Qualified, isBuiltinModuleName, runModuleName)
+import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
 import Language.PureScript.Renamer (renameInModule)
 import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
@@ -79,7 +80,6 @@ rebuildModule' ::
   m ExternsFile
 rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
 
-
 rebuildModuleWithIndex ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
@@ -89,77 +89,26 @@ rebuildModuleWithIndex ::
   Module ->
   Maybe (Int, Int) ->
   m ExternsFile
-rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do
-  progress $ CompilingModule moduleName moduleIndex
+rebuildModuleWithIndex act exEnv externs m moduleIndex = do
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
-      withPrim = importPrim m
-  lint withPrim
-  ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
-    (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
-    let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-    (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
-    let usedImports' =
-          foldl'
-            ( flip $ \(fromModuleName, newtypeCtorName) ->
-                M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
-            )
-            usedImports
-            checkConstructorImportsForCoercible
-    -- Imports cannot be linted before type checking because we need to
-    -- known which newtype constructors are used to solve Coercible
-    -- constraints in order to not report them as unused.
-    censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
-    return (checked, checkEnv)
-
-  -- desugar case declarations *after* type- and exhaustiveness checking
-  -- since pattern guards introduces cases which the exhaustiveness checker
-  -- reports as not-exhaustive.
-  (deguarded, nextVar') <- runSupplyT nextVar $ do
-    desugarCaseGuards elaborated
-
-  regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
-  let mod' = Module ss coms moduleName regrouped exps
-      corefn = CF.moduleToCoreFn env' mod'
-      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
-      (renamedIdents, renamed) = renameInModule optimized
-      exts = moduleToExternsFile mod' env' renamedIdents
-  ffiCodegen renamed
-  -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
-  -- but I have not done so for two reasons:
-  -- 1. This should never fail; any genuine errors in the code should have been
-  -- caught earlier in this function. Therefore if we do fail here it indicates
-  -- a bug in the compiler, which should be reported as such.
-  -- 2. We do not want to perform any extra work generating docs unless the
-  -- user has asked for docs to be generated.
-  let docs = case Docs.convertModule externs exEnv env' withPrim of
-        Left errs ->
-          internalError $
-            "Failed to produce docs for "
-              ++ T.unpack (runModuleName moduleName)
-              ++ "; details:\n"
-              ++ prettyPrintMultipleErrors defaultPPEOptions errs
-        Right d -> d
+  rebuildModuleWithProvidedEnv act exEnv env externs m moduleIndex
 
-  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
-  return exts
-  
 rebuildModuleWithProvidedEnv ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
-  (Module -> StateT (Env, M.Map ModuleName [Qualified Name]) (SupplyT m) Module) ->
-  (Module -> Either MultipleErrors Docs.Module) ->
   MakeActions m ->
   Env ->
   Environment ->
+  [ExternsFile] ->
   Module ->
   Maybe (Int, Int) ->
-  m (ExternsFile,  Environment)
-rebuildModuleWithProvidedEnv desugar' convertDocsModule MakeActions {..} exEnv env m@(Module _ _ moduleName _ _) moduleIndex = do
+  m ExternsFile
+rebuildModuleWithProvidedEnv MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
-    (desugared, (exEnv', usedImports)) <- runStateT (desugar' withPrim) (exEnv, mempty)
+    (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
     (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
     let usedImports' =
@@ -195,7 +144,7 @@ rebuildModuleWithProvidedEnv desugar' convertDocsModule MakeActions {..} exEnv e
   -- a bug in the compiler, which should be reported as such.
   -- 2. We do not want to perform any extra work generating docs unless the
   -- user has asked for docs to be generated.
-  let docs = case convertDocsModule withPrim of
+  let docs = case Docs.convertModule externs exEnv env' withPrim of
         Left errs ->
           internalError $
             "Failed to produce docs for "
@@ -205,7 +154,7 @@ rebuildModuleWithProvidedEnv desugar' convertDocsModule MakeActions {..} exEnv e
         Right d -> d
 
   evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
-  return (exts, env')
+  return exts
 
 -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
 -- but I have not done so for two reasons:

From de49453e0260f29e77be2e377234ff611197994a Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 23:36:12 +0200
Subject: [PATCH 117/297] fast cached rebuilds

---
 src/Language/PureScript/Ide/Rebuild.hs      |  2 +-
 src/Language/PureScript/Lsp/Diagnostics.hs  |  5 +-
 src/Language/PureScript/Lsp/Rebuild.hs      | 77 +++++++++++++--------
 src/Language/PureScript/Lsp/ServerConfig.hs |  3 +-
 src/Language/PureScript/Lsp/State.hs        | 16 +++--
 src/Language/PureScript/Lsp/Types.hs        |  3 +-
 src/Language/PureScript/Lsp/Util.hs         |  4 +-
 src/Language/PureScript/Make.hs             |  2 +-
 src/Language/PureScript/Make/Actions.hs     |  6 +-
 src/Language/PureScript/Make/Index.hs       |  8 +--
 10 files changed, 74 insertions(+), 52 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 1e84131773..8078123101 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -184,7 +184,7 @@ shushProgress ma =
 -- | Stops any kind of codegen
 shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
-  ma { P.codegen = \_ _ _ _ _-> pure ()
+  ma { P.codegen = \_ _ _ _ _ _-> pure ()
      , P.ffiCodegen = \_ -> pure ()
      }
 
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index abf044b2b7..fbd9865e3d 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -2,7 +2,6 @@ module Language.PureScript.Lsp.Diagnostics where
 
 import Control.Lens ((^.))
 import Control.Monad.Catch (MonadThrow)
-import Control.Monad.IO.Unlift
 import Data.Aeson qualified as A
 import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as T
@@ -18,12 +17,14 @@ import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
+import Language.LSP.Server (MonadLsp)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 
 getFileDiagnotics ::
   ( LSP.HasParams s a1,
     LSP.HasTextDocument a1 a2,
     LSP.HasUri a2 Uri,
-    MonadIO m,
+    MonadLsp ServerConfig m,
     MonadThrow m,
     MonadReader LspEnvironment m
   ) =>
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index ebe0c7152d..45973eb2a6 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,36 +1,37 @@
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE PackageImports #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.Lsp.Rebuild (rebuildFile, codegenTargets) where
 
+import Control.Concurrent.STM (TVar)
 import Control.Monad.Catch (MonadThrow)
 import Data.List qualified as List
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as S
 import Data.Set qualified as Set
 import Data.Text qualified as T
+import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors qualified as P
+import Language.PureScript.Externs (ExternsFile)
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
-import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.ReadFile (lspReadFile)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection), LspState)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
+import Language.PureScript.Lsp.State (addExternToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild)
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection, lspStateVar), LspState, OpenFile (OpenFile))
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
-import Language.PureScript.Lsp.State (buildExportEnvCache, addExternToExportEnv)
-import Control.Concurrent.STM (TVar)
 
 rebuildFile ::
-  ( MonadIO m,
-    MonadThrow m,
-    MonadReader LspEnvironment m
+  ( MonadThrow m,
+    MonadReader LspEnvironment m,
+    MonadLsp ServerConfig m
   ) =>
   FilePath ->
   m (Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors))
@@ -44,30 +45,50 @@ rebuildFile srcPath = logPerfStandard ("Rebuild file " <> T.pack srcPath) do
       pure $ Left ([(fp, input)], CST.toMultipleErrors fp parseError)
     Right (pwarnings, m) -> do
       let moduleName = P.getModuleName m
-      externs <- logPerfStandard "Select depenencies" $ selectDependencies m
-      outputDirectory <- asks (confOutputPath . lspConfig)
       let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+      outputDirectory <- asks (confOutputPath . lspConfig)
       let pureRebuild = fp == ""
       let modulePath = if pureRebuild then fp else srcPath
-      foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
       conn <- asks lspDbConnection
-      let makeEnv =
+      stVar <- asks lspStateVar
+      maxCache <- getMaxFilesInCache
+      cachedBuild <- cachedRebuild srcPath
+      let makeEnv foreigns externs =
             P.buildMakeActions outputDirectory filePathMap foreigns False
               & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
               & shushProgress
               & addAllIndexing conn
-      !exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
-      (!result, warnings) <- logPerfStandard ("Rebuild Module " <> T.pack srcPath) $ fmap force $ liftIO $ do
-        P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-          newExterns <- P.rebuildModule' makeEnv exportEnv externs m
-          unless pureRebuild $
-            updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
-          pure newExterns
+              & addRebuildCaching stVar maxCache externs
+      debugLsp $ "Cache found: " <> show (isJust cachedBuild)
+      case cachedBuild of
+        Just (OpenFile _ _ externs env _) -> do
+          foreigns <-  P.inferForeignModules (M.singleton moduleName (Right modulePath))
+          exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
+          res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
+            P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+              newExtern <- P.rebuildModuleWithProvidedEnv (makeEnv foreigns externs) exportEnv env externs m Nothing
+              unless pureRebuild $
+                updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
+              pure newExtern
+          handleRebuildResult fp input pwarnings res
+        Nothing -> do
+          externs <- logPerfStandard "Select depenencies" $ selectDependencies m
+          foreigns <-  P.inferForeignModules (M.singleton moduleName (Right modulePath))
+          exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
+          res <- logPerfStandard "Rebuild Module" $ liftIO $ do
+            P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+              newExtern <- P.rebuildModule' (makeEnv foreigns externs) exportEnv externs m
+              unless pureRebuild $
+                updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
+              pure newExtern
+          handleRebuildResult fp input pwarnings res
+  where
+    handleRebuildResult fp input pwarnings (result, warnings) = do
       case result of
         Left errors ->
           pure (Left ([(fp, input)], errors))
-        Right newExterns -> do
-          addExternToExportEnv newExterns
+        Right newExtern -> do
+          addExternToExportEnv newExtern
           pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
 
 codegenTargets :: Set P.CodegenTarget
@@ -82,11 +103,10 @@ shushProgress ma =
 shushCodegen :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
   ma
-    { P.codegen = \_ _ _ _ _ -> pure (),
+    { P.codegen = \_ _ _ _ _ _ -> pure (),
       P.ffiCodegen = \_ -> pure ()
     }
 
-
 enableForeignCheck ::
   M.Map P.ModuleName FilePath ->
   S.Set P.CodegenTarget ->
@@ -97,11 +117,8 @@ enableForeignCheck foreigns codegenTargets' ma =
     { P.ffiCodegen = ffiCodegen' foreigns codegenTargets' Nothing
     }
 
-
-cacheEnv :: TVar LspState -> P.MakeActions P.Make -> P.MakeActions P.Make
-cacheEnv stVar ma =
+addRebuildCaching :: TVar LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
+addRebuildCaching stVar maxCache deps ma =
   ma
-    { P.readCacheDb = \_ -> do
-        st <- liftIO $ readTVarIO stVar
-        pure $ P.CacheDb (P.cacheDb st)
+    { P.codegen = \prevEnv env astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv env) <* P.codegen ma prevEnv env astM m docs ext
     }
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index f4a3b32fbb..62671039c8 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -33,7 +33,8 @@ defaultFromEnv env =
         LogWarning -> TraceValue_Messages
         _ -> TraceValue_Off,
       maxTypeLength = Nothing,
-      maxCompletions = Nothing
+      maxCompletions = Nothing, 
+      maxFilesInCache = Nothing
     }
   where
     logLevel = confLogLevel $ lspConfig env
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 394e4913ed..f82af0b44a 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -35,17 +35,19 @@ import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => FilePath -> ExternsFile -> [ExternsFile] -> P.Environment -> m ()
-cacheRebuild fp ef deps env = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Environment -> m ()
+cacheRebuild ef deps prevEnv finalEnv = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
-  liftIO $ cacheRebuild' st maxFiles fp ef deps env
+  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv finalEnv
 
-cacheRebuild' :: TVar LspState -> Int -> FilePath -> ExternsFile -> [P.ExternsFile] -> P.Environment -> IO ()
-cacheRebuild' st maxFiles fp ef deps env = atomically . modifyTVar st $ \x ->
+cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [P.ExternsFile] -> P.Environment -> P.Environment -> IO ()
+cacheRebuild' st maxFiles ef deps prevEnv finalEnv = atomically . modifyTVar st $ \x ->
   x
-    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps env) : filter ((/= fp) . fst) (openFiles x)
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv finalEnv) : filter ((/= fp) . fst) (openFiles x)
     }
+  where
+    fp = P.spanName $ efSourceSpan ef
 
 cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe OpenFile)
 cachedRebuild fp = do
@@ -76,7 +78,7 @@ buildExportEnvCache module' externs = do
         case result of
           Left err -> pure $ Left err
           Right newEnv -> do
-            writeTVar st $ st' {exportEnv = newEnv}
+            writeTVar st $ st' {exportEnv = newEnv }
             pure $ Right newEnv
 
   case result of
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 46be6e3c63..3f74421c13 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -52,7 +52,8 @@ data OpenFile = OpenFile
   { ofModuleName :: P.ModuleName,
     ofExternsFile :: P.ExternsFile,
     ofDependencies :: [P.ExternsFile],
-    ofEnv :: P.Environment
+    ofStartingEnv :: P.Environment,
+    ofFinalEnv :: P.Environment
   }
   deriving (Show)
 
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 3f06489161..ba11424a1c 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -28,7 +28,7 @@ import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
 
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
-import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (ofEnv))
+import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (ofFinalEnv))
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
@@ -139,7 +139,7 @@ getNamesAtPosition pos moduleName' src = do
 
 lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> P.Qualified P.Name -> m (Maybe P.SourceType)
 lookupTypeInEnv fp (P.Qualified qb name) = do
-  envMb :: Maybe P.Environment <- fmap ofEnv <$> cachedRebuild fp
+  envMb :: Maybe P.Environment <- fmap ofFinalEnv <$> cachedRebuild fp
   pure $
     envMb
       >>= ( \(P.Environment {..}) -> case name of
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 5d217fd899..49b3f14dae 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -153,7 +153,7 @@ rebuildModuleWithProvidedEnv MakeActions {..} exEnv env externs m@(Module _ _ mo
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
+  evalSupplyT nextVar'' $ codegen env env' mod' renamed docs exts
   return exts
 
 -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 0019dc559f..eb1b6a5ab4 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -113,7 +113,7 @@ data MakeActions m = MakeActions
   , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
   -- ^ Read the externs file for a module as a string and also return the actual
   -- path for the file.
-  , codegen :: Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
+  , codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
   -- ^ Run the code generator for the module and write any required output files.
   , ffiCodegen :: CF.Module CF.Ann -> m ()
   -- ^ Check ffi and print it in the output directory.
@@ -246,8 +246,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
       writeJSONFile (outputFilename modName "docs.json") docsMod
 
-  codegen :: Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
-  codegen _env _m m docs exts = do
+  codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
+  codegen _prevEnv _env _m m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
     codegenTargets <- lift $ asks optionsCodegenTargets
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index d575bb856c..1904f4ee46 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -61,7 +61,7 @@ addAllIndexing conn ma =
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \env astM m docs ext -> lift (indexAstModule conn astM ext) <* P.codegen ma env astM m docs ext
+    { P.codegen = \prevEnv env astM m docs ext -> lift (indexAstModule conn astM ext) <* P.codegen ma prevEnv env astM m docs ext
     }
 
 indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> m ()
@@ -129,7 +129,7 @@ insertDeclExprs conn name decl = liftIO $ void $ handleDecl decl
 addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addEnvIndexing conn ma =
   ma
-    { P.codegen = \env astM m docs ext -> lift (indexEnv conn (P.getModuleName astM) env) <* P.codegen ma env astM m docs ext
+    { P.codegen = \prevEnv env astM m docs ext -> lift (indexEnv conn (P.getModuleName astM) env) <* P.codegen ma prevEnv env astM m docs ext
     }
 
 indexEnv :: (MonadIO m) => Connection -> P.ModuleName -> P.Environment -> m ()
@@ -145,7 +145,7 @@ indexEnv conn name env =
 addCoreFnIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addCoreFnIndexing conn ma =
   ma
-    { P.codegen = \env astM m docs ext -> lift (indexCoreFn conn m) <* P.codegen ma env astM m docs ext
+    { P.codegen = \prevEnv env astM m docs ext -> lift (indexCoreFn conn m) <* P.codegen ma prevEnv env astM m docs ext
     }
 
 indexCoreFn :: forall m. (MonadIO m) => Connection -> CF.Module CF.Ann -> m ()
@@ -240,7 +240,7 @@ indexCoreFn conn m = do
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma
-    { P.codegen = \env astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma env astM m docs ext
+    { P.codegen = \prevEnv env astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma prevEnv env astM m docs ext
     }
 
 indexExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()

From 2fd6d19f43d5cbf6f5bd8ac557a9c8163bb3b950 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 8 Oct 2024 23:57:47 +0200
Subject: [PATCH 118/297] remove open and save rebuild

---
 src/Language/PureScript/Lsp/Handlers.hs | 18 ++++++++----------
 1 file changed, 8 insertions(+), 10 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 42b87f1375..2fd55d87fc 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -35,8 +35,8 @@ import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQuali
 import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, setTraceValue, getMaxCompletions)
-import Language.PureScript.Lsp.State (cancelRequest)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, setTraceValue)
+import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
 import Language.PureScript.Make.Index (initDb)
@@ -54,17 +54,15 @@ handlers =
     [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
         void updateAvailableSrcs
         sendInfoMsg "Lsp initialized",
-      Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \msg -> do
-        let uri :: Uri
-            uri = getMsgUri msg
-            fileName = Types.uriToFilePath uri
-
-        traverse_ rebuildFile fileName,
-      Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \msg -> do
+      Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \_msg -> do
+        pure (),
+      Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \_msg -> do
+        pure (),
+      Server.notificationHandler Message.SMethod_TextDocumentDidClose $ \msg -> do
         let uri :: Uri
             uri = getMsgUri msg
             fileName = Types.uriToFilePath uri
-        traverse_ rebuildFile fileName,
+        traverse_ removedCachedRebuild fileName,
       Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
         pure (),
       Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do

From bda8b529f191d503f161037d1c11c1081701a7f5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 9 Oct 2024 10:53:35 +0200
Subject: [PATCH 119/297] put handlers in their own modules

---
 purescript.cabal                              |   7 +
 src/Language/PureScript/LSP.hs                |  33 +-
 src/Language/PureScript/Lsp/Handlers.hs       | 373 ++----------------
 src/Language/PureScript/Lsp/Handlers/Build.hs |  41 ++
 .../PureScript/Lsp/Handlers/Completion.hs     | 119 ++++++
 .../PureScript/Lsp/Handlers/Definition.hs     |  88 +++++
 .../PureScript/Lsp/Handlers/DeleteOutput.hs   |  27 ++
 .../PureScript/Lsp/Handlers/Diagnostic.hs     |  52 +++
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  96 +++++
 src/Language/PureScript/Lsp/Monad.hs          |   9 +
 10 files changed, 503 insertions(+), 342 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Handlers/Build.hs
 create mode 100644 src/Language/PureScript/Lsp/Handlers/Completion.hs
 create mode 100644 src/Language/PureScript/Lsp/Handlers/Definition.hs
 create mode 100644 src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
 create mode 100644 src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
 create mode 100644 src/Language/PureScript/Lsp/Handlers/Hover.hs
 create mode 100644 src/Language/PureScript/Lsp/Monad.hs

diff --git a/purescript.cabal b/purescript.cabal
index d06b1e2126..2a531fd70e 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -349,7 +349,14 @@ library
     Language.PureScript.Lsp.Cache.Query
     Language.PureScript.Lsp.Diagnostics
     Language.PureScript.Lsp.Handlers
+    Language.PureScript.Lsp.Handlers.Build
+    Language.PureScript.Lsp.Handlers.Completion
+    Language.PureScript.Lsp.Handlers.Definition
+    Language.PureScript.Lsp.Handlers.DeleteOutput
+    Language.PureScript.Lsp.Handlers.Diagnostic
+    Language.PureScript.Lsp.Handlers.Hover
     Language.PureScript.Lsp.Log
+    Language.PureScript.Lsp.Monad
     Language.PureScript.Lsp.Prim
     Language.PureScript.Lsp.Print
     Language.PureScript.Lsp.ReadFile
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index b124f4ded5..328c9f6e8b 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -16,8 +16,9 @@ import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server as LSP.Server
 import Language.LSP.Server qualified as Server
-import Language.PureScript.Lsp.Handlers (HandlerM, handlers)
+import Language.PureScript.Lsp.Handlers (handlers)
 import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultFromEnv)
 import Language.PureScript.Lsp.State (requestIsCancelled)
 import Language.PureScript.Lsp.Types (LspEnvironment)
@@ -29,14 +30,14 @@ main lspEnv = do
   Server.runServer $ serverDefinition lspEnv rin
 
 serverDefinition :: LspEnvironment -> TChan ReactorInput -> ServerDefinition ServerConfig
-serverDefinition lspEnv rin =
+serverDefinition lspEnv _rin =
   Server.ServerDefinition
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = const $ pure (),
       defaultConfig = defaultFromEnv lspEnv,
       configSection = "oa-purescript-lsp",
-      doInitialize = \env _ -> forkIO (reactor rin) >> pure (Right env),
-      staticHandlers = \_caps -> lspHandlers lspEnv rin,
+      doInitialize = \env _ -> pure (Right env),
+      staticHandlers = const handlers,
       interpretHandler = \serverEnv ->
         Server.Iso
           ( Server.runLspT serverEnv . flip runReaderT lspEnv
@@ -45,6 +46,13 @@ serverDefinition lspEnv rin =
       options = lspOptions
     }
 
+lspOptions :: Server.Options
+lspOptions =
+  Server.defaultOptions
+    { Server.optTextDocumentSync = Just syncOptions,
+      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
+    }
+
 syncOptions :: Types.TextDocumentSyncOptions
 syncOptions =
   Types.TextDocumentSyncOptions
@@ -55,23 +63,24 @@ syncOptions =
       Types._save = Just $ Types.InL True
     }
 
-lspOptions :: Server.Options
-lspOptions =
-  Server.defaultOptions
-    { Server.optTextDocumentSync = Just syncOptions,
-      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
-    }
-
 -- The reactor is a process that serialises and buffers all requests from the
 -- LSP client, so they can be sent to the backend compiler one at a time, and a
 -- reply sent.
-
 data ReactorInput = ReactorAction
   { riId :: Maybe (Either Int32 Text),
     riMethod :: Text,
     riAction :: IO ()
   }
 
+-- | We have 3 channels for the 3 different types of requests we can receive
+-- | As diagnostics and custom commands are often slow, we want to keep them
+-- | separate from the standard requests
+data Reactors = Reactors
+  { standard :: ReactorInput,
+    diagnostics :: ReactorInput,
+    customCommands :: ReactorInput
+  }
+
 -- | The single point that all events flow through, allowing management of state
 -- to stitch replies and requests together from the two asynchronous sides: lsp
 -- server and backend compiler
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 2fd55d87fc..e14b58b771 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -7,348 +7,61 @@
 module Language.PureScript.Lsp.Handlers where
 
 import Control.Lens ((^.))
-import Control.Lens.Getter (to)
-import Control.Lens.Setter (set)
-import Data.Aeson qualified as A
-import Data.Map qualified as Map
-import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Uri)
-import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
-import Language.LSP.VFS qualified as VFS
-import Language.PureScript qualified as P
-import Language.PureScript.Compile (compile)
-import Language.PureScript.CoreFn.Expr qualified as CF
-import Language.PureScript.DB (dbFile)
-import Language.PureScript.Docs.Convert.Single (convertComments)
-import Language.PureScript.Errors qualified as Errors
-import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Ide.Imports (Import (..))
-import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName, updateAvailableSrcs)
-import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationInModule, getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule, getCoreFnExprAt, getEfDeclarationInModule)
-import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, getFileDiagnotics, getMsgUri)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown, readQualifiedNameDocsSourceSpan)
-import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
-import Language.PureScript.Lsp.Log (logPerfStandard)
-import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.Rebuild (codegenTargets, rebuildFile)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, setTraceValue)
+import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
+import Language.PureScript.Lsp.Diagnostics (getMsgUri)
+import Language.PureScript.Lsp.Handlers.Build (buildHandler)
+import Language.PureScript.Lsp.Handlers.Completion (completionAndResolveHandlers)
+import Language.PureScript.Lsp.Handlers.Definition (definitionHandler)
+import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutputHandler)
+import Language.PureScript.Lsp.Handlers.Diagnostic (diagnosticAndCodeActionHandlers)
+import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, setTraceValue)
 import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild)
-import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection), decodeCompleteItemData)
-import Language.PureScript.Lsp.Util (efDeclSourceSpan, efDeclSourceType, getNamesAtPosition, getWordAt, lookupTypeInEnv, sourcePosToPosition)
-import Language.PureScript.Make.Index (initDb)
-import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
-import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
-import System.FilePath ((</>))
-import System.IO.UTF8 (readUTF8FilesT)
-
-type HandlerM config = ReaderT LspEnvironment (Server.LspT config IO)
 
 handlers :: Server.Handlers (HandlerM ServerConfig)
 handlers =
   mconcat
-    [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
-        void updateAvailableSrcs
-        sendInfoMsg "Lsp initialized",
-      Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \_msg -> do
-        pure (),
-      Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \_msg -> do
-        pure (),
-      Server.notificationHandler Message.SMethod_TextDocumentDidClose $ \msg -> do
-        let uri :: Uri
-            uri = getMsgUri msg
-            fileName = Types.uriToFilePath uri
-        traverse_ removedCachedRebuild fileName,
-      Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
-        pure (),
-      Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
-        setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
-      Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
-        let reqId = msg ^. LSP.params . LSP.id
-        cancelRequest reqId,
-      Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
-        (_errs, diagnostics) <- getFileDiagnotics req
-        res $
-          Right $
-            Types.DocumentDiagnosticReport $
-              Types.InL $
-                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
-        let params = req ^. LSP.params
-            diags = params ^. LSP.context . LSP.diagnostics
-            uri = getMsgUri req
-
-        res $
-          Right $
-            Types.InL $
-              diags <&> \diag ->
-                let textEdits = case A.fromJSON <$> diag ^. LSP.data_ of
-                      Just (A.Success tes) -> tes
-                      _ -> []
-                 in Types.InR $
-                      Types.CodeAction
-                        "Apply suggestion"
-                        (Just Types.CodeActionKind_QuickFix)
-                        (Just diags)
-                        (Just True)
-                        Nothing -- disabled
-                        ( Just $
-                            Types.WorkspaceEdit
-                              (Just $ Map.singleton uri textEdits)
-                              Nothing
-                              Nothing
-                        )
-                        Nothing
-                        Nothing,
-      Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-        let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
-            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            docUri =
-              docIdent
-                ^. LSP.uri
-                  . to Types.toNormalizedUri
-            nullRes = res $ Right $ Types.InR Types.Null
-
-            markdownRes :: Text -> HandlerM ServerConfig ()
-            markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
-
-            markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM ServerConfig ()
-            markdownTypeRes word type' comments =
-              markdownRes $ pursTypeStr word type' comments
-
-            pursTypeStr word type' comments =
-              "```purescript\n"
-                <> word
-                <> annotation
-                <> "\n"
-                <> fold (convertComments comments)
-                <> "\n```"
-              where
-                annotation = case type' of
-                  Just t -> " :: " <> t
-                  Nothing -> ""
-
-            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
-            forLsp val f = maybe nullRes f val
-
-        forLsp filePathMb \filePath -> do
-          corefnExprMb <- getCoreFnExprAt filePath pos
-          case corefnExprMb of
-            Just (CF.Literal _ _) -> nullRes
-            Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
-              docsMb <- do
-                mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
-                maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` P.runProperName tName) mNameMb
-              case docsMb of
-                Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
-                Just docs -> markdownRes docs
-            Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
-              case qb of
-                P.ByModuleName mName -> do
-                  docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
-                  case docsMb of
-                    Just docs -> markdownRes docs
-                    _ -> do
-                      declMb <- getEfDeclarationInModule mName (runIdent ident)
-                      markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
-                P.BySourcePos _pos' ->
-                  markdownTypeRes (P.runIdent ident) Nothing []
-            _ -> do
-              vfMb <- Server.getVirtualFile docUri
-              forLsp vfMb \vf -> do
-                mNameMb <- selectExternModuleNameFromFilePath filePath
-                forLsp mNameMb \mName -> do
-                  names <- getNamesAtPosition pos mName (VFS._file_text vf)
-                  forLsp (head names) \name -> do
-                    docsMb <- readQualifiedNameDocsAsMarkdown name
-                    case docsMb of
-                      Nothing -> do
-                        typeMb <- lookupTypeInEnv filePath name
-                        forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
-                      Just docs -> markdownRes docs,
-      Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-        let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            uri :: Types.NormalizedUri
-            uri =
-              req
-                ^. LSP.params
-                  . LSP.textDocument
-                  . LSP.uri
-                  . to Types.toNormalizedUri
-
-            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-            locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
-
-            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
-            forLsp val f = maybe nullRes f val
-        forLsp filePathMb \filePath -> do
-          vfMb <- Server.getVirtualFile uri
-          forLsp vfMb \vf -> do
-            mNameMb <- selectExternModuleNameFromFilePath filePath
-            forLsp mNameMb \mName -> do
-              names <- getNamesAtPosition pos mName (VFS._file_text vf)
-
-              case head names of
-                Just name -> do
-                  spanMb <- readQualifiedNameDocsSourceSpan name
-                  case spanMb of
-                    _ -> do
-                      case name of
-                        P.Qualified (P.BySourcePos pos') _ -> do
-                          locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
-                        P.Qualified (P.ByModuleName nameModule) ident -> do
-                          declMb <- getAstDeclarationInModule nameModule (printName ident)
-                          forLsp declMb \decl -> do
-                            modFpMb <- selectExternPathFromModuleName nameModule
-                            forLsp modFpMb \modFp -> do
-                              let sourceSpan = P.declSourceSpan decl
-                              locationRes modFp (spanToRange sourceSpan)
-                    Just span ->
-                      locationRes (P.spanName span) (spanToRange span)
-                _ -> do
-                  corefnExprMb <- getCoreFnExprAt filePath pos
-                  case corefnExprMb of
-                    Just (CF.Var (_ss, _comments, _meta) (P.Qualified qb ident)) -> do
-                      let name = P.runIdent ident
-                      case qb of
-                        P.ByModuleName coreMName -> do
-                          declMb <- getEfDeclarationInModule coreMName name
-                          forLsp declMb \decl -> do
-                            modFpMb <- selectExternPathFromModuleName coreMName
-                            forLsp modFpMb \modFp -> do
-                              let sourceSpan = efDeclSourceSpan decl
-                              locationRes modFp (spanToRange sourceSpan)
-                        P.BySourcePos srcPos ->
-                          locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-                    _ -> nullRes,
-      Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
-        let Types.CompletionParams docIdent pos _prog _prog' _completionCtx = req ^. LSP.params
-            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-            uri :: Types.NormalizedUri
-            uri =
-              req
-                ^. LSP.params
-                  . LSP.textDocument
-                  . LSP.uri
-                  . to Types.toNormalizedUri
-
-            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
-            forLsp val f = maybe nullRes f val
-
-        forLsp filePathMb \filePath -> do
-          vfMb <- Server.getVirtualFile uri
-          forLsp vfMb \vf -> do
-            let (range, word) = getWordAt (VFS._file_text vf) pos
-            if T.length word < 2
-              then nullRes
-              else do
-                mNameMb <- selectExternModuleNameFromFilePath filePath
-                forLsp mNameMb \mName -> do
-                  let withQualifier = getIdentModuleQualifier word
-                      wordWithoutQual = maybe word snd withQualifier
-                  limit <- getMaxCompletions
-                  matchingImport <- maybe (pure Nothing) (getMatchingImport filePath . fst) withQualifier
-                  -- matchingImport =
-                  decls <- case (matchingImport, withQualifier) of
-                    (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
-                    (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
-                    _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith mName wordWithoutQual
-                  -- Just
-                  res $
-                    Right $
-                      Types.InR $
-                        Types.InL $
-                          Types.CompletionList (length decls >= limit) Nothing $
-                            decls <&> \cr ->
-                              let label = crName cr
-                               in Types.CompletionItem
-                                    { _label = label,
-                                      _labelDetails =
-                                        Just $
-                                          Types.CompletionItemLabelDetails
-                                            (Just $ " " <> crType cr)
-                                            (Just $ P.runModuleName (crModule cr)),
-                                      _kind = Nothing, --  Maybe Types.CompletionItemKind TODO: add kind
-                                      _tags = Nothing,
-                                      _detail = Nothing,
-                                      _documentation = Nothing,
-                                      _deprecated = Nothing, --  Maybe Bool
-                                      _preselect = Nothing, --  Maybe Bool
-                                      _sortText = Nothing, --  Maybe Text
-                                      _filterText = Nothing, --  Maybe Text
-                                      _insertText = Nothing, --  Maybe Text
-                                      _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
-                                      _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
-                                      _textEdit = Nothing, --  Maybe
-                                      --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
-                                      _textEditText = Nothing, --  Maybe Text
-                                      _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
-                                      _commitCharacters = Nothing, --  Maybe [Text]
-                                      _command = Nothing, --  Maybe Types.Command
-                                      _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word range
-                                    },
-      Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
-        let completionItem = req ^. LSP.params
-            result = completionItem ^. LSP.data_ & decodeCompleteItemData
-
-        case result of
-          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _ _)) -> do
-            docsMb <- readDeclarationDocsAsMarkdown declModule label
-            withImports <- addImportToTextEdit completionItem cid
-            let addDocs :: Types.CompletionItem -> Types.CompletionItem
-                addDocs =
-                  docsMb & maybe
-                    identity
-                    \docs ->
-                      set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
-            res $
-              Right $
-                withImports
-                  & addDocs
-          _ -> res $ Right completionItem,
-      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete output") $ \_req res -> do
-        outDir <- asks (confOutputPath . lspConfig)
-        liftIO $ createDirectoryIfMissing True outDir
-        contents <- liftIO $ listDirectory outDir
-        for_ contents \f -> do
-          unless (f == dbFile || dbFile `isPrefixOf` f) do
-            let path = outDir </> f
-            liftIO $ removePathForcibly path
-        res $ Right A.Null,
-      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
-        config <- asks lspConfig
-        conn <- asks lspDbConnection
-        liftIO $ initDb conn
-        input <- updateAvailableSrcs
-        moduleFiles <- liftIO $ readUTF8FilesT input
-        (result, warnings) <-
-          liftIO $
-            compile
-              (P.Options False False codegenTargets)
-              moduleFiles
-              conn
-              (confOutputPath config)
-              False
-        let diags :: [Types.Diagnostic]
-            diags =
-              (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
-                <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
-        res $ Right $ A.toJSON diags
+    [ simpleHandlers,
+      buildHandler,
+      completionAndResolveHandlers,
+      definitionHandler,
+      deleteOutputHandler,
+      diagnosticAndCodeActionHandlers,
+      hoverHandler
     ]
-
-spanToRange :: Errors.SourceSpan -> Types.Range
-spanToRange (Errors.SourceSpan _ start end) =
-  Types.Range
-    (sourcePosToPosition start)
-    (sourcePosToPosition end)
+  where
+    -- Simple handlers that don't need to be in their own module
+    simpleHandlers =
+      mconcat
+        [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
+            void updateAvailableSrcs
+            sendInfoMsg "Lsp initialized",
+          Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \_msg -> do
+            pure (),
+          Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \_msg -> do
+            pure (),
+          Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> do
+            pure (),
+          Server.notificationHandler Message.SMethod_TextDocumentDidClose $ \msg -> do
+            let uri :: Uri
+                uri = getMsgUri msg
+                fileName = Types.uriToFilePath uri
+            traverse_ removedCachedRebuild fileName,
+          Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
+            pure (),
+          Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
+            setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
+          Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
+            let reqId = msg ^. LSP.params . LSP.id
+            cancelRequest reqId
+        ]
 
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
 sendInfoMsg msg = Server.sendNotification Message.SMethod_WindowShowMessage (Types.ShowMessageParams Types.MessageType_Info msg)
diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
new file mode 100644
index 0000000000..805920a509
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Language.PureScript.Lsp.Handlers.Build where
+
+import Data.Aeson qualified as A
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server qualified as Server
+import Language.PureScript qualified as P
+import Language.PureScript.Compile (compile)
+import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
+import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.Rebuild (codegenTargets)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection))
+import Language.PureScript.Make.Index (initDb)
+import Protolude hiding (to)
+import System.IO.UTF8 (readUTF8FilesT)
+
+buildHandler :: Server.Handlers (HandlerM ServerConfig)
+buildHandler =
+  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
+    config <- asks lspConfig
+    conn <- asks lspDbConnection
+    liftIO $ initDb conn
+    input <- updateAvailableSrcs
+    moduleFiles <- liftIO $ readUTF8FilesT input
+    (result, warnings) <-
+      liftIO $
+        compile
+          (P.Options False False codegenTargets)
+          moduleFiles
+          conn
+          (confOutputPath config)
+          False
+    let diags :: [Types.Diagnostic]
+        diags =
+          (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
+            <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
+    res $ Right $ A.toJSON diags
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
new file mode 100644
index 0000000000..3ec1cd3c98
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Language.PureScript.Lsp.Handlers.Completion where
+
+import Control.Lens ((^.))
+import Control.Lens.Getter (to)
+import Control.Lens.Setter (set)
+import Data.Aeson qualified as A
+import Data.Text qualified as T
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types qualified as LSP
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server qualified as Server
+import Language.LSP.VFS qualified as VFS
+import Language.PureScript qualified as P
+import Language.PureScript.Ide.Imports (Import (..))
+import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
+import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
+import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
+import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions)
+import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
+import Language.PureScript.Lsp.Util (getWordAt)
+import Protolude hiding (to)
+
+completionAndResolveHandlers :: Server.Handlers (HandlerM ServerConfig)
+completionAndResolveHandlers =
+  mconcat
+    [ Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
+        let Types.CompletionParams docIdent pos _prog _prog' _completionCtx = req ^. LSP.params
+            filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+            uri :: Types.NormalizedUri
+            uri =
+              req
+                ^. LSP.params
+                  . LSP.textDocument
+                  . LSP.uri
+                  . to Types.toNormalizedUri
+
+            nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
+            forLsp val f = maybe nullRes f val
+
+        forLsp filePathMb \filePath -> do
+          vfMb <- Server.getVirtualFile uri
+          forLsp vfMb \vf -> do
+            let (range, word) = getWordAt (VFS._file_text vf) pos
+            if T.length word < 2
+              then nullRes
+              else do
+                mNameMb <- selectExternModuleNameFromFilePath filePath
+                forLsp mNameMb \mName -> do
+                  let withQualifier = getIdentModuleQualifier word
+                      wordWithoutQual = maybe word snd withQualifier
+                  limit <- getMaxCompletions
+                  matchingImport <- maybe (pure Nothing) (getMatchingImport filePath . fst) withQualifier
+                  -- matchingImport =
+                  decls <- case (matchingImport, withQualifier) of
+                    (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
+                    (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
+                    _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith mName wordWithoutQual
+                  -- Just
+                  res $
+                    Right $
+                      Types.InR $
+                        Types.InL $
+                          Types.CompletionList (length decls >= limit) Nothing $
+                            decls <&> \cr ->
+                              let label = crName cr
+                               in Types.CompletionItem
+                                    { _label = label,
+                                      _labelDetails =
+                                        Just $
+                                          Types.CompletionItemLabelDetails
+                                            (Just $ " " <> crType cr)
+                                            (Just $ P.runModuleName (crModule cr)),
+                                      _kind = Nothing, --  Maybe Types.CompletionItemKind TODO: add kind
+                                      _tags = Nothing,
+                                      _detail = Nothing,
+                                      _documentation = Nothing,
+                                      _deprecated = Nothing, --  Maybe Bool
+                                      _preselect = Nothing, --  Maybe Bool
+                                      _sortText = Nothing, --  Maybe Text
+                                      _filterText = Nothing, --  Maybe Text
+                                      _insertText = Nothing, --  Maybe Text
+                                      _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
+                                      _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
+                                      _textEdit = Nothing, --  Maybe
+                                      --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                                      _textEditText = Nothing, --  Maybe Text
+                                      _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
+                                      _commitCharacters = Nothing, --  Maybe [Text]
+                                      _command = Nothing, --  Maybe Types.Command
+                                      _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word range
+                                    },
+      Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
+        let completionItem = req ^. LSP.params
+            result = completionItem ^. LSP.data_ & decodeCompleteItemData
+
+        case result of
+          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _ _)) -> do
+            docsMb <- readDeclarationDocsAsMarkdown declModule label
+            withImports <- addImportToTextEdit completionItem cid
+            let addDocs :: Types.CompletionItem -> Types.CompletionItem
+                addDocs =
+                  docsMb & maybe
+                    identity
+                    \docs ->
+                      set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
+            res $
+              Right $
+                withImports
+                  & addDocs
+          _ -> res $ Right completionItem
+    ]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
new file mode 100644
index 0000000000..f1145728df
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+
+module Language.PureScript.Lsp.Handlers.Definition where
+
+import Control.Lens ((^.))
+import Control.Lens.Getter (to)
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server qualified as Server
+import Language.LSP.VFS qualified as VFS
+import Language.PureScript qualified as P
+import Language.PureScript.CoreFn.Expr qualified as CF
+import Language.PureScript.Errors qualified as Errors
+import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Docs (readQualifiedNameDocsSourceSpan)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.Print (printName)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Language.PureScript.Lsp.Util (efDeclSourceSpan, getNamesAtPosition, sourcePosToPosition)
+import Protolude hiding (to)
+
+definitionHandler :: Server.Handlers (HandlerM ServerConfig)
+definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+  let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+      filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+      uri :: Types.NormalizedUri
+      uri =
+        req
+          ^. LSP.params
+            . LSP.textDocument
+            . LSP.uri
+            . to Types.toNormalizedUri
+
+      nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+      locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
+
+      forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
+      forLsp val f = maybe nullRes f val
+  forLsp filePathMb \filePath -> do
+    vfMb <- Server.getVirtualFile uri
+    forLsp vfMb \vf -> do
+      mNameMb <- selectExternModuleNameFromFilePath filePath
+      forLsp mNameMb \mName -> do
+        names <- getNamesAtPosition pos mName (VFS._file_text vf)
+
+        case head names of
+          Just name -> do
+            spanMb <- readQualifiedNameDocsSourceSpan name
+            case spanMb of
+              _ -> do
+                case name of
+                  P.Qualified (P.BySourcePos pos') _ -> do
+                    locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
+                  P.Qualified (P.ByModuleName nameModule) ident -> do
+                    declMb <- getAstDeclarationInModule nameModule (printName ident)
+                    forLsp declMb \decl -> do
+                      modFpMb <- selectExternPathFromModuleName nameModule
+                      forLsp modFpMb \modFp -> do
+                        let sourceSpan = P.declSourceSpan decl
+                        locationRes modFp (spanToRange sourceSpan)
+              Just span ->
+                locationRes (P.spanName span) (spanToRange span)
+          _ -> do
+            corefnExprMb <- getCoreFnExprAt filePath pos
+            case corefnExprMb of
+              Just (CF.Var (_ss, _comments, _meta) (P.Qualified qb ident)) -> do
+                let name = P.runIdent ident
+                case qb of
+                  P.ByModuleName coreMName -> do
+                    declMb <- getEfDeclarationInModule coreMName name
+                    forLsp declMb \decl -> do
+                      modFpMb <- selectExternPathFromModuleName coreMName
+                      forLsp modFpMb \modFp -> do
+                        let sourceSpan = efDeclSourceSpan decl
+                        locationRes modFp (spanToRange sourceSpan)
+                  P.BySourcePos srcPos ->
+                    locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
+              _ -> nullRes
+
+spanToRange :: Errors.SourceSpan -> Types.Range
+spanToRange (Errors.SourceSpan _ start end) =
+  Types.Range
+    (sourcePosToPosition start)
+    (sourcePosToPosition end)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
new file mode 100644
index 0000000000..a9e9b518eb
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Language.PureScript.Lsp.Handlers.DeleteOutput where
+
+import Data.Aeson qualified as A
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Server qualified as Server
+import Language.PureScript.DB (dbFile)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig))
+import Protolude hiding (to)
+import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
+import System.FilePath ((</>))
+
+deleteOutputHandler :: Server.Handlers (HandlerM ServerConfig)
+deleteOutputHandler =
+  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete output") $ \_req res -> do
+    outDir <- asks (confOutputPath . lspConfig)
+    liftIO $ createDirectoryIfMissing True outDir
+    contents <- liftIO $ listDirectory outDir
+    for_ contents \f -> do
+      unless (f == dbFile || dbFile `isPrefixOf` f) do
+        let path = outDir </> f
+        liftIO $ removePathForcibly path
+    res $ Right A.Null
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
new file mode 100644
index 0000000000..886d296a6a
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
@@ -0,0 +1,52 @@
+module Language.PureScript.Lsp.Handlers.Diagnostic where
+
+import Control.Lens ((^.))
+import Data.Aeson qualified as A
+import Data.Map qualified as Map
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server qualified as Server
+import Language.PureScript.Lsp.Diagnostics (getFileDiagnotics, getMsgUri)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Protolude hiding (to)
+
+diagnosticAndCodeActionHandlers :: Server.Handlers (HandlerM ServerConfig)
+diagnosticAndCodeActionHandlers =
+  mconcat
+    [ Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
+        (_errs, diagnostics) <- getFileDiagnotics req
+        res $
+          Right $
+            Types.DocumentDiagnosticReport $
+              Types.InL $
+                Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
+      Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
+        let params = req ^. LSP.params
+            diags = params ^. LSP.context . LSP.diagnostics
+            uri = getMsgUri req
+
+        res $
+          Right $
+            Types.InL $
+              diags <&> \diag ->
+                let textEdits = case A.fromJSON <$> diag ^. LSP.data_ of
+                      Just (A.Success tes) -> tes
+                      _ -> []
+                 in Types.InR $
+                      Types.CodeAction
+                        "Apply suggestion"
+                        (Just Types.CodeActionKind_QuickFix)
+                        (Just diags)
+                        (Just True)
+                        Nothing -- disabled
+                        ( Just $
+                            Types.WorkspaceEdit
+                              (Just $ Map.singleton uri textEdits)
+                              Nothing
+                              Nothing
+                        )
+                        Nothing
+                        Nothing
+    ]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
new file mode 100644
index 0000000000..58dd13f170
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+
+module Language.PureScript.Lsp.Handlers.Hover where
+
+import Control.Lens ((^.))
+import Control.Lens.Getter (to)
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server qualified as Server
+import Language.LSP.VFS qualified as VFS
+import Language.PureScript qualified as P
+import Language.PureScript.CoreFn.Expr qualified as CF
+import Language.PureScript.Docs.Convert.Single (convertComments)
+import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
+import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
+import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.Print (printName)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Language.PureScript.Lsp.Util (efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
+import Language.PureScript.Names (disqualify, runIdent)
+import Protolude hiding (to)
+
+hoverHandler :: Server.Handlers (HandlerM ServerConfig)
+hoverHandler =
+  Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+    let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
+        filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+        docUri =
+          docIdent
+            ^. LSP.uri
+              . to Types.toNormalizedUri
+        nullRes = res $ Right $ Types.InR Types.Null
+
+        markdownRes :: Text -> HandlerM ServerConfig ()
+        markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
+
+        markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM ServerConfig ()
+        markdownTypeRes word type' comments =
+          markdownRes $ pursTypeStr word type' comments
+
+        pursTypeStr word type' comments =
+          "```purescript\n"
+            <> word
+            <> annotation
+            <> "\n"
+            <> fold (convertComments comments)
+            <> "\n```"
+          where
+            annotation = case type' of
+              Just t -> " :: " <> t
+              Nothing -> ""
+
+        forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
+        forLsp val f = maybe nullRes f val
+
+    forLsp filePathMb \filePath -> do
+      corefnExprMb <- getCoreFnExprAt filePath pos
+      case corefnExprMb of
+        Just (CF.Literal _ _) -> nullRes
+        Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
+          docsMb <- do
+            mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
+            maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` P.runProperName tName) mNameMb
+          case docsMb of
+            Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
+            Just docs -> markdownRes docs
+        Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
+          case qb of
+            P.ByModuleName mName -> do
+              docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
+              case docsMb of
+                Just docs -> markdownRes docs
+                _ -> do
+                  declMb <- getEfDeclarationInModule mName (runIdent ident)
+                  markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
+            P.BySourcePos _pos' ->
+              markdownTypeRes (P.runIdent ident) Nothing []
+        _ -> do
+          vfMb <- Server.getVirtualFile docUri
+          forLsp vfMb \vf -> do
+            mNameMb <- selectExternModuleNameFromFilePath filePath
+            forLsp mNameMb \mName -> do
+              names <- getNamesAtPosition pos mName (VFS._file_text vf)
+              forLsp (head names) \name -> do
+                docsMb <- readQualifiedNameDocsAsMarkdown name
+                case docsMb of
+                  Nothing -> do
+                    typeMb <- lookupTypeInEnv filePath name
+                    forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
+                  Just docs -> markdownRes docs
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Monad.hs b/src/Language/PureScript/Lsp/Monad.hs
new file mode 100644
index 0000000000..d696737f8a
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Monad.hs
@@ -0,0 +1,9 @@
+module Language.PureScript.Lsp.Monad where
+
+import Language.LSP.Server (LspT)
+import Language.PureScript.Lsp.Types
+import Protolude
+
+type HandlerM = HandlerMWithConfig ServerConfig
+
+type HandlerMWithConfig config = ReaderT LspEnvironment (LspT config IO)
\ No newline at end of file

From 84f646860e08a2adfb39d3403c3f5169c261c1d9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 9 Oct 2024 11:03:29 +0200
Subject: [PATCH 120/297] remove Config var from HandlerM

---
 src/Language/PureScript/LSP.hs                       | 6 +++---
 src/Language/PureScript/Lsp/Handlers.hs              | 4 ++--
 src/Language/PureScript/Lsp/Handlers/Build.hs        | 3 +--
 src/Language/PureScript/Lsp/Handlers/Completion.hs   | 6 +++---
 src/Language/PureScript/Lsp/Handlers/Definition.hs   | 5 ++---
 src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs | 3 +--
 src/Language/PureScript/Lsp/Handlers/Diagnostic.hs   | 3 +--
 src/Language/PureScript/Lsp/Handlers/Hover.hs        | 9 ++++-----
 src/Language/PureScript/Lsp/Monad.hs                 | 1 +
 9 files changed, 18 insertions(+), 22 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 328c9f6e8b..8138f68c66 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -105,10 +105,10 @@ reactor inp = do
 
 -- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
 -- input into the reactor
-lspHandlers :: LspEnvironment -> TChan ReactorInput -> Handlers (HandlerM ServerConfig)
+lspHandlers :: LspEnvironment -> TChan ReactorInput -> Handlers HandlerM
 lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
   where
-    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler (HandlerM ServerConfig) a -> LSP.Server.Handler (HandlerM ServerConfig) a
+    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler HandlerM a -> LSP.Server.Handler HandlerM a
     goReq f msg@(LSP.TRequestMessage _ id method _) k = do
       let reqId = case id of
             LSP.IdInt i -> Left i
@@ -120,7 +120,7 @@ lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
           (k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing)
           (logPerfStandard ("Request " <> show method) $ f msg k)
 
-    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler (HandlerM ServerConfig) a -> LSP.Server.Handler (HandlerM ServerConfig) a
+    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler HandlerM a -> LSP.Server.Handler HandlerM a
     goNotification f msg@(LSP.TNotificationMessage _ LSP.SMethod_CancelRequest _) = do
       f msg -- cancel requests skip the queue and are handled immediately on the main thread
     goNotification f msg@(LSP.TNotificationMessage _ method _) = do
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index e14b58b771..ff610d0a3b 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -21,11 +21,11 @@ import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutputHandler)
 import Language.PureScript.Lsp.Handlers.Diagnostic (diagnosticAndCodeActionHandlers)
 import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, setTraceValue)
+import Language.PureScript.Lsp.ServerConfig (setTraceValue)
 import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild)
 import Protolude hiding (to)
 
-handlers :: Server.Handlers (HandlerM ServerConfig)
+handlers :: Server.Handlers HandlerM
 handlers =
   mconcat
     [ simpleHandlers,
diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index 805920a509..8a70415e09 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -12,13 +12,12 @@ import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Rebuild (codegenTargets)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make.Index (initDb)
 import Protolude hiding (to)
 import System.IO.UTF8 (readUTF8FilesT)
 
-buildHandler :: Server.Handlers (HandlerM ServerConfig)
+buildHandler :: Server.Handlers HandlerM
 buildHandler =
   Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
     config <- asks lspConfig
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 3ec1cd3c98..8793b013c0 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -21,12 +21,12 @@ import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
 import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions)
+import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (getWordAt)
 import Protolude hiding (to)
 
-completionAndResolveHandlers :: Server.Handlers (HandlerM ServerConfig)
+completionAndResolveHandlers :: Server.Handlers HandlerM
 completionAndResolveHandlers =
   mconcat
     [ Server.requestHandler Message.SMethod_TextDocumentCompletion $ \req res -> do
@@ -42,7 +42,7 @@ completionAndResolveHandlers =
 
             nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
 
-            forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
+            forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
             forLsp val f = maybe nullRes f val
 
         forLsp filePathMb \filePath -> do
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index f1145728df..8bdb0af417 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -18,11 +18,10 @@ import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getCoreFn
 import Language.PureScript.Lsp.Docs (readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getNamesAtPosition, sourcePosToPosition)
 import Protolude hiding (to)
 
-definitionHandler :: Server.Handlers (HandlerM ServerConfig)
+definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
@@ -38,7 +37,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
 
-      forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
+      forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
   forLsp filePathMb \filePath -> do
     vfMb <- Server.getVirtualFile uri
diff --git a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
index a9e9b518eb..47d6c7c3ad 100644
--- a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
@@ -8,13 +8,12 @@ import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Server qualified as Server
 import Language.PureScript.DB (dbFile)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig))
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
 import System.FilePath ((</>))
 
-deleteOutputHandler :: Server.Handlers (HandlerM ServerConfig)
+deleteOutputHandler :: Server.Handlers HandlerM
 deleteOutputHandler =
   Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete output") $ \_req res -> do
     outDir <- asks (confOutputPath . lspConfig)
diff --git a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
index 886d296a6a..d254a62b45 100644
--- a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
@@ -9,10 +9,9 @@ import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Diagnostics (getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Protolude hiding (to)
 
-diagnosticAndCodeActionHandlers :: Server.Handlers (HandlerM ServerConfig)
+diagnosticAndCodeActionHandlers :: Server.Handlers HandlerM
 diagnosticAndCodeActionHandlers =
   mconcat
     [ Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 58dd13f170..440d5005d7 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -21,12 +21,11 @@ import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInM
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
 import Language.PureScript.Names (disqualify, runIdent)
 import Protolude hiding (to)
 
-hoverHandler :: Server.Handlers (HandlerM ServerConfig)
+hoverHandler :: Server.Handlers HandlerM
 hoverHandler =
   Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
     let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
@@ -37,10 +36,10 @@ hoverHandler =
               . to Types.toNormalizedUri
         nullRes = res $ Right $ Types.InR Types.Null
 
-        markdownRes :: Text -> HandlerM ServerConfig ()
+        markdownRes :: Text -> HandlerM ()
         markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
 
-        markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM ServerConfig ()
+        markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM ()
         markdownTypeRes word type' comments =
           markdownRes $ pursTypeStr word type' comments
 
@@ -56,7 +55,7 @@ hoverHandler =
               Just t -> " :: " <> t
               Nothing -> ""
 
-        forLsp :: Maybe a -> (a -> HandlerM ServerConfig ()) -> HandlerM ServerConfig ()
+        forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
         forLsp val f = maybe nullRes f val
 
     forLsp filePathMb \filePath -> do
diff --git a/src/Language/PureScript/Lsp/Monad.hs b/src/Language/PureScript/Lsp/Monad.hs
index d696737f8a..02997b452e 100644
--- a/src/Language/PureScript/Lsp/Monad.hs
+++ b/src/Language/PureScript/Lsp/Monad.hs
@@ -3,6 +3,7 @@ module Language.PureScript.Lsp.Monad where
 import Language.LSP.Server (LspT)
 import Language.PureScript.Lsp.Types
 import Protolude
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 
 type HandlerM = HandlerMWithConfig ServerConfig
 

From 343428f7089fc035c4576d36224c40e63c2add8e Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 9 Oct 2024 11:10:40 +0200
Subject: [PATCH 121/297] adds cancel running requests

---
 src/Language/PureScript/Lsp/State.hs | 12 ++++++++----
 src/Language/PureScript/Lsp/Types.hs |  4 ++--
 2 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index f82af0b44a..169b6a5353 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -119,10 +119,14 @@ getExportEnv = exportEnv <$> (liftIO . readTVarIO =<< lspStateVar <$> ask)
 cancelRequest :: (MonadReader LspEnvironment m, MonadIO m) => (Int32 |? Text) -> m ()
 cancelRequest requestId = do
   st <- lspStateVar <$> ask
-  liftIO . atomically . modifyTVar st $ \x ->
-    x
-      { cancelledRequests = Set.insert eitherId (cancelledRequests x)
-      }
+  reqMb <- liftIO . atomically $ do 
+    modifyTVar st $ \x ->
+      x
+        { cancelledRequests = Set.insert eitherId (cancelledRequests x)
+        }
+    Map.lookup eitherId . runningRequests <$> readTVar st
+
+  for_ reqMb $ \req -> liftIO $ cancel req
   where
     eitherId = case requestId of
       InL i -> Left i
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 3f74421c13..fd04886af4 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -30,7 +30,7 @@ mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do
   createDirectoryIfMissing True $ confOutputPath conf
   connection <- mkConnection $ confOutputPath conf
-  st <- newTVarIO (LspState mempty P.primEnv mempty)
+  st <- newTVarIO (LspState mempty P.primEnv mempty mempty)
   pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
@@ -44,9 +44,9 @@ data LspConfig = LspConfig
 data LspState = LspState
   { openFiles :: [(FilePath, OpenFile)],
     exportEnv :: Env,
+    runningRequests :: Map (Either Int32 Text) (Async ()),
     cancelledRequests :: Set (Either Int32 Text)
   }
-  deriving (Show)
 
 data OpenFile = OpenFile
   { ofModuleName :: P.ModuleName,

From 82e296e4ec974096d9dac2ec3af4b7cc94770d0b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 9 Oct 2024 12:37:32 +0200
Subject: [PATCH 122/297] adds cancellation and error handling

---
 src/Language/PureScript/LSP.hs       | 111 ++++++++++-----------------
 src/Language/PureScript/Lsp/Monad.hs |   4 +-
 src/Language/PureScript/Lsp/State.hs |  31 ++++----
 src/Language/PureScript/Lsp/Types.hs |   5 +-
 4 files changed, 59 insertions(+), 92 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 8138f68c66..935e2ee2c9 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -3,41 +3,39 @@
 {-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Lsp (main, serverDefinition) where
 
-import Control.Concurrent.STM.TChan
+import Control.Concurrent.Async.Lifted (AsyncCancelled (AsyncCancelled))
 import Control.Monad.IO.Unlift
 import Data.Aeson qualified as A
 import Data.Aeson.Types qualified as A
 import Data.Text qualified as T
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
-import Language.LSP.Server as LSP.Server
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Handlers (handlers)
-import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.Log (debugLsp, errorLsp, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultFromEnv)
-import Language.PureScript.Lsp.State (requestIsCancelled)
+import Language.PureScript.Lsp.State (addRunningRequest, removeRunningRequest)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
+import Language.LSP.Server (mapHandlers, MonadLsp (getLspEnv))
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
-  rin <- atomically newTChan :: IO (TChan ReactorInput)
-  Server.runServer $ serverDefinition lspEnv rin
+  Server.runServer $ serverDefinition lspEnv
 
-serverDefinition :: LspEnvironment -> TChan ReactorInput -> ServerDefinition ServerConfig
-serverDefinition lspEnv _rin =
+serverDefinition :: LspEnvironment -> Server.ServerDefinition ServerConfig
+serverDefinition lspEnv =
   Server.ServerDefinition
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = const $ pure (),
       defaultConfig = defaultFromEnv lspEnv,
       configSection = "oa-purescript-lsp",
       doInitialize = \env _ -> pure (Right env),
-      staticHandlers = const handlers,
+      staticHandlers = const (lspHandlers lspEnv),
       interpretHandler = \serverEnv ->
         Server.Iso
           ( Server.runLspT serverEnv . flip runReaderT lspEnv
@@ -63,73 +61,44 @@ syncOptions =
       Types._save = Just $ Types.InL True
     }
 
--- The reactor is a process that serialises and buffers all requests from the
--- LSP client, so they can be sent to the backend compiler one at a time, and a
--- reply sent.
-data ReactorInput = ReactorAction
-  { riId :: Maybe (Either Int32 Text),
-    riMethod :: Text,
-    riAction :: IO ()
-  }
-
--- | We have 3 channels for the 3 different types of requests we can receive
--- | As diagnostics and custom commands are often slow, we want to keep them
--- | separate from the standard requests
-data Reactors = Reactors
-  { standard :: ReactorInput,
-    diagnostics :: ReactorInput,
-    customCommands :: ReactorInput
-  }
-
--- | The single point that all events flow through, allowing management of state
--- to stitch replies and requests together from the two asynchronous sides: lsp
--- server and backend compiler
-reactor :: TChan ReactorInput -> IO ()
-reactor inp = do
-  forever $ do
-    ReactorAction reqId method act <- atomically $ readTChan inp
-    withAsync act \a -> do
-      res <- waitCatch a
-      case res of
-        Left e ->
-          putErrLn
-            ( "Request failed. Method: "
-                <> show method
-                <> ". id: "
-                <> show reqId
-                <> ". Error: "
-                <> show e ::
-                Text
-            )
-        Right _ -> pure ()
-
--- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as
--- input into the reactor
-lspHandlers :: LspEnvironment -> TChan ReactorInput -> Handlers HandlerM
-lspHandlers lspEnv rin = mapHandlers goReq goNotification handlers
+lspHandlers :: LspEnvironment -> Server.Handlers HandlerM
+lspHandlers lspEnv = mapHandlers goReq goNotification handlers
   where
-    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). LSP.Server.Handler HandlerM a -> LSP.Server.Handler HandlerM a
+    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). Server.Handler HandlerM a -> Server.Handler HandlerM a
     goReq f msg@(LSP.TRequestMessage _ id method _) k = do
       let reqId = case id of
             LSP.IdInt i -> Left i
             LSP.IdString t -> Right t
+      env <- getLspEnv
+      debugLsp $ "Request: " <> show method
+      liftIO $ do
+        withAsync (runHandler env $ f msg k) \asyncAct -> do
+          addRunningRequest lspEnv reqId asyncAct
+          result <- waitCatch asyncAct
+          runHandler env case result of
+            Left e -> do
+              case fromException e of
+                Just AsyncCancelled -> do
+                  warnLsp $ "Request cancelled. Method: " <> show method <> ". id: " <> show reqId
+                  k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing
+                _ -> do
+                  errorLsp $ "Request failed. Method: " <> show method <> ". id: " <> show reqId <> ". Error: " <> show e
+                  k $ Left $ LSP.TResponseError (Types.InR Types.ErrorCodes_InternalError) "Internal error" Nothing
+            _ -> pure ()
+          removeRunningRequest lspEnv reqId
 
-      writeToChannel (Just reqId) (show method) $
-        ifM
-          (requestIsCancelled reqId)
-          (k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing)
-          (logPerfStandard ("Request " <> show method) $ f msg k)
-
-    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). LSP.Server.Handler HandlerM a -> LSP.Server.Handler HandlerM a
-    goNotification f msg@(LSP.TNotificationMessage _ LSP.SMethod_CancelRequest _) = do
-      f msg -- cancel requests skip the queue and are handled immediately on the main thread
+    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). Server.Handler HandlerM a -> Server.Handler HandlerM a
     goNotification f msg@(LSP.TNotificationMessage _ method _) = do
-      writeToChannel Nothing (show method) (f msg)
-
-    writeToChannel = writeToChannelWith writeTChan
-
-    writeToChannelWith fn reqId method a = do
       env <- getLspEnv
-      liftIO $ atomically $ fn rin $ ReactorAction reqId method (runHandler env a)
+      liftIO $ withAsync (runHandler env $ f msg) \asyncAct -> do
+        result <- waitCatch asyncAct
+        case result of
+          Left e -> do
+            runHandler env case fromException e of
+              Just AsyncCancelled -> do
+                warnLsp $ "Notification cancelled. Method: " <> show method
+              _ -> do
+                errorLsp $ "Notification failed. Method: " <> show method <> ". Error: " <> show e
+          _ -> pure ()
 
-    runHandler env a = runLspT env $ runReaderT a lspEnv
+    runHandler env a = Server.runLspT env $ runReaderT a lspEnv
diff --git a/src/Language/PureScript/Lsp/Monad.hs b/src/Language/PureScript/Lsp/Monad.hs
index 02997b452e..a65c8d5b69 100644
--- a/src/Language/PureScript/Lsp/Monad.hs
+++ b/src/Language/PureScript/Lsp/Monad.hs
@@ -5,6 +5,4 @@ import Language.PureScript.Lsp.Types
 import Protolude
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 
-type HandlerM = HandlerMWithConfig ServerConfig
-
-type HandlerMWithConfig config = ReaderT LspEnvironment (LspT config IO)
\ No newline at end of file
+type HandlerM = ReaderT LspEnvironment (LspT ServerConfig IO) 
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 169b6a5353..44c14a8638 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -8,8 +8,9 @@ module Language.PureScript.Lsp.State
     buildExportEnvCache,
     addExternToExportEnv,
     getExportEnv,
-    requestIsCancelled,
     cancelRequest,
+    addRunningRequest,
+    removeRunningRequest,
   )
 where
 
@@ -18,7 +19,6 @@ import Control.Monad.Catch (MonadThrow (throwM))
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
 import Data.List qualified as List
 import Data.Map qualified as Map
-import Data.Set qualified as Set
 import Data.Text qualified as T
 import Language.LSP.Protocol.Types (type (|?) (..))
 import Language.LSP.Server (MonadLsp)
@@ -78,7 +78,7 @@ buildExportEnvCache module' externs = do
         case result of
           Left err -> pure $ Left err
           Right newEnv -> do
-            writeTVar st $ st' {exportEnv = newEnv }
+            writeTVar st $ st' {exportEnv = newEnv}
             pure $ Right newEnv
 
   case result of
@@ -116,14 +116,22 @@ addExternToExportEnv ef = do
 getExportEnv :: (MonadReader LspEnvironment m, MonadIO m) => m P.Env
 getExportEnv = exportEnv <$> (liftIO . readTVarIO =<< lspStateVar <$> ask)
 
+addRunningRequest :: (MonadIO m) => LspEnvironment -> Either Int32 Text -> Async () -> m ()
+addRunningRequest env requestId req = liftIO . atomically $ modifyTVar (lspStateVar env) $ \x ->
+  x
+    { runningRequests = Map.insert requestId req (runningRequests x)
+    }
+
+removeRunningRequest :: (MonadIO m) => LspEnvironment -> Either Int32 Text -> m ()
+removeRunningRequest env requestId = liftIO . atomically $ modifyTVar (lspStateVar env) $ \x ->
+  x
+    { runningRequests = Map.delete requestId (runningRequests x)
+    }
+
 cancelRequest :: (MonadReader LspEnvironment m, MonadIO m) => (Int32 |? Text) -> m ()
 cancelRequest requestId = do
   st <- lspStateVar <$> ask
-  reqMb <- liftIO . atomically $ do 
-    modifyTVar st $ \x ->
-      x
-        { cancelledRequests = Set.insert eitherId (cancelledRequests x)
-        }
+  reqMb <- liftIO . atomically $ do
     Map.lookup eitherId . runningRequests <$> readTVar st
 
   for_ reqMb $ \req -> liftIO $ cancel req
@@ -131,10 +139,3 @@ cancelRequest requestId = do
     eitherId = case requestId of
       InL i -> Left i
       InR t -> Right t
-
-requestIsCancelled :: (MonadReader LspEnvironment m, MonadIO m) => Either Int32 Text -> m Bool
-requestIsCancelled requestId = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically $ do
-    st' <- readTVar st
-    pure $ requestId `Set.member` cancelledRequests st'
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index fd04886af4..fdf30164e7 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -30,7 +30,7 @@ mkEnv :: LspConfig -> IO LspEnvironment
 mkEnv conf = do
   createDirectoryIfMissing True $ confOutputPath conf
   connection <- mkConnection $ confOutputPath conf
-  st <- newTVarIO (LspState mempty P.primEnv mempty mempty)
+  st <- newTVarIO (LspState mempty P.primEnv mempty)
   pure $ LspEnvironment conf connection st
 
 data LspConfig = LspConfig
@@ -44,8 +44,7 @@ data LspConfig = LspConfig
 data LspState = LspState
   { openFiles :: [(FilePath, OpenFile)],
     exportEnv :: Env,
-    runningRequests :: Map (Either Int32 Text) (Async ()),
-    cancelledRequests :: Set (Either Int32 Text)
+    runningRequests :: Map (Either Int32 Text) (Async ())
   }
 
 data OpenFile = OpenFile

From 2ae4d0ca4abb4a95545d4e4b62ec551e911897d9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 9 Oct 2024 14:20:39 +0200
Subject: [PATCH 123/297] use vfs for rebuilding and diagnostics

---
 src/Language/PureScript/LSP.hs                |  2 +-
 src/Language/PureScript/Lsp/Diagnostics.hs    | 35 ++++----
 .../PureScript/Lsp/Handlers/Completion.hs     |  2 +-
 .../PureScript/Lsp/Handlers/Diagnostic.hs     |  2 +-
 src/Language/PureScript/Lsp/Imports.hs        | 24 +++---
 src/Language/PureScript/Lsp/ReadFile.hs       | 54 ++++++-------
 src/Language/PureScript/Lsp/Rebuild.hs        | 79 +++++++------------
 src/Language/PureScript/Lsp/Util.hs           |  4 +
 8 files changed, 92 insertions(+), 110 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 935e2ee2c9..054a44fa08 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -56,7 +56,7 @@ syncOptions =
   Types.TextDocumentSyncOptions
     { Types._openClose = Just True,
       Types._change = Just Types.TextDocumentSyncKind_Incremental,
-      Types._willSave = Just False,
+      Types._willSave = Just True,
       Types._willSaveWaitUntil = Just False,
       Types._save = Just $ Types.InL True
     }
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index fbd9865e3d..adcd81c5bc 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -13,7 +13,7 @@ import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
-import Language.PureScript.Lsp.Rebuild (rebuildFile)
+import Language.PureScript.Lsp.Rebuild (rebuildFile, RebuildResult (RebuildError, RebuildWarning))
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
@@ -29,33 +29,26 @@ getFileDiagnotics ::
     MonadReader LspEnvironment m
   ) =>
   s ->
-  m ([ErrorMessage], [Diagnostic])
+  m [Diagnostic]
 getFileDiagnotics msg = do
-  let uri :: Uri
-      uri = getMsgUri msg
-      fileName = Types.uriToFilePath uri
-  case fileName of
-    Just file -> do
-      res <- rebuildFile file
-      pure $ getResultDiagnostics res
-    Nothing -> pure ([], [])
+  let uri :: Types.NormalizedUri
+      uri = getMsgUri msg & Types.toNormalizedUri
+  res <- rebuildFile uri
+  pure $ getResultDiagnostics res
 
 getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
 getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
 
 getResultDiagnostics ::
-  Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors) ->
-  ([ErrorMessage], [Types.Diagnostic])
+  RebuildResult ->
+  [Types.Diagnostic]
 getResultDiagnostics res = case res of
-  Left (_, errs) -> do
-    let errors = runMultipleErrors errs
-        diags = errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> errors
-    (errors, diags)
-  Right (_, errs) | Errors.nonEmpty errs -> do
-    let errors = runMultipleErrors errs
-        diags = errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> errors
-    (errors, diags)
-  _ -> ([], [])
+  RebuildError errors -> errorsToDiagnostics Types.DiagnosticSeverity_Error errors
+  RebuildWarning errors -> errorsToDiagnostics Types.DiagnosticSeverity_Warning errors
+
+errorsToDiagnostics :: Types.DiagnosticSeverity ->  P.MultipleErrors -> [Types.Diagnostic]
+errorsToDiagnostics severity errs =
+  errorMessageDiagnostic severity <$> runMultipleErrors errs
 
 errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
 errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 8793b013c0..d7b270d06d 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -57,7 +57,7 @@ completionAndResolveHandlers =
                   let withQualifier = getIdentModuleQualifier word
                       wordWithoutQual = maybe word snd withQualifier
                   limit <- getMaxCompletions
-                  matchingImport <- maybe (pure Nothing) (getMatchingImport filePath . fst) withQualifier
+                  matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
                   -- matchingImport =
                   decls <- case (matchingImport, withQualifier) of
                     (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
diff --git a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
index d254a62b45..6027b2b98c 100644
--- a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
@@ -15,7 +15,7 @@ diagnosticAndCodeActionHandlers :: Server.Handlers HandlerM
 diagnosticAndCodeActionHandlers =
   mconcat
     [ Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do
-        (_errs, diagnostics) <- getFileDiagnotics req
+        diagnostics <- getFileDiagnotics req
         res $
           Right $
             Types.DocumentDiagnosticReport $
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index b1a1a472d8..845bf0b289 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -5,6 +5,7 @@ import Control.Monad.Catch (MonadThrow)
 import Data.List (init, last)
 import Data.Maybe as Maybe
 import Data.Text qualified as T
+import Data.Text.Utf16.Rope.Mixed qualified as Rope
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Types as LSP
 import Language.PureScript.AST.Declarations qualified as P
@@ -12,29 +13,32 @@ import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
 import Language.PureScript.Lsp.Log (errorLsp)
-import Language.PureScript.Lsp.ReadFile (lspReadFile)
+import Language.PureScript.Lsp.ReadFile (lspReadFileRope)
 import Language.PureScript.Lsp.Types (CompleteItemData (..), LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
+import Language.PureScript.Lsp.Util (filePathToNormalizedUri)
+import Language.LSP.Server (MonadLsp)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 
-getMatchingImport :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => FilePath -> P.ModuleName -> m (Maybe Import)
+getMatchingImport :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) => NormalizedUri -> P.ModuleName -> m (Maybe Import)
 getMatchingImport path moduleName' = do
   parseRes <- parseImportsFromFile path
   case parseRes of
     Left err -> do
-      errorLsp $ "In " <> T.pack path <> " failed to parse imports from file: " <> err
+      errorLsp $ "In " <> show path <> " failed to parse imports from file: " <> err
       pure Nothing
     Right (_mn, _before, imports, _after) -> do
       pure $ find (\(Import _ _ mn) -> Just moduleName' == mn) imports
 
-addImportToTextEdit :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompletionItem -> CompleteItemData -> m CompletionItem
+addImportToTextEdit :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) => CompletionItem -> CompleteItemData -> m CompletionItem
 addImportToTextEdit completionItem completeItemData = do
   importEdits <- getImportEdits completeItemData
   pure $ set LSP.additionalTextEdits importEdits completionItem
 
-getImportEdits :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit])
+getImportEdits :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit])
 getImportEdits (CompleteItemData path moduleName' importedModuleName name word (Range wordStart _)) = do
-  parseRes <- parseImportsFromFile path
+  parseRes <- parseImportsFromFile (filePathToNormalizedUri path)
   case parseRes of
     Left err -> do
       errorLsp $ "In " <> T.pack path <> " failed to parse imports from file: " <> err
@@ -128,9 +132,9 @@ importsToTextEdit before imports =
 -- | Reads a file and returns the (lines before the imports, the imports, the
 -- lines after the imports)
 parseImportsFromFile ::
-  (MonadIO m, MonadThrow m) =>
-  FilePath ->
+  (MonadThrow m, MonadLsp ServerConfig m) =>
+  NormalizedUri ->
   m (Either Text (P.ModuleName, [Text], [Import], [Text]))
 parseImportsFromFile fp = do
-  (_, file) <- lspReadFile fp
-  pure $ sliceImportSection (T.lines file)
+  rope <- lspReadFileRope fp
+  pure $ sliceImportSection (Rope.lines rope)
diff --git a/src/Language/PureScript/Lsp/ReadFile.hs b/src/Language/PureScript/Lsp/ReadFile.hs
index 6570c4b321..39cf113adc 100644
--- a/src/Language/PureScript/Lsp/ReadFile.hs
+++ b/src/Language/PureScript/Lsp/ReadFile.hs
@@ -1,32 +1,32 @@
 module Language.PureScript.Lsp.ReadFile where
 
 import Control.Monad.Catch (MonadThrow (throwM))
-import GHC.IO.Exception (IOException (ioe_description))
-import Protolude hiding
-  ( decodeUtf8,
-    encodeUtf8,
-    to,
-  )
-import System.Directory (makeAbsolute)
-import System.IO.UTF8 (readUTF8FileT)
+import Data.Text.Utf16.Rope.Mixed (Rope)
+import Data.Text.Utf16.Rope.Mixed qualified as Rope
+import Language.LSP.Protocol.Types (NormalizedUri)
+import Language.LSP.Server (MonadLsp, getVirtualFile)
+import Language.LSP.VFS qualified as VFS
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Protolude
 
+lspReadFileText ::
+  (MonadThrow m, MonadLsp ServerConfig m) =>
+  NormalizedUri ->
+  m Text
+lspReadFileText fp =
+  Rope.toText <$> lspReadFileRope fp
 
-lspReadFile ::
-  (MonadIO m, MonadThrow m) =>
-  FilePath ->
-  m (FilePath, Text)
-lspReadFile fp = do
-  absPath <-
-    liftIO (try (makeAbsolute fp)) >>= \case
-      Left (err :: IOException) ->
-        throwM
-          (err {ioe_description = "Couldn't resolve path for: " <> show fp <> ", " <> ioe_description err})
-      Right absPath -> pure absPath
-  contents <-
-    liftIO (try (readUTF8FileT absPath)) >>= \case
-      Left (err :: IOException) ->
-        throwM
-          (err {ioe_description = "Couldn't resolve path for: " <> show fp <> ", " <> ioe_description err})
-      Right contents ->
-        pure contents
-  pure (absPath, contents)
\ No newline at end of file
+lspReadFileRope ::
+  (MonadThrow m, MonadLsp ServerConfig m) =>
+  NormalizedUri ->
+  m Rope
+lspReadFileRope fp = do
+  vfMb <- getVirtualFile fp
+  case vfMb of
+    Nothing -> throwM $ VirtualFileNotFoundException fp
+    Just vf -> pure $ VFS._file_text vf
+
+data VirtualFileNotFoundException = VirtualFileNotFoundException NormalizedUri
+  deriving (Show)
+
+instance Exception VirtualFileNotFoundException
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 45973eb2a6..e9f95c2aae 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,14 +1,13 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
-module Language.PureScript.Lsp.Rebuild (rebuildFile, codegenTargets) where
+module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, codegenTargets) where
 
 import Control.Concurrent.STM (TVar)
-import Control.Monad.Catch (MonadThrow)
-import Data.List qualified as List
+import Control.Monad.Catch (MonadThrow (throwM))
 import Data.Map.Lazy qualified as M
-import Data.Set qualified as S
 import Data.Set qualified as Set
-import Data.Text qualified as T
+import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
@@ -17,14 +16,12 @@ import Language.PureScript.Externs (ExternsFile)
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
-import Language.PureScript.Lsp.ReadFile (lspReadFile)
+import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
 import Language.PureScript.Lsp.State (addExternToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection, lspStateVar), LspState, OpenFile (OpenFile))
-import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
-import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Protolude hiding (moduleName)
 
@@ -33,63 +30,65 @@ rebuildFile ::
     MonadReader LspEnvironment m,
     MonadLsp ServerConfig m
   ) =>
-  FilePath ->
-  m (Either ([(FilePath, Text)], P.MultipleErrors) (FilePath, P.MultipleErrors))
-rebuildFile srcPath = logPerfStandard ("Rebuild file " <> T.pack srcPath) do
-  (fp, input) <-
-    case List.stripPrefix "data:" srcPath of
-      Just source -> pure ("", T.pack source)
-      _ -> lspReadFile srcPath -- todo replace with VFS
+  NormalizedUri ->
+  m RebuildResult
+rebuildFile uri = logPerfStandard "Rebuild file " do
+  fp <- case fromNormalizedUri uri & uriToFilePath of
+    Just x -> pure x
+    Nothing -> throwM $ CouldNotConvertUriToFilePath uri
+  input <- lspReadFileText uri
   case sequence $ CST.parseFromFile fp input of
     Left parseError ->
-      pure $ Left ([(fp, input)], CST.toMultipleErrors fp parseError)
+      pure $ RebuildError $ CST.toMultipleErrors fp parseError
     Right (pwarnings, m) -> do
       let moduleName = P.getModuleName m
       let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
       outputDirectory <- asks (confOutputPath . lspConfig)
-      let pureRebuild = fp == ""
-      let modulePath = if pureRebuild then fp else srcPath
       conn <- asks lspDbConnection
       stVar <- asks lspStateVar
       maxCache <- getMaxFilesInCache
-      cachedBuild <- cachedRebuild srcPath
+      cachedBuild <- cachedRebuild fp
       let makeEnv foreigns externs =
             P.buildMakeActions outputDirectory filePathMap foreigns False
-              & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
               & shushProgress
               & addAllIndexing conn
               & addRebuildCaching stVar maxCache externs
       debugLsp $ "Cache found: " <> show (isJust cachedBuild)
       case cachedBuild of
         Just (OpenFile _ _ externs env _) -> do
-          foreigns <-  P.inferForeignModules (M.singleton moduleName (Right modulePath))
+          foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
           exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
           res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
             P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
               newExtern <- P.rebuildModuleWithProvidedEnv (makeEnv foreigns externs) exportEnv env externs m Nothing
-              unless pureRebuild $
-                updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
+              updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
               pure newExtern
-          handleRebuildResult fp input pwarnings res
+          handleRebuildResult fp pwarnings res
         Nothing -> do
           externs <- logPerfStandard "Select depenencies" $ selectDependencies m
-          foreigns <-  P.inferForeignModules (M.singleton moduleName (Right modulePath))
+          foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
           exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
           res <- logPerfStandard "Rebuild Module" $ liftIO $ do
             P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
               newExtern <- P.rebuildModule' (makeEnv foreigns externs) exportEnv externs m
-              unless pureRebuild $
-                updateCacheDb codegenTargets outputDirectory srcPath Nothing moduleName
+              updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
               pure newExtern
-          handleRebuildResult fp input pwarnings res
+          handleRebuildResult fp pwarnings res
   where
-    handleRebuildResult fp input pwarnings (result, warnings) = do
+    handleRebuildResult fp pwarnings (result, warnings) = do
       case result of
         Left errors ->
-          pure (Left ([(fp, input)], errors))
+          pure $ RebuildError errors
         Right newExtern -> do
           addExternToExportEnv newExtern
-          pure $ Right (fp, CST.toMultipleWarnings fp pwarnings <> warnings)
+          pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
+
+data RebuildResult
+  = RebuildError P.MultipleErrors
+  | RebuildWarning P.MultipleErrors
+
+data RebuildException = CouldNotConvertUriToFilePath NormalizedUri
+  deriving (Exception, Show)
 
 codegenTargets :: Set P.CodegenTarget
 codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
@@ -99,24 +98,6 @@ shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushProgress ma =
   ma {P.progress = \_ -> pure ()}
 
--- | Stops any kind of codegen
-shushCodegen :: (Monad m) => P.MakeActions m -> P.MakeActions m
-shushCodegen ma =
-  ma
-    { P.codegen = \_ _ _ _ _ _ -> pure (),
-      P.ffiCodegen = \_ -> pure ()
-    }
-
-enableForeignCheck ::
-  M.Map P.ModuleName FilePath ->
-  S.Set P.CodegenTarget ->
-  P.MakeActions P.Make ->
-  P.MakeActions P.Make
-enableForeignCheck foreigns codegenTargets' ma =
-  ma
-    { P.ffiCodegen = ffiCodegen' foreigns codegenTargets' Nothing
-    }
-
 addRebuildCaching :: TVar LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps ma =
   ma
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index ba11424a1c..2b9f354d27 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -220,3 +220,7 @@ declToCompletionItemKind = \case
   P.RoleDeclaration {} -> Nothing
   P.ExternDeclaration {} -> Just Types.CompletionItemKind_Value
   _ -> Nothing
+
+
+filePathToNormalizedUri :: FilePath -> Types.NormalizedUri
+filePathToNormalizedUri = Types.toNormalizedUri . Types.filePathToUri
\ No newline at end of file

From 6ade82c76d76d4756a5e1b20e56e88d27690aaf7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 9 Oct 2024 14:44:24 +0200
Subject: [PATCH 124/297] remove will save sync

---
 src/Language/PureScript/LSP.hs          | 2 +-
 src/Language/PureScript/Lsp/Handlers.hs | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 054a44fa08..935e2ee2c9 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -56,7 +56,7 @@ syncOptions =
   Types.TextDocumentSyncOptions
     { Types._openClose = Just True,
       Types._change = Just Types.TextDocumentSyncKind_Incremental,
-      Types._willSave = Just True,
+      Types._willSave = Just False,
       Types._willSaveWaitUntil = Just False,
       Types._save = Just $ Types.InL True
     }
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index ff610d0a3b..89cf7b0e08 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -45,10 +45,10 @@ handlers =
             sendInfoMsg "Lsp initialized",
           Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \_msg -> do
             pure (),
-          Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \_msg -> do
-            pure (),
           Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> do
             pure (),
+          Server.notificationHandler Message.SMethod_TextDocumentDidSave $ \_msg -> do
+            pure (),
           Server.notificationHandler Message.SMethod_TextDocumentDidClose $ \msg -> do
             let uri :: Uri
                 uri = getMsgUri msg

From fa1537a152a485c1eadf6a0f9ef4ceea3c2c33f0 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 9 Oct 2024 15:35:38 +0200
Subject: [PATCH 125/297] remove comma

---
 src/Language/PureScript/Lsp/State.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 44c14a8638..c4386b086a 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -10,7 +10,7 @@ module Language.PureScript.Lsp.State
     getExportEnv,
     cancelRequest,
     addRunningRequest,
-    removeRunningRequest,
+    removeRunningRequest
   )
 where
 

From f31bcf653823f686d671f6c88f54c37be17ccb4b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 10 Oct 2024 13:33:45 +0200
Subject: [PATCH 126/297] easier to read logs

---
 src/Language/PureScript/AST/Binders.hs        |   1 -
 src/Language/PureScript/AST/Declarations.hs   |   9 +-
 src/Language/PureScript/AST/Traversals.hs     | 132 ++++++++-
 .../PureScript/Lsp/Handlers/Definition.hs     | 272 +++++++++++++++++-
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  94 +++---
 src/Language/PureScript/Lsp/Log.hs            |   9 +-
 src/Language/PureScript/Lsp/Rebuild.hs        |   4 +-
 src/Language/PureScript/Lsp/State.hs          |  12 +-
 src/Language/PureScript/Lsp/Types.hs          |   4 +-
 src/Language/PureScript/Lsp/Util.hs           |  97 ++++---
 10 files changed, 541 insertions(+), 93 deletions(-)

diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 6ea7e1ae4c..8dd11c13fa 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -154,7 +154,6 @@ binderNamesWithSpans = go []
   lit ns (ArrayLiteral bs) = foldl go ns bs
   lit ns _ = ns
 
-
 isIrrefutable :: Binder -> Bool
 isIrrefutable NullBinder = True
 isIrrefutable (VarBinder _ _) = True
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index a73997bda7..3653337219 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -34,6 +34,7 @@ import Protolude (ConvertText (toS), readMaybe)
 import Protolude.Exceptions (hush)
 import Prelude
 import Data.ByteString.Lazy qualified as Lazy
+import Language.PureScript.Types qualified as P
 
 -- | A map of locally-bound names in scope.
 type Context = [(Ident, SourceType)]
@@ -798,7 +799,7 @@ exprSourceSpan (TypedValue _ _ _) = Nothing
 exprSourceSpan (Let _ _ _) = Nothing
 exprSourceSpan (Do _ _) = Nothing
 exprSourceSpan (Ado _ _ _) = Nothing
-exprSourceSpan (TypeClassDictionary _ _ _) = Nothing
+exprSourceSpan (TypeClassDictionary sa _ _) = Just $ fst $ P.constraintAnn sa
 exprSourceSpan (DeferredDictionary _ _) = Nothing
 exprSourceSpan (DerivedInstancePlaceholder _ _) = Nothing
 exprSourceSpan AnonymousArgument = Nothing
@@ -806,6 +807,12 @@ exprSourceSpan (Hole _) = Nothing
 exprSourceSpan (PositionedValue ss _ _) = Just ss
 
 
+-- findExprSourceSpan :: Expr -> Maybe SourceSpan
+-- findExprSourceSpan = goExpr 
+--   where 
+--     ( ) = P.everythingOnValues
+
+
 -- |
 -- Metadata that tells where a let binding originated
 --
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index abbe6e5a15..cd623deb90 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -4,7 +4,7 @@
 module Language.PureScript.AST.Traversals where
 
 import Prelude
-import Protolude (swap)
+import Protolude (swap, Bifunctor (bimap), first)
 
 import Control.Monad ((<=<), (>=>))
 import Control.Monad.Trans.State (StateT(..))
@@ -17,13 +17,14 @@ import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 import Data.Set qualified as S
 
-import Language.PureScript.AST.Binders (Binder(..), binderNames)
+import Language.PureScript.AST.Binders (Binder(..), binderNames, binderNamesWithSpans)
 import Language.PureScript.AST.Declarations (CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, ValueDeclarationData(..), mapTypeInstanceBody, traverseTypeInstanceBody)
 import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.Names (pattern ByNullSourcePos, Ident)
 import Language.PureScript.Traversals (sndM, sndM', thirdM)
 import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceType, mapConstraintArgs)
+import Language.PureScript.AST.SourcePos (SourceAnn, SourceSpan)
 
 guardedExprM :: Applicative m
              => (Guard -> m Guard)
@@ -665,6 +666,133 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
 
   localBinderNames = map LocalIdent . binderNames
 
+type IdentsAnn = M.Map ScopedIdent SourceAnn
+
+everythingWithScopeAnn
+  :: forall r
+   . (Monoid r)
+  => (IdentsAnn -> Declaration -> r)
+  -> (IdentsAnn -> Expr -> r)
+  -> (IdentsAnn -> Binder -> r)
+  -> (IdentsAnn -> CaseAlternative -> r)
+  -> (IdentsAnn -> DoNotationElement -> r)
+  -> ( IdentsAnn -> Declaration -> r
+     , IdentsAnn -> Expr -> r
+     , IdentsAnn -> Binder -> r
+     , IdentsAnn -> CaseAlternative -> r
+     , IdentsAnn -> DoNotationElement -> r
+     )
+everythingWithScopeAnn f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
+  where
+  f'' :: IdentsAnn -> Declaration -> r
+  f'' s a = f s a <> f' s a
+
+  f' :: IdentsAnn -> Declaration -> r
+  f' s (DataBindingGroupDeclaration ds) =
+    let s' = M.union s (M.fromList (map (first ToplevelIdent) (mapMaybe getDeclIdentAndAnn (NEL.toList ds))))
+    in foldMap (f'' s') ds
+  f' s (ValueDecl sann name _ bs val) =
+    let s' = M.insert (ToplevelIdent name) sann s
+        s'' = M.union s' (M.fromList (concatMap localBinderNames bs))
+    in foldMap (h'' s') bs <> foldMap (l' s'') val
+  f' s (BindingGroupDeclaration ds) =
+    let s' = M.union s (M.fromList (NEL.toList (fmap (\((sa, name), _, _) -> (ToplevelIdent name, sa)) ds)))
+    in foldMap (\(_, _, val) -> g'' s' val) ds
+  f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds
+  f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds
+  f' _ _ = mempty
+
+  g'' :: IdentsAnn -> Expr -> r
+  g'' s a = g s a <> g' s a
+
+  g' :: IdentsAnn -> Expr -> r
+  g' s (Literal _ l) = lit g'' s l
+  g' s (UnaryMinus _ v1) = g'' s v1
+  g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
+  g' s (Parens v1) = g'' s v1
+  g' s (Accessor _ v1) = g'' s v1
+  g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
+  g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs
+  g' s (Abs b v1) =
+    let s' = M.union (M.fromList (localBinderNames b)) s
+    in h'' s b <> g'' s' v1
+  g' s (App v1 v2) = g'' s v1 <> g'' s v2
+  g' s (VisibleTypeApp v _) = g'' s v
+  g' s (Unused v) = g'' s v
+  g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
+  g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts
+  g' s (TypedValue _ v1 _) = g'' s v1
+  g' s (Let _ ds v1) =
+    let s' = M.union s (M.fromList (map (first LocalIdent) (mapMaybe getDeclIdentAndAnn ds)))
+    in foldMap (f'' s') ds <> g'' s' v1
+  g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es
+  g' s (Ado _ es v1) =
+    let s' = M.union s (foldMap (fst . j'' s) es)
+    in g'' s' v1
+  g' s (PositionedValue _ _ v1) = g'' s v1
+  g' _ _ = mempty
+
+  h'' :: IdentsAnn -> Binder -> r
+  h'' s a = h s a <> h' s a
+
+  h' :: IdentsAnn -> Binder -> r
+  h' s (LiteralBinder _ l) = lit h'' s l
+  h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
+  h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
+  h' s (ParensInBinder b) = h'' s b
+  h' s (NamedBinder ss name b1) = h'' (M.insert (LocalIdent name) (noComments ss) s) b1
+  h' s (PositionedBinder _ _ b1) = h'' s b1
+  h' s (TypedBinder _ b1) = h'' s b1
+  h' _ _ = mempty
+
+  lit :: (IdentsAnn -> a -> r) -> IdentsAnn -> Literal a -> r
+  lit go s (ArrayLiteral as) = foldMap (go s) as
+  lit go s (ObjectLiteral as) = foldMap (go s . snd) as
+  lit _ _ _ = mempty
+
+  i'' :: IdentsAnn -> CaseAlternative -> r
+  i'' s a = i s a <> i' s a
+
+  i' :: IdentsAnn -> CaseAlternative -> r
+  i' s (CaseAlternative bs gs) =
+    let s' = M.union s (M.fromList (concatMap localBinderNames bs))
+    in foldMap (h'' s) bs <> foldMap (l' s') gs
+
+  j'' :: IdentsAnn -> DoNotationElement -> (IdentsAnn, r)
+  j'' s a = let (s', r) = j' s a in (s', j s a <> r)
+
+  j' :: IdentsAnn -> DoNotationElement -> (IdentsAnn, r)
+  j' s (DoNotationValue v) = (s, g'' s v)
+  j' s (DoNotationBind b v) =
+    let s' = M.union (M.fromList (localBinderNames b)) s
+    in (s', h'' s b <> g'' s v)
+  j' s (DoNotationLet ds) =
+    let s' = M.union s (M.fromList (map (first LocalIdent) (mapMaybe getDeclIdentAndAnn ds)))
+    in (s', foldMap (f'' s') ds)
+  j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
+
+  k' :: IdentsAnn -> Guard -> (IdentsAnn, r)
+  k' s (ConditionGuard e) = (s, g'' s e)
+  k' s (PatternGuard b e) =
+    let s' = M.union (M.fromList (localBinderNames b)) s
+    in (s', h'' s b <> g'' s' e)
+
+  l' s (GuardedExpr [] e) = g'' s e
+  l' s (GuardedExpr (grd:gs) e) =
+    let (s', r) = k' s grd
+    in r <> l' s' (GuardedExpr gs e)
+
+  getDeclIdentAndAnn :: Declaration -> Maybe (Ident, SourceAnn)
+  getDeclIdentAndAnn (ValueDeclaration vd) = Just (valdeclIdent vd, valdeclSourceAnn vd)
+  getDeclIdentAndAnn (TypeDeclaration td) = Just (tydeclIdent td, tydeclSourceAnn td)
+  getDeclIdentAndAnn _ = Nothing
+
+  localBinderNames :: Binder -> [(ScopedIdent, SourceAnn)]
+  localBinderNames = fmap (bimap LocalIdent noComments . swap) .  binderNamesWithSpans
+
+  noComments :: SourceSpan -> SourceAnn
+  noComments ss = (ss, [])
+
 accumTypes
   :: (Monoid r)
   => (SourceType -> r)
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 8bdb0af417..ca46bc5e2f 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -1,28 +1,212 @@
 {-# LANGUAGE BlockArguments #-}
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.Lsp.Handlers.Definition where
 
-import Control.Lens ((^.))
+import Control.Lens (Field1 (_1), Field3 (_3), view, (^.))
 import Control.Lens.Getter (to)
+import Data.Map qualified as Map
+import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
+import Language.PureScript.AST qualified as AST
+import Language.PureScript.AST.Traversals (everythingWithScopeAnn)
 import Language.PureScript.CoreFn.Expr qualified as CF
-import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Docs (readQualifiedNameDocsSourceSpan)
+import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.Util (efDeclSourceSpan, getNamesAtPosition, sourcePosToPosition)
+import Language.PureScript.Lsp.State (cachedRebuild)
+import Language.PureScript.Lsp.Types (OpenFile (..))
+import Language.PureScript.Lsp.Util (declSourceSpanWithExpr, efDeclSourceSpan, getExprName, getNamesAtPosition, lookupTypeInEnv, posInSpan, posInSpanLines, sourcePosToPosition)
+import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
+  let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+      filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+
+      nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+      locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
+
+      posRes fp srcPos = locationRes fp $ Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos)
+
+      forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
+      forLsp val f = maybe nullRes f val
+
+  forLsp filePathMb \filePath -> do
+    cacheOpenMb <- cachedRebuild filePath
+    forLsp cacheOpenMb \OpenFile {..} -> do
+      let withoutPrim =
+            ofModule
+              & P.getModuleDeclarations
+              & filter (not . isPrimImport)
+
+          declsAtPos =
+            withoutPrim
+              & filter (posInSpanLines pos . declSourceSpanWithExpr)
+
+          decls = if null declsAtPos then withoutPrim else declsAtPos
+
+          exprs = getExprsAtPos pos =<< decls
+
+      debugLsp $ "pos: " <> show pos
+
+      debugLsp $ "declsAtPos: " <> show (length declsAtPos)
+
+      case head exprs of
+        Nothing -> nullRes
+        Just expr -> do
+          debugLsp $ "expr: " <> show expr
+          case expr of
+            P.Var _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
+            P.Op _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
+            P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
+            P.VisibleTypeApp _ st -> locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
+            P.TypedValue _ _ st -> locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
+            _ -> do
+              moduleNameMb <- selectExternModuleNameFromFilePath filePath
+              forLsp moduleNameMb \moduleName -> do
+                nameMb <- getExprName moduleName expr
+                forLsp nameMb \name -> do
+                  spanMb <- readQualifiedNameDocsSourceSpan name
+                  case spanMb of
+                    Just span -> locationRes (P.spanName span) (spanToRange span)
+                    _ -> nullRes
+              -- forLsp (liftA2 (,) moduleNameMb (getExprName expr)) \(modName, name) -> do
+              --   spanMb <- readQualifiedNameDocsSourceSpan name
+              --   case spanMb of
+              --     Just span -> locationRes (P.spanName span) (spanToRange span)
+              --     _ -> nullRes
+
+isPrimImport :: P.Declaration -> Bool
+isPrimImport (P.ImportDeclaration _ (P.ModuleName "Prim") _ _) = True
+isPrimImport (P.ImportDeclaration ss _ _ _) | ss == AST.nullSourceAnn = True
+isPrimImport _ = False
+
+spanToRange :: AST.SourceSpan -> Types.Range
+spanToRange (AST.SourceSpan _ start end) =
+  Types.Range
+    (sourcePosToPosition start)
+    (sourcePosToPosition end)
+
+getExprsAtPos :: Types.Position -> P.Declaration -> [P.Expr]
+getExprsAtPos pos declaration = execState (goDecl declaration) []
+  where
+    goDecl :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
+    goDecl = onDecl
+
+    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
+
+    handleExpr :: AST.Expr -> StateT [P.Expr] Identity AST.Expr
+    handleExpr expr = do
+      when (maybe False (posInSpan pos) (P.exprSourceSpan expr)) do
+        modify (expr :)
+      pure expr
+
+getExprsAtPos' :: Types.Position -> P.Declaration -> [P.Expr]
+getExprsAtPos' pos = fmap (view _1) . getExprsAndBindersAtPos' pos
+
+getExprsAndBindersAtPos :: Types.Position -> P.Declaration -> [(P.Expr, [P.Declaration], [P.Binder])]
+getExprsAndBindersAtPos pos declaration = view _3 $ execState (goDecl declaration) ([], [], [])
+  where
+    goDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
+    goDecl = onDecl
+
+    (onDecl, _, _) = P.everywhereOnValuesTopDownM handleDecl handleExpr handleBinder
+
+    handleDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
+    handleDecl decl = do
+      modify $ \(decls, binds, exprs) -> (decl : decls, binds, exprs)
+      pure decl
+
+    handleExpr :: AST.Expr -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Expr
+    handleExpr expr =
+      if maybe False (posInSpan pos) (P.exprSourceSpan expr)
+        then do
+          modify $ \(decls, binds, exprs) -> (decls, binds, (expr, decls, binds) : exprs)
+          pure expr
+        else pure expr
+
+    handleBinder :: AST.Binder -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Binder
+    handleBinder binder = do
+      modify $ first ((:) binder)
+      pure binder
+
+getExprsAndBindersAtPos' :: Types.Position -> P.Declaration -> [(P.Expr, [P.Declaration], [P.Binder])]
+getExprsAndBindersAtPos' pos declaration = view _3 $ execState (goDecl declaration) ([], [], [])
+  where
+    goDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
+    goDecl = onDecl
+
+    (onDecl, _, _) = P.everywhereOnValuesM handleDecl handleExpr handleBinder
+
+    handleDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
+    handleDecl decl = do
+      modify $ \(decls, binds, exprs) -> (decl : decls, binds, exprs)
+      pure decl
+
+    handleExpr :: AST.Expr -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Expr
+    handleExpr expr =
+      if maybe False (posInSpan pos) (P.exprSourceSpan expr)
+        then do
+          modify $ \(decls, binds, exprs) -> (decls, binds, (expr, decls, binds) : exprs)
+          pure expr
+        else pure expr
+
+    handleBinder :: AST.Binder -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Binder
+    handleBinder binder = do
+      modify $ first ((:) binder)
+      pure binder
+
+getExprAtPosWithLocalBindAnn :: Types.Position -> P.Declaration -> [(P.Expr, P.Qualified P.Name, Maybe AST.SourceAnn)]
+getExprAtPosWithLocalBindAnn pos decl = goDecl Map.empty decl
+  where
+    (goDecl, _, _, _, _) = everythingWithScopeAnn mempty handleExpr handleBinder mempty mempty
+
+    handleExpr :: AST.IdentsAnn -> AST.Expr -> [(P.Expr, P.Qualified P.Name, Maybe AST.SourceAnn)]
+    handleExpr idents expr = case expr of
+      AST.Var ss i
+        | posInSpan pos ss ->
+            let lookupIdent locKind = Map.lookup (locKind $ P.disqualify i) idents
+             in [(expr, P.IdentName <$> i, lookupIdent P.LocalIdent <|> lookupIdent P.ToplevelIdent)]
+      AST.Constructor ss name
+        | posInSpan pos ss ->
+            [ (expr, P.DctorName <$> name, Nothing)
+            ]
+      AST.Op _ opName ->
+        [ ( expr,
+            P.ValOpName <$> opName,
+            Nothing
+          )
+        ]
+      _
+        --   | Just ss <- exprSourceSpan expr, posInSpan pos ss ->
+        --     [(expr, _ expr, Nothing)
+        --     ]
+        | otherwise -> []
+
+    handleBinder :: AST.IdentsAnn -> AST.Binder -> [(P.Expr, P.Qualified P.Name, Maybe AST.SourceAnn)]
+    handleBinder _idents binder = case binder of
+      AST.ConstructorBinder ss ctorName _ ->
+        [ ( AST.Constructor ss ctorName,
+            P.DctorName <$> ctorName,
+            Nothing
+          )
+        ]
+      _ -> []
+
+definitionHandlerV1 :: Server.Handlers HandlerM
+definitionHandlerV1 = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
   let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
       uri :: Types.NormalizedUri
@@ -80,8 +264,80 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
                     locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
               _ -> nullRes
 
-spanToRange :: Errors.SourceSpan -> Types.Range
-spanToRange (Errors.SourceSpan _ start end) =
-  Types.Range
-    (sourcePosToPosition start)
-    (sourcePosToPosition end)
\ No newline at end of file
+-- t = [ ImportDeclaration (SourceSpan { spanStart = SourcePos {sourcePosLine = 1, sourcePosColumn = 1}
+--   , spanEnd = SourcePos {sourcePosLine = 107, sourcePosColumn = 82}},[]) (ModuleName "Prim") Implicit (Just (ModuleName "Prim")),ImportDeclaration (SourceSpan { spanStart = SourcePos {sourcePosLine = 1, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 107, sourcePosColumn = 82}},[]) (ModuleName "Prim") Implicit Nothing,ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}},[]), valdeclIdent = Ident "v", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (TypedValue True (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) [] (Let FromWhere [ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}},[]), valdeclIdent = Ident "a", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}) [] (Literal (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}) (NumericLiteral (Left 1))))]})] (TypedValue True (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) [] (Var (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) (Qualified (BySourcePos (SourcePos {sourcePosLine = 77, sourcePosColumn = 3})) (Ident "a")))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))))]})]
+
+-- x =
+--   [ ValueDeclaration
+--       ( ValueDeclarationData
+--           { valdeclSourceAnn =
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 1},
+--                     spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}
+--                   },
+--                 []
+--               ),
+--             valdeclIdent = Ident "v",
+--             valdeclName = Public,
+--             valdeclBinders = [],
+--             valdeclExpression =
+--               [ GuardedExpr
+--                   []
+--                   ( TypedValue
+--                       True
+--                       ( PositionedValue
+--                           ( SourceSpan {spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}
+--                           )
+--                           []
+--                           ( Let
+--                               FromWhere
+--                               [ ValueDeclaration
+--                                   ( ValueDeclarationData
+--                                       { valdeclSourceAnn = (SourceSpan {spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}, []),
+--                                         valdeclIdent = Ident "a",
+--                                         valdeclName = Public,
+--                                         valdeclBinders = [],
+--                                         valdeclExpression =
+--                                           [ GuardedExpr
+--                                               []
+--                                               ( PositionedValue
+--                                                   ( SourceSpan
+--                                                       { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7},
+--                                                         spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}
+--                                                       }
+--                                                   )
+--                                                   []
+--                                                   ( Literal
+--                                                       ( SourceSpan
+--                                                           { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7},
+--                                                             spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}
+--                                                           }
+--                                                       )
+--                                                       (NumericLiteral (Left 1))
+--                                                   )
+--                                               )
+--                                           ]
+--                                       }
+--                                   )
+--                               ]
+--                               ( TypedValue
+--                                   True
+--                                   ( PositionedValue
+--                                       ( SourceSpan
+--                                           { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5},
+--                                             spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}
+--                                           }
+--                                       )
+--                                       []
+--                                       (Var (SourceSpan {spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) (Qualified (BySourcePos (SourcePos {sourcePosLine = 77, sourcePosColumn = 3})) (Ident "a")))
+--                                   )
+--                                   (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
+--                               )
+--                           )
+--                       )
+--                       (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
+--                   )
+--               ]
+--           }
+--       )
+--   ]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 440d5005d7..5f1bc1dcee 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -2,11 +2,13 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.Lsp.Handlers.Hover where
 
 import Control.Lens ((^.))
 import Control.Lens.Getter (to)
+import Data.Set qualified as Set
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
@@ -22,8 +24,12 @@ import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifie
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Util (efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
-import Language.PureScript.Names (disqualify, runIdent)
+import Language.PureScript.Names (disqualify, runIdent, Qualified (..))
 import Protolude hiding (to)
+import Language.PureScript.Lsp.State (cacheRebuild, cachedRebuild)
+import Language.PureScript.AST.Traversals (everythingWithContextOnValues)
+import Language.PureScript.Lsp.Types (OpenFile(..))
+import Language.PureScript.AST.Declarations (Expr(..))
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler =
@@ -59,37 +65,57 @@ hoverHandler =
         forLsp val f = maybe nullRes f val
 
     forLsp filePathMb \filePath -> do
-      corefnExprMb <- getCoreFnExprAt filePath pos
-      case corefnExprMb of
-        Just (CF.Literal _ _) -> nullRes
-        Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
-          docsMb <- do
-            mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
-            maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` P.runProperName tName) mNameMb
-          case docsMb of
-            Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
-            Just docs -> markdownRes docs
-        Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
-          case qb of
-            P.ByModuleName mName -> do
-              docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
-              case docsMb of
-                Just docs -> markdownRes docs
-                _ -> do
-                  declMb <- getEfDeclarationInModule mName (runIdent ident)
-                  markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
-            P.BySourcePos _pos' ->
-              markdownTypeRes (P.runIdent ident) Nothing []
-        _ -> do
-          vfMb <- Server.getVirtualFile docUri
-          forLsp vfMb \vf -> do
-            mNameMb <- selectExternModuleNameFromFilePath filePath
-            forLsp mNameMb \mName -> do
-              names <- getNamesAtPosition pos mName (VFS._file_text vf)
-              forLsp (head names) \name -> do
-                docsMb <- readQualifiedNameDocsAsMarkdown name
+      openFileMb <- cachedRebuild  filePath
+      forLsp openFileMb \_ -> do
+        corefnExprMb <- getCoreFnExprAt filePath pos
+        case corefnExprMb of
+          Just (CF.Literal _ _) -> nullRes
+          Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
+            docsMb <- do
+              mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
+              maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` P.runProperName tName) mNameMb
+            case docsMb of
+              Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
+              Just docs -> markdownRes docs
+          Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
+            case qb of
+              P.ByModuleName mName -> do
+                docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
                 case docsMb of
-                  Nothing -> do
-                    typeMb <- lookupTypeInEnv filePath name
-                    forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
-                  Just docs -> markdownRes docs
\ No newline at end of file
+                  Just docs -> markdownRes docs
+                  _ -> do
+                    declMb <- getEfDeclarationInModule mName (runIdent ident)
+                    markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
+              P.BySourcePos _pos' ->
+                markdownTypeRes (P.runIdent ident) Nothing []
+          _ -> do
+            vfMb <- Server.getVirtualFile docUri
+            forLsp vfMb \vf -> do
+              mNameMb <- selectExternModuleNameFromFilePath filePath
+              forLsp mNameMb \mName -> do
+                names <- getNamesAtPosition pos mName (VFS._file_text vf)
+                forLsp (head names) \name -> do
+                  docsMb <- readQualifiedNameDocsAsMarkdown name
+                  case docsMb of
+                    Nothing -> do
+                      typeMb <- lookupTypeInEnv filePath name
+                      forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
+                    Just docs -> markdownRes docs
+
+
+-- getExprsAtPosition :: Types.Position -> Text -> P.Declaration -> [(P.SourcePos, P.Expr)]
+-- getExprsAtPosition pos word decl = []
+
+-- usedIdents :: P.ModuleName ->  P.Expr -> [P.Ident]
+-- usedIdents moduleName = ordNub . usedIdents' Set.empty 
+--   where
+--   def _ _ = []
+
+--   (_, usedIdents', _, _, _) = P.everythingWithScope def usedNamesE def def def
+
+--   usedNamesE :: Set.Set ScopedIdent -> Expr -> [Ident]
+--   usedNamesE scope (Var _ (Qualified (BySourcePos _) name))
+--     | LocalIdent name `S.notMember` scope = [name]
+--   usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name))
+--     | moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name]
+--   usedNamesE _ _ = []
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index 025fc5649a..c123271644 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -26,15 +26,14 @@ logLsp :: (MonadIO m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text ->
 logLsp msgLogLevel msg = do
   logLevel <- confLogLevel . lspConfig <$> ask
   when (shouldLog msgLogLevel logLevel) $ do
-    now <- liftIO $ utctDayTime <$> getCurrentTime
+    now <- liftIO getCurrentTime
     liftIO $
       putErrLn -- Use stderr for logging as LSP messages should be on stdout
         ( printLogMsgSeverity msgLogLevel
-            <> ": "
+            <> "\n:\n"
             <> T.pack (formatTime defaultTimeLocale "%T" now)
-            <> " "
-            <> ": "
-            <> show msg
+            <> "\n:\n"
+            <> msg
         )
 
 logPerfStandard :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m t -> m t
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index e9f95c2aae..a65a0af70e 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -55,7 +55,7 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
               & addRebuildCaching stVar maxCache externs
       debugLsp $ "Cache found: " <> show (isJust cachedBuild)
       case cachedBuild of
-        Just (OpenFile _ _ externs env _) -> do
+        Just (OpenFile _ _ externs env _ _) -> do
           foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
           exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
           res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
@@ -101,5 +101,5 @@ shushProgress ma =
 addRebuildCaching :: TVar LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps ma =
   ma
-    { P.codegen = \prevEnv env astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv env) <* P.codegen ma prevEnv env astM m docs ext
+    { P.codegen = \prevEnv env astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv env astM) <* P.codegen ma prevEnv env astM m docs ext
     }
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index c4386b086a..90430316d1 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -35,16 +35,16 @@ import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Environment -> m ()
-cacheRebuild ef deps prevEnv finalEnv = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Environment -> P.Module -> m ()
+cacheRebuild ef deps prevEnv finalEnv module' = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
-  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv finalEnv
+  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv finalEnv  module'
 
-cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [P.ExternsFile] -> P.Environment -> P.Environment -> IO ()
-cacheRebuild' st maxFiles ef deps prevEnv finalEnv = atomically . modifyTVar st $ \x ->
+cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [P.ExternsFile] -> P.Environment -> P.Environment -> P.Module -> IO ()
+cacheRebuild' st maxFiles ef deps prevEnv finalEnv  module' = atomically . modifyTVar st $ \x ->
   x
-    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv finalEnv) : filter ((/= fp) . fst) (openFiles x)
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv finalEnv module') : filter ((/= fp) . fst) (openFiles x)
     }
   where
     fp = P.spanName $ efSourceSpan ef
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index fdf30164e7..4a64a25d5b 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -19,6 +19,7 @@ import Language.PureScript.Sugar.Names (Env)
 import Language.PureScript.Sugar.Names qualified as P
 import Protolude
 import System.Directory (createDirectoryIfMissing)
+import Language.PureScript.AST qualified as P
 
 data LspEnvironment = LspEnvironment
   { lspConfig :: LspConfig,
@@ -52,7 +53,8 @@ data OpenFile = OpenFile
     ofExternsFile :: P.ExternsFile,
     ofDependencies :: [P.ExternsFile],
     ofStartingEnv :: P.Environment,
-    ofFinalEnv :: P.Environment
+    ofFinalEnv :: P.Environment, 
+    ofModule ::  P.Module
   }
   deriving (Show)
 
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 2b9f354d27..4b5563fad4 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -16,16 +16,17 @@ import Data.Text.Utf16.Rope.Mixed as Rope
 import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.LSP.Protocol.Types (UInt)
 import Language.LSP.Protocol.Types qualified as Types
+import Language.PureScript.AST qualified as AST
 import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.Declarations (declSourceAnn)
+-- import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
+
+import Language.PureScript.AST.SourcePos (widenSourceSpan)
 import Language.PureScript.Comments qualified as P
 import Language.PureScript.Environment qualified as P
-import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Linter qualified as P
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
--- import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
-
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (ofFinalEnv))
@@ -33,13 +34,18 @@ import Language.PureScript.Names qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
 
-posInSpan :: Types.Position -> Errors.SourceSpan -> Bool
-posInSpan (Types.Position line col) (Errors.SourceSpan _ (Errors.SourcePos startLine startCol) (Errors.SourcePos endLine endCol)) =
+posInSpan :: Types.Position -> AST.SourceSpan -> Bool
+posInSpan (Types.Position line col) (AST.SourceSpan _ (AST.SourcePos startLine startCol) (AST.SourcePos endLine endCol)) =
   startLine <= fromIntegral (line + 1)
     && endLine >= fromIntegral (line + 1)
     && startCol <= fromIntegral (col + 1)
     && endCol >= fromIntegral (col + 1)
 
+posInSpanLines :: Types.Position -> AST.SourceSpan -> Bool
+posInSpanLines (Types.Position line _) (AST.SourceSpan _ (AST.SourcePos startLine _) (AST.SourcePos endLine _)) =
+  startLine <= fromIntegral (line + 1)
+    && endLine >= fromIntegral (line + 1)
+
 getDeclarationAtPos :: Types.Position -> [P.Declaration] -> Maybe P.Declaration
 getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn)
 
@@ -54,7 +60,6 @@ getWordAt file pos@(Types.Position {..}) =
           (wordStartCol, wordEndCol, _word) = getWordOnLine line' _character
        in (Types.Range (Types.Position _line $ fromIntegral wordStartCol) (Types.Position _line $ fromIntegral wordEndCol), _word)
 
-
 getWordOnLine :: Text -> UInt -> (Int, Int, Text)
 getWordOnLine line' col =
   if T.length line' < fromIntegral col || col < 0
@@ -105,26 +110,6 @@ getNamesAtPosition pos moduleName' src = do
                         <> Set.singleton (flip P.mkQualified modName $ P.TyName name)
                     _ -> mempty
 
-            getExprName :: P.ModuleName -> P.Expr -> (P.ModuleName, Set (P.Qualified P.Name))
-            getExprName modName expr = (modName,) case expr of
-              P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
-              P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
-              P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-              P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-              P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-              P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
-              _ -> mempty
-
-            getTypeNames :: P.SourceType -> [P.Qualified P.Name]
-            getTypeNames = P.everythingOnTypes (<>) goType
-              where
-                goType :: P.SourceType -> [P.Qualified P.Name]
-                goType = \case
-                  P.TypeConstructor _ ctr -> [fmap P.TyName ctr]
-                  P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
-                  -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
-                  _ -> []
-
             goBinder :: P.ModuleName -> P.Binder -> (P.ModuleName, Set (P.Qualified P.Name))
             goBinder modName b = (modName,) case b of
               P.ConstructorBinder _ (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.DctorName ident
@@ -137,6 +122,26 @@ getNamesAtPosition pos moduleName' src = do
 
         Set.filter ((==) search . printName . P.disqualify) exprNames
 
+getExprName :: P.ModuleName -> P.Expr -> (P.ModuleName, Set (P.Qualified P.Name))
+getExprName modName expr = (modName,) case expr of
+  P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
+  P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
+  P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+  P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+  P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+  P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
+  _ -> mempty
+
+getTypeNames :: P.SourceType -> [P.Qualified P.Name]
+getTypeNames = P.everythingOnTypes (<>) goType
+  where
+    goType :: P.SourceType -> [P.Qualified P.Name]
+    goType = \case
+      P.TypeConstructor _ ctr -> [fmap P.TyName ctr]
+      P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
+      -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
+      _ -> []
+
 lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> P.Qualified P.Name -> m (Maybe P.SourceType)
 lookupTypeInEnv fp (P.Qualified qb name) = do
   envMb :: Maybe P.Environment <- fmap ofFinalEnv <$> cachedRebuild fp
@@ -197,16 +202,16 @@ efDeclSourceSpan = \case
 efDeclComments :: P.ExternsDeclaration -> [P.Comment]
 efDeclComments = foldr getComments [] . efDeclSourceType
   where
-    getComments :: Errors.SourceAnn -> [P.Comment] -> [P.Comment]
+    getComments :: AST.SourceAnn -> [P.Comment] -> [P.Comment]
     getComments (_, cs) acc = cs ++ acc
 
-sourcePosToPosition :: Errors.SourcePos -> Types.Position
-sourcePosToPosition (Errors.SourcePos line col) =
+sourcePosToPosition :: AST.SourcePos -> Types.Position
+sourcePosToPosition (AST.SourcePos line col) =
   Types.Position (fromIntegral $ line - 1) (fromIntegral $ col - 1)
 
-positionToSourcePos :: Types.Position -> Errors.SourcePos
+positionToSourcePos :: Types.Position -> AST.SourcePos
 positionToSourcePos (Types.Position line col) =
-  Errors.SourcePos (fromIntegral $ line + 1) (fromIntegral $ col + 1)
+  AST.SourcePos (fromIntegral $ line + 1) (fromIntegral $ col + 1)
 
 declToCompletionItemKind :: P.Declaration -> Maybe Types.CompletionItemKind
 declToCompletionItemKind = \case
@@ -221,6 +226,32 @@ declToCompletionItemKind = \case
   P.ExternDeclaration {} -> Just Types.CompletionItemKind_Value
   _ -> Nothing
 
-
 filePathToNormalizedUri :: FilePath -> Types.NormalizedUri
-filePathToNormalizedUri = Types.toNormalizedUri . Types.filePathToUri
\ No newline at end of file
+filePathToNormalizedUri = Types.toNormalizedUri . Types.filePathToUri
+
+declSourceSpanWithExpr :: P.Declaration -> AST.SourceSpan
+declSourceSpanWithExpr d = maybe span (widenSourceSpan span) exprSpan
+  where
+    span = P.declSourceSpan d
+    exprSpan = case d of
+      P.ValueDeclaration (P.ValueDeclarationData {..}) ->
+        let go acc (P.GuardedExpr _ e) =
+              case acc of
+                Nothing -> findExprSourceSpan e
+                Just acc' -> widenSourceSpan acc' <$> findExprSourceSpan e
+         in foldl' go Nothing valdeclExpression
+      _ -> Nothing
+
+findExprSourceSpan :: P.Expr -> Maybe AST.SourceSpan
+findExprSourceSpan = goExpr
+  where
+    combine (Just a) _ = Just a
+    combine _ b = b
+    (_, goExpr, _, _, _) =
+      P.everythingOnValues
+        combine
+        (Just . P.declSourceSpan)
+        P.exprSourceSpan
+        (const Nothing)
+        (const Nothing)
+        (const Nothing)
\ No newline at end of file

From 76747e99abac9bc4ec9401ebf88b5b53394bfd28 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 10 Oct 2024 15:44:56 +0200
Subject: [PATCH 127/297] prettier logging

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 35 ++++++-------
 src/Language/PureScript/Lsp/Log.hs            | 17 ++++---
 src/Language/PureScript/Lsp/Util.hs           | 51 ++++++++++---------
 3 files changed, 54 insertions(+), 49 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index ca46bc5e2f..483fc6cc80 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -7,7 +7,6 @@ module Language.PureScript.Lsp.Handlers.Definition where
 import Control.Lens (Field1 (_1), Field3 (_3), view, (^.))
 import Control.Lens.Getter (to)
 import Data.Map qualified as Map
-import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
@@ -25,9 +24,10 @@ import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declSourceSpanWithExpr, efDeclSourceSpan, getExprName, getNamesAtPosition, lookupTypeInEnv, posInSpan, posInSpanLines, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declSourceSpanWithExpr, efDeclSourceSpan, getNamesAtPosition, posInSpan, posInSpanLines, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
+import Language.PureScript.Environment qualified as E
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -40,6 +40,8 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       posRes fp srcPos = locationRes fp $ Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos)
 
+      sourceTypeLocRes st = locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
+
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
@@ -59,29 +61,28 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
           exprs = getExprsAtPos pos =<< decls
 
-      debugLsp $ "pos: " <> show pos
-
-      debugLsp $ "declsAtPos: " <> show (length declsAtPos)
-
       case head exprs of
         Nothing -> nullRes
         Just expr -> do
           debugLsp $ "expr: " <> show expr
           case expr of
             P.Var _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
+            P.Var _ ident | Just (st, _ , _) <- Map.lookup ident (E.names ofFinalEnv) -> sourceTypeLocRes st
             P.Op _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
             P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
-            P.VisibleTypeApp _ st -> locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
-            P.TypedValue _ _ st -> locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
-            _ -> do
-              moduleNameMb <- selectExternModuleNameFromFilePath filePath
-              forLsp moduleNameMb \moduleName -> do
-                nameMb <- getExprName moduleName expr
-                forLsp nameMb \name -> do
-                  spanMb <- readQualifiedNameDocsSourceSpan name
-                  case spanMb of
-                    Just span -> locationRes (P.spanName span) (spanToRange span)
-                    _ -> nullRes
+            P.Constructor _ ident | Just (_, _, st, _) <-  Map.lookup ident (E.dataConstructors ofFinalEnv) -> sourceTypeLocRes st
+            P.VisibleTypeApp _ st -> sourceTypeLocRes st
+            P.TypedValue _ _ st -> sourceTypeLocRes st
+            _ -> nullRes
+              -- do
+              -- moduleNameMb <- selectExternModuleNameFromFilePath filePath
+              -- forLsp moduleNameMb \moduleName' -> do
+              --   nameMb <- getExprName moduleName expr
+              --   forLsp nameMb \name -> do
+              --     spanMb <- readQualifiedNameDocsSourceSpan name
+              --     case spanMb of
+              --       Just span -> locationRes (P.spanName span) (spanToRange span)
+              --       _ -> nullRes
               -- forLsp (liftA2 (,) moduleNameMb (getExprName expr)) \(modName, name) -> do
               --   spanMb <- readQualifiedNameDocsSourceSpan name
               --   case spanMb of
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index c123271644..8644cc05ee 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -1,11 +1,11 @@
 module Language.PureScript.Lsp.Log where
 
 import Data.Text qualified as T
-import Data.Time (UTCTime (utctDayTime), defaultTimeLocale, formatTime, getCurrentTime)
+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
+import Language.PureScript.Ide.Logging (displayTimeSpec)
 import Language.PureScript.Lsp.Types (LspConfig (confLogLevel), LspEnvironment (lspConfig), LspLogLevel (..))
 import Protolude
-import System.Clock (TimeSpec, getTime, Clock (Monotonic), diffTimeSpec)
-import Language.PureScript.Ide.Logging (displayTimeSpec)
+import System.Clock (Clock (Monotonic), TimeSpec, diffTimeSpec, getTime)
 
 infoLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
 infoLsp = logLsp LogMsgInfo
@@ -29,11 +29,14 @@ logLsp msgLogLevel msg = do
     now <- liftIO getCurrentTime
     liftIO $
       putErrLn -- Use stderr for logging as LSP messages should be on stdout
-        ( printLogMsgSeverity msgLogLevel
-            <> "\n:\n"
+        ( "[ "
+            <> printLogMsgSeverity msgLogLevel
+            <> " ]"
+            <> " "
             <> T.pack (formatTime defaultTimeLocale "%T" now)
-            <> "\n:\n"
+            <> "\n"
             <> msg
+            <> "\n\n"
         )
 
 logPerfStandard :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m t -> m t
@@ -47,7 +50,7 @@ logPerf format f = do
   perfLsp (format (diffTimeSpec start end))
   pure result
 
-getPerfTime :: MonadIO m => m TimeSpec
+getPerfTime :: (MonadIO m) => m TimeSpec
 getPerfTime = liftIO (getTime Monotonic)
 
 labelTimespec :: Text -> TimeSpec -> Text
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 4b5563fad4..5b99fa1473 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -110,6 +110,26 @@ getNamesAtPosition pos moduleName' src = do
                         <> Set.singleton (flip P.mkQualified modName $ P.TyName name)
                     _ -> mempty
 
+            getExprNames :: P.ModuleName -> P.Expr -> (P.ModuleName, Set (P.Qualified P.Name))
+            getExprNames modName expr = (modName,) case expr of
+              P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
+              P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
+              P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+              P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+              P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
+              P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
+              _ -> mempty
+
+            getTypeNames :: P.SourceType -> [P.Qualified P.Name]
+            getTypeNames = P.everythingOnTypes (<>) goType
+              where
+                goType :: P.SourceType -> [P.Qualified P.Name]
+                goType = \case
+                  P.TypeConstructor _ ctr -> [fmap P.TyName ctr]
+                  P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
+                  -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
+                  _ -> []
+
             goBinder :: P.ModuleName -> P.Binder -> (P.ModuleName, Set (P.Qualified P.Name))
             goBinder modName b = (modName,) case b of
               P.ConstructorBinder _ (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.DctorName ident
@@ -117,31 +137,11 @@ getNamesAtPosition pos moduleName' src = do
               P.TypedBinder st _ -> Set.fromList $ getTypeNames st
               _ -> mempty
 
-            exprNames = P.everythingWithContextOnValues moduleName' Set.empty (<>) getDeclName getExprName goBinder goDef goDef ^. _1 $ decl
+            exprNames = P.everythingWithContextOnValues moduleName' Set.empty (<>) getDeclName getExprNames goBinder goDef goDef ^. _1 $ decl
         -- typeNames = Set.fromList $ usedTypeNames moduleName' decl
 
         Set.filter ((==) search . printName . P.disqualify) exprNames
 
-getExprName :: P.ModuleName -> P.Expr -> (P.ModuleName, Set (P.Qualified P.Name))
-getExprName modName expr = (modName,) case expr of
-  P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
-  P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
-  P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-  P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-  P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-  P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
-  _ -> mempty
-
-getTypeNames :: P.SourceType -> [P.Qualified P.Name]
-getTypeNames = P.everythingOnTypes (<>) goType
-  where
-    goType :: P.SourceType -> [P.Qualified P.Name]
-    goType = \case
-      P.TypeConstructor _ ctr -> [fmap P.TyName ctr]
-      P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
-      -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
-      _ -> []
-
 lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> P.Qualified P.Name -> m (Maybe P.SourceType)
 lookupTypeInEnv fp (P.Qualified qb name) = do
   envMb :: Maybe P.Environment <- fmap ofFinalEnv <$> cachedRebuild fp
@@ -157,7 +157,8 @@ lookupTypeInEnv fp (P.Qualified qb name) = do
               P.DctorName dctorName -> view _3 <$> Map.lookup (P.Qualified qb dctorName) dataConstructors
               P.TyClassName tyClassName ->
                 view _1 <$> Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) types
-              _ -> Nothing
+              P.ModName _ -> Nothing
+              -- _ -> Nothing
               -- P.Qualified (P.ByModuleName mn) n -> P.lookupType n mn env
               -- P.Qualified (P.BySourcePos _) n -> P.lookupType n (P.moduleName env) env
           )
@@ -236,9 +237,9 @@ declSourceSpanWithExpr d = maybe span (widenSourceSpan span) exprSpan
     exprSpan = case d of
       P.ValueDeclaration (P.ValueDeclarationData {..}) ->
         let go acc (P.GuardedExpr _ e) =
-              case acc of
-                Nothing -> findExprSourceSpan e
-                Just acc' -> widenSourceSpan acc' <$> findExprSourceSpan e
+             case acc of 
+               Nothing -> findExprSourceSpan e
+               Just acc' -> widenSourceSpan acc' <$> findExprSourceSpan e
          in foldl' go Nothing valdeclExpression
       _ -> Nothing
 

From b3a5d01c7916162597a8c577b7cb003290997003 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 13 Oct 2024 09:00:25 +0200
Subject: [PATCH 128/297] move from glob to instr, remove value selection of
 ast decls, add NameType, remove addCoreFnIndexing and get definition from ast

---
 purescript.cabal                              |   1 +
 src/Language/PureScript/Lsp/Cache/Query.hs    |  35 +++-
 .../PureScript/Lsp/Handlers/Definition.hs     | 169 ++++--------------
 src/Language/PureScript/Lsp/NameType.hs       |  25 +++
 src/Language/PureScript/Lsp/Util.hs           |  15 +-
 src/Language/PureScript/Make/Index.hs         |  26 +--
 src/Language/PureScript/Names.hs              |   3 +
 7 files changed, 120 insertions(+), 154 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/NameType.hs

diff --git a/purescript.cabal b/purescript.cabal
index 2a531fd70e..9861745333 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -357,6 +357,7 @@ library
     Language.PureScript.Lsp.Handlers.Hover
     Language.PureScript.Lsp.Log
     Language.PureScript.Lsp.Monad
+    Language.PureScript.Lsp.NameType
     Language.PureScript.Lsp.Prim
     Language.PureScript.Lsp.Print
     Language.PureScript.Lsp.ReadFile
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index cbdbb049c1..d45ed4c4b9 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -24,6 +24,7 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, ge
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
+import Language.PureScript.Lsp.NameType (LspNameType)
 
 getCoreFnExprAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Expr CF.Ann))
 getCoreFnExprAt path (LSP.Position line col) = do
@@ -129,6 +130,24 @@ getAstDeclarationInModule moduleName' name = do
       ]
   pure $ deserialise . fromOnly <$> listToMaybe decls
 
+getAstDeclarationLocationInModule :: (MonadIO m, MonadReader LspEnvironment m) => Maybe LspNameType -> P.ModuleName -> Text -> m [P.SourceSpan]
+getAstDeclarationLocationInModule lspNameType moduleName' name = do
+  decls :: [([Char], Int, Int, Int, Int)] <-
+    DB.queryNamed
+      "SELECT path, start_line, start_col, end_line, end_col \
+      \FROM ast_declarations \
+      \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
+      \WHERE module_name = :module_name \
+      \AND name = :name \
+      \AND name_type IS :name_type"
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := name,
+        ":name_type" := (map show lspNameType :: Maybe Text)
+      ]
+  pure $ decls <&> \(spanName, sl, sc, el, ec) -> P.SourceSpan spanName (SourcePos sl sc) (SourcePos el ec)
+
+-- pure $ deserialise . fromOnly <$> listToMaybe decls
+
 getAstDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> SourcePos -> m [P.Declaration]
 getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
   decls <-
@@ -161,13 +180,13 @@ getAstDeclarationsStartingWith moduleName' prefix = do
              \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
-             \AND (name == :prefix OR name GLOB :prefix) \
+             \AND instr(name, :prefix) == 1 \
              \ORDER BY name ASC \
              \LIMIT :limit \
              \OFFSET :offset"
     )
     [ ":module_name" := P.runModuleName moduleName',
-      ":prefix" := prefix <> "*",
+      ":prefix" := prefix,
       ":limit" := limit,
       ":offset" := offset
     ]
@@ -190,15 +209,15 @@ getAstDeclarationsStartingWithAndSearchingModuleNames moduleName' moduleNameCont
              \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
-             \AND ast_declarations.module_name like :module_name_contains \
-             \AND (name == :prefix OR name GLOB :prefix) \
+             \AND instr(ast_declarations.module_name, :module_name_contains) <> 0 \
+             \AND instr(name, :prefix) == 1 \
              \ORDER BY name ASC \
              \LIMIT :limit \
              \OFFSET :offset"
     )
     [ ":module_name" := P.runModuleName moduleName',
-      ":prefix" := prefix <> "*",
-      ":module_name_contains" := "%" <> P.runModuleName moduleNameContains <> "%",
+      ":prefix" := prefix,
+      ":module_name_contains" := P.runModuleName moduleNameContains,
       ":limit" := limit,
       ":offset" := offset
     ]
@@ -220,13 +239,13 @@ getAstDeclarationsStartingWithOnlyInModule moduleName' prefix = do
              \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE ast_declarations.module_name = :module_name \
-             \AND (name == :prefix OR name GLOB :prefix)\
+             \AND instr(name, :prefix) == 1 \
              \ORDER BY name ASC \
              \LIMIT :limit \
              \OFFSET :offset"
     )
     [ ":module_name" := P.runModuleName moduleName',
-      ":prefix" := prefix <> "*",
+      ":prefix" := prefix,
       ":limit" := limit,
       ":offset" := offset
     ]
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 483fc6cc80..161fe0c857 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -4,9 +4,8 @@
 
 module Language.PureScript.Lsp.Handlers.Definition where
 
-import Control.Lens (Field1 (_1), Field3 (_3), view, (^.))
+import Control.Lens (Field1 (_1), view, (^.))
 import Control.Lens.Getter (to)
-import Data.Map qualified as Map
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
@@ -14,24 +13,24 @@ import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.AST qualified as AST
-import Language.PureScript.AST.Traversals (everythingWithScopeAnn)
+import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.CoreFn.Expr qualified as CF
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationLocationInModule, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Docs (readQualifiedNameDocsSourceSpan)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declSourceSpanWithExpr, efDeclSourceSpan, getNamesAtPosition, posInSpan, posInSpanLines, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceSpan, getNamesAtPosition, posInSpan, posInSpanLines, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
-import Language.PureScript.Environment qualified as E
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-  let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+  let Types.DefinitionParams docIdent pos@(Types.Position {..}) _prog _prog' = req ^. LSP.params
       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
 
       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
@@ -45,6 +44,12 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
+      respondWithDeclInOtherModule :: Maybe LspNameType -> P.ModuleName -> Text -> HandlerM ()
+      respondWithDeclInOtherModule nameType modName ident = do
+        declSpans <- getAstDeclarationLocationInModule nameType modName ident
+        forLsp (head declSpans) $ \sourceSpan ->
+          locationRes (AST.spanName sourceSpan) (spanToRange sourceSpan)
+
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -53,41 +58,29 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
               & P.getModuleDeclarations
               & filter (not . isPrimImport)
 
-          declsAtPos =
+          declAtPos =
             withoutPrim
-              & filter (posInSpanLines pos . declSourceSpanWithExpr)
-
-          decls = if null declsAtPos then withoutPrim else declsAtPos
-
-          exprs = getExprsAtPos pos =<< decls
-
-      case head exprs of
-        Nothing -> nullRes
-        Just expr -> do
-          debugLsp $ "expr: " <> show expr
-          case expr of
-            P.Var _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
-            P.Var _ ident | Just (st, _ , _) <- Map.lookup ident (E.names ofFinalEnv) -> sourceTypeLocRes st
-            P.Op _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
-            P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
-            P.Constructor _ ident | Just (_, _, st, _) <-  Map.lookup ident (E.dataConstructors ofFinalEnv) -> sourceTypeLocRes st
-            P.VisibleTypeApp _ st -> sourceTypeLocRes st
-            P.TypedValue _ _ st -> sourceTypeLocRes st
-            _ -> nullRes
-              -- do
-              -- moduleNameMb <- selectExternModuleNameFromFilePath filePath
-              -- forLsp moduleNameMb \moduleName' -> do
-              --   nameMb <- getExprName moduleName expr
-              --   forLsp nameMb \name -> do
-              --     spanMb <- readQualifiedNameDocsSourceSpan name
-              --     case spanMb of
-              --       Just span -> locationRes (P.spanName span) (spanToRange span)
-              --       _ -> nullRes
-              -- forLsp (liftA2 (,) moduleNameMb (getExprName expr)) \(modName, name) -> do
-              --   spanMb <- readQualifiedNameDocsSourceSpan name
-              --   case spanMb of
-              --     Just span -> locationRes (P.spanName span) (spanToRange span)
-              --     _ -> nullRes
+              & declAtLine (fromIntegral _line)
+
+      forLsp declAtPos $ \decl ->
+        case head $ getExprsAtPos pos decl of
+          Nothing -> nullRes
+          Just expr -> do
+            debugLsp $ "expr: " <> show expr
+            case expr of
+              P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+              P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
+              P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+              P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
+              P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+              P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
+              _ -> forLsp (find (not . isNullSourceTypeSpan) $ getTypesAtPos pos decl) sourceTypeLocRes
+
+isNullSourceTypeSpan :: P.SourceType -> Bool
+isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
 
 isPrimImport :: P.Declaration -> Bool
 isPrimImport (P.ImportDeclaration _ (P.ModuleName "Prim") _ _) = True
@@ -114,97 +107,11 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
         modify (expr :)
       pure expr
 
-getExprsAtPos' :: Types.Position -> P.Declaration -> [P.Expr]
-getExprsAtPos' pos = fmap (view _1) . getExprsAndBindersAtPos' pos
-
-getExprsAndBindersAtPos :: Types.Position -> P.Declaration -> [(P.Expr, [P.Declaration], [P.Binder])]
-getExprsAndBindersAtPos pos declaration = view _3 $ execState (goDecl declaration) ([], [], [])
-  where
-    goDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
-    goDecl = onDecl
-
-    (onDecl, _, _) = P.everywhereOnValuesTopDownM handleDecl handleExpr handleBinder
-
-    handleDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
-    handleDecl decl = do
-      modify $ \(decls, binds, exprs) -> (decl : decls, binds, exprs)
-      pure decl
-
-    handleExpr :: AST.Expr -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Expr
-    handleExpr expr =
-      if maybe False (posInSpan pos) (P.exprSourceSpan expr)
-        then do
-          modify $ \(decls, binds, exprs) -> (decls, binds, (expr, decls, binds) : exprs)
-          pure expr
-        else pure expr
-
-    handleBinder :: AST.Binder -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Binder
-    handleBinder binder = do
-      modify $ first ((:) binder)
-      pure binder
-
-getExprsAndBindersAtPos' :: Types.Position -> P.Declaration -> [(P.Expr, [P.Declaration], [P.Binder])]
-getExprsAndBindersAtPos' pos declaration = view _3 $ execState (goDecl declaration) ([], [], [])
+getTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
+getTypesAtPos pos decl = (view _1 $ P.accumTypes getAtPos) decl
   where
-    goDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
-    goDecl = onDecl
-
-    (onDecl, _, _) = P.everywhereOnValuesM handleDecl handleExpr handleBinder
-
-    handleDecl :: P.Declaration -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity P.Declaration
-    handleDecl decl = do
-      modify $ \(decls, binds, exprs) -> (decl : decls, binds, exprs)
-      pure decl
-
-    handleExpr :: AST.Expr -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Expr
-    handleExpr expr =
-      if maybe False (posInSpan pos) (P.exprSourceSpan expr)
-        then do
-          modify $ \(decls, binds, exprs) -> (decls, binds, (expr, decls, binds) : exprs)
-          pure expr
-        else pure expr
-
-    handleBinder :: AST.Binder -> StateT ([P.Declaration], [P.Binder], [(P.Expr, [P.Declaration], [P.Binder])]) Identity AST.Binder
-    handleBinder binder = do
-      modify $ first ((:) binder)
-      pure binder
-
-getExprAtPosWithLocalBindAnn :: Types.Position -> P.Declaration -> [(P.Expr, P.Qualified P.Name, Maybe AST.SourceAnn)]
-getExprAtPosWithLocalBindAnn pos decl = goDecl Map.empty decl
-  where
-    (goDecl, _, _, _, _) = everythingWithScopeAnn mempty handleExpr handleBinder mempty mempty
-
-    handleExpr :: AST.IdentsAnn -> AST.Expr -> [(P.Expr, P.Qualified P.Name, Maybe AST.SourceAnn)]
-    handleExpr idents expr = case expr of
-      AST.Var ss i
-        | posInSpan pos ss ->
-            let lookupIdent locKind = Map.lookup (locKind $ P.disqualify i) idents
-             in [(expr, P.IdentName <$> i, lookupIdent P.LocalIdent <|> lookupIdent P.ToplevelIdent)]
-      AST.Constructor ss name
-        | posInSpan pos ss ->
-            [ (expr, P.DctorName <$> name, Nothing)
-            ]
-      AST.Op _ opName ->
-        [ ( expr,
-            P.ValOpName <$> opName,
-            Nothing
-          )
-        ]
-      _
-        --   | Just ss <- exprSourceSpan expr, posInSpan pos ss ->
-        --     [(expr, _ expr, Nothing)
-        --     ]
-        | otherwise -> []
-
-    handleBinder :: AST.IdentsAnn -> AST.Binder -> [(P.Expr, P.Qualified P.Name, Maybe AST.SourceAnn)]
-    handleBinder _idents binder = case binder of
-      AST.ConstructorBinder ss ctorName _ ->
-        [ ( AST.Constructor ss ctorName,
-            P.DctorName <$> ctorName,
-            Nothing
-          )
-        ]
-      _ -> []
+    getAtPos :: P.SourceType -> [P.SourceType]
+    getAtPos st = [st | posInSpanLines pos (fst $ getAnnForType st)]
 
 definitionHandlerV1 :: Server.Handlers HandlerM
 definitionHandlerV1 = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
new file mode 100644
index 0000000000..5bc16ce1ac
--- /dev/null
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -0,0 +1,25 @@
+module Language.PureScript.Lsp.NameType where
+
+import Protolude
+import Language.PureScript.Names
+
+data LspNameType
+  = IdentNameType
+  | ValOpNameType
+  | TyNameType
+  | TyOpNameType
+  | DctorNameType
+  | TyClassNameType
+  | ModNameType
+  deriving (Show, Eq)
+
+
+lspNameType :: Name -> LspNameType
+lspNameType = \case 
+  IdentName _ -> IdentNameType
+  ValOpName _ -> ValOpNameType
+  TyName _ -> TyNameType
+  TyOpName _ -> TyOpNameType
+  DctorName _ -> DctorNameType
+  TyClassName _ -> TyClassNameType
+  ModName _ -> ModNameType
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 5b99fa1473..242cf92ef5 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -158,9 +158,6 @@ lookupTypeInEnv fp (P.Qualified qb name) = do
               P.TyClassName tyClassName ->
                 view _1 <$> Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) types
               P.ModName _ -> Nothing
-              -- _ -> Nothing
-              -- P.Qualified (P.ByModuleName mn) n -> P.lookupType n mn env
-              -- P.Qualified (P.BySourcePos _) n -> P.lookupType n (P.moduleName env) env
           )
 
 data ExternsDeclarationCategory
@@ -243,6 +240,18 @@ declSourceSpanWithExpr d = maybe span (widenSourceSpan span) exprSpan
          in foldl' go Nothing valdeclExpression
       _ -> Nothing
 
+
+declAtLine :: Int -> [P.Declaration] -> Maybe P.Declaration
+declAtLine l (d:d':ds) 
+  | declStartLine d >= l && declStartLine d' < l = Just d
+  | otherwise = declAtLine l (d':ds)
+declAtLine l [d] | declStartLine d >= l = Just d
+declAtLine _ _ = Nothing 
+
+declStartLine :: P.Declaration -> Int
+declStartLine = P.sourcePosLine . AST.spanStart . P.declSourceSpan
+
+
 findExprSourceSpan :: P.Expr -> Maybe AST.SourceSpan
 findExprSourceSpan = goExpr
   where
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 1904f4ee46..abae39deb8 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -50,13 +50,12 @@ import Language.PureScript.Types (everywhereOnTypesM)
 import Paths_purescript qualified as Paths
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
+import Language.PureScript.Lsp.NameType (lspNameType)
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
   addAstModuleIndexing conn $
-    -- addEnvIndexing conn $
-    addCoreFnIndexing conn $
-      addExternIndexing conn ma
+    addExternIndexing conn ma
 
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
@@ -65,30 +64,33 @@ addAstModuleIndexing conn ma =
     }
 
 indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> m ()
-indexAstModule conn m@(P.Module _ss _comments name decls exportRefs) extern = liftIO do
+indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) extern = liftIO do
   path <- makeAbsolute externPath
   SQL.executeNamed
     conn
     (SQL.Query "INSERT OR REPLACE INTO ast_modules (module_name, path) VALUES (:module_name, :path)")
-    [ ":module_name" := P.runModuleName name,
+    [ ":module_name" := P.runModuleName moduleName',
       ":path" := path
     ]
-  SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
-  SQL.execute conn "DELETE FROM ast_expressions WHERE module_name = ?" (SQL.Only $ P.runModuleName name)
+  SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName moduleName')
+  SQL.execute conn "DELETE FROM ast_expressions WHERE module_name = ?" (SQL.Only $ P.runModuleName moduleName')
 
   let exports = Set.fromList $ P.exportedDeclarations m
 
   forM_ decls \decl -> do
     let (ss, _) = P.declSourceAnn decl
-    let start = P.spanStart ss
+        start = P.spanStart ss
         end = P.spanEnd ss
+        name = P.declName decl
+        nameType =  name <&> lspNameType
     SQL.executeNamed
       conn
-      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, printed_type, start_line, end_line, start_col, end_col, lines, cols, exported) VALUES (:module_name, :name, :value, :printed_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
-      [ ":module_name" := P.runModuleName name,
-        ":name" := printName <$> P.declName decl,
+      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) VALUES (:module_name, :name, :value, :printed_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := printName <$> name,
         ":value" := serialise decl,
         ":printed_type" := printDeclarationType decl,
+        ":name_type" := (show <$> nameType :: Maybe Text),
         ":start_line" := P.sourcePosLine start,
         ":end_line" := P.sourcePosLine end,
         ":start_col" := P.sourcePosColumn start,
@@ -319,7 +321,7 @@ initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, value TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, name_type TEXT, value TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index e5df3610bf..7d3b289877 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 -- |
 -- Data types for names
@@ -21,6 +22,7 @@ import Data.Text (Text)
 import Data.Text qualified as T
 
 import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
+import Data.Aeson qualified as A
 
 -- | A sum of the possible name types, useful for error and lint messages.
 data Name
@@ -175,6 +177,7 @@ data ProperNameType
   | ConstructorName
   | ClassName
   | Namespace
+  deriving (Show, Generic, A.FromJSON, A.ToJSON)
 
 -- |
 -- Coerces a ProperName from one ProperNameType to another. This should be used

From bc1dab58abb7c4d13b3cd5731b814a581252ae5d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 13 Oct 2024 21:35:38 +0200
Subject: [PATCH 129/297] fix go to definition for values bugs

---
 src/Language/PureScript/Lsp/Cache/Query.hs    |  2 +-
 .../PureScript/Lsp/Handlers/Definition.hs     | 36 +++++++++++--------
 src/Language/PureScript/Make/Index.hs         |  8 +++--
 3 files changed, 28 insertions(+), 18 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index d45ed4c4b9..6b973cd8ac 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -137,7 +137,7 @@ getAstDeclarationLocationInModule lspNameType moduleName' name = do
       "SELECT path, start_line, start_col, end_line, end_col \
       \FROM ast_declarations \
       \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
-      \WHERE module_name = :module_name \
+      \WHERE ast_declarations.module_name = :module_name \
       \AND name = :name \
       \AND name_type IS :name_type"
       [ ":module_name" := P.runModuleName moduleName',
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 161fe0c857..9612bf7e44 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -47,6 +47,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       respondWithDeclInOtherModule :: Maybe LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInOtherModule nameType modName ident = do
         declSpans <- getAstDeclarationLocationInModule nameType modName ident
+        debugLsp $ "Decl spans: " <> show declSpans
         forLsp (head declSpans) $ \sourceSpan ->
           locationRes (AST.spanName sourceSpan) (spanToRange sourceSpan)
 
@@ -63,21 +64,26 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
               & declAtLine (fromIntegral _line)
 
       forLsp declAtPos $ \decl ->
-        case head $ getExprsAtPos pos decl of
-          Nothing -> nullRes
-          Just expr -> do
-            debugLsp $ "expr: " <> show expr
-            case expr of
-              P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-              P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
-              P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-              P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
-              P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-              P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
-              _ -> forLsp (find (not . isNullSourceTypeSpan) $ getTypesAtPos pos decl) sourceTypeLocRes
+        let respondWithTypeLocation =
+              forLsp (find (not . isNullSourceTypeSpan) $ getTypesAtPos pos decl) sourceTypeLocRes
+         in case head $ getExprsAtPos pos decl of
+              Just expr -> do
+                debugLsp $ "expr: " <> show expr
+                case expr of
+                  P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do 
+                    debugLsp $ "Var in source pos: " <> show srcPos
+                    posRes filePath srcPos
+                  P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                    debugLsp $ "Var in module: " <> show modName <> " " <> show ident
+                    respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
+                  P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                  P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                    respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
+                  P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                  P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                    respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
+                  _ -> respondWithTypeLocation
+              _ -> respondWithTypeLocation
 
 isNullSourceTypeSpan :: P.SourceType -> Bool
 isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index abae39deb8..ca87cc2e94 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -85,7 +85,10 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
         nameType =  name <&> lspNameType
     SQL.executeNamed
       conn
-      (SQL.Query "INSERT INTO ast_declarations (module_name, name, value, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) VALUES (:module_name, :name, :value, :printed_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+      (SQL.Query 
+      "INSERT INTO ast_declarations \
+      \        (module_name, name, value, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
+      \ VALUES (:module_name, :name, :value, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := printName <$> name,
         ":value" := serialise decl,
@@ -317,7 +320,7 @@ insertEfExport conn moduleName' dr = do
 
 initDb :: Connection -> IO ()
 initDb conn = do
-  -- dropTables conn
+  dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
@@ -372,6 +375,7 @@ dropTables :: Connection -> IO ()
 dropTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS ast_declarations"
   SQL.execute_ conn "DROP TABLE IF EXISTS ast_expressions"
+  SQL.execute_ conn "DROP TABLE IF EXISTS ast_modules"
   SQL.execute_ conn "DROP TABLE IF EXISTS envs"
   SQL.execute_ conn "DROP TABLE IF EXISTS corefn_modules"
   SQL.execute_ conn "DROP TABLE IF EXISTS corefn_imports"

From d72bae334dc5da6bd45b6c6c4dbb55814429d116 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 13 Oct 2024 22:04:49 +0200
Subject: [PATCH 130/297] fix decl at line

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 30 ++++++++++++++-----
 src/Language/PureScript/Lsp/Util.hs           | 20 ++++++-------
 src/Language/PureScript/Make/Index.hs         |  2 +-
 3 files changed, 34 insertions(+), 18 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 9612bf7e44..079aaedbb2 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -24,9 +24,10 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceSpan, getNamesAtPosition, posInSpan, posInSpanLines, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceSpan, getNamesAtPosition, posInSpan, posInSpanLines, sourcePosToPosition, declStartLine)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
+import Language.PureScript (declName)
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -47,10 +48,11 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       respondWithDeclInOtherModule :: Maybe LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInOtherModule nameType modName ident = do
         declSpans <- getAstDeclarationLocationInModule nameType modName ident
-        debugLsp $ "Decl spans: " <> show declSpans
         forLsp (head declSpans) $ \sourceSpan ->
           locationRes (AST.spanName sourceSpan) (spanToRange sourceSpan)
 
+  debugLsp $ "Position: " <> show pos
+
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -59,18 +61,32 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
               & P.getModuleDeclarations
               & filter (not . isPrimImport)
 
+          srcPosLine = fromIntegral _line + 1
+
           declAtPos =
             withoutPrim
-              & declAtLine (fromIntegral _line)
+              & declAtLine srcPosLine
+
+      let declNameAndLine d = (foldMap printName (declName d), P.sourcePosLine $ P.spanStart $ fst $ P.declSourceAnn d)
+
+      debugLsp $ "srcPosLine: " <> show srcPosLine
+
+      debugLsp $ "all decls: " <> show (declNameAndLine <$> sortBy (comparing declStartLine) withoutPrim)
 
-      forLsp declAtPos $ \decl ->
+
+      debugLsp $ "found decl at pos: " <> maybe "Nothing" (show . declNameAndLine) declAtPos
+
+      forLsp declAtPos $ \decl -> do
         let respondWithTypeLocation =
               forLsp (find (not . isNullSourceTypeSpan) $ getTypesAtPos pos decl) sourceTypeLocRes
-         in case head $ getExprsAtPos pos decl of
+
+            exprsAtPos = getExprsAtPos pos decl
+
+        debugLsp $ "exprs at pos: " <> show (length exprsAtPos)
+        case head exprsAtPos of
               Just expr -> do
-                debugLsp $ "expr: " <> show expr
                 case expr of
-                  P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do 
+                  P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
                     debugLsp $ "Var in source pos: " <> show srcPos
                     posRes filePath srcPos
                   P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 242cf92ef5..73e632d3f6 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -234,24 +234,24 @@ declSourceSpanWithExpr d = maybe span (widenSourceSpan span) exprSpan
     exprSpan = case d of
       P.ValueDeclaration (P.ValueDeclarationData {..}) ->
         let go acc (P.GuardedExpr _ e) =
-             case acc of 
-               Nothing -> findExprSourceSpan e
-               Just acc' -> widenSourceSpan acc' <$> findExprSourceSpan e
+              case acc of
+                Nothing -> findExprSourceSpan e
+                Just acc' -> widenSourceSpan acc' <$> findExprSourceSpan e
          in foldl' go Nothing valdeclExpression
       _ -> Nothing
 
-
 declAtLine :: Int -> [P.Declaration] -> Maybe P.Declaration
-declAtLine l (d:d':ds) 
-  | declStartLine d >= l && declStartLine d' < l = Just d
-  | otherwise = declAtLine l (d':ds)
-declAtLine l [d] | declStartLine d >= l = Just d
-declAtLine _ _ = Nothing 
+declAtLine l = go . sortBy (comparing declStartLine)
+  where
+    go (d : d' : ds)
+      | declStartLine d <= l && declStartLine d' > l = Just d
+      | otherwise = go (d' : ds)
+    go [d] | declStartLine d >= l = Just d
+    go _ = Nothing
 
 declStartLine :: P.Declaration -> Int
 declStartLine = P.sourcePosLine . AST.spanStart . P.declSourceSpan
 
-
 findExprSourceSpan :: P.Expr -> Maybe AST.SourceSpan
 findExprSourceSpan = goExpr
   where
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index ca87cc2e94..dc7c5863f9 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -87,7 +87,7 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
       conn
       (SQL.Query 
       "INSERT INTO ast_declarations \
-      \        (module_name, name, value, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
+      \         (module_name, name, value, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
       \ VALUES (:module_name, :name, :value, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := printName <$> name,

From e4cea7f6011dee8d5509a16949d3d0ffc34fab7a Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 13 Oct 2024 23:26:35 +0200
Subject: [PATCH 131/297] type definition via ast working

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 625 +++++++++++++++---
 1 file changed, 535 insertions(+), 90 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 079aaedbb2..2295d169f3 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -11,6 +11,7 @@ import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
+import Language.PureScript (declName)
 import Language.PureScript qualified as P
 import Language.PureScript.AST qualified as AST
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
@@ -24,10 +25,9 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceSpan, getNamesAtPosition, posInSpan, posInSpanLines, sourcePosToPosition, declStartLine)
+import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceSpan, getNamesAtPosition, posInSpan, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
-import Language.PureScript (declName)
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -40,7 +40,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       posRes fp srcPos = locationRes fp $ Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos)
 
-      sourceTypeLocRes st = locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
+      -- sourceTypeLocRes st = locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
 
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
@@ -71,39 +71,63 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       debugLsp $ "srcPosLine: " <> show srcPosLine
 
-      debugLsp $ "all decls: " <> show (declNameAndLine <$> sortBy (comparing declStartLine) withoutPrim)
-
-
       debugLsp $ "found decl at pos: " <> maybe "Nothing" (show . declNameAndLine) declAtPos
 
       forLsp declAtPos $ \decl -> do
-        let respondWithTypeLocation =
-              forLsp (find (not . isNullSourceTypeSpan) $ getTypesAtPos pos decl) sourceTypeLocRes
+        let respondWithTypeLocation = do
+              let tipes =
+                    filter isSingleLine $
+                      filter (not . fromPrim) $
+                      filter (not . isNullSourceTypeSpan) $
+                        getTypesAtPos pos decl
+              debugLsp $ "types at pos: " <> show tipes
+              case tipes of
+                [] -> nullRes
+                _ -> do
+                  let smallest = minimumBy (comparing getTypeColumns) tipes
+                  debugLsp $ "smallest: " <> show smallest
+                  case smallest of
+                    P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                    P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                      respondWithDeclInOtherModule (Just TyNameType) modName $ P.runProperName ident
+                    _ -> nullRes
+
+            -- forLsp (find (not . isNullSourceTypeSpan) $ getTypesAtPos pos decl) sourceTypeLocRes
 
             exprsAtPos = getExprsAtPos pos decl
 
         debugLsp $ "exprs at pos: " <> show (length exprsAtPos)
         case head exprsAtPos of
-              Just expr -> do
-                case expr of
-                  P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
-                    debugLsp $ "Var in source pos: " <> show srcPos
-                    posRes filePath srcPos
-                  P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                    debugLsp $ "Var in module: " <> show modName <> " " <> show ident
-                    respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
-                  P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                  P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                    respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
-                  P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                  P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                    respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
-                  _ -> respondWithTypeLocation
+          Just expr -> do
+            case expr of
+              P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
+                posRes filePath srcPos
+              P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
+              P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+              P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
+              P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+              P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
               _ -> respondWithTypeLocation
+          _ -> respondWithTypeLocation
 
 isNullSourceTypeSpan :: P.SourceType -> Bool
 isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
 
+isSingleLine :: P.SourceType -> Bool
+isSingleLine st = P.sourcePosLine (P.spanStart (fst (getAnnForType st))) == P.sourcePosLine (P.spanEnd (fst (getAnnForType st)))
+
+getTypeColumns :: P.SourceType -> Int
+getTypeColumns st = P.sourcePosColumn (P.spanEnd (fst (getAnnForType st))) - P.sourcePosColumn (P.spanStart (fst (getAnnForType st)))
+
+fromPrim :: P.SourceType -> Bool
+fromPrim st = case st of
+  P.TypeConstructor _ (P.Qualified (P.ByModuleName (P.ModuleName "Prim")) _) -> True
+  P.TypeOp _ (P.Qualified (P.ByModuleName (P.ModuleName "Prim")) _) -> True
+  _ -> False
+
 isPrimImport :: P.Declaration -> Bool
 isPrimImport (P.ImportDeclaration _ (P.ModuleName "Prim") _ _) = True
 isPrimImport (P.ImportDeclaration ss _ _ _) | ss == AST.nullSourceAnn = True
@@ -130,10 +154,10 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
       pure expr
 
 getTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
-getTypesAtPos pos decl = (view _1 $ P.accumTypes getAtPos) decl
+getTypesAtPos pos decl = P.everythingOnTypes (<>) getAtPos =<< (view _1 $ P.accumTypes getAtPos) decl
   where
     getAtPos :: P.SourceType -> [P.SourceType]
-    getAtPos st = [st | posInSpanLines pos (fst $ getAnnForType st)]
+    getAtPos st = [st | posInSpan pos (fst $ getAnnForType st)]
 
 definitionHandlerV1 :: Server.Handlers HandlerM
 definitionHandlerV1 = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -198,76 +222,497 @@ definitionHandlerV1 = Server.requestHandler Message.SMethod_TextDocumentDefiniti
 --   , spanEnd = SourcePos {sourcePosLine = 107, sourcePosColumn = 82}},[]) (ModuleName "Prim") Implicit (Just (ModuleName "Prim")),ImportDeclaration (SourceSpan { spanStart = SourcePos {sourcePosLine = 1, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 107, sourcePosColumn = 82}},[]) (ModuleName "Prim") Implicit Nothing,ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}},[]), valdeclIdent = Ident "v", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (TypedValue True (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) [] (Let FromWhere [ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}},[]), valdeclIdent = Ident "a", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}) [] (Literal (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}) (NumericLiteral (Left 1))))]})] (TypedValue True (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) [] (Var (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) (Qualified (BySourcePos (SourcePos {sourcePosLine = 77, sourcePosColumn = 3})) (Ident "a")))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))))]})]
 
 -- x =
---   [ ValueDeclaration
---       ( ValueDeclarationData
---           { valdeclSourceAnn =
+--   [ ForAll
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 6},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--           },
+--         []
+--       )
+--       TypeVarInvisible
+--       "a"
+--       (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))
+--       (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}}, []) "a"))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 28}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}}, []) "a"))
+--       (Just (SkolemScope {runSkolemScope = 1})),
+--     TypeApp
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--           },
+--         []
+--       )
+--       ( TypeApp
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--               },
+--             []
+--           )
+--           (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"})))
+--           ( TypeApp
 --               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 1},
---                     spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                     spanEnd =
+--                       SourcePos
+--                         { sourcePosLine = 20,
+--                           sourcePosColumn = 24
+--                         }
 --                   },
 --                 []
---               ),
---             valdeclIdent = Ident "v",
---             valdeclName = Public,
---             valdeclBinders = [],
---             valdeclExpression =
---               [ GuardedExpr
---                   []
---                   ( TypedValue
---                       True
---                       ( PositionedValue
---                           ( SourceSpan {spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}
---                           )
---                           []
---                           ( Let
---                               FromWhere
---                               [ ValueDeclaration
---                                   ( ValueDeclarationData
---                                       { valdeclSourceAnn = (SourceSpan {spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}, []),
---                                         valdeclIdent = Ident "a",
---                                         valdeclName = Public,
---                                         valdeclBinders = [],
---                                         valdeclExpression =
---                                           [ GuardedExpr
---                                               []
---                                               ( PositionedValue
---                                                   ( SourceSpan
---                                                       { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7},
---                                                         spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}
---                                                       }
---                                                   )
---                                                   []
---                                                   ( Literal
---                                                       ( SourceSpan
---                                                           { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7},
---                                                             spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}
---                                                           }
---                                                       )
---                                                       (NumericLiteral (Left 1))
---                                                   )
---                                               )
---                                           ]
---                                       }
---                                   )
---                               ]
---                               ( TypedValue
---                                   True
---                                   ( PositionedValue
---                                       ( SourceSpan
---                                           { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5},
---                                             spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}
---                                           }
---                                       )
---                                       []
---                                       (Var (SourceSpan {spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) (Qualified (BySourcePos (SourcePos {sourcePosLine = 77, sourcePosColumn = 3})) (Ident "a")))
---                                   )
---                                   (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
---                               )
+--               )
+--               (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})))
+--               ( Skolem
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
+--                         spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
+--                       },
+--                     []
+--                   )
+--                   "a"
+--                   (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))
+--                   0
+--                   (SkolemScope {runSkolemScope = 1})
+--               )
+--           )
+--       )
+--       ( Skolem
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
+--                 spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
+--               },
+--             []
+--           )
+--           "a"
+--           (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))
+--           0
+--           (SkolemScope {runSkolemScope = 1})
+--       )
+--   ]
+
+-- x =
+--   [ ForAll
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 6},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--           },
+--         []
+--       )
+--       TypeVarInvisible
+--       "a"
+--       ( Just
+--           ( TypeConstructor
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                   },
+--                 []
+--               )
+--               (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
+--           )
+--       )
+--       ( TypeApp
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--               },
+--             []
+--           )
+--           ( TypeApp
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--                   },
+--                 []
+--               )
+--               ( TypeConstructor
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
+--                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
+--                       },
+--                     []
+--                   )
+--                   (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
+--               )
+--               ( TypeApp
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--                       },
+--                     []
+--                   )
+--                   ( TypeConstructor
+--                       ( SourceSpan
+--                           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                           },
+--                         []
+--                       )
+--                       (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
+--                   )
+--                   ( TypeVar
+--                       ( SourceSpan
+--                           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
+--                             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--                           },
+--                         []
+--                       )
+--                       "a"
+--                   )
+--               )
+--           )
+--           ( TypeVar
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 28},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--                   },
+--                 []
+--               )
+--               "a"
+--           )
+--       )
+--       (Just (SkolemScope {runSkolemScope = 1})),
+--     TypeConstructor
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--           },
+--         []
+--       )
+--       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})),
+--     TypeApp
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--           },
+--         []
+--       )
+--       ( TypeApp
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--               },
+--             []
+--           )
+--           ( TypeConstructor
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
+--                   },
+--                 []
+--               )
+--               (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
+--           )
+--           ( TypeApp
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--                   },
+--                 []
+--               )
+--               ( TypeConstructor
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                       },
+--                     []
+--                   )
+--                   (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
+--               )
+--               ( TypeVar
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
+--                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--                       },
+--                     []
+--                   )
+--                   "a"
+--               )
+--           )
+--       )
+--       ( TypeVar
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 28},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--               },
+--             []
+--           )
+--           "a"
+--       ),
+--     TypeApp
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--           },
+--         []
+--       )
+--       ( TypeConstructor
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
+--               },
+--             []
+--           )
+--           (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
+--       )
+--       ( TypeApp
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--               },
+--             []
+--           )
+--           ( TypeConstructor
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                   },
+--                 []
+--               )
+--               (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
+--           )
+--           ( TypeVar
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--                   },
+--                 []
+--               )
+--               "a"
+--           )
+--       ),
+--     TypeApp
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--           },
+--         []
+--       )
+--       ( TypeConstructor
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--               },
+--             []
+--           )
+--           (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
+--       )
+--       ( TypeVar
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--               },
+--             []
+--           )
+--           "a"
+--       ),
+--     TypeConstructor
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--           },
+--         []
+--       )
+--       (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})),
+--     TypeApp
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--           },
+--         []
+--       )
+--       ( TypeApp
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--               },
+--             []
+--           )
+--           ( TypeConstructor
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
+--                   },
+--                 []
+--               )
+--               (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
+--           )
+--           ( TypeApp
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--                   },
+--                 []
+--               )
+--               ( TypeConstructor
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                       },
+--                     []
+--                   )
+--                   (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
+--               )
+--               ( Skolem
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
+--                         spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
+--                       },
+--                     []
+--                   )
+--                   "a"
+--                   ( Just
+--                       ( TypeConstructor
+--                           ( SourceSpan
+--                               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                               },
+--                             []
 --                           )
+--                           (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
+--                       )
+--                   )
+--                   0
+--                   (SkolemScope {runSkolemScope = 1})
+--               )
+--           )
+--       )
+--       ( Skolem
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
+--                 spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
+--               },
+--             []
+--           )
+--           "a"
+--           ( Just
+--               ( TypeConstructor
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                       },
+--                     []
+--                   )
+--                   (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
+--               )
+--           )
+--           0
+--           (SkolemScope {runSkolemScope = 1})
+--       ),
+--     TypeApp
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
+--           },
+--         []
+--       )
+--       ( TypeConstructor
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
+--               },
+--             []
+--           )
+--           (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
+--       )
+--       ( TypeApp
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--               },
+--             []
+--           )
+--           ( TypeConstructor
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                   },
+--                 []
+--               )
+--               (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
+--           )
+--           ( Skolem
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
+--                     spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
+--                   },
+--                 []
+--               )
+--               "a"
+--               ( Just
+--                   ( TypeConstructor
+--                       ( SourceSpan
+--                           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                           },
+--                         []
 --                       )
---                       (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
+--                       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
 --                   )
---               ]
---           }
+--               )
+--               0
+--               (SkolemScope {runSkolemScope = 1})
+--           )
+--       ),
+--     TypeApp
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
+--           },
+--         []
+--       )
+--       ( TypeConstructor
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--               },
+--             []
+--           )
+--           (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
+--       )
+--       ( Skolem
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
+--                 spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
+--               },
+--             []
+--           )
+--           "a"
+--           ( Just
+--               ( TypeConstructor
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--                       },
+--                     []
+--                   )
+--                   (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
+--               )
+--           )
+--           0
+--           (SkolemScope {runSkolemScope = 1})
+--       ),
+--     TypeConstructor
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--           },
+--         []
+--       )
+--       (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})),
+--     TypeConstructor
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--           },
+--         []
+--       )
+--       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})),
+--     TypeConstructor
+--       ( SourceSpan
+--           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
+--             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
+--           },
+--         []
 --       )
+--       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
 --   ]
\ No newline at end of file

From f3d7018895b780c918085103639c4e75e4df7bdb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 13 Oct 2024 23:51:37 +0200
Subject: [PATCH 132/297] adds type var lookups

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 530 +-----------------
 1 file changed, 23 insertions(+), 507 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 2295d169f3..b9f0835b63 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -40,7 +40,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       posRes fp srcPos = locationRes fp $ Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos)
 
-      -- sourceTypeLocRes st = locationRes (AST.spanName $ fst $ getAnnForType st) $ spanToRange $ fst $ getAnnForType st
+      -- spanRes fp srcSpan = locationRes fp $ spanToRange srcSpan
 
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
@@ -76,24 +76,33 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       forLsp declAtPos $ \decl -> do
         let respondWithTypeLocation = do
               let tipes =
-                    filter isSingleLine $
-                      filter (not . fromPrim) $
+                    filter (not . fromPrim) $
                       filter (not . isNullSourceTypeSpan) $
                         getTypesAtPos pos decl
+
+                  onOneLine = filter isSingleLine tipes
               debugLsp $ "types at pos: " <> show tipes
-              case tipes of
+              case onOneLine of
                 [] -> nullRes
                 _ -> do
-                  let smallest = minimumBy (comparing getTypeColumns) tipes
+                  let smallest = minimumBy (comparing getTypeColumns) onOneLine
                   debugLsp $ "smallest: " <> show smallest
                   case smallest of
                     P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
                     P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
                       respondWithDeclInOtherModule (Just TyNameType) modName $ P.runProperName ident
+                    P.TypeOp _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                    P.TypeOp _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                      respondWithDeclInOtherModule (Just TyOpNameType) modName $ P.runOpName ident
+                    P.ConstrainedType _ c _ -> case P.constraintClass c of
+                      (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
+                      (P.Qualified (P.ByModuleName modName) ident) -> do
+                        respondWithDeclInOtherModule (Just TyClassNameType) modName $ P.runProperName ident
+                    P.TypeVar _ name -> case findForallSpan name tipes of
+                      Just srcSpan -> posRes filePath (P.spanStart srcSpan)
+                      _ -> nullRes
                     _ -> nullRes
 
-            -- forLsp (find (not . isNullSourceTypeSpan) $ getTypesAtPos pos decl) sourceTypeLocRes
-
             exprsAtPos = getExprsAtPos pos decl
 
         debugLsp $ "exprs at pos: " <> show (length exprsAtPos)
@@ -133,6 +142,12 @@ isPrimImport (P.ImportDeclaration _ (P.ModuleName "Prim") _ _) = True
 isPrimImport (P.ImportDeclaration ss _ _ _) | ss == AST.nullSourceAnn = True
 isPrimImport _ = False
 
+findForallSpan :: Text -> [P.SourceType] -> Maybe P.SourceSpan
+findForallSpan _ [] = Nothing
+findForallSpan var (P.ForAll ss _ fa _ _ _ : rest) =
+  if fa == var then Just (fst ss) else findForallSpan var rest
+findForallSpan var (_ : rest) = findForallSpan var rest
+
 spanToRange :: AST.SourceSpan -> Types.Range
 spanToRange (AST.SourceSpan _ start end) =
   Types.Range
@@ -216,503 +231,4 @@ definitionHandlerV1 = Server.requestHandler Message.SMethod_TextDocumentDefiniti
                         locationRes modFp (spanToRange sourceSpan)
                   P.BySourcePos srcPos ->
                     locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-              _ -> nullRes
-
--- t = [ ImportDeclaration (SourceSpan { spanStart = SourcePos {sourcePosLine = 1, sourcePosColumn = 1}
---   , spanEnd = SourcePos {sourcePosLine = 107, sourcePosColumn = 82}},[]) (ModuleName "Prim") Implicit (Just (ModuleName "Prim")),ImportDeclaration (SourceSpan { spanStart = SourcePos {sourcePosLine = 1, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 107, sourcePosColumn = 82}},[]) (ModuleName "Prim") Implicit Nothing,ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}},[]), valdeclIdent = Ident "v", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (TypedValue True (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) [] (Let FromWhere [ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}},[]), valdeclIdent = Ident "a", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}) [] (Literal (SourceSpan { spanStart = SourcePos {sourcePosLine = 77, sourcePosColumn = 7}, spanEnd = SourcePos {sourcePosLine = 77, sourcePosColumn = 8}}) (NumericLiteral (Left 1))))]})] (TypedValue True (PositionedValue (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) [] (Var (SourceSpan { spanStart = SourcePos {sourcePosLine = 75, sourcePosColumn = 5}, spanEnd = SourcePos {sourcePosLine = 75, sourcePosColumn = 6}}) (Qualified (BySourcePos (SourcePos {sourcePosLine = 77, sourcePosColumn = 3})) (Ident "a")))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))))) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},[]) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))))]})]
-
--- x =
---   [ ForAll
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 6},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---           },
---         []
---       )
---       TypeVarInvisible
---       "a"
---       (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))
---       (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}}, []) "a"))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 28}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}}, []) "a"))
---       (Just (SkolemScope {runSkolemScope = 1})),
---     TypeApp
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---           },
---         []
---       )
---       ( TypeApp
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---               },
---             []
---           )
---           (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"})))
---           ( TypeApp
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                     spanEnd =
---                       SourcePos
---                         { sourcePosLine = 20,
---                           sourcePosColumn = 24
---                         }
---                   },
---                 []
---               )
---               (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})))
---               ( Skolem
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
---                         spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
---                       },
---                     []
---                   )
---                   "a"
---                   (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))
---                   0
---                   (SkolemScope {runSkolemScope = 1})
---               )
---           )
---       )
---       ( Skolem
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
---                 spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
---               },
---             []
---           )
---           "a"
---           (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))
---           0
---           (SkolemScope {runSkolemScope = 1})
---       )
---   ]
-
--- x =
---   [ ForAll
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 6},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---           },
---         []
---       )
---       TypeVarInvisible
---       "a"
---       ( Just
---           ( TypeConstructor
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                   },
---                 []
---               )
---               (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
---           )
---       )
---       ( TypeApp
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---               },
---             []
---           )
---           ( TypeApp
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---                   },
---                 []
---               )
---               ( TypeConstructor
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
---                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
---                       },
---                     []
---                   )
---                   (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
---               )
---               ( TypeApp
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---                       },
---                     []
---                   )
---                   ( TypeConstructor
---                       ( SourceSpan
---                           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                           },
---                         []
---                       )
---                       (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
---                   )
---                   ( TypeVar
---                       ( SourceSpan
---                           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
---                             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---                           },
---                         []
---                       )
---                       "a"
---                   )
---               )
---           )
---           ( TypeVar
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 28},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---                   },
---                 []
---               )
---               "a"
---           )
---       )
---       (Just (SkolemScope {runSkolemScope = 1})),
---     TypeConstructor
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---           },
---         []
---       )
---       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})),
---     TypeApp
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---           },
---         []
---       )
---       ( TypeApp
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---               },
---             []
---           )
---           ( TypeConstructor
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
---                   },
---                 []
---               )
---               (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
---           )
---           ( TypeApp
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---                   },
---                 []
---               )
---               ( TypeConstructor
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                       },
---                     []
---                   )
---                   (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
---               )
---               ( TypeVar
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
---                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---                       },
---                     []
---                   )
---                   "a"
---               )
---           )
---       )
---       ( TypeVar
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 28},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---               },
---             []
---           )
---           "a"
---       ),
---     TypeApp
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---           },
---         []
---       )
---       ( TypeConstructor
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
---               },
---             []
---           )
---           (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
---       )
---       ( TypeApp
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---               },
---             []
---           )
---           ( TypeConstructor
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                   },
---                 []
---               )
---               (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
---           )
---           ( TypeVar
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---                   },
---                 []
---               )
---               "a"
---           )
---       ),
---     TypeApp
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---           },
---         []
---       )
---       ( TypeConstructor
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---               },
---             []
---           )
---           (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
---       )
---       ( TypeVar
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 23},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---               },
---             []
---           )
---           "a"
---       ),
---     TypeConstructor
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---           },
---         []
---       )
---       (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})),
---     TypeApp
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---           },
---         []
---       )
---       ( TypeApp
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---               },
---             []
---           )
---           ( TypeConstructor
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
---                   },
---                 []
---               )
---               (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
---           )
---           ( TypeApp
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---                   },
---                 []
---               )
---               ( TypeConstructor
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                       },
---                     []
---                   )
---                   (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
---               )
---               ( Skolem
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
---                         spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
---                       },
---                     []
---                   )
---                   "a"
---                   ( Just
---                       ( TypeConstructor
---                           ( SourceSpan
---                               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                               },
---                             []
---                           )
---                           (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
---                       )
---                   )
---                   0
---                   (SkolemScope {runSkolemScope = 1})
---               )
---           )
---       )
---       ( Skolem
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
---                 spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
---               },
---             []
---           )
---           "a"
---           ( Just
---               ( TypeConstructor
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                       },
---                     []
---                   )
---                   (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
---               )
---           )
---           0
---           (SkolemScope {runSkolemScope = 1})
---       ),
---     TypeApp
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 29}
---           },
---         []
---       )
---       ( TypeConstructor
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 25},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 27}
---               },
---             []
---           )
---           (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
---       )
---       ( TypeApp
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---               },
---             []
---           )
---           ( TypeConstructor
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                     spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                   },
---                 []
---               )
---               (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
---           )
---           ( Skolem
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
---                     spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
---                   },
---                 []
---               )
---               "a"
---               ( Just
---                   ( TypeConstructor
---                       ( SourceSpan
---                           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                           },
---                         []
---                       )
---                       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
---                   )
---               )
---               0
---               (SkolemScope {runSkolemScope = 1})
---           )
---       ),
---     TypeApp
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 24}
---           },
---         []
---       )
---       ( TypeConstructor
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                 spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---               },
---             []
---           )
---           (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))
---       )
---       ( Skolem
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 21, sourcePosColumn = 5},
---                 spanEnd = SourcePos {sourcePosLine = 21, sourcePosColumn = 24}
---               },
---             []
---           )
---           "a"
---           ( Just
---               ( TypeConstructor
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---                         spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---                       },
---                     []
---                   )
---                   (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
---               )
---           )
---           0
---           (SkolemScope {runSkolemScope = 1})
---       ),
---     TypeConstructor
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---           },
---         []
---       )
---       (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})),
---     TypeConstructor
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---           },
---         []
---       )
---       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})),
---     TypeConstructor
---       ( SourceSpan
---           { spanStart = SourcePos {sourcePosLine = 20, sourcePosColumn = 16},
---             spanEnd = SourcePos {sourcePosLine = 20, sourcePosColumn = 22}
---           },
---         []
---       )
---       (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
---   ]
\ No newline at end of file
+              _ -> nullRes
\ No newline at end of file

From 77419c8c48f45f9adec70611ad50534cfd793827 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 00:15:17 +0200
Subject: [PATCH 133/297] adds import defintions

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 122 +++++++++++-------
 1 file changed, 74 insertions(+), 48 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index b9f0835b63..9b79db0669 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -40,8 +40,6 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       posRes fp srcPos = locationRes fp $ Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos)
 
-      -- spanRes fp srcSpan = locationRes fp $ spanToRange srcSpan
-
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
@@ -51,6 +49,29 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
         forLsp (head declSpans) $ \sourceSpan ->
           locationRes (AST.spanName sourceSpan) (spanToRange sourceSpan)
 
+      respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
+      respondWithModule ss modName =
+        if posInSpan pos ss
+          then do
+            modFpMb <- selectExternPathFromModuleName modName
+            forLsp modFpMb \modFp -> do
+              posRes modFp $ P.SourcePos 1 1
+          else nullRes
+
+      respondWithImports ss importedModuleName imports = do
+        case find (posInSpan pos . P.declRefSourceSpan) imports of
+          Just import' -> do
+            let name = P.declRefName import'
+                nameType = case import' of
+                  P.TypeClassRef _ _ -> Just TyClassNameType
+                  P.TypeRef _ _ _ -> Just TyNameType
+                  P.TypeOpRef _ _ -> Just TyOpNameType
+                  P.ValueRef _ _ -> Just IdentNameType
+                  P.ValueOpRef _ _ -> Just ValOpNameType
+                  _ -> Nothing
+            respondWithDeclInOtherModule nameType importedModuleName (printName name)
+          _ -> respondWithModule ss importedModuleName
+
   debugLsp $ "Position: " <> show pos
 
   forLsp filePathMb \filePath -> do
@@ -74,53 +95,58 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       debugLsp $ "found decl at pos: " <> maybe "Nothing" (show . declNameAndLine) declAtPos
 
       forLsp declAtPos $ \decl -> do
-        let respondWithTypeLocation = do
-              let tipes =
-                    filter (not . fromPrim) $
-                      filter (not . isNullSourceTypeSpan) $
-                        getTypesAtPos pos decl
-
-                  onOneLine = filter isSingleLine tipes
-              debugLsp $ "types at pos: " <> show tipes
-              case onOneLine of
-                [] -> nullRes
-                _ -> do
-                  let smallest = minimumBy (comparing getTypeColumns) onOneLine
-                  debugLsp $ "smallest: " <> show smallest
-                  case smallest of
-                    P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                    P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                      respondWithDeclInOtherModule (Just TyNameType) modName $ P.runProperName ident
-                    P.TypeOp _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                    P.TypeOp _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                      respondWithDeclInOtherModule (Just TyOpNameType) modName $ P.runOpName ident
-                    P.ConstrainedType _ c _ -> case P.constraintClass c of
-                      (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
-                      (P.Qualified (P.ByModuleName modName) ident) -> do
-                        respondWithDeclInOtherModule (Just TyClassNameType) modName $ P.runProperName ident
-                    P.TypeVar _ name -> case findForallSpan name tipes of
-                      Just srcSpan -> posRes filePath (P.spanStart srcSpan)
-                      _ -> nullRes
-                    _ -> nullRes
-
-            exprsAtPos = getExprsAtPos pos decl
-
-        debugLsp $ "exprs at pos: " <> show (length exprsAtPos)
-        case head exprsAtPos of
-          Just expr -> do
-            case expr of
-              P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
-                posRes filePath srcPos
-              P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
-              P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-              P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
-              P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-              P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
+        case decl of
+          P.ImportDeclaration (ss, _) importedModuleName importType _ -> do 
+            debugLsp $ "found import at pos: " <> show importedModuleName
+            case importType of
+              P.Implicit -> respondWithModule ss importedModuleName
+              P.Explicit imports -> respondWithImports ss importedModuleName imports
+              P.Hiding imports -> respondWithImports ss importedModuleName imports
+          _ -> do
+            let respondWithTypeLocation = do
+                  let tipes =
+                        filter (not . fromPrim) $
+                          filter (not . isNullSourceTypeSpan) $
+                            getTypesAtPos pos decl
+
+                      onOneLine = filter isSingleLine tipes
+                  case onOneLine of
+                    [] -> nullRes
+                    _ -> do
+                      let smallest = minimumBy (comparing getTypeColumns) onOneLine
+                      case smallest of
+                        P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                        P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                          respondWithDeclInOtherModule (Just TyNameType) modName $ P.runProperName ident
+                        P.TypeOp _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                        P.TypeOp _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                          respondWithDeclInOtherModule (Just TyOpNameType) modName $ P.runOpName ident
+                        P.ConstrainedType _ c _ -> case P.constraintClass c of
+                          (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
+                          (P.Qualified (P.ByModuleName modName) ident) -> do
+                            respondWithDeclInOtherModule (Just TyClassNameType) modName $ P.runProperName ident
+                        P.TypeVar _ name -> case findForallSpan name tipes of
+                          Just srcSpan -> posRes filePath (P.spanStart srcSpan)
+                          _ -> nullRes
+                        _ -> nullRes
+
+                exprsAtPos = getExprsAtPos pos decl
+
+            case head exprsAtPos of
+              Just expr -> do
+                case expr of
+                  P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
+                    posRes filePath srcPos
+                  P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                    respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
+                  P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                  P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                    respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
+                  P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                  P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
+                    respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
+                  _ -> respondWithTypeLocation
               _ -> respondWithTypeLocation
-          _ -> respondWithTypeLocation
 
 isNullSourceTypeSpan :: P.SourceType -> Bool
 isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])

From 3c9f9638170a148988053bdfec95f926053b6fc1 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 01:40:52 +0200
Subject: [PATCH 134/297] adds type for imports without docs

---
 src/Language/PureScript/Lsp/Cache/Query.hs    |  16 +++
 src/Language/PureScript/Lsp/Docs.hs           |  37 ++++-
 .../PureScript/Lsp/Handlers/Definition.hs     | 103 ++++----------
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 132 +++++++++++++-----
 4 files changed, 168 insertions(+), 120 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 6b973cd8ac..a008e6c7ce 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -146,6 +146,22 @@ getAstDeclarationLocationInModule lspNameType moduleName' name = do
       ]
   pure $ decls <&> \(spanName, sl, sc, el, ec) -> P.SourceSpan spanName (SourcePos sl sc) (SourcePos el ec)
 
+getAstDeclarationTypeInModule :: (MonadIO m, MonadReader LspEnvironment m) => Maybe LspNameType -> P.ModuleName -> Text -> m [Text]
+getAstDeclarationTypeInModule lspNameType moduleName' name = do
+  decls :: [SQL.Only Text] <-
+    DB.queryNamed
+      "SELECT printed_type \
+      \FROM ast_declarations \
+      \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
+      \WHERE ast_declarations.module_name = :module_name \
+      \AND name = :name \
+      \AND name_type IS :name_type"
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := name,
+        ":name_type" := (map show lspNameType :: Maybe Text)
+      ]
+  pure $ decls <&> fromOnly
+
 -- pure $ deserialise . fromOnly <$> listToMaybe decls
 
 getAstDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> SourcePos -> m [P.Declaration]
diff --git a/src/Language/PureScript/Lsp/Docs.hs b/src/Language/PureScript/Lsp/Docs.hs
index faa6737a5b..39f8da846f 100644
--- a/src/Language/PureScript/Lsp/Docs.hs
+++ b/src/Language/PureScript/Lsp/Docs.hs
@@ -1,22 +1,53 @@
 module Language.PureScript.Lsp.Docs where
 
 import Control.Arrow ((>>>))
+import Language.PureScript.AST.SourcePos qualified as P
 import Language.PureScript.Docs qualified as Docs
 import Language.PureScript.Docs.AsMarkdown (declAsMarkdown, runDocs)
 import Language.PureScript.Docs.Collect (parseDocsJsonFile)
 import Language.PureScript.Docs.Types qualified as P
+import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig))
 import Language.PureScript.Names qualified as P
 import Protolude
-import Language.PureScript.AST.SourcePos qualified as P
+
+readModuleDocs :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m (Maybe Docs.Module)
+readModuleDocs modName = do
+  outputDirectory <- asks (confOutputPath . lspConfig)
+  liftIO $ catchError (Just <$> parseDocsJsonFile outputDirectory modName) (const $ pure Nothing)
 
 readDeclarationDocs :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Docs.Declaration)
 readDeclarationDocs modName ident = do
-  outputDirectory <- asks (confOutputPath . lspConfig)
-  modMb <- liftIO $ catchError (Just <$> parseDocsJsonFile outputDirectory modName) (const $ pure Nothing)
+  modMb <- readModuleDocs modName
   pure $ modMb >>= (P.modDeclarations >>> find ((== ident) . P.declTitle))
 
+
+-- todo: add child info and operator matching
+readDeclarationDocsWithNameType :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> LspNameType -> Text -> m (Maybe Text)
+readDeclarationDocsWithNameType modName nameType ident = do
+  modMb <- readModuleDocs modName
+  pure $ modMb >>= (P.modDeclarations >>> getMarkdown)
+  where
+    getMarkdown :: [Docs.Declaration] -> Maybe Text
+    getMarkdown [] = Nothing
+    getMarkdown (decl : decls) = case decl of
+      _ | P.declTitle decl == ident && matchesNameType decl -> Just $ runDocs $ declAsMarkdown decl
+      _ -> getMarkdown decls
+
+    matchesNameType :: P.Declaration -> Bool
+    matchesNameType d = case P.declInfo d of
+      P.ValueDeclaration _ -> nameType == IdentNameType
+      P.DataDeclaration _ _ _ -> nameType == TyNameType
+      P.TypeSynonymDeclaration _ _ -> nameType == TyNameType
+      P.TypeClassDeclaration _ _ _ -> nameType == TyClassNameType
+      _ -> False
+
+-- matches
+-- if P.declTitle decl == ident && P.declNameType decl == Just nameType
+--   then Just $ runDocs $ declAsMarkdown decl
+--   else getMarkdown decls
+
 readDeclarationDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Text)
 readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$> readDeclarationDocs modName ident
 
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 9b79db0669..6680f33ef2 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -5,27 +5,22 @@
 module Language.PureScript.Lsp.Handlers.Definition where
 
 import Control.Lens (Field1 (_1), view, (^.))
-import Control.Lens.Getter (to)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
-import Language.LSP.VFS qualified as VFS
 import Language.PureScript (declName)
 import Language.PureScript qualified as P
-import Language.PureScript.AST qualified as AST
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
-import Language.PureScript.CoreFn.Expr qualified as CF
-import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath, selectExternPathFromModuleName)
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule, getAstDeclarationLocationInModule, getCoreFnExprAt, getEfDeclarationInModule)
-import Language.PureScript.Lsp.Docs (readQualifiedNameDocsSourceSpan)
+import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceSpan, getNamesAtPosition, posInSpan, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
 
@@ -47,7 +42,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       respondWithDeclInOtherModule nameType modName ident = do
         declSpans <- getAstDeclarationLocationInModule nameType modName ident
         forLsp (head declSpans) $ \sourceSpan ->
-          locationRes (AST.spanName sourceSpan) (spanToRange sourceSpan)
+          locationRes (P.spanName sourceSpan) (spanToRange sourceSpan)
 
       respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
       respondWithModule ss modName =
@@ -59,16 +54,11 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
           else nullRes
 
       respondWithImports ss importedModuleName imports = do
-        case find (posInSpan pos . P.declRefSourceSpan) imports of
+        case findDeclRefAtPos pos imports of
           Just import' -> do
             let name = P.declRefName import'
-                nameType = case import' of
-                  P.TypeClassRef _ _ -> Just TyClassNameType
-                  P.TypeRef _ _ _ -> Just TyNameType
-                  P.TypeOpRef _ _ -> Just TyOpNameType
-                  P.ValueRef _ _ -> Just IdentNameType
-                  P.ValueOpRef _ _ -> Just ValOpNameType
-                  _ -> Nothing
+                nameType = getImportRefNameType import'
+            
             respondWithDeclInOtherModule nameType importedModuleName (printName name)
           _ -> respondWithModule ss importedModuleName
 
@@ -165,7 +155,7 @@ fromPrim st = case st of
 
 isPrimImport :: P.Declaration -> Bool
 isPrimImport (P.ImportDeclaration _ (P.ModuleName "Prim") _ _) = True
-isPrimImport (P.ImportDeclaration ss _ _ _) | ss == AST.nullSourceAnn = True
+isPrimImport (P.ImportDeclaration ss _ _ _) | ss == P.nullSourceAnn = True
 isPrimImport _ = False
 
 findForallSpan :: Text -> [P.SourceType] -> Maybe P.SourceSpan
@@ -174,8 +164,8 @@ findForallSpan var (P.ForAll ss _ fa _ _ _ : rest) =
   if fa == var then Just (fst ss) else findForallSpan var rest
 findForallSpan var (_ : rest) = findForallSpan var rest
 
-spanToRange :: AST.SourceSpan -> Types.Range
-spanToRange (AST.SourceSpan _ start end) =
+spanToRange :: P.SourceSpan -> Types.Range
+spanToRange (P.SourceSpan _ start end) =
   Types.Range
     (sourcePosToPosition start)
     (sourcePosToPosition end)
@@ -188,7 +178,7 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
 
     (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
 
-    handleExpr :: AST.Expr -> StateT [P.Expr] Identity AST.Expr
+    handleExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
     handleExpr expr = do
       when (maybe False (posInSpan pos) (P.exprSourceSpan expr)) do
         modify (expr :)
@@ -200,61 +190,16 @@ getTypesAtPos pos decl = P.everythingOnTypes (<>) getAtPos =<< (view _1 $ P.accu
     getAtPos :: P.SourceType -> [P.SourceType]
     getAtPos st = [st | posInSpan pos (fst $ getAnnForType st)]
 
-definitionHandlerV1 :: Server.Handlers HandlerM
-definitionHandlerV1 = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-  let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
-      filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-      uri :: Types.NormalizedUri
-      uri =
-        req
-          ^. LSP.params
-            . LSP.textDocument
-            . LSP.uri
-            . to Types.toNormalizedUri
-
-      nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
-
-      locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
-
-      forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
-      forLsp val f = maybe nullRes f val
-  forLsp filePathMb \filePath -> do
-    vfMb <- Server.getVirtualFile uri
-    forLsp vfMb \vf -> do
-      mNameMb <- selectExternModuleNameFromFilePath filePath
-      forLsp mNameMb \mName -> do
-        names <- getNamesAtPosition pos mName (VFS._file_text vf)
-
-        case head names of
-          Just name -> do
-            spanMb <- readQualifiedNameDocsSourceSpan name
-            case spanMb of
-              _ -> do
-                case name of
-                  P.Qualified (P.BySourcePos pos') _ -> do
-                    locationRes filePath (Types.Range (sourcePosToPosition pos') (sourcePosToPosition pos'))
-                  P.Qualified (P.ByModuleName nameModule) ident -> do
-                    declMb <- getAstDeclarationInModule nameModule (printName ident)
-                    forLsp declMb \decl -> do
-                      modFpMb <- selectExternPathFromModuleName nameModule
-                      forLsp modFpMb \modFp -> do
-                        let sourceSpan = P.declSourceSpan decl
-                        locationRes modFp (spanToRange sourceSpan)
-              Just span ->
-                locationRes (P.spanName span) (spanToRange span)
-          _ -> do
-            corefnExprMb <- getCoreFnExprAt filePath pos
-            case corefnExprMb of
-              Just (CF.Var (_ss, _comments, _meta) (P.Qualified qb ident)) -> do
-                let name = P.runIdent ident
-                case qb of
-                  P.ByModuleName coreMName -> do
-                    declMb <- getEfDeclarationInModule coreMName name
-                    forLsp declMb \decl -> do
-                      modFpMb <- selectExternPathFromModuleName coreMName
-                      forLsp modFpMb \modFp -> do
-                        let sourceSpan = efDeclSourceSpan decl
-                        locationRes modFp (spanToRange sourceSpan)
-                  P.BySourcePos srcPos ->
-                    locationRes filePath (Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos))
-              _ -> nullRes
\ No newline at end of file
+findDeclRefAtPos :: Foldable t => Types.Position -> t P.DeclarationRef -> Maybe P.DeclarationRef
+findDeclRefAtPos pos imports = find (posInSpan pos . P.declRefSourceSpan) imports
+
+getImportRefNameType :: P.DeclarationRef -> Maybe LspNameType
+getImportRefNameType = \case
+  P.TypeClassRef _ _ -> Just TyClassNameType
+  P.TypeRef _ _ _ -> Just TyNameType
+  P.TypeOpRef _ _ -> Just TyOpNameType
+  P.ValueRef _ _ -> Just IdentNameType
+  P.ValueOpRef _ _ -> Just ValOpNameType
+  P.ModuleRef _ _ -> Just ModNameType
+  P.ReExportRef _ _ _ -> Just ModNameType
+  _ -> Nothing
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 5f1bc1dcee..0712caf1a7 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -9,30 +9,100 @@ module Language.PureScript.Lsp.Handlers.Hover where
 import Control.Lens ((^.))
 import Control.Lens.Getter (to)
 import Data.Set qualified as Set
+import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
+import Language.PureScript.AST.Declarations (Expr (..))
+import Language.PureScript.AST.Traversals (everythingWithContextOnValues)
 import Language.PureScript.CoreFn.Expr qualified as CF
+import Language.PureScript.CoreFn.Module (Module (moduleComments))
 import Language.PureScript.Docs.Convert.Single (convertComments)
+import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
-import Language.PureScript.Lsp.Cache.Query (getCoreFnExprAt, getEfDeclarationInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readQualifiedNameDocsAsMarkdown)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule, getAstDeclarationTypeInModule, getCoreFnExprAt, getEfDeclarationInModule)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readModuleDocs, readQualifiedNameDocsAsMarkdown, readDeclarationDocsWithNameType)
+import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, getImportRefNameType, isPrimImport, spanToRange)
+import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.Util (efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
-import Language.PureScript.Names (disqualify, runIdent, Qualified (..))
-import Protolude hiding (to)
 import Language.PureScript.Lsp.State (cacheRebuild, cachedRebuild)
-import Language.PureScript.AST.Traversals (everythingWithContextOnValues)
-import Language.PureScript.Lsp.Types (OpenFile(..))
-import Language.PureScript.AST.Declarations (Expr(..))
+import Language.PureScript.Lsp.Types (OpenFile (..))
+import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
+import Language.PureScript.Names (Qualified (..), disqualify, runIdent)
+import Protolude hiding (to)
 
 hoverHandler :: Server.Handlers HandlerM
-hoverHandler =
+hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
+  let Types.HoverParams docIdent pos@(Types.Position {..}) _prog = req ^. LSP.params
+      filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+
+      nullRes = res $ Right $ Types.InR Types.Null
+
+      markdownRes md range = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) range
+
+      forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
+      forLsp val f = maybe nullRes f val
+
+      respondWithDeclInOtherModule :: P.SourceSpan -> LspNameType -> P.ModuleName -> Text -> HandlerM ()
+      respondWithDeclInOtherModule ss nameType modName ident = do
+        declDocMb <- readDeclarationDocsWithNameType modName nameType ident -- TODO include nametype
+        case declDocMb of
+          Just docs -> markdownRes docs (Just $ spanToRange ss)
+          _ -> do
+            tipes <- getAstDeclarationTypeInModule (Just nameType) modName ident
+            forLsp (head tipes) \tipe ->
+              markdownRes tipe (Just $ spanToRange ss)
+
+      respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
+      respondWithModule ss modName = do
+        docsMb <- readModuleDocs modName
+        case docsMb of
+          Just docs | Just comments <- Docs.modComments docs -> markdownRes comments (Just $ spanToRange ss)
+          _ -> nullRes
+
+      respondWithImports ss importedModuleName imports = do
+        case findDeclRefAtPos pos imports of
+          Just import' -> do
+            let name = P.declRefName import'
+                nameType = getImportRefNameType import'
+            forLsp nameType \nameType' -> do
+              respondWithDeclInOtherModule ss nameType' importedModuleName (printName name)
+          _ -> respondWithModule ss importedModuleName
+
+  debugLsp $ "Position: " <> show pos
+
+  forLsp filePathMb \filePath -> do
+    cacheOpenMb <- cachedRebuild filePath
+    forLsp cacheOpenMb \OpenFile {..} -> do
+      let withoutPrim =
+            ofModule
+              & P.getModuleDeclarations
+              & filter (not . isPrimImport)
+
+          srcPosLine = fromIntegral _line + 1
+
+          declAtPos =
+            withoutPrim
+              & declAtLine srcPosLine
+      forLsp declAtPos $ \decl -> do
+        case decl of
+          P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
+            -- debugLsp $ "found import at pos: " <> show importedModuleName
+            case importType of
+              P.Implicit -> respondWithModule ss importedModuleName
+              P.Explicit imports -> respondWithImports ss importedModuleName imports
+              P.Hiding imports -> respondWithImports ss importedModuleName imports
+          _ ->
+            nullRes
+
+hoverHandlerV1 :: Server.Handlers HandlerM
+hoverHandlerV1 =
   Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
     let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
         filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
@@ -49,23 +119,11 @@ hoverHandler =
         markdownTypeRes word type' comments =
           markdownRes $ pursTypeStr word type' comments
 
-        pursTypeStr word type' comments =
-          "```purescript\n"
-            <> word
-            <> annotation
-            <> "\n"
-            <> fold (convertComments comments)
-            <> "\n```"
-          where
-            annotation = case type' of
-              Just t -> " :: " <> t
-              Nothing -> ""
-
         forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
         forLsp val f = maybe nullRes f val
 
     forLsp filePathMb \filePath -> do
-      openFileMb <- cachedRebuild  filePath
+      openFileMb <- cachedRebuild filePath
       forLsp openFileMb \_ -> do
         corefnExprMb <- getCoreFnExprAt filePath pos
         case corefnExprMb of
@@ -102,20 +160,18 @@ hoverHandler =
                       forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
                     Just docs -> markdownRes docs
 
+pursTypeStr :: Text -> Maybe Text -> [P.Comment] -> Text
+pursTypeStr word type' comments =
+  "```purescript\n"
+    <> word
+    <> annotation
+    <> "\n"
+    <> fold (convertComments comments)
+    <> "\n```"
+  where
+    annotation = case type' of
+      Just t -> " :: " <> t
+      Nothing -> ""
 
--- getExprsAtPosition :: Types.Position -> Text -> P.Declaration -> [(P.SourcePos, P.Expr)]
--- getExprsAtPosition pos word decl = []
-
--- usedIdents :: P.ModuleName ->  P.Expr -> [P.Ident]
--- usedIdents moduleName = ordNub . usedIdents' Set.empty 
---   where
---   def _ _ = []
-
---   (_, usedIdents', _, _, _) = P.everythingWithScope def usedNamesE def def def
-
---   usedNamesE :: Set.Set ScopedIdent -> Expr -> [Ident]
---   usedNamesE scope (Var _ (Qualified (BySourcePos _) name))
---     | LocalIdent name `S.notMember` scope = [name]
---   usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name))
---     | moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name]
---   usedNamesE _ _ = []
\ No newline at end of file
+pursMd :: Text -> Text
+pursMd t = "```purescript\n" <> t <> "\n```"
\ No newline at end of file

From 846f1475f6c35d3e75974de47d80de070066fdae Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 02:09:49 +0200
Subject: [PATCH 135/297] fix getting last decl

---
 src/Language/PureScript/Lsp/Docs.hs           | 25 ++++++++-----
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 37 ++++++++++++++-----
 src/Language/PureScript/Lsp/Util.hs           |  2 +-
 3 files changed, 44 insertions(+), 20 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Docs.hs b/src/Language/PureScript/Lsp/Docs.hs
index 39f8da846f..29556c9205 100644
--- a/src/Language/PureScript/Lsp/Docs.hs
+++ b/src/Language/PureScript/Lsp/Docs.hs
@@ -5,6 +5,7 @@ import Language.PureScript.AST.SourcePos qualified as P
 import Language.PureScript.Docs qualified as Docs
 import Language.PureScript.Docs.AsMarkdown (declAsMarkdown, runDocs)
 import Language.PureScript.Docs.Collect (parseDocsJsonFile)
+import Language.PureScript.Docs.Types (Declaration (declChildren))
 import Language.PureScript.Docs.Types qualified as P
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
@@ -22,7 +23,6 @@ readDeclarationDocs modName ident = do
   modMb <- readModuleDocs modName
   pure $ modMb >>= (P.modDeclarations >>> find ((== ident) . P.declTitle))
 
-
 -- todo: add child info and operator matching
 readDeclarationDocsWithNameType :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> LspNameType -> Text -> m (Maybe Text)
 readDeclarationDocsWithNameType modName nameType ident = do
@@ -32,21 +32,26 @@ readDeclarationDocsWithNameType modName nameType ident = do
     getMarkdown :: [Docs.Declaration] -> Maybe Text
     getMarkdown [] = Nothing
     getMarkdown (decl : decls) = case decl of
-      _ | P.declTitle decl == ident && matchesNameType decl -> Just $ runDocs $ declAsMarkdown decl
+      _ | matchesNameType decl -> Just $ runDocs $ declAsMarkdown decl
+      _ | matchesChildren (declChildren decl) -> Just $ runDocs $ declAsMarkdown decl
       _ -> getMarkdown decls
 
     matchesNameType :: P.Declaration -> Bool
     matchesNameType d = case P.declInfo d of
-      P.ValueDeclaration _ -> nameType == IdentNameType
-      P.DataDeclaration _ _ _ -> nameType == TyNameType
-      P.TypeSynonymDeclaration _ _ -> nameType == TyNameType
-      P.TypeClassDeclaration _ _ _ -> nameType == TyClassNameType
+      P.ValueDeclaration _ -> nameType == IdentNameType && P.declTitle d == ident
+      P.DataDeclaration _ _ _ -> nameType == TyNameType && P.declTitle d == ident
+      P.TypeSynonymDeclaration _ _ -> nameType == TyNameType && P.declTitle d == ident
+      P.TypeClassDeclaration _ _ _ -> nameType == TyClassNameType && P.declTitle d == ident
       _ -> False
 
--- matches
--- if P.declTitle decl == ident && P.declNameType decl == Just nameType
---   then Just $ runDocs $ declAsMarkdown decl
---   else getMarkdown decls
+    matchesChildren :: [P.ChildDeclaration] -> Bool
+    matchesChildren = any matchesChild
+
+    matchesChild :: P.ChildDeclaration -> Bool
+    matchesChild cd = case P.cdeclInfo cd of
+      P.ChildInstance _ _ -> nameType == TyClassNameType && P.cdeclTitle cd == ident
+      P.ChildDataConstructor _ -> nameType == DctorNameType && P.cdeclTitle cd == ident
+      P.ChildTypeClassMember _ -> nameType == IdentNameType && P.cdeclTitle cd == ident
 
 readDeclarationDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Text)
 readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$> readDeclarationDocs modName ident
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 0712caf1a7..ccf8906e6b 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -25,15 +25,15 @@ import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule, getAstDeclarationTypeInModule, getCoreFnExprAt, getEfDeclarationInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readModuleDocs, readQualifiedNameDocsAsMarkdown, readDeclarationDocsWithNameType)
-import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, getImportRefNameType, isPrimImport, spanToRange)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readDeclarationDocsWithNameType, readModuleDocs, readQualifiedNameDocsAsMarkdown)
+import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, getExprsAtPos, getImportRefNameType, isPrimImport, spanToRange)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cacheRebuild, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
+import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceType, getNamesAtPosition, lookupTypeInEnv, declStartLine)
 import Language.PureScript.Names (Qualified (..), disqualify, runIdent)
 import Protolude hiding (to)
 
@@ -51,7 +51,9 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 
       respondWithDeclInOtherModule :: P.SourceSpan -> LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInOtherModule ss nameType modName ident = do
-        declDocMb <- readDeclarationDocsWithNameType modName nameType ident -- TODO include nametype
+        debugLsp $ "looking for decl in other module: " <> show (modName, ident, nameType)
+        declDocMb <- readDeclarationDocsWithNameType modName nameType ident
+        debugLsp $ "found docs: " <> show (isJust declDocMb)
         case declDocMb of
           Just docs -> markdownRes docs (Just $ spanToRange ss)
           _ -> do
@@ -75,8 +77,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               respondWithDeclInOtherModule ss nameType' importedModuleName (printName name)
           _ -> respondWithModule ss importedModuleName
 
-  debugLsp $ "Position: " <> show pos
-
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -90,16 +90,35 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           declAtPos =
             withoutPrim
               & declAtLine srcPosLine
+      debugLsp $ "Position: " <> show pos
+
+      debugLsp $ "srcPosLine: " <> show srcPosLine
+
       forLsp declAtPos $ \decl -> do
         case decl of
           P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
-            -- debugLsp $ "found import at pos: " <> show importedModuleName
             case importType of
               P.Implicit -> respondWithModule ss importedModuleName
               P.Explicit imports -> respondWithImports ss importedModuleName imports
               P.Hiding imports -> respondWithImports ss importedModuleName imports
-          _ ->
-            nullRes
+          _ -> do
+            let 
+              exprsAtPos = getExprsAtPos pos decl
+              -- fromExprType
+            debugLsp $ "Exprs at pos: " <> show (length exprsAtPos)
+
+            case head exprsAtPos of
+              Just expr -> do
+                debugLsp $ "found hover expr at pos: " <> show expr
+                case expr of
+                  P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
+                    respondWithDeclInOtherModule ss IdentNameType modName (P.runIdent ident)
+                  P.Op ss (P.Qualified (P.ByModuleName modName) ident) -> do
+                    respondWithDeclInOtherModule ss ValOpNameType modName (P.runOpName ident)
+                  P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
+                    respondWithDeclInOtherModule ss DctorNameType modName (P.runProperName ident)
+                  _ -> nullRes
+              _ -> nullRes
 
 hoverHandlerV1 :: Server.Handlers HandlerM
 hoverHandlerV1 =
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 73e632d3f6..8146630342 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -246,7 +246,7 @@ declAtLine l = go . sortBy (comparing declStartLine)
     go (d : d' : ds)
       | declStartLine d <= l && declStartLine d' > l = Just d
       | otherwise = go (d' : ds)
-    go [d] | declStartLine d >= l = Just d
+    go [d] | declStartLine d <= l = Just d
     go _ = Nothing
 
 declStartLine :: P.Declaration -> Int

From 8033aafaa02f459b9085b670cc609fc94dba9615 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 03:21:39 +0200
Subject: [PATCH 136/297] adds hover for local bindings

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 17 +++++++++++
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 28 +++++++++++++++----
 2 files changed, 39 insertions(+), 6 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 6680f33ef2..5f4f6144c1 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -184,6 +184,23 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
         modify (expr :)
       pure expr
 
+getTypedValuesAtPos :: Types.Position -> P.Declaration -> [P.Expr]
+getTypedValuesAtPos pos declaration = execState (goDecl declaration) []
+  where
+    goDecl :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
+    goDecl = onDecl
+
+    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
+
+    handleExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
+    handleExpr expr = do
+      case expr of
+        P.TypedValue _ e t -> do
+          when (maybe False (posInSpan pos) (P.exprSourceSpan e) || posInSpan pos (fst $ getAnnForType t)) do
+            modify (expr :)
+        _ -> pure ()
+      pure expr
+
 getTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
 getTypesAtPos pos decl = P.everythingOnTypes (<>) getAtPos =<< (view _1 $ P.accumTypes getAtPos) decl
   where
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index ccf8906e6b..93c7427296 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -26,15 +26,16 @@ import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule, getAstDeclarationTypeInModule, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readDeclarationDocsWithNameType, readModuleDocs, readQualifiedNameDocsAsMarkdown)
-import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, getExprsAtPos, getImportRefNameType, isPrimImport, spanToRange)
+import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, getExprsAtPos, getImportRefNameType, getTypedValuesAtPos, isPrimImport, spanToRange)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cacheRebuild, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine, efDeclSourceType, getNamesAtPosition, lookupTypeInEnv, declStartLine)
+import Language.PureScript.Lsp.Util (declAtLine, declStartLine, efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
 import Language.PureScript.Names (Qualified (..), disqualify, runIdent)
+import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -61,6 +62,17 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             forLsp (head tipes) \tipe ->
               markdownRes tipe (Just $ spanToRange ss)
 
+      respondWithSourceType :: P.Expr -> (P.SourceType, Maybe P.SourceSpan) -> HandlerM ()
+      respondWithSourceType expr (tipe, sa) = do
+        let word = case expr of
+              P.Var _ (P.Qualified _ ident) -> P.runIdent ident
+              P.Op _ (P.Qualified _ ident) -> P.runOpName ident
+              P.Constructor _ (P.Qualified _ ident) -> P.runProperName ident
+              _ -> "<expression>"
+            printedType = prettyPrintTypeSingleLine tipe
+
+        markdownRes (pursTypeStr word (Just printedType) []) (spanToRange <$> sa)
+
       respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
       respondWithModule ss modName = do
         docsMb <- readModuleDocs modName
@@ -102,9 +114,13 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               P.Explicit imports -> respondWithImports ss importedModuleName imports
               P.Hiding imports -> respondWithImports ss importedModuleName imports
           _ -> do
-            let 
-              exprsAtPos = getExprsAtPos pos decl
-              -- fromExprType
+            debugLsp $ "Decl at pos: " <> show decl
+            let exprsAtPos = getExprsAtPos pos decl
+                findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
+                findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
+                findTypedExpr (_ : es) = findTypedExpr es
+                findTypedExpr [] = Nothing
+
             debugLsp $ "Exprs at pos: " <> show (length exprsAtPos)
 
             case head exprsAtPos of
@@ -117,7 +133,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                     respondWithDeclInOtherModule ss ValOpNameType modName (P.runOpName ident)
                   P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
                     respondWithDeclInOtherModule ss DctorNameType modName (P.runProperName ident)
-                  _ -> nullRes
+                  _ -> forLsp (findTypedExpr $ getTypedValuesAtPos pos decl) (respondWithSourceType expr)
               _ -> nullRes
 
 hoverHandlerV1 :: Server.Handlers HandlerM

From ee5cae664d727b0c30922f761c1e5c1784598dac Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 03:32:22 +0200
Subject: [PATCH 137/297] adds hover to types using ast

---
 .../PureScript/Lsp/Handlers/Definition.hs     |  3 --
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 40 +++++++++++++------
 2 files changed, 28 insertions(+), 15 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 5f4f6144c1..53b77066f9 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -78,12 +78,9 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
             withoutPrim
               & declAtLine srcPosLine
 
-      let declNameAndLine d = (foldMap printName (declName d), P.sourcePosLine $ P.spanStart $ fst $ P.declSourceAnn d)
 
       debugLsp $ "srcPosLine: " <> show srcPosLine
 
-      debugLsp $ "found decl at pos: " <> maybe "Nothing" (show . declNameAndLine) declAtPos
-
       forLsp declAtPos $ \decl -> do
         case decl of
           P.ImportDeclaration (ss, _) importedModuleName importType _ -> do 
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 93c7427296..c65680c26d 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -26,7 +26,7 @@ import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule, getAstDeclarationTypeInModule, getCoreFnExprAt, getEfDeclarationInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readDeclarationDocsWithNameType, readModuleDocs, readQualifiedNameDocsAsMarkdown)
-import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, getExprsAtPos, getImportRefNameType, getTypedValuesAtPos, isPrimImport, spanToRange)
+import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, isSingleLine, spanToRange)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
@@ -50,9 +50,8 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
-      respondWithDeclInOtherModule :: P.SourceSpan -> LspNameType -> P.ModuleName -> Text -> HandlerM ()
-      respondWithDeclInOtherModule ss nameType modName ident = do
-        debugLsp $ "looking for decl in other module: " <> show (modName, ident, nameType)
+      respondWithDeclInModule :: P.SourceSpan -> LspNameType -> P.ModuleName -> Text -> HandlerM ()
+      respondWithDeclInModule ss nameType modName ident = do
         declDocMb <- readDeclarationDocsWithNameType modName nameType ident
         debugLsp $ "found docs: " <> show (isJust declDocMb)
         case declDocMb of
@@ -86,7 +85,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             let name = P.declRefName import'
                 nameType = getImportRefNameType import'
             forLsp nameType \nameType' -> do
-              respondWithDeclInOtherModule ss nameType' importedModuleName (printName name)
+              respondWithDeclInModule ss nameType' importedModuleName (printName name)
           _ -> respondWithModule ss importedModuleName
 
   forLsp filePathMb \filePath -> do
@@ -102,9 +101,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           declAtPos =
             withoutPrim
               & declAtLine srcPosLine
-      debugLsp $ "Position: " <> show pos
-
-      debugLsp $ "srcPosLine: " <> show srcPosLine
 
       forLsp declAtPos $ \decl -> do
         case decl of
@@ -128,13 +124,33 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                 debugLsp $ "found hover expr at pos: " <> show expr
                 case expr of
                   P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                    respondWithDeclInOtherModule ss IdentNameType modName (P.runIdent ident)
+                    respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
                   P.Op ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                    respondWithDeclInOtherModule ss ValOpNameType modName (P.runOpName ident)
+                    respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
                   P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                    respondWithDeclInOtherModule ss DctorNameType modName (P.runProperName ident)
+                    respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
                   _ -> forLsp (findTypedExpr $ getTypedValuesAtPos pos decl) (respondWithSourceType expr)
-              _ -> nullRes
+              _ -> do
+                let tipes =
+                      filter (not . fromPrim) $
+                        filter (not . isNullSourceTypeSpan) $
+                          getTypesAtPos pos decl
+
+                    onOneLine = filter isSingleLine tipes
+                case onOneLine of
+                  [] -> nullRes
+                  _ -> do
+                    let smallest = minimumBy (comparing getTypeColumns) onOneLine
+                    case smallest of
+                      P.TypeConstructor (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
+                        respondWithDeclInModule ss TyNameType modName $ P.runProperName ident
+                      P.TypeOp (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
+                        respondWithDeclInModule ss TyOpNameType modName $ P.runOpName ident
+                      P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of 
+                        (P.Qualified (P.ByModuleName modName) ident) -> do
+                          respondWithDeclInModule ss TyClassNameType modName $ P.runProperName ident
+                        _ -> nullRes 
+                      _ -> nullRes
 
 hoverHandlerV1 :: Server.Handlers HandlerM
 hoverHandlerV1 =

From 857fc44cf79366a2211fe05f0120c90815b8b9c5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 03:33:24 +0200
Subject: [PATCH 138/297] clean up

---
 .../PureScript/Lsp/Handlers/Definition.hs     |  3 -
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 79 +------------------
 2 files changed, 4 insertions(+), 78 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 53b77066f9..ded5e3a90d 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -1,6 +1,4 @@
 {-# LANGUAGE BlockArguments #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.Lsp.Handlers.Definition where
 
@@ -9,7 +7,6 @@ import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
-import Language.PureScript (declName)
 import Language.PureScript qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index c65680c26d..77d35c7668 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -1,41 +1,29 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.Lsp.Handlers.Hover where
 
 import Control.Lens ((^.))
-import Control.Lens.Getter (to)
-import Data.Set qualified as Set
-import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
-import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.AST.Declarations (Expr (..))
-import Language.PureScript.AST.Traversals (everythingWithContextOnValues)
-import Language.PureScript.CoreFn.Expr qualified as CF
-import Language.PureScript.CoreFn.Module (Module (moduleComments))
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule, getAstDeclarationTypeInModule, getCoreFnExprAt, getEfDeclarationInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readDeclarationDocsWithNameType, readModuleDocs, readQualifiedNameDocsAsMarkdown)
+import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, isSingleLine, spanToRange)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.State (cacheRebuild, cachedRebuild)
+import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine, declStartLine, efDeclSourceType, getNamesAtPosition, lookupTypeInEnv)
-import Language.PureScript.Names (Qualified (..), disqualify, runIdent)
-import Language.PureScript.Types (getAnnForType)
+import Language.PureScript.Lsp.Util (declAtLine)
 import Protolude hiding (to)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -152,65 +140,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                         _ -> nullRes 
                       _ -> nullRes
 
-hoverHandlerV1 :: Server.Handlers HandlerM
-hoverHandlerV1 =
-  Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-    let Types.HoverParams docIdent pos _workDone = req ^. LSP.params
-        filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
-        docUri =
-          docIdent
-            ^. LSP.uri
-              . to Types.toNormalizedUri
-        nullRes = res $ Right $ Types.InR Types.Null
-
-        markdownRes :: Text -> HandlerM ()
-        markdownRes md = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) Nothing
-
-        markdownTypeRes :: Text -> Maybe Text -> [P.Comment] -> HandlerM ()
-        markdownTypeRes word type' comments =
-          markdownRes $ pursTypeStr word type' comments
-
-        forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
-        forLsp val f = maybe nullRes f val
-
-    forLsp filePathMb \filePath -> do
-      openFileMb <- cachedRebuild filePath
-      forLsp openFileMb \_ -> do
-        corefnExprMb <- getCoreFnExprAt filePath pos
-        case corefnExprMb of
-          Just (CF.Literal _ _) -> nullRes
-          Just (CF.Constructor (ss, comments, _meta) tName cMame _) -> do
-            docsMb <- do
-              mNameMb <- selectExternModuleNameFromFilePath (P.spanName ss)
-              maybe (pure Nothing) (`readDeclarationDocsAsMarkdown` P.runProperName tName) mNameMb
-            case docsMb of
-              Nothing -> markdownTypeRes (P.runProperName cMame) (Just $ P.runProperName tName) comments
-              Just docs -> markdownRes docs
-          Just (CF.Var (_ss, comments, _meta) (P.Qualified qb ident)) -> do
-            case qb of
-              P.ByModuleName mName -> do
-                docsMb <- readDeclarationDocsAsMarkdown mName (P.runIdent ident)
-                case docsMb of
-                  Just docs -> markdownRes docs
-                  _ -> do
-                    declMb <- getEfDeclarationInModule mName (runIdent ident)
-                    markdownTypeRes (P.runIdent ident) (prettyPrintTypeSingleLine . efDeclSourceType <$> declMb) comments
-              P.BySourcePos _pos' ->
-                markdownTypeRes (P.runIdent ident) Nothing []
-          _ -> do
-            vfMb <- Server.getVirtualFile docUri
-            forLsp vfMb \vf -> do
-              mNameMb <- selectExternModuleNameFromFilePath filePath
-              forLsp mNameMb \mName -> do
-                names <- getNamesAtPosition pos mName (VFS._file_text vf)
-                forLsp (head names) \name -> do
-                  docsMb <- readQualifiedNameDocsAsMarkdown name
-                  case docsMb of
-                    Nothing -> do
-                      typeMb <- lookupTypeInEnv filePath name
-                      forLsp typeMb \t -> markdownTypeRes (printName $ disqualify name) (Just $ prettyPrintTypeSingleLine t) []
-                    Just docs -> markdownRes docs
-
 pursTypeStr :: Text -> Maybe Text -> [P.Comment] -> Text
 pursTypeStr word type' comments =
   "```purescript\n"

From bf5d16b54414228ce47161498421a78c8937adef Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 03:37:57 +0200
Subject: [PATCH 139/297] remove unused queries

---
 src/Language/PureScript/Lsp/Cache/Query.hs | 81 ----------------------
 src/Language/PureScript/Lsp/Util.hs        | 60 ----------------
 2 files changed, 141 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index a008e6c7ce..53fe1c5208 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -4,20 +4,14 @@ module Language.PureScript.Lsp.Cache.Query where
 
 import Codec.Serialise (deserialise)
 import Data.Aeson (encode)
-import Data.Aeson qualified as A
-import Data.Aeson.Types qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.List qualified as List
 import Data.Map qualified as Map
 import Database.SQLite.Simple (NamedParam ((:=)), fromOnly)
 import Database.SQLite.Simple qualified as SQL
-import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.SourcePos (SourcePos (SourcePos))
-import Language.PureScript.CoreFn qualified as CF
-import Language.PureScript.CoreFn.Expr as CF
-import Language.PureScript.CoreFn.FromJSON qualified as CF
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, getMaxTypeLength)
@@ -26,50 +20,6 @@ import Language.PureScript.Names qualified as P
 import Protolude
 import Language.PureScript.Lsp.NameType (LspNameType)
 
-getCoreFnExprAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Expr CF.Ann))
-getCoreFnExprAt path (LSP.Position line col) = do
-  decls :: [SQL.Only Lazy.ByteString] <-
-    DB.queryNamed
-      "SELECT corefn_expressions.value FROM corefn_expressions \
-      \INNER JOIN corefn_modules on corefn_expressions.module_name = corefn_modules.name \
-      \WHERE start_line <= :line AND end_line >= :line \
-      \AND start_col <= :column AND end_col >= :column \
-      \AND path = :path \
-      \AND lines = 0 \
-      \ORDER BY cols ASC \
-      \LIMIT 1"
-      [ ":line" := toInteger (line + 1),
-        ":column" := toInteger (col + 1),
-        ":path" := path
-      ]
-
-  pure $
-    A.parseMaybe (CF.exprFromJSON path)
-      =<< A.decode'
-      =<< fromOnly
-      <$> listToMaybe decls
-
-getCodeFnBindAt :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> LSP.Position -> m (Maybe (CF.Bind CF.Ann))
-getCodeFnBindAt path (LSP.Position line col) = do
-  decls :: [SQL.Only Lazy.ByteString] <-
-    DB.queryNamed
-      "SELECT corefn_declarations.value FROM corefn_declarations \
-      \INNER JOIN corefn_modules on corefn_declarations.module_name = corefn_modules.name \
-      \WHERE start_line <= :line AND end_line >= :line \
-      \AND start_col <= :column AND end_col >= :column \
-      \AND path = :path \
-      \AND lines = 0 \
-      \ORDER BY cols ASC \
-      \LIMIT 1"
-      [ ":line" := toInteger (line + 1),
-        ":column" := toInteger (col + 1),
-        ":path" := path
-      ]
-  pure $
-    A.parseMaybe (CF.bindFromJSON path)
-      =<< A.decode'
-      =<< fromOnly
-      <$> listToMaybe decls
 
 ------------------------------------------------------------------------------------------------------------------------
 ------------ Externs ---------------------------------------------------------------------------------------------------
@@ -105,21 +55,6 @@ getEfDeclarationInModule moduleName' name = do
       ]
   pure $ deserialise . fromOnly <$> listToMaybe decls
 
-getEfDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> SourcePos -> m [P.ExternsDeclaration]
-getEfDeclarationsAtSrcPos path (SourcePos line col) = do
-  decls <-
-    DB.queryNamed
-      "SELECT ef_declarations.value FROM ef_declarations \
-      \inner join externs on ef_declarations.module_name = externs.module_name \
-      \WHERE start_line <= :line AND end_line >= :line \
-      \AND start_col <= :column AND end_col >= :column \
-      \AND path = :path"
-      [ ":line" := line,
-        ":column" := col,
-        ":path" := path
-      ]
-  pure $ deserialise . fromOnly <$> decls
-
 getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.Declaration)
 getAstDeclarationInModule moduleName' name = do
   decls <-
@@ -162,22 +97,6 @@ getAstDeclarationTypeInModule lspNameType moduleName' name = do
       ]
   pure $ decls <&> fromOnly
 
--- pure $ deserialise . fromOnly <$> listToMaybe decls
-
-getAstDeclarationsAtSrcPos :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> SourcePos -> m [P.Declaration]
-getAstDeclarationsAtSrcPos moduleName' (SourcePos line col) = do
-  decls <-
-    DB.queryNamed
-      "SELECT value FROM ast_declarations \
-      \WHERE start_line <= :line AND end_line >= :line \
-      \AND start_col <= :column AND end_col >= :column \
-      \AND module_name = :module_name \
-      \ORDER BY lines ASC, cols ASC"
-      [ ":line" := line,
-        ":column" := col,
-        ":module_name" := P.runModuleName moduleName'
-      ]
-  pure $ deserialise . fromOnly <$> decls
 
 getAstDeclarationsStartingWith ::
   (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 8146630342..615475a032 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -26,8 +26,6 @@ import Language.PureScript.Comments qualified as P
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Linter qualified as P
-import Language.PureScript.Lsp.Cache.Query (getAstDeclarationsAtSrcPos)
-import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (ofFinalEnv))
 import Language.PureScript.Names qualified as P
@@ -84,64 +82,6 @@ getWordOnLine line' col =
     isWordBreak :: Char -> Bool
     isWordBreak = not . (isAlphaNum ||^ (== '_') ||^ (== '.'))
 
-getNamesAtPosition :: (MonadIO m, MonadReader LspEnvironment m) => Types.Position -> P.ModuleName -> Rope -> m (Set (P.Qualified P.Name))
-getNamesAtPosition pos moduleName' src = do
-  let (_, search) = getWordAt src pos
-  decls <- getAstDeclarationsAtSrcPos moduleName' (positionToSourcePos pos)
-  pure $
-    mconcat $
-      decls <&> \decl -> do
-        let goDef m _ = (m, mempty)
-            getDeclName :: P.ModuleName -> P.Declaration -> (P.ModuleName, Set (P.Qualified P.Name))
-            getDeclName modName decl' = case decl' of
-              P.ImportDeclaration _ newMod _ _ -> (newMod, mempty)
-              _ ->
-                (modName,)
-                  case decl' of
-                    P.DataDeclaration _ _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
-                    P.TypeSynonymDeclaration _ n _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyName n
-                    P.TypeClassDeclaration _ n _ _ _ _ | True -> Set.singleton $ flip P.mkQualified modName $ P.TyClassName n
-                    P.TypeDeclaration (P.TypeDeclarationData _ _ st) -> Set.fromList $ getTypeNames st
-                    P.ValueDeclaration (P.ValueDeclarationData _ ident _ _ _) ->
-                      Set.singleton $ flip P.mkQualified modName $ P.IdentName ident
-                    P.ExternDeclaration _ _ st -> Set.fromList $ getTypeNames st
-                    P.ExternDataDeclaration _ name st ->
-                      Set.fromList (getTypeNames st)
-                        <> Set.singleton (flip P.mkQualified modName $ P.TyName name)
-                    _ -> mempty
-
-            getExprNames :: P.ModuleName -> P.Expr -> (P.ModuleName, Set (P.Qualified P.Name))
-            getExprNames modName expr = (modName,) case expr of
-              P.Var _ (P.Qualified qb ident) | True -> Set.singleton $ P.Qualified qb $ P.IdentName ident
-              P.Constructor _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.DctorName ident
-              P.TypeClassDictionary (P.Constraint _ (P.Qualified qb ident) _ _ _) _ _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-              P.DeferredDictionary (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-              P.DerivedInstancePlaceholder (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.TyClassName ident
-              P.TypedValue _ _ tipe -> Set.fromList (getTypeNames tipe)
-              _ -> mempty
-
-            getTypeNames :: P.SourceType -> [P.Qualified P.Name]
-            getTypeNames = P.everythingOnTypes (<>) goType
-              where
-                goType :: P.SourceType -> [P.Qualified P.Name]
-                goType = \case
-                  P.TypeConstructor _ ctr -> [fmap P.TyName ctr]
-                  P.ConstrainedType _ (P.Constraint {..}) _ -> [fmap P.TyClassName constraintClass]
-                  -- P.TypeClassDictionary (P.Constraint {..}) _ _ -> [_ constraintClass]
-                  _ -> []
-
-            goBinder :: P.ModuleName -> P.Binder -> (P.ModuleName, Set (P.Qualified P.Name))
-            goBinder modName b = (modName,) case b of
-              P.ConstructorBinder _ (P.Qualified qb ident) _ -> Set.singleton $ P.Qualified qb $ P.DctorName ident
-              P.OpBinder _ (P.Qualified qb ident) -> Set.singleton $ P.Qualified qb $ P.ValOpName ident
-              P.TypedBinder st _ -> Set.fromList $ getTypeNames st
-              _ -> mempty
-
-            exprNames = P.everythingWithContextOnValues moduleName' Set.empty (<>) getDeclName getExprNames goBinder goDef goDef ^. _1 $ decl
-        -- typeNames = Set.fromList $ usedTypeNames moduleName' decl
-
-        Set.filter ((==) search . printName . P.disqualify) exprNames
-
 lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> P.Qualified P.Name -> m (Maybe P.SourceType)
 lookupTypeInEnv fp (P.Qualified qb name) = do
   envMb :: Maybe P.Environment <- fmap ofFinalEnv <$> cachedRebuild fp

From 5b39f4d5074d136349dbf470f4dee4b82d0e76c9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 04:25:37 +0200
Subject: [PATCH 140/297] stop storing declaration blobs

---
 src/Language/PureScript/Lsp/Cache/Query.hs |  48 +--
 src/Language/PureScript/Lsp/Imports.hs     |  31 +-
 src/Language/PureScript/Lsp/NameType.hs    |  15 +-
 src/Language/PureScript/Lsp/Util.hs        |   3 +-
 src/Language/PureScript/Make/Index.hs      | 336 +--------------------
 5 files changed, 38 insertions(+), 395 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 53fe1c5208..f88784eec6 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -2,68 +2,31 @@
 
 module Language.PureScript.Lsp.Cache.Query where
 
-import Codec.Serialise (deserialise)
-import Data.Aeson (encode)
-import Data.ByteString.Lazy qualified as Lazy
-import Data.List qualified as List
-import Data.Map qualified as Map
 import Database.SQLite.Simple (NamedParam ((:=)), fromOnly)
 import Database.SQLite.Simple qualified as SQL
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.SourcePos (SourcePos (SourcePos))
-import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.DB qualified as DB
+import Language.PureScript.Lsp.NameType (LspNameType)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, getMaxTypeLength)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
-import Language.PureScript.Lsp.NameType (LspNameType)
-
 
 ------------------------------------------------------------------------------------------------------------------------
------------- Externs ---------------------------------------------------------------------------------------------------
+------------ AST -------------------------------------------------------------------------------------------------------
 ------------------------------------------------------------------------------------------------------------------------
 
-getEfImportsMap :: (MonadIO f, MonadReader LspEnvironment f) => [P.ModuleName] -> f (Map P.ModuleName [P.DeclarationRef])
-getEfImportsMap mNames = Map.fromListWith (++) . fmap (fmap List.singleton) <$> getEfExports mNames
-
-getEfImports :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m [P.ExternsImport]
-getEfImports moduleName' = do
-  imports <-
-    DB.queryNamed
-      "SELECT value FROM ef_imports WHERE module_name = :module_name"
-      [":module_name" := P.runModuleName moduleName']
-  pure $ deserialise . fromOnly <$> imports
-
-getEfExports :: (MonadIO m, MonadReader LspEnvironment m) => [P.ModuleName] -> m [(P.ModuleName, P.DeclarationRef)]
-getEfExports moduleNames = do
-  exports :: [(Text, Lazy.ByteString)] <-
-    DB.queryNamed
-      "SELECT module_name, value FROM ef_exports WHERE module_name IN (SELECT value FROM json_each(:module_names))"
-      [ ":module_names" := encode (fmap P.runModuleName moduleNames)
-      ]
-  pure $ bimap P.ModuleName deserialise <$> exports
-
-getEfDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.ExternsDeclaration)
-getEfDeclarationInModule moduleName' name = do
-  decls <-
-    DB.queryNamed
-      "SELECT value FROM ef_declarations WHERE module_name = :module_name AND name = :name"
-      [ ":module_name" := P.runModuleName moduleName',
-        ":name" := name
-      ]
-  pure $ deserialise . fromOnly <$> listToMaybe decls
-
-getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.Declaration)
+getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (Text, Maybe LspNameType))
 getAstDeclarationInModule moduleName' name = do
   decls <-
     DB.queryNamed
-      "SELECT value FROM ast_declarations WHERE module_name = :module_name AND name = :name"
+      "SELECT name, name_type FROM ast_declarations WHERE module_name = :module_name AND name = :name"
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := name
       ]
-  pure $ deserialise . fromOnly <$> listToMaybe decls
+  pure $ listToMaybe decls
 
 getAstDeclarationLocationInModule :: (MonadIO m, MonadReader LspEnvironment m) => Maybe LspNameType -> P.ModuleName -> Text -> m [P.SourceSpan]
 getAstDeclarationLocationInModule lspNameType moduleName' name = do
@@ -97,7 +60,6 @@ getAstDeclarationTypeInModule lspNameType moduleName' name = do
       ]
   pure $ decls <&> fromOnly
 
-
 getAstDeclarationsStartingWith ::
   (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
   P.ModuleName ->
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 845bf0b289..5e8c2da20c 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -8,18 +8,19 @@ import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed qualified as Rope
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Types as LSP
+import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
 import Language.PureScript.Lsp.Log (errorLsp)
+import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ReadFile (lspReadFileRope)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types (CompleteItemData (..), LspEnvironment)
+import Language.PureScript.Lsp.Util (filePathToNormalizedUri)
 import Language.PureScript.Names qualified as P
 import Protolude
-import Language.PureScript.Lsp.Util (filePathToNormalizedUri)
-import Language.LSP.Server (MonadLsp)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 
 getMatchingImport :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) => NormalizedUri -> P.ModuleName -> m (Maybe Import)
 getMatchingImport path moduleName' = do
@@ -49,8 +50,8 @@ getImportEdits (CompleteItemData path moduleName' importedModuleName name word (
         Nothing -> do
           errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> name
           pure Nothing
-        Just decl -> do
-          case addDeclarationToImports moduleName' importedModuleName wordQualifierMb decl imports of
+        Just (declName, nameType) -> do
+          case addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName nameType imports of
             Nothing -> pure Nothing
             Just (newImports, moduleQualifier) -> do
               let importEdits = importsToTextEdit before newImports
@@ -69,8 +70,8 @@ getIdentModuleQualifier word =
     [_] -> Nothing
     xs -> Just (P.ModuleName $ T.intercalate "." $ init xs, last xs)
 
-addDeclarationToImports :: P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> P.Declaration -> [Import] -> Maybe ([Import], Maybe P.ModuleName)
-addDeclarationToImports moduleName' importedModuleName wordQualifierMb decl imports
+addDeclarationToImports :: P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> Text -> Maybe LspNameType -> [Import] -> Maybe ([Import], Maybe P.ModuleName)
+addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName nameType imports
   | importingSelf = Nothing
   | Just existing <- alreadyImportedModuleMb,
     Just ref <- refMb = case existing of
@@ -99,14 +100,14 @@ addDeclarationToImports moduleName' importedModuleName wordQualifierMb decl impo
 
     refMb :: Maybe P.DeclarationRef
     refMb =
-      P.declName decl >>= \case
-        P.IdentName name -> Just $ P.ValueRef nullSourceSpan name
-        P.ValOpName name -> Just $ P.ValueOpRef nullSourceSpan name
-        P.TyName name -> Just $ P.TypeRef nullSourceSpan name Nothing
-        P.TyOpName name -> Just $ P.TypeOpRef nullSourceSpan name
-        P.TyClassName name -> Just $ P.TypeClassRef nullSourceSpan name
-        P.ModName name -> Just $ P.ModuleRef nullSourceSpan name
-        P.DctorName _name -> Nothing
+      nameType >>= \case
+        IdentNameType -> Just $ P.ValueRef nullSourceSpan (P.Ident declName)
+        ValOpNameType -> Just $ P.ValueOpRef nullSourceSpan (P.OpName declName)
+        TyNameType -> Just $ P.TypeRef nullSourceSpan (P.ProperName declName) Nothing
+        TyOpNameType -> Just $ P.TypeOpRef nullSourceSpan (P.OpName declName)
+        DctorNameType -> Nothing
+        TyClassNameType -> Just $ P.TypeClassRef nullSourceSpan (P.ProperName declName)
+        ModNameType -> Just $ P.ModuleRef nullSourceSpan (P.ModuleName declName)
 
     alreadyImportedModuleMb =
       find (\(Import mn' _ _) -> mn' == importedModuleName) imports
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index 5bc16ce1ac..d3214f8177 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -1,7 +1,11 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
 module Language.PureScript.Lsp.NameType where
 
-import Protolude
+import Database.SQLite.Simple.FromField (FromField (fromField))
+import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.PureScript.Names
+import Protolude
 
 data LspNameType
   = IdentNameType
@@ -11,11 +15,16 @@ data LspNameType
   | DctorNameType
   | TyClassNameType
   | ModNameType
-  deriving (Show, Eq)
+  deriving (Show, Read, Eq, Generic)
+
+instance ToField LspNameType where
+  toField = toField . (show :: LspNameType -> Text)
 
+instance FromField LspNameType where
+  fromField = fmap (fromMaybe IdentNameType . (readMaybe :: Text -> Maybe LspNameType)) . fromField
 
 lspNameType :: Name -> LspNameType
-lspNameType = \case 
+lspNameType = \case
   IdentName _ -> IdentNameType
   ValOpName _ -> ValOpNameType
   TyName _ -> TyNameType
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 615475a032..c4d378f3f5 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -8,9 +8,8 @@ module Language.PureScript.Lsp.Util where
 import Codec.Serialise qualified as S
 -- import Language.PureScript.Linter qualified as P
 
-import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view, (^.))
+import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view)
 import Data.Map qualified as Map
-import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed as Rope
 import Database.SQLite.Simple.ToField (ToField (toField))
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index dc7c5863f9..205d703eb2 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -87,13 +87,12 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
       conn
       (SQL.Query 
       "INSERT INTO ast_declarations \
-      \         (module_name, name, value, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
-      \ VALUES (:module_name, :name, :value, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+      \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
+      \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := printName <$> name,
-        ":value" := serialise decl,
         ":printed_type" := printDeclarationType decl,
-        ":name_type" := (show <$> nameType :: Maybe Text),
+        ":name_type" := nameType,
         ":start_line" := P.sourcePosLine start,
         ":end_line" := P.sourcePosLine end,
         ":start_col" := P.sourcePosColumn start,
@@ -105,143 +104,6 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
-insertDeclExprs :: (MonadIO m) => Connection -> P.ModuleName -> P.Declaration -> m ()
-insertDeclExprs conn name decl = liftIO $ void $ handleDecl decl
-  where
-    (handleDecl, _, _) =
-      P.everywhereOnValuesM
-        pure
-        (\e -> e <$ insertAstExpr e)
-        pure
-
-    insertAstExpr :: P.Expr -> IO ()
-    insertAstExpr expr =
-      SQL.execute
-        conn
-        (SQL.Query "INSERT INTO ast_expressions (module_name, value, shown, start_line, end_line, start_col, end_col, length) VALUES (?, ?, ?, ?, ?, ?, ?, ?)")
-        ( P.runModuleName name,
-          serialise expr,
-          show expr :: Text,
-          fmap (P.sourcePosLine . P.spanStart) ss,
-          fmap (P.sourcePosLine . P.spanEnd) ss,
-          fmap (P.sourcePosColumn . P.spanStart) ss,
-          fmap (P.sourcePosColumn . P.spanEnd) ss,
-          T.length (show expr :: Text)
-        )
-      where
-        ss = exprSourceSpan expr
-
-addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
-addEnvIndexing conn ma =
-  ma
-    { P.codegen = \prevEnv env astM m docs ext -> lift (indexEnv conn (P.getModuleName astM) env) <* P.codegen ma prevEnv env astM m docs ext
-    }
-
-indexEnv :: (MonadIO m) => Connection -> P.ModuleName -> P.Environment -> m ()
-indexEnv conn name env =
-  liftIO $
-    SQL.executeNamed
-      conn
-      (SQL.Query "INSERT OR REPLACE INTO envs (module_name, value) VALUES (:module_name, :value)")
-      [ ":module_name" := P.runModuleName name,
-        ":value" := serialise env
-      ]
-
-addCoreFnIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
-addCoreFnIndexing conn ma =
-  ma
-    { P.codegen = \prevEnv env astM m docs ext -> lift (indexCoreFn conn m) <* P.codegen ma prevEnv env astM m docs ext
-    }
-
-indexCoreFn :: forall m. (MonadIO m) => Connection -> CF.Module CF.Ann -> m ()
-indexCoreFn conn m = do
-  liftIO do
-    let mName = P.runModuleName $ CF.moduleName m
-    path <- makeAbsolute $ CF.modulePath m
-    SQL.execute conn "DELETE FROM corefn_modules WHERE name = ?" (SQL.Only mName)
-    SQL.execute
-      conn
-      (SQL.Query "INSERT INTO corefn_modules (name, path, value) VALUES (?, ?, ?)")
-      ( mName,
-        path,
-        A.encode $ CFJ.moduleToJSON Paths.version m
-      )
-
-    SQL.execute conn "DELETE FROM corefn_imports WHERE module_name = ?" (SQL.Only mName)
-    SQL.execute conn "DELETE FROM corefn_declarations WHERE module_name = ?" (SQL.Only mName)
-    SQL.execute conn "DELETE FROM corefn_expressions WHERE module_name = ?" (SQL.Only mName)
-
-    forM_ (CF.moduleImports m) \((span, _, _), importedModule) -> do
-      SQL.execute
-        conn
-        (SQL.Query "INSERT INTO corefn_imports (module_name, imported_module) VALUES (?, ?)")
-        ( mName,
-          P.runModuleName importedModule
-        )
-
-    forM_ (CF.moduleDecls m) \b ->
-      do
-        let insertBindQuery topLevel ss ident bind =
-              SQL.execute
-                conn
-                ( SQL.Query
-                    "INSERT INTO corefn_declarations (module_name, ident, top_level, value, start_line, end_line, start_col, end_col) \
-                    \VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
-                )
-                ( mName,
-                  P.runIdent ident,
-                  topLevel,
-                  A.encode $ CFJ.bindToJSON bind,
-                  P.sourcePosLine $ P.spanStart ss,
-                  P.sourcePosLine $ P.spanEnd ss,
-                  P.sourcePosColumn $ P.spanStart ss,
-                  P.sourcePosColumn $ P.spanEnd ss
-                )
-            (handleBind, handleExpr, handleBinder, handleCaseAlternative) =
-              traverseCoreFn (insertBind False) insertExpr handleBinder handleCaseAlternative
-
-            insertBind' :: Bool -> CF.Bind CF.Ann -> IO ()
-            insertBind' topLevel bind = do
-              case bind of
-                CF.NonRec (ss, _comments, _meta) ident expr -> do
-                  insertBindQuery topLevel ss ident bind
-                CF.Rec binds -> forM_ binds $ \(((ss, _, _), ident), expr) -> do
-                  insertBindQuery topLevel ss ident bind
-
-            insertBind :: Bool -> CF.Bind CF.Ann -> IO (CF.Bind CF.Ann)
-            insertBind topLevel bind = do
-              insertBind' topLevel bind
-              handleBind bind
-
-            insertExpr :: CF.Expr CF.Ann -> IO (CF.Expr CF.Ann)
-            insertExpr expr = do
-              SQL.execute
-                conn
-                ( SQL.Query
-                    "INSERT INTO corefn_expressions (module_name, value, start_line, end_line, start_col, end_col, lines, cols, shown)\
-                    \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)"
-                )
-                ( mName,
-                  A.encode $ CFJ.exprToJSON expr,
-                  P.sourcePosLine start,
-                  P.sourcePosLine end,
-                  P.sourcePosColumn start,
-                  P.sourcePosColumn end,
-                  lines',
-                  cols,
-                  show expr :: Text
-                )
-              handleExpr expr
-              where
-                (ss, _comments, _meta) = CF.extractAnn expr
-                start = P.spanStart ss
-                end = P.spanEnd ss
-                lines' = P.sourcePosLine end - P.sourcePosLine start
-                cols = P.sourcePosColumn end - P.sourcePosColumn start
-
-        void $ insertBind' True b
-        void $ handleBind b
-
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma
@@ -324,7 +186,7 @@ initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, name_type TEXT, value TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
@@ -385,193 +247,3 @@ dropTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_exports"
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_declarations"
-
--- xzzz =
---   TypedValue
---     True
---     ( Var
---         (SS {ss = SP {l = 15, c = 31}, end = SP {l = 15, c = 34}})
---         ( Qualified
---             ( ByModuleName
---                 (ModuleName "Data.Functor")
---             )
---             (Ident "map")
---         )
---     )
---     ( ForAll
---         (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---         TypeVarVisible
---         "f"
---         ( Just
---             ( TypeApp
---                 (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---                 ( TypeApp
---                     (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---                     ( TypeConstructor
---                         (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---                         ( Qualified
---                             ( ByModuleName
---                                 (ModuleName "Prim")
---                             )
---                             (ProperName {runProperName = "Function"})
---                         )
---                     )
---                     ( TypeConstructor
---                         (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---                         ( Qualified
---                             ( ByModuleName
---                                 (ModuleName "Prim")
---                             )
---                             (ProperName {runProperName = "Type"})
---                         )
---                     )
---                 )
---                 ( TypeConstructor
---                     (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---                     ( Qualified
---                         ( ByModuleName
---                             (ModuleName "Prim")
---                         )
---                         (ProperName {runProperName = "Type"})
---                     )
---                 )
---             )
---         )
---         ( ForAll
---             (SS {ss = SP {l = 32, c = 10}, end = SP {l = 32, c = 44}}, [])
---             TypeVarInvisible
---             "a"
---             ( Just
---                 ( TypeConstructor
---                     (SS {ss = SP {l = 32, c = 25}, end = SP {l = 32, c = 27}}, [])
---                     ( Qualified
---                         ( ByModuleName
---                             (ModuleName "Prim")
---                         )
---                         (ProperName {runProperName = "Type"})
---                     )
---                 )
---             )
---             ( ForAll
---                 (SS {ss = SP {l = 32, c = 19}, end = SP {l = 32, c = 44}}, [])
---                 TypeVarInvisible
---                 "b"
---                 ( Just
---                     ( TypeConstructor
---                         (SS {ss = SP {l = 32, c = 25}, end = SP {l = 32, c = 27}}, [])
---                         ( Qualified
---                             ( ByModuleName
---                                 (ModuleName "Prim")
---                             )
---                             (ProperName {runProperName = "Type"})
---                         )
---                     )
---                 )
---                 ( ConstrainedType
---                     (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---                     ( Constraint
---                         { constraintAnn =
---                             (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, []),
---                           constraintClass =
---                             Qualified
---                               ( ByModuleName
---                                   (ModuleName "Data.Functor")
---                               )
---                               (ProperName {runProperName = "Functor"}),
---                           constraintKindArgs = [],
---                           constraintArgs =
---                             [ TypeVar
---                                 (SS {spanName = "", ss = SP {l = 0, c = 0}, end = SP {l = 0, c = 0}}, [])
---                                 "f"
---                             ],
---                           constraintData = Nothing
---                         }
---                     )
---                     ( TypeApp
---                         (SS {ss = SP {l = 32, c = 22}, end = SP {l = 32, c = 44}}, [])
---                         ( TypeApp
---                             (SS {ss = SP {l = 32, c = 22}, end = SP {l = 32, c = 44}}, [])
---                             ( TypeConstructor
---                                 (SS {ss = SP {l = 32, c = 31}, end = SP {l = 32, c = 33}}, [])
---                                 ( Qualified
---                                     ( ByModuleName
---                                         (ModuleName "Prim")
---                                     )
---                                     (ProperName {runProperName = "Function"})
---                                 )
---                             )
---                             ( TypeApp
---                                 (SS {ss = SP {l = 32, c = 23}, end = SP {l = 32, c = 29}}, [])
---                                 ( TypeApp
---                                     (SS {ss = SP {l = 32, c = 23}, end = SP {l = 32, c = 29}}, [])
---                                     ( TypeConstructor
---                                         (SS {ss = SP {l = 32, c = 25}, end = SP {l = 32, c = 27}}, [])
---                                         ( Qualified
---                                             ( ByModuleName
---                                                 (ModuleName "Prim")
---                                             )
---                                             (ProperName {runProperName = "Function"})
---                                         )
---                                     )
---                                     ( TypeVar
---                                         (SS {ss = SP {l = 32, c = 23}, end = SP {l = 32, c = 24}}, [])
---                                         "a"
---                                     )
---                                 )
---                                 ( TypeVar
---                                     (SS {ss = SP {l = 32, c = 28}, end = SP {l = 32, c = 29}}, [])
---                                     "b"
---                                 )
---                             )
---                         )
---                         ( TypeApp
---                             (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 44}}, [])
---                             ( TypeApp
---                                 (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 44}}, [])
---                                 ( TypeConstructor
---                                     (SS {ss = SP {l = 32, c = 38}, end = SP {l = 32, c = 40}}, [])
---                                     ( Qualified
---                                         ( ByModuleName
---                                             (ModuleName "Prim")
---                                         )
---                                         (ProperName {runProperName = "Function"})
---                                     )
---                                 )
---                                 ( TypeApp
---                                     (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 37}}, [])
---                                     ( TypeVar
---                                         (SS {ss = SP {l = 32, c = 34}, end = SP {l = 32, c = 35}}, [])
---                                         "f"
---                                     )
---                                     ( TypeVar
---                                         (SS {ss = SP {l = 32, c = 36}, end = SP {l = 32, c = 37}}, [])
---                                         "a"
---                                     )
---                                 )
---                             )
---                             ( TypeApp
---                                 (SS {ss = SP {l = 32, c = 41}, end = SP {l = 32, c = 44}}, [])
---                                 ( TypeVar
---                                     (SS {ss = SP {l = 32, c = 41}, end = SP {l = 32, c = 42}}, [])
---                                     "f"
---                                 )
---                                 ( TypeVar
---                                     (SS {ss = SP {l = 32, c = 43}, end = SP {l = 32, c = 44}}, [])
---                                     "b"
---                                 )
---                             )
---                         )
---                     )
---                 )
---                 ( Just
---                     (SkS {rss = 0})
---                 )
---             )
---             ( Just
---                 (SkS {rss = 1})
---             )
---         )
---         ( Just
---             (SkS {rss = 2})
---         )
---     )

From 3429485ae0fe82e651efae8f6e7d6b1430c1d40c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 04:36:22 +0200
Subject: [PATCH 141/297] remove end env from cache

---
 .../PureScript/Lsp/Handlers/Diagnostic.hs     |  2 +-
 src/Language/PureScript/Lsp/Rebuild.hs        |  4 +--
 src/Language/PureScript/Lsp/State.hs          | 14 +++++------
 src/Language/PureScript/Lsp/Types.hs          |  1 -
 src/Language/PureScript/Lsp/Util.hs           | 25 -------------------
 5 files changed, 10 insertions(+), 36 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
index 6027b2b98c..5e182513dd 100644
--- a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
@@ -25,7 +25,7 @@ diagnosticAndCodeActionHandlers =
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
             uri = getMsgUri req
-
+            
         res $
           Right $
             Types.InL $
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index a65a0af70e..152b95bec5 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -55,7 +55,7 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
               & addRebuildCaching stVar maxCache externs
       debugLsp $ "Cache found: " <> show (isJust cachedBuild)
       case cachedBuild of
-        Just (OpenFile _ _ externs env _ _) -> do
+        Just (OpenFile _ _ externs env _) -> do
           foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
           exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
           res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
@@ -101,5 +101,5 @@ shushProgress ma =
 addRebuildCaching :: TVar LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps ma =
   ma
-    { P.codegen = \prevEnv env astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv env astM) <* P.codegen ma prevEnv env astM m docs ext
+    { P.codegen = \prevEnv env astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv astM) <* P.codegen ma prevEnv env astM m docs ext
     }
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 90430316d1..432bde65fc 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -10,7 +10,7 @@ module Language.PureScript.Lsp.State
     getExportEnv,
     cancelRequest,
     addRunningRequest,
-    removeRunningRequest
+    removeRunningRequest,
   )
 where
 
@@ -35,16 +35,16 @@ import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Environment -> P.Module -> m ()
-cacheRebuild ef deps prevEnv finalEnv module' = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Module -> m ()
+cacheRebuild ef deps prevEnv module' = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
-  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv finalEnv  module'
+  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv module'
 
-cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [P.ExternsFile] -> P.Environment -> P.Environment -> P.Module -> IO ()
-cacheRebuild' st maxFiles ef deps prevEnv finalEnv  module' = atomically . modifyTVar st $ \x ->
+cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [P.ExternsFile] -> P.Environment -> P.Module -> IO ()
+cacheRebuild' st maxFiles ef deps prevEnv module' = atomically . modifyTVar st $ \x ->
   x
-    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv finalEnv module') : filter ((/= fp) . fst) (openFiles x)
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv module') : filter ((/= fp) . fst) (openFiles x)
     }
   where
     fp = P.spanName $ efSourceSpan ef
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 4a64a25d5b..154d4f2f05 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -53,7 +53,6 @@ data OpenFile = OpenFile
     ofExternsFile :: P.ExternsFile,
     ofDependencies :: [P.ExternsFile],
     ofStartingEnv :: P.Environment,
-    ofFinalEnv :: P.Environment, 
     ofModule ::  P.Module
   }
   deriving (Show)
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index c4d378f3f5..5b43a7d3fa 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -8,8 +8,6 @@ module Language.PureScript.Lsp.Util where
 import Codec.Serialise qualified as S
 -- import Language.PureScript.Linter qualified as P
 
-import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view)
-import Data.Map qualified as Map
 import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed as Rope
 import Database.SQLite.Simple.ToField (ToField (toField))
@@ -22,12 +20,7 @@ import Language.PureScript.AST.Declarations (declSourceAnn)
 
 import Language.PureScript.AST.SourcePos (widenSourceSpan)
 import Language.PureScript.Comments qualified as P
-import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
-import Language.PureScript.Linter qualified as P
-import Language.PureScript.Lsp.State (cachedRebuild)
-import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (ofFinalEnv))
-import Language.PureScript.Names qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
 
@@ -81,24 +74,6 @@ getWordOnLine line' col =
     isWordBreak :: Char -> Bool
     isWordBreak = not . (isAlphaNum ||^ (== '_') ||^ (== '.'))
 
-lookupTypeInEnv :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> P.Qualified P.Name -> m (Maybe P.SourceType)
-lookupTypeInEnv fp (P.Qualified qb name) = do
-  envMb :: Maybe P.Environment <- fmap ofFinalEnv <$> cachedRebuild fp
-  pure $
-    envMb
-      >>= ( \(P.Environment {..}) -> case name of
-              P.IdentName ident -> view _1 <$> Map.lookup (P.Qualified qb ident) names
-              P.ValOpName _opName -> Nothing
-              P.TyName tyName ->
-                (view _1 <$> Map.lookup (P.Qualified qb tyName) types)
-                  <|> (view _2 <$> Map.lookup (P.Qualified qb tyName) typeSynonyms)
-              P.TyOpName _opName -> Nothing
-              P.DctorName dctorName -> view _3 <$> Map.lookup (P.Qualified qb dctorName) dataConstructors
-              P.TyClassName tyClassName ->
-                view _1 <$> Map.lookup (P.Qualified qb $ P.coerceProperName tyClassName) types
-              P.ModName _ -> Nothing
-          )
-
 data ExternsDeclarationCategory
   = EDCType
   | EDCTypeSynonym

From 4b3de187bb88911c2a62816ae0dd7bfdb1aa147b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 10:35:42 +0200
Subject: [PATCH 142/297] adds clear cache commands

---
 src/Language/PureScript/Lsp/Handlers.hs        | 14 ++++++++++++--
 src/Language/PureScript/Lsp/Handlers/Build.hs  |  2 ++
 .../PureScript/Lsp/Handlers/Diagnostic.hs      |  3 +--
 src/Language/PureScript/Lsp/Rebuild.hs         |  7 ++++---
 src/Language/PureScript/Lsp/State.hs           | 18 ++++++++++++++++++
 5 files changed, 37 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 89cf7b0e08..cc47cd4024 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -22,8 +22,9 @@ import Language.PureScript.Lsp.Handlers.Diagnostic (diagnosticAndCodeActionHandl
 import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (setTraceValue)
-import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild)
+import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild, clearCache, clearExportCache, clearRebuildCache)
 import Protolude hiding (to)
+import Data.Aeson qualified as A
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -60,7 +61,16 @@ handlers =
             setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
             let reqId = msg ^. LSP.params . LSP.id
-            cancelRequest reqId
+            cancelRequest reqId, 
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear cache") $ \_req res -> do
+            clearCache
+            res $ Right A.Null,
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear export cache") $ \_req res -> do
+            clearExportCache
+            res $ Right A.Null,
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear rebuild cache") $ \_req res -> do
+            clearRebuildCache
+            res $ Right A.Null
         ]
 
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index 8a70415e09..e03f309f21 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -16,10 +16,12 @@ import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment
 import Language.PureScript.Make.Index (initDb)
 import Protolude hiding (to)
 import System.IO.UTF8 (readUTF8FilesT)
+import Language.PureScript.Lsp.State (clearCache)
 
 buildHandler :: Server.Handlers HandlerM
 buildHandler =
   Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
+    clearCache
     config <- asks lspConfig
     conn <- asks lspDbConnection
     liftIO $ initDb conn
diff --git a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
index 5e182513dd..cd6ed73cad 100644
--- a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
@@ -24,8 +24,7 @@ diagnosticAndCodeActionHandlers =
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
-            uri = getMsgUri req
-            
+            uri = getMsgUri req            
         res $
           Right $
             Types.InL $
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 152b95bec5..f75d653f6e 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -8,7 +8,8 @@ import Control.Monad.Catch (MonadThrow (throwM))
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
-import Language.LSP.Server (MonadLsp)
+import Language.LSP.Server (MonadLsp (getLspEnv))
+import Language.PureScript (MultipleErrors)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors qualified as P
@@ -17,7 +18,7 @@ import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getMaxFilesInCache)
 import Language.PureScript.Lsp.State (addExternToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection, lspStateVar), LspState, OpenFile (OpenFile))
 import Language.PureScript.Make qualified as P
@@ -87,7 +88,7 @@ data RebuildResult
   = RebuildError P.MultipleErrors
   | RebuildWarning P.MultipleErrors
 
-data RebuildException = CouldNotConvertUriToFilePath NormalizedUri
+data RebuildException = CouldNotConvertUriToFilePath NormalizedUri | CouldNotReadCacheDb MultipleErrors
   deriving (Exception, Show)
 
 codegenTargets :: Set P.CodegenTarget
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 432bde65fc..3a0797597e 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -4,6 +4,9 @@ module Language.PureScript.Lsp.State
   ( cacheRebuild,
     cacheRebuild',
     cachedRebuild,
+    clearCache,
+    clearRebuildCache,
+    clearExportCache,
     removedCachedRebuild,
     buildExportEnvCache,
     addExternToExportEnv,
@@ -48,6 +51,8 @@ cacheRebuild' st maxFiles ef deps prevEnv module' = atomically . modifyTVar st $
     }
   where
     fp = P.spanName $ efSourceSpan ef
+    
+
 
 cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe OpenFile)
 cachedRebuild fp = do
@@ -64,6 +69,19 @@ removedCachedRebuild fp = do
       { openFiles = filter ((/= fp) . fst) (openFiles x)
       }
 
+clearRebuildCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
+clearRebuildCache = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x -> x {openFiles = []}
+
+clearExportCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
+clearExportCache = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x -> x {exportEnv = P.primEnv}
+
+clearCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
+clearCache = clearRebuildCache >> clearExportCache
+
 buildExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => P.Module -> [ExternsFile] -> m P.Env
 buildExportEnvCache module' externs = do
   st <- lspStateVar <$> ask

From 8cd55444167499097f1609f7bebea7be332cc568 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 10:49:57 +0200
Subject: [PATCH 143/297] remove spaces from commands

---
 src/Language/PureScript/Lsp/Handlers.hs              | 6 +++---
 src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs | 2 +-
 src/Language/PureScript/Lsp/Rebuild.hs               | 4 ++--
 3 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index cc47cd4024..7815cacb87 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -62,13 +62,13 @@ handlers =
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
             let reqId = msg ^. LSP.params . LSP.id
             cancelRequest reqId, 
-          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear cache") $ \_req res -> do
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache") $ \_req res -> do
             clearCache
             res $ Right A.Null,
-          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear export cache") $ \_req res -> do
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:exports") $ \_req res -> do
             clearExportCache
             res $ Right A.Null,
-          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear rebuild cache") $ \_req res -> do
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:rebuilds") $ \_req res -> do
             clearRebuildCache
             res $ Right A.Null
         ]
diff --git a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
index 47d6c7c3ad..432520d4d3 100644
--- a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
@@ -15,7 +15,7 @@ import System.FilePath ((</>))
 
 deleteOutputHandler :: Server.Handlers HandlerM
 deleteOutputHandler =
-  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete output") $ \_req res -> do
+  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete-output") $ \_req res -> do
     outDir <- asks (confOutputPath . lspConfig)
     liftIO $ createDirectoryIfMissing True outDir
     contents <- liftIO $ listDirectory outDir
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index f75d653f6e..34aac7fbc7 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -8,7 +8,7 @@ import Control.Monad.Catch (MonadThrow (throwM))
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
-import Language.LSP.Server (MonadLsp (getLspEnv))
+import Language.LSP.Server (MonadLsp)
 import Language.PureScript (MultipleErrors)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
@@ -18,7 +18,7 @@ import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getMaxFilesInCache)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
 import Language.PureScript.Lsp.State (addExternToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection, lspStateVar), LspState, OpenFile (OpenFile))
 import Language.PureScript.Make qualified as P

From bc25b190d0d2ae218738ed6909814b7ddea9f70d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 12:17:45 +0200
Subject: [PATCH 144/297] removes unnecessary indexing

---
 purescript.cabal                        |  1 -
 src/Language/PureScript/Lsp/Cache/IO.hs | 23 --------
 src/Language/PureScript/Make/Index.hs   | 76 ++-----------------------
 3 files changed, 5 insertions(+), 95 deletions(-)
 delete mode 100644 src/Language/PureScript/Lsp/Cache/IO.hs

diff --git a/purescript.cabal b/purescript.cabal
index 9861745333..26ccf56e74 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -345,7 +345,6 @@ library
     Language.PureScript.Lsp.Docs
     Language.PureScript.Lsp.Imports
     Language.PureScript.Lsp.Cache
-    Language.PureScript.Lsp.Cache.IO
     Language.PureScript.Lsp.Cache.Query
     Language.PureScript.Lsp.Diagnostics
     Language.PureScript.Lsp.Handlers
diff --git a/src/Language/PureScript/Lsp/Cache/IO.hs b/src/Language/PureScript/Lsp/Cache/IO.hs
deleted file mode 100644
index c40231e168..0000000000
--- a/src/Language/PureScript/Lsp/Cache/IO.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Language.PureScript.Lsp.Cache.IO where
-
-import Protolude
-import Database.SQLite.Simple qualified as SQL
-
-
-dropTables :: SQL.Connection -> IO ()
-dropTables conn = do
-  SQL.execute_ conn "DROP TABLE IF EXISTS modules"
-  SQL.execute_ conn "DROP TABLE IF EXISTS declarations"
-  SQL.execute_ conn "DROP TABLE IF EXISTS externs"
-  SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
-  SQL.execute_ conn "DROP TABLE IF EXISTS ef_exports"
-  SQL.execute_ conn "DROP TABLE IF EXISTS ef_declarations"
-
-initDb :: SQL.Connection -> IO ()
-initDb conn = do
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS modules (module_name TEXT PRIMARY KEY, path TEXT, UNIQUE(module_name), UNIQUE(path))"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS declarations (module_name TEXT, name BLOB, printed_name TEXT, type_printed TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, comments TEXT, exported BOOLEAN, value BLOB, shown TEXT, PRIMARY KEY (module_name, name))"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path), UNIQUE(module_name))"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 205d703eb2..852a314dad 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -73,7 +73,6 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
       ":path" := path
     ]
   SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName moduleName')
-  SQL.execute conn "DELETE FROM ast_expressions WHERE module_name = ?" (SQL.Only $ P.runModuleName moduleName')
 
   let exports = Set.fromList $ P.exportedDeclarations m
 
@@ -119,16 +118,13 @@ indexExtern conn extern = liftIO do
     [":path" := path]
   SQL.executeNamed
     conn
-    (SQL.Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name, shown) VALUES (:path, :ef_version, :value, :module_name, :shown)")
+    (SQL.Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name) VALUES (:path, :ef_version, :value, :module_name)")
     [ ":path" := path,
       ":ef_version" := P.efVersion extern,
       ":value" := serialise extern,
-      ":module_name" := P.runModuleName name,
-      ":shown" := (show extern :: Text)
+      ":module_name" := P.runModuleName name
     ]
   forM_ (P.efImports extern) $ insertEfImport conn name
-  forM_ (P.efExports extern) $ insertEfExport conn name
-  forM_ (P.efDeclarations extern) $ insertEfDeclaration conn name
   where
     name = efModuleName extern
     externPath = P.spanName (P.efSourceSpan extern)
@@ -145,40 +141,6 @@ insertEfImport conn moduleName' ei = do
       ":value" := serialise ei
     ]
 
-insertEfDeclaration :: Connection -> P.ModuleName -> P.ExternsDeclaration -> IO ()
-insertEfDeclaration conn moduleName' decl = do
-  SQL.executeNamed
-    conn
-    (SQL.Query "INSERT OR REPLACE INTO ef_declarations (module_name, value, shown, name, start_col, start_line, end_col, end_line, category) VALUES (:module_name, :value, :shown, :name, :start_col, :start_line, :end_col, :end_line, :category)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":name" := printEfDeclName decl,
-      ":value" := serialise decl,
-      ":shown" := (show decl :: Text),
-      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
-      ":start_line" := (P.sourcePosLine . P.spanStart) span,
-      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
-      ":end_line" := (P.sourcePosLine . P.spanEnd) span,
-      ":category" := efDeclCategory decl
-    ]
-  where
-    span = efDeclSourceSpan decl
-
-insertEfExport :: Connection -> P.ModuleName -> P.DeclarationRef -> IO ()
-insertEfExport conn moduleName' dr = do
-  SQL.executeNamed
-    conn
-    (SQL.Query "INSERT OR REPLACE INTO ef_exports (module_name, value, name, printed_name, start_col, start_line, end_col, end_line) VALUES (:module_name, :value, :name, :printed_name, :start_col, :start_line, :end_col, :end_line)")
-    [ ":module_name" := P.runModuleName moduleName',
-      ":value" := serialise dr,
-      ":name" := serialise (declRefName dr),
-      ":printed_name" := printName (declRefName dr),
-      ":start_col" := (P.sourcePosColumn . P.spanStart) span,
-      ":start_line" := (P.sourcePosLine . P.spanStart) span,
-      ":end_col" := (P.sourcePosColumn . P.spanEnd) span,
-      ":end_line" := (P.sourcePosLine . P.spanEnd) span
-    ]
-  where
-    span = P.declRefSourceSpan dr
 
 initDb :: Connection -> IO ()
 initDb conn = do
@@ -187,16 +149,14 @@ initDb conn = do
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, shown TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, imported_module TEXT, UNIQUE(module_name, imported_module) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, shown TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, shown TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_exports (module_name TEXT references externs(module_name) ON DELETE CASCADE, export_name TEXT, value BLOB, name BLOB, printed_name TEXT, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_declarations (module_name TEXT references externs(module_name) ON DELETE CASCADE, name TEXT, value BLOB, start_col INTEGER, start_line INTEGER, end_col INTEGER, end_line INTEGER, category TEXT, shown TEXT)"
 
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
 
@@ -208,42 +168,16 @@ addDbIndexes conn = do
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_name ON ast_declarations (name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_start_line ON ast_declarations (start_line)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_end_line ON ast_declarations (end_line)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_expressions_start_line ON ast_expressions (start_line)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_expressions_end_line ON ast_expressions (end_line)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_modules_name ON corefn_modules (name)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_modules_path ON corefn_modules (path)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_imports_module ON corefn_imports (module_name)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_imports_imported_module ON corefn_imports (imported_module)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_declarations_module_name ON corefn_declarations (module_name)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_declarations_start_line ON corefn_declarations (start_line)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_declarations_end_line ON corefn_declarations (end_line)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_start_line ON corefn_expressions (start_line)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_end_line ON corefn_expressions (end_line)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_lines ON corefn_expressions (lines)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_cols ON corefn_expressions (cols)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS corefn_expressions_module_name ON corefn_expressions (module_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS externs_path ON externs (path)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS externs_module_name ON externs (module_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_module_name ON ef_imports (module_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_imported_module ON ef_imports (imported_module)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_import_type ON ef_imports (import_type)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_imports_imported_as ON ef_imports (imported_as)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_exports_module_name ON ef_exports (module_name)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_exports_export_name ON ef_exports (export_name)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_declarations_module_name ON ef_declarations (module_name)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ef_declarations_name ON ef_declarations (name)"
 
 dropTables :: Connection -> IO ()
 dropTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS ast_declarations"
-  SQL.execute_ conn "DROP TABLE IF EXISTS ast_expressions"
   SQL.execute_ conn "DROP TABLE IF EXISTS ast_modules"
-  SQL.execute_ conn "DROP TABLE IF EXISTS envs"
-  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_modules"
-  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_imports"
-  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_declarations"
-  SQL.execute_ conn "DROP TABLE IF EXISTS corefn_expressions"
   SQL.execute_ conn "DROP TABLE IF EXISTS externs"
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
-  SQL.execute_ conn "DROP TABLE IF EXISTS ef_exports"
-  SQL.execute_ conn "DROP TABLE IF EXISTS ef_declarations"

From efa7be98522993860e3eeb573996f1d384ef1879 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 12:54:42 +0200
Subject: [PATCH 145/297] auto complete working better without manual
 triggering

---
 src/Language/PureScript/LSP.hs                |  3 +-
 .../PureScript/Lsp/Handlers/Completion.hs     | 94 +++++++++----------
 2 files changed, 47 insertions(+), 50 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 935e2ee2c9..db81024f99 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -48,7 +48,8 @@ lspOptions :: Server.Options
 lspOptions =
   Server.defaultOptions
     { Server.optTextDocumentSync = Just syncOptions,
-      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"]
+      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"],
+      Server.optCompletionTriggerCharacters = Just $ "._" <> ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] 
     }
 
 syncOptions :: Types.TextDocumentSyncOptions
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index d7b270d06d..71c6176314 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -6,7 +6,6 @@ import Control.Lens ((^.))
 import Control.Lens.Getter (to)
 import Control.Lens.Setter (set)
 import Data.Aeson qualified as A
-import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as LSP
@@ -49,54 +48,51 @@ completionAndResolveHandlers =
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
             let (range, word) = getWordAt (VFS._file_text vf) pos
-            if T.length word < 2
-              then nullRes
-              else do
-                mNameMb <- selectExternModuleNameFromFilePath filePath
-                forLsp mNameMb \mName -> do
-                  let withQualifier = getIdentModuleQualifier word
-                      wordWithoutQual = maybe word snd withQualifier
-                  limit <- getMaxCompletions
-                  matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
-                  -- matchingImport =
-                  decls <- case (matchingImport, withQualifier) of
-                    (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
-                    (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
-                    _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith mName wordWithoutQual
-                  -- Just
-                  res $
-                    Right $
-                      Types.InR $
-                        Types.InL $
-                          Types.CompletionList (length decls >= limit) Nothing $
-                            decls <&> \cr ->
-                              let label = crName cr
-                               in Types.CompletionItem
-                                    { _label = label,
-                                      _labelDetails =
-                                        Just $
-                                          Types.CompletionItemLabelDetails
-                                            (Just $ " " <> crType cr)
-                                            (Just $ P.runModuleName (crModule cr)),
-                                      _kind = Nothing, --  Maybe Types.CompletionItemKind TODO: add kind
-                                      _tags = Nothing,
-                                      _detail = Nothing,
-                                      _documentation = Nothing,
-                                      _deprecated = Nothing, --  Maybe Bool
-                                      _preselect = Nothing, --  Maybe Bool
-                                      _sortText = Nothing, --  Maybe Text
-                                      _filterText = Nothing, --  Maybe Text
-                                      _insertText = Nothing, --  Maybe Text
-                                      _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
-                                      _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
-                                      _textEdit = Nothing, --  Maybe
-                                      --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
-                                      _textEditText = Nothing, --  Maybe Text
-                                      _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
-                                      _commitCharacters = Nothing, --  Maybe [Text]
-                                      _command = Nothing, --  Maybe Types.Command
-                                      _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word range
-                                    },
+            mNameMb <- selectExternModuleNameFromFilePath filePath
+            forLsp mNameMb \mName -> do
+              let withQualifier = getIdentModuleQualifier word
+                  wordWithoutQual = maybe word snd withQualifier
+              limit <- getMaxCompletions
+              matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
+              -- matchingImport =
+              decls <- case (matchingImport, withQualifier) of
+                (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
+                (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
+                _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith mName wordWithoutQual
+              -- Just
+              res $
+                Right $
+                  Types.InR $
+                    Types.InL $
+                      Types.CompletionList (length decls >= limit) Nothing $
+                        decls <&> \cr ->
+                          let label = crName cr
+                            in Types.CompletionItem
+                                { _label = label,
+                                  _labelDetails =
+                                    Just $
+                                      Types.CompletionItemLabelDetails
+                                        (Just $ " " <> crType cr)
+                                        (Just $ P.runModuleName (crModule cr)),
+                                  _kind = Nothing, --  Maybe Types.CompletionItemKind TODO: add kind
+                                  _tags = Nothing,
+                                  _detail = Nothing,
+                                  _documentation = Nothing,
+                                  _deprecated = Nothing, --  Maybe Bool
+                                  _preselect = Nothing, --  Maybe Bool
+                                  _sortText = Nothing, --  Maybe Text
+                                  _filterText = Nothing, --  Maybe Text
+                                  _insertText = Nothing, --  Maybe Text
+                                  _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
+                                  _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
+                                  _textEdit = Nothing, --  Maybe
+                                  --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                                  _textEditText = Nothing, --  Maybe Text
+                                  _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
+                                  _commitCharacters = Nothing, --  Maybe [Text]
+                                  _command = Nothing, --  Maybe Types.Command
+                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word range
+                                },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         let completionItem = req ^. LSP.params
             result = completionItem ^. LSP.data_ & decodeCompleteItemData

From eddff6b4dd296f2628a86a1a8804933c17aa4125 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 21:58:27 +0200
Subject: [PATCH 146/297] adds index custom handler

---
 purescript.cabal                              |  1 +
 src/Language/PureScript/Lsp/Cache.hs          |  2 -
 src/Language/PureScript/Lsp/Handlers.hs       |  4 +-
 .../PureScript/Lsp/Handlers/Completion.hs     | 24 +++++--
 src/Language/PureScript/Lsp/Handlers/Index.hs | 68 +++++++++++++++++++
 src/Language/PureScript/Lsp/NameType.hs       | 10 +++
 src/Language/PureScript/Lsp/Print.hs          | 33 +++++++--
 src/Language/PureScript/Lsp/Rebuild.hs        | 34 ++++++++--
 src/Language/PureScript/Lsp/State.hs          | 37 ++++++----
 src/Language/PureScript/Make/Index.hs         | 30 +++++++-
 10 files changed, 208 insertions(+), 35 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Handlers/Index.hs

diff --git a/purescript.cabal b/purescript.cabal
index 26ccf56e74..3b49d80af7 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -354,6 +354,7 @@ library
     Language.PureScript.Lsp.Handlers.DeleteOutput
     Language.PureScript.Lsp.Handlers.Diagnostic
     Language.PureScript.Lsp.Handlers.Hover
+    Language.PureScript.Lsp.Handlers.Index
     Language.PureScript.Lsp.Log
     Language.PureScript.Lsp.Monad
     Language.PureScript.Lsp.NameType
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index bbbbb0b7d5..fd9b3e45f2 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -20,8 +20,6 @@ import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents
 import System.FilePath (normalise, (</>))
 import Language.PureScript.Lsp.Log (logPerfStandard)
 
--- import Language.PureScript.Lsp.Prim (primExterns)
-
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName ExternsFile)
 selectAllExternsMap = do
   Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectAllExterns
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 7815cacb87..cae2721361 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -25,6 +25,7 @@ import Language.PureScript.Lsp.ServerConfig (setTraceValue)
 import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild, clearCache, clearExportCache, clearRebuildCache)
 import Protolude hiding (to)
 import Data.Aeson qualified as A
+import Language.PureScript.Lsp.Handlers.Index (indexHandler)
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -35,7 +36,8 @@ handlers =
       definitionHandler,
       deleteOutputHandler,
       diagnosticAndCodeActionHandlers,
-      hoverHandler
+      hoverHandler,
+      indexHandler
     ]
   where
     -- Simple handlers that don't need to be in their own module
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 71c6176314..cf1bd95a33 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -18,7 +18,7 @@ import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
 import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
-import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.Log (logPerfStandard, debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
@@ -48,18 +48,28 @@ completionAndResolveHandlers =
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
             let (range, word) = getWordAt (VFS._file_text vf) pos
+            debugLsp $ "word: " <> word
             mNameMb <- selectExternModuleNameFromFilePath filePath
+            debugLsp $ "mNameMb: " <> show mNameMb
             forLsp mNameMb \mName -> do
               let withQualifier = getIdentModuleQualifier word
                   wordWithoutQual = maybe word snd withQualifier
+              debugLsp $ "withQualifier: " <> show withQualifier
+              debugLsp $ "wordWithoutQual: " <> wordWithoutQual
               limit <- getMaxCompletions
               matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
-              -- matchingImport =
-              decls <- case (matchingImport, withQualifier) of
-                (Just (Import importModuleName _ _), _) -> getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
-                (_, Just (wordModuleName, _)) -> getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
-                _ -> logPerfStandard "getAstDeclarationsStartingWith" $ getAstDeclarationsStartingWith mName wordWithoutQual
-              -- Just
+              debugLsp $ "matchingImport: " <> show matchingImport
+              decls <- logPerfStandard "get completion declarations" case (matchingImport, withQualifier) of
+                (Just (Import importModuleName _ _), _) -> do 
+                  debugLsp "getAstDeclarationsStartingWithOnlyInModule"
+                  getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
+                (_, Just (wordModuleName, _)) -> do 
+                  debugLsp $ "getAstDeclarationsStartingWithAndSearchingModuleNames: " <> show wordModuleName
+                  getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
+                _ ->  do
+                  debugLsp "getAstDeclarationsStartingWith"
+                  getAstDeclarationsStartingWith mName wordWithoutQual
+              debugLsp $ "decls length: " <> show (length decls)
               res $
                 Right $
                   Types.InR $
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
new file mode 100644
index 0000000000..8993b00874
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Language.PureScript.Lsp.Handlers.Index (indexHandler) where
+
+import Data.Aeson qualified as A
+import Data.Text qualified as T
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Server (MonadLsp, getConfig)
+import Language.LSP.Server qualified as Server
+import Language.PureScript (ExternsFile)
+import Language.PureScript qualified as P
+import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
+import Language.PureScript.Lsp.Types (LspEnvironment (lspDbConnection))
+import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexExtern)
+import Language.PureScript.Make.Monad (readExternsFile)
+import Protolude hiding (to)
+import System.Directory (doesFileExist, getDirectoryContents)
+import System.FilePath ((</>))
+
+indexHandler :: Server.Handlers HandlerM
+indexHandler =
+  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index") $ \_req res -> do
+    externs <- findAvailableExterns
+    for_ externs indexExternAndDecls
+    res $ Right A.Null
+  where
+    indexExternAndDecls :: ExternsFile -> HandlerM ()
+    indexExternAndDecls ef = do
+      conn <- asks lspDbConnection
+      indexExtern conn ef
+      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn (P.efModuleName ef))
+
+-- \| Finds all the externs inside the output folder and returns the
+-- corresponding module names
+findAvailableExterns ::
+  forall m.
+  ( MonadLsp ServerConfig m,
+    MonadReader LspEnvironment m
+  ) =>
+  m [ExternsFile]
+findAvailableExterns = do
+  oDir <- outputPath <$> getConfig
+  directories <- liftIO $ getDirectoryContents oDir
+  moduleNames <- liftIO $ filterM (containsExterns oDir) directories
+  catMaybes <$> for moduleNames (readExtern oDir)
+  where
+    -- Takes the output directory and a filepath like "Data.Array" and
+    -- looks up, whether that folder contains an externs file
+    containsExterns :: FilePath -> FilePath -> IO Bool
+    containsExterns oDir d
+      | d `elem` [".", ".."] = pure False
+      | otherwise = do
+          let file = oDir </> d </> P.externsFileName
+          doesFileExist file
+
+    readExtern :: FilePath -> FilePath -> m (Maybe ExternsFile)
+    readExtern oDir fp = do
+      let path = oDir </> fp
+      res <- runExceptT $ readExternsFile path
+      case res of
+        Left err -> do
+          debugLsp $ "Error reading externs file: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
+          pure Nothing
+        Right (Just ef) -> pure $ Just ef
+        _ -> pure Nothing
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index d3214f8177..2e7831875f 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -6,6 +6,7 @@ import Database.SQLite.Simple.FromField (FromField (fromField))
 import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.PureScript.Names
 import Protolude
+import Language.PureScript.Externs (ExternsDeclaration(..))
 
 data LspNameType
   = IdentNameType
@@ -32,3 +33,12 @@ lspNameType = \case
   DctorName _ -> DctorNameType
   TyClassName _ -> TyClassNameType
   ModName _ -> ModNameType
+
+externDeclNameType :: ExternsDeclaration -> LspNameType
+externDeclNameType = \case
+  EDType _ _ _ -> TyNameType
+  EDTypeSynonym _ _ _ -> TyNameType
+  EDDataConstructor _ _ _ _ _ -> DctorNameType
+  EDValue _ _ -> IdentNameType
+  EDClass _ _ _ _ _ _ -> TyClassNameType
+  EDInstance _ _ _ _ _ _ _ _ _ _ -> IdentNameType
diff --git a/src/Language/PureScript/Lsp/Print.hs b/src/Language/PureScript/Lsp/Print.hs
index 440ff559dc..310c3ecfb5 100644
--- a/src/Language/PureScript/Lsp/Print.hs
+++ b/src/Language/PureScript/Lsp/Print.hs
@@ -6,12 +6,13 @@ module Language.PureScript.Lsp.Print where
 
 import Control.Lens (Field1 (_1), (^.))
 import Data.Text qualified as T
-import Language.PureScript.AST.Traversals (accumTypes)
 import Language.PureScript.AST qualified as P
+import Language.PureScript.AST.Traversals (accumTypes)
 import Language.PureScript.Externs qualified as P
 -- import Language.PureScript.Linter qualified as P
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Pretty qualified as P
+import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
 
 printDeclarationType :: P.Declaration -> Text
@@ -23,9 +24,9 @@ printDeclarationType decl =
 
 printDeclarationTypeMb :: P.Declaration -> Maybe Text
 printDeclarationTypeMb decl =
-    (head :: [Text] -> Maybe Text) $
-      accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
-        decl
+  (head :: [Text] -> Maybe Text) $
+    accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
+      decl
 
 printName :: P.Name -> Text
 printName = \case
@@ -37,7 +38,6 @@ printName = \case
   P.TyClassName name -> P.runProperName name
   P.ModName name -> P.runModuleName name
 
-
 printEfDeclName :: P.ExternsDeclaration -> Text
 printEfDeclName = \case
   P.EDType name _ _ -> P.runProperName name
@@ -46,3 +46,26 @@ printEfDeclName = \case
   P.EDValue ident _ -> P.runIdent ident
   P.EDClass name _ _ _ _ _ -> P.runProperName name
   P.EDInstance name _ _ _ _ _ _ _ _ _ -> P.runProperName $ P.disqualify name
+
+printEfDeclType :: P.ExternsDeclaration -> Text
+printEfDeclType =
+  \case
+    P.EDType _ ty _ -> T.pack $ P.prettyPrintType maxBound ty
+    P.EDTypeSynonym _ _ ty -> T.pack $ P.prettyPrintType maxBound ty
+    P.EDDataConstructor _ _ _ ty _ -> T.pack $ P.prettyPrintType maxBound ty
+    P.EDValue _ ty -> T.pack $ P.prettyPrintType maxBound ty
+    P.EDClass {..} ->
+      let constraints :: [P.SourceConstraint] -> P.Type () -> P.Type ()
+          constraints [] t = t
+          constraints (sc : scs) t = P.ConstrainedType () (void sc) (constraints scs t)
+
+          args :: [(Text, Maybe P.SourceType)] -> P.Type () -> P.Type ()
+          args [] t = t
+          args ((n, Nothing) : ts) t = P.TypeApp () (P.TypeVar () n) (args ts t)
+          args ((n, Just ty) : ts) t = P.TypeApp () (P.KindedType () (P.TypeVar () n) (void ty)) (args ts t)
+       in T.pack $
+            P.prettyPrintType maxBound $
+              constraints edClassConstraints $
+                args edClassTypeArguments $
+                  P.TypeVar () "Constraint"
+    _ -> "instance"
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 34aac7fbc7..ebba25027a 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -9,21 +9,22 @@ import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
 import Language.LSP.Server (MonadLsp)
-import Language.PureScript (MultipleErrors)
+import Language.PureScript (primEnv)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile)
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
-import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
+import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild)
+import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild, setExportEnvCache, cacheDependencies)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection, lspStateVar), LspState, OpenFile (OpenFile))
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Options qualified as P
+import Language.PureScript.Sugar.Names qualified as P
 import Protolude hiding (moduleName)
 
 rebuildFile ::
@@ -58,7 +59,8 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
       case cachedBuild of
         Just (OpenFile _ _ externs env _) -> do
           foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-          exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
+          (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
+          for_ externsMb (cacheDependencies moduleName)
           res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
             P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
               newExtern <- P.rebuildModuleWithProvidedEnv (makeEnv foreigns externs) exportEnv env externs m Nothing
@@ -68,7 +70,7 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
         Nothing -> do
           externs <- logPerfStandard "Select depenencies" $ selectDependencies m
           foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-          exportEnv <- logPerfStandard "build export cache" $ buildExportEnvCache m externs
+          (exportEnv, _) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (pure externs) m externs
           res <- logPerfStandard "Rebuild Module" $ liftIO $ do
             P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
               newExtern <- P.rebuildModule' (makeEnv foreigns externs) exportEnv externs m
@@ -84,11 +86,31 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
           addExternToExportEnv newExtern
           pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
 
+buildExportEnvCacheAndHandleErrors :: (MonadReader LspEnvironment m, MonadIO m, MonadThrow m) => m [ExternsFile] -> P.Module -> [ExternsFile] -> m (P.Env, Maybe [ExternsFile])
+buildExportEnvCacheAndHandleErrors refectExterns m externs = do
+  fromCache <- buildExportEnvCache m externs
+  case fromCache of
+    Left err -> do
+      warnLsp $ "Error building export env cache: " <> show err
+      externs' <- refectExterns
+      envRes <- addExternsToExportEnv primEnv externs'
+      case envRes of
+        Left err' ->
+          throwM $
+            CouldNotRebuildExportEnv $
+              P.prettyPrintMultipleErrors P.noColorPPEOptions err'
+        Right env -> do
+          setExportEnvCache env
+          pure (env, Just externs')
+    Right env -> pure (env, Nothing)
+
 data RebuildResult
   = RebuildError P.MultipleErrors
   | RebuildWarning P.MultipleErrors
 
-data RebuildException = CouldNotConvertUriToFilePath NormalizedUri | CouldNotReadCacheDb MultipleErrors
+data RebuildException
+  = CouldNotConvertUriToFilePath NormalizedUri
+  | CouldNotRebuildExportEnv [Char]
   deriving (Exception, Show)
 
 codegenTargets :: Set P.CodegenTarget
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 3a0797597e..8af5bab965 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -4,12 +4,15 @@ module Language.PureScript.Lsp.State
   ( cacheRebuild,
     cacheRebuild',
     cachedRebuild,
+    cacheDependencies,
     clearCache,
     clearRebuildCache,
     clearExportCache,
+    setExportEnvCache,
     removedCachedRebuild,
     buildExportEnvCache,
     addExternToExportEnv,
+    addExternsToExportEnv,
     getExportEnv,
     cancelRequest,
     addRunningRequest,
@@ -18,7 +21,6 @@ module Language.PureScript.Lsp.State
 where
 
 import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar)
-import Control.Monad.Catch (MonadThrow (throwM))
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
 import Data.List qualified as List
 import Data.Map qualified as Map
@@ -36,6 +38,7 @@ import Language.PureScript.Lsp.Types
 import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
+import Language.PureScript.Names qualified as P
 
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Module -> m ()
@@ -51,8 +54,6 @@ cacheRebuild' st maxFiles ef deps prevEnv module' = atomically . modifyTVar st $
     }
   where
     fp = P.spanName $ efSourceSpan ef
-    
-
 
 cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe OpenFile)
 cachedRebuild fp = do
@@ -61,6 +62,17 @@ cachedRebuild fp = do
     st' <- readTVar st
     pure $ List.lookup fp $ openFiles st'
 
+cacheDependencies :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> [ExternsFile] -> m ()
+cacheDependencies moduleName deps = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x ->
+    x
+      { openFiles = openFiles x <&> \(fp, ofile) ->
+          if ofModuleName ofile == moduleName
+            then (fp, ofile {ofDependencies = deps})
+            else (fp, ofile)
+      }
+
 removedCachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m ()
 removedCachedRebuild fp = do
   st <- lspStateVar <$> ask
@@ -82,34 +94,35 @@ clearExportCache = do
 clearCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
 clearCache = clearRebuildCache >> clearExportCache
 
-buildExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m, MonadThrow m) => P.Module -> [ExternsFile] -> m P.Env
+buildExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> [ExternsFile] -> m (Either MultipleErrors P.Env)
 buildExportEnvCache module' externs = do
   st <- lspStateVar <$> ask
-  result <- liftIO . atomically $ do
+  liftIO . atomically $ do
     st' <- readTVar st
     if Map.member (P.getModuleName module') (exportEnv st')
       then pure $ Right $ exportEnv st'
       else do
         let notInEnv :: ExternsFile -> Bool
             notInEnv = flip Map.notMember (exportEnv st') . efModuleName
-        result <- addExterns (exportEnv st') (filter notInEnv externs)
+        result <- addExternsToExportEnv (exportEnv st') (filter notInEnv externs)
         case result of
           Left err -> pure $ Left err
           Right newEnv -> do
             writeTVar st $ st' {exportEnv = newEnv}
             pure $ Right newEnv
 
-  case result of
-    Left err -> throwM $ BuildEnvCacheException $ printBuildErrors err
-    Right env -> pure env
+setExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Env -> m ()
+setExportEnvCache env = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x -> x {exportEnv = env}
 
 data BuildEnvCacheException = BuildEnvCacheException Text
   deriving (Show)
 
 instance Exception BuildEnvCacheException
 
-addExterns :: (Foldable t, Monad f) => P.Env -> t ExternsFile -> f (Either MultipleErrors P.Env)
-addExterns env externs = fmap fst . runWriterT $ runExceptT $ foldM externsEnv env externs
+addExternsToExportEnv :: (Foldable t, Monad f) => P.Env -> t ExternsFile -> f (Either MultipleErrors P.Env)
+addExternsToExportEnv env externs = fmap fst . runWriterT $ runExceptT $ foldM externsEnv env externs
 
 logBuildErrors :: (MonadIO m, MonadReader LspEnvironment m) => MultipleErrors -> m ()
 logBuildErrors = errorLsp . printBuildErrors
@@ -122,7 +135,7 @@ addExternToExportEnv ef = do
   stVar <- lspStateVar <$> ask
   error <- liftIO $ atomically $ do
     st <- readTVar stVar
-    result <- addExterns (exportEnv st) [ef]
+    result <- addExternsToExportEnv (exportEnv st) [ef]
     case result of
       Left err -> pure $ Just err
       Right newEnv -> do
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 852a314dad..543267397b 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -38,7 +38,7 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
-import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printName)
+import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printName, printEfDeclType)
 import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
 import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
 import Language.PureScript.Make (ffiCodegen')
@@ -50,7 +50,7 @@ import Language.PureScript.Types (everywhereOnTypesM)
 import Paths_purescript qualified as Paths
 import Protolude hiding (moduleName)
 import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
-import Language.PureScript.Lsp.NameType (lspNameType)
+import Language.PureScript.Lsp.NameType (lspNameType, externDeclNameType)
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
@@ -103,6 +103,32 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
+indexAstDeclFromExternDecl :: (MonadIO m) => Connection -> P.ModuleName -> P.ExternsDeclaration -> m ()
+indexAstDeclFromExternDecl conn moduleName' externDecl = liftIO do
+  let ss = efDeclSourceSpan externDecl
+      start = P.spanStart ss
+      end = P.spanEnd ss
+      printedType :: Text 
+      printedType = printEfDeclType externDecl
+  SQL.executeNamed
+    conn
+    (SQL.Query 
+    "INSERT INTO ast_declarations \
+    \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
+    \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":name" := printEfDeclName externDecl,
+      ":printed_type" := printedType,
+      ":name_type" := externDeclNameType externDecl,
+      ":start_line" := P.sourcePosLine start,
+      ":end_line" := P.sourcePosLine end,
+      ":start_col" := P.sourcePosColumn start,
+      ":end_col" := P.sourcePosColumn end,
+      ":lines" := P.sourcePosLine end - P.sourcePosLine start,
+      ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
+      ":exported" := False
+    ]
+
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma

From d821f4fb3b2e9f267b103ac9b6e6be8bf2974d91 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 14 Oct 2024 22:21:33 +0200
Subject: [PATCH 147/297] adds index full

---
 src/Language/PureScript/Lsp/Handlers/Build.hs | 41 ++++++++++---------
 .../PureScript/Lsp/Handlers/Completion.hs     |  6 +--
 .../PureScript/Lsp/Handlers/DeleteOutput.hs   | 21 ++++++----
 src/Language/PureScript/Lsp/Handlers/Index.hs | 18 +++++---
 src/Language/PureScript/Lsp/Imports.hs        | 13 +++++-
 5 files changed, 63 insertions(+), 36 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index e03f309f21..efd970a4d0 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -21,22 +21,25 @@ import Language.PureScript.Lsp.State (clearCache)
 buildHandler :: Server.Handlers HandlerM
 buildHandler =
   Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
-    clearCache
-    config <- asks lspConfig
-    conn <- asks lspDbConnection
-    liftIO $ initDb conn
-    input <- updateAvailableSrcs
-    moduleFiles <- liftIO $ readUTF8FilesT input
-    (result, warnings) <-
-      liftIO $
-        compile
-          (P.Options False False codegenTargets)
-          moduleFiles
-          conn
-          (confOutputPath config)
-          False
-    let diags :: [Types.Diagnostic]
-        diags =
-          (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
-            <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
-    res $ Right $ A.toJSON diags
\ No newline at end of file
+    diags <- buildForLsp
+    res $ Right $ A.toJSON diags
+
+buildForLsp :: HandlerM [Types.Diagnostic]
+buildForLsp = do
+  clearCache
+  config <- asks lspConfig
+  conn <- asks lspDbConnection
+  liftIO $ initDb conn
+  input <- updateAvailableSrcs
+  moduleFiles <- liftIO $ readUTF8FilesT input
+  (result, warnings) <-
+    liftIO $
+      compile
+        (P.Options False False codegenTargets)
+        moduleFiles
+        conn
+        (confOutputPath config)
+        False
+  pure $
+    (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
+      <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index cf1bd95a33..f7118ade5d 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -14,10 +14,9 @@ import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.Ide.Imports (Import (..))
-import Language.PureScript.Lsp.Cache (selectExternModuleNameFromFilePath)
 import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
-import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport)
+import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
 import Language.PureScript.Lsp.Log (logPerfStandard, debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
@@ -49,7 +48,8 @@ completionAndResolveHandlers =
           forLsp vfMb \vf -> do
             let (range, word) = getWordAt (VFS._file_text vf) pos
             debugLsp $ "word: " <> word
-            mNameMb <- selectExternModuleNameFromFilePath filePath
+            debugLsp $ "filePath: " <> show filePath
+            mNameMb <- parseModuleNameFromFile uri
             debugLsp $ "mNameMb: " <> show mNameMb
             forLsp mNameMb \mName -> do
               let withQualifier = getIdentModuleQualifier word
diff --git a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
index 432520d4d3..03f9e38eff 100644
--- a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
@@ -4,6 +4,7 @@
 module Language.PureScript.Lsp.Handlers.DeleteOutput where
 
 import Data.Aeson qualified as A
+import Data.Aeson.KeyMap (delete)
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Server qualified as Server
 import Language.PureScript.DB (dbFile)
@@ -16,11 +17,15 @@ import System.FilePath ((</>))
 deleteOutputHandler :: Server.Handlers HandlerM
 deleteOutputHandler =
   Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete-output") $ \_req res -> do
-    outDir <- asks (confOutputPath . lspConfig)
-    liftIO $ createDirectoryIfMissing True outDir
-    contents <- liftIO $ listDirectory outDir
-    for_ contents \f -> do
-      unless (f == dbFile || dbFile `isPrefixOf` f) do
-        let path = outDir </> f
-        liftIO $ removePathForcibly path
-    res $ Right A.Null
\ No newline at end of file
+    deleteOutput
+    res $ Right A.Null
+
+deleteOutput :: HandlerM ()
+deleteOutput = do
+  outDir <- asks (confOutputPath . lspConfig)
+  liftIO $ createDirectoryIfMissing True outDir
+  contents <- liftIO $ listDirectory outDir
+  for_ contents \f -> do
+    unless (f == dbFile || dbFile `isPrefixOf` f) do
+      let path = outDir </> f
+      liftIO $ removePathForcibly path
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 8993b00874..d1189407b4 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -19,13 +19,21 @@ import Language.PureScript.Make.Monad (readExternsFile)
 import Protolude hiding (to)
 import System.Directory (doesFileExist, getDirectoryContents)
 import System.FilePath ((</>))
+import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutput)
+import Language.PureScript.Lsp.Handlers.Build (buildForLsp)
 
 indexHandler :: Server.Handlers HandlerM
 indexHandler =
-  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index") $ \_req res -> do
-    externs <- findAvailableExterns
-    for_ externs indexExternAndDecls
-    res $ Right A.Null
+  mconcat
+    [ Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-fast") $ \_req res -> do
+        externs <- findAvailableExterns
+        for_ externs indexExternAndDecls
+        res $ Right A.Null,
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \_req res -> do
+        deleteOutput
+        diags <- buildForLsp
+        res $ Right $ A.toJSON diags
+    ]
   where
     indexExternAndDecls :: ExternsFile -> HandlerM ()
     indexExternAndDecls ef = do
@@ -58,7 +66,7 @@ findAvailableExterns = do
 
     readExtern :: FilePath -> FilePath -> m (Maybe ExternsFile)
     readExtern oDir fp = do
-      let path = oDir </> fp
+      let path = oDir </> fp </> P.externsFileName
       res <- runExceptT $ readExternsFile path
       case res of
         Left err -> do
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 5e8c2da20c..777305615d 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -13,7 +13,7 @@ import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
-import Language.PureScript.Lsp.Log (errorLsp)
+import Language.PureScript.Lsp.Log (errorLsp, warnLsp)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ReadFile (lspReadFileRope)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
@@ -139,3 +139,14 @@ parseImportsFromFile ::
 parseImportsFromFile fp = do
   rope <- lspReadFileRope fp
   pure $ sliceImportSection (Rope.lines rope)
+
+parseModuleNameFromFile ::
+  (MonadThrow m, MonadLsp ServerConfig m, MonadReader LspEnvironment m) =>
+  NormalizedUri ->
+  m (Maybe P.ModuleName)
+parseModuleNameFromFile = parseImportsFromFile >=> \case 
+  Left err -> do 
+    warnLsp $ "Failed to parse module name from file: " <> err
+    pure Nothing
+  Right (mn, _, _, _) -> pure $ Just mn
+

From d14e52fdb594d7ad61403f0daf07b6dcab4f02e5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 15 Oct 2024 01:02:42 +0200
Subject: [PATCH 148/297] clean up

---
 src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
index 03f9e38eff..5c3c1366bc 100644
--- a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
@@ -4,7 +4,6 @@
 module Language.PureScript.Lsp.Handlers.DeleteOutput where
 
 import Data.Aeson qualified as A
-import Data.Aeson.KeyMap (delete)
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Server qualified as Server
 import Language.PureScript.DB (dbFile)

From 3b977bcd0d826ce6256a6a2373f6afe473660c20 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 15 Oct 2024 10:08:17 +0200
Subject: [PATCH 149/297] use purs-lsp-client config section in tests

---
 src/Language/PureScript/LSP.hs              | 2 +-
 src/Language/PureScript/Lsp/ServerConfig.hs | 6 +++---
 tests/TestLsp.hs                            | 2 +-
 3 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index db81024f99..6630dc6b22 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -33,7 +33,7 @@ serverDefinition lspEnv =
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = const $ pure (),
       defaultConfig = defaultFromEnv lspEnv,
-      configSection = "oa-purescript-lsp",
+      configSection = "purs-lsp-client",
       doInitialize = \env _ -> pure (Right env),
       staticHandlers = const (lspHandlers lspEnv),
       interpretHandler = \serverEnv ->
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index 62671039c8..f20cf7ad4c 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -13,7 +13,7 @@ data ServerConfig = ServerConfig
     globs :: [FilePath],
     inputSrcFromFile :: Maybe FilePath,
     logLevel :: LspLogLevel,
-    traceValue :: TraceValue,
+    traceValue :: Maybe TraceValue,
     maxTypeLength :: Maybe Int,
     maxCompletions :: Maybe Int, 
     maxFilesInCache :: Maybe Int
@@ -27,7 +27,7 @@ defaultFromEnv env =
       globs = confGlobs $ lspConfig env,
       inputSrcFromFile = confInputSrcFromFile $ lspConfig env,
       logLevel = logLevel,
-      traceValue = case logLevel of
+      traceValue = Just $ case logLevel of
         LogDebug -> TraceValue_Verbose
         LogAll -> TraceValue_Verbose
         LogWarning -> TraceValue_Messages
@@ -42,7 +42,7 @@ defaultFromEnv env =
 setTraceValue :: (MonadLsp ServerConfig m) => TraceValue -> m ()
 setTraceValue tv = do
   config <- getConfig
-  setConfig (config {traceValue = tv})
+  setConfig (config {traceValue = Just tv})
 
 defaultMaxTypeLength :: Int
 defaultMaxTypeLength = 100
diff --git a/tests/TestLsp.hs b/tests/TestLsp.hs
index 518ecc263a..dfccadb5ce 100644
--- a/tests/TestLsp.hs
+++ b/tests/TestLsp.hs
@@ -65,7 +65,7 @@ sessionConfig :: SessionConfig
 sessionConfig = SessionConfig 30 True True True clientConfig True True True Nothing
   where
     clientConfig :: KeyMap A.Value
-    clientConfig = KeyMap.singleton "oa-purescript-lsp" (A.toJSON pursLspConfig)
+    clientConfig = KeyMap.singleton "purs-lsp-client" (A.toJSON pursLspConfig)
 
     pursLspConfig :: Map Text.Text A.Value
     pursLspConfig = Map.empty

From 54e263966937fd1644c66855222ac8865ff25374 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 15 Oct 2024 14:13:55 +0200
Subject: [PATCH 150/297] remove env config and use lsp config

---
 app/Command/Lsp.hs                            | 13 ++-------
 src/Language/PureScript/LSP.hs                |  9 ++++--
 src/Language/PureScript/Lsp/Cache.hs          | 16 ++++++-----
 src/Language/PureScript/Lsp/DB.hs             | 11 ++++----
 src/Language/PureScript/Lsp/Docs.hs           | 20 +++++++------
 src/Language/PureScript/Lsp/Handlers.hs       | 13 ++++++++-
 src/Language/PureScript/Lsp/Handlers/Build.hs | 11 ++++----
 .../PureScript/Lsp/Handlers/DeleteOutput.hs   |  5 ++--
 src/Language/PureScript/Lsp/Handlers/Index.hs | 11 ++++++--
 src/Language/PureScript/Lsp/Log.hs            | 22 ++++++++-------
 src/Language/PureScript/Lsp/Rebuild.hs        | 20 ++++++-------
 src/Language/PureScript/Lsp/ServerConfig.hs   | 28 ++++++++-----------
 src/Language/PureScript/Lsp/State.hs          | 11 ++++++--
 src/Language/PureScript/Lsp/Types.hs          | 13 ++++-----
 src/Language/PureScript/Make/Index.hs         | 10 +------
 15 files changed, 112 insertions(+), 101 deletions(-)

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index d7f92396b6..4df9567078 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -1,6 +1,6 @@
 module Command.Lsp (command) where
 
-import Language.PureScript.Lsp.Types (LspConfig (..), mkEnv, LspLogLevel(..))
+import Language.PureScript.Lsp.Types (mkEnv, LspLogLevel(..))
 import Language.PureScript.Lsp as Lsp
 import Options.Applicative qualified as Opts
 import Protolude
@@ -32,19 +32,12 @@ command = Opts.helper <*> subcommands
         ]
 
     server :: ServerOptions -> IO ()
-    server opts'@(ServerOptions dir globs globsFromFile _globsExcluded outputPath logLevel) = do
+    server opts'@(ServerOptions dir _globs _globsFromFile _globsExcluded outputPath logLevel) = do
       when
         (logLevel == LogDebug || logLevel == LogAll)
         (hPutStrLn stderr ("Parsed Options:" :: Text) *> hPutStrLn stderr (show opts' :: Text))
       maybe (pure ()) setCurrentDirectory dir
-      let conf =
-            LspConfig
-              { confOutputPath = outputPath,
-                confGlobs = globs,
-                confInputSrcFromFile = globsFromFile,
-                confLogLevel = logLevel
-              }
-      env <- mkEnv conf
+      env <- mkEnv outputPath
       startServer env
 
     serverOptions :: Opts.Parser ServerOptions
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 6630dc6b22..a14e7e9f71 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -17,7 +17,7 @@ import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Handlers (handlers)
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultFromEnv)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Lsp.State (addRunningRequest, removeRunningRequest)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
@@ -32,7 +32,7 @@ serverDefinition lspEnv =
   Server.ServerDefinition
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = const $ pure (),
-      defaultConfig = defaultFromEnv lspEnv,
+      defaultConfig = defaultConfig,
       configSection = "purs-lsp-client",
       doInitialize = \env _ -> pure (Right env),
       staticHandlers = const (lspHandlers lspEnv),
@@ -72,6 +72,9 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
             LSP.IdString t -> Right t
       env <- getLspEnv
       debugLsp $ "Request: " <> show method
+      --  <>  case method of 
+      --     Method_CustomMethod a ->  _ a 
+      --     _ -> show method
       liftIO $ do
         withAsync (runHandler env $ f msg k) \asyncAct -> do
           addRunningRequest lspEnv reqId asyncAct
@@ -103,3 +106,5 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
           _ -> pure ()
 
     runHandler env a = Server.runLspT env $ runReaderT a lspEnv
+
+
diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index fd9b3e45f2..c1f5edd363 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -13,12 +13,14 @@ import Language.PureScript.Externs qualified as P
 import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Lsp.DB qualified as DB
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute, canonicalizePath)
 import System.FilePath (normalise, (</>))
 import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig(outputPath, globs, inputSrcFromFile))
+import Language.LSP.Server (getConfig, MonadLsp)
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName ExternsFile)
 selectAllExternsMap = do
@@ -82,9 +84,9 @@ selectExternPathFromModuleName mName =
 
 -- | Finds all the externs inside the output folder and returns the
 -- corresponding module names
-findAvailableExterns :: (MonadIO m, MonadReader LspEnvironment m, MonadError IdeError m) => m [P.ModuleName]
+findAvailableExterns :: (MonadReader LspEnvironment m, MonadError IdeError m, MonadLsp ServerConfig m) => m [P.ModuleName]
 findAvailableExterns = do
-  oDir <- asks (confOutputPath . lspConfig)
+  oDir <- outputPath <$> getConfig
   unlessM
     (liftIO (doesDirectoryExist oDir))
     (throwError (GeneralError $ "Couldn't locate your output directory at: " <> T.pack (normalise oDir)))
@@ -102,17 +104,17 @@ findAvailableExterns = do
           let file = oDir </> d </> P.externsFileName
           doesFileExist file
 
-updateAvailableSrcs :: (MonadIO m, MonadReader LspEnvironment m) => m [FilePath]
+updateAvailableSrcs :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => m [FilePath]
 updateAvailableSrcs = logPerfStandard "updateAvailableSrcs" $ do
   DB.execute_ "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
   DB.execute_ (Query "DELETE FROM available_srcs")
-  config <- asks lspConfig
+  config <- getConfig
   srcs <-
     liftIO $
       toInputGlobs $
         PSCGlobs
-          { pscInputGlobs = confGlobs config,
-            pscInputGlobsFromFile = confInputSrcFromFile config,
+          { pscInputGlobs = globs config,
+            pscInputGlobsFromFile = inputSrcFromFile config,
             pscExcludeGlobs = [],
             pscWarnFileTypeNotFound = warnFileTypeNotFound "lsp server"
           }
diff --git a/src/Language/PureScript/Lsp/DB.hs b/src/Language/PureScript/Lsp/DB.hs
index 3972c1e680..257d3603af 100644
--- a/src/Language/PureScript/Lsp/DB.hs
+++ b/src/Language/PureScript/Lsp/DB.hs
@@ -3,8 +3,9 @@ module Language.PureScript.Lsp.DB where
 import Database.SQLite.Simple qualified as SQL
 import Database.SQLite.Simple.FromRow (FromRow)
 import Database.SQLite.Simple.Types (Query)
-import Language.PureScript.Lsp.Types (LspEnvironment (lspDbConnection))
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude
+import Language.PureScript.Lsp.State (getDbConn)
 
 
 -- initDb :: (MonadReader LspEnvironment m, MonadIO m) => FilePath -> m ()
@@ -15,7 +16,7 @@ queryNamed ::
   [SQL.NamedParam] ->
   m [r]
 queryNamed q params = do
-  conn <- asks lspDbConnection
+  conn <- getDbConn
   liftIO $ SQL.queryNamed conn q params
   
 query_ ::
@@ -23,7 +24,7 @@ query_ ::
   Query ->
   m [r]
 query_ q  = do
-  conn <- asks lspDbConnection
+  conn <- getDbConn
   liftIO $ SQL.query_ conn q 
   
 executeNamed ::
@@ -32,11 +33,11 @@ executeNamed ::
   [SQL.NamedParam] ->
   m ()
 executeNamed q params = do
-  conn <- asks lspDbConnection
+  conn <- getDbConn
   liftIO $ SQL.executeNamed conn q params
 
 execute_ :: (MonadReader LspEnvironment m, MonadIO m) => Query -> m ()
 execute_ q  = do
-  conn <- asks lspDbConnection
+  conn <- getDbConn
   liftIO $ SQL.execute_ conn q 
   
diff --git a/src/Language/PureScript/Lsp/Docs.hs b/src/Language/PureScript/Lsp/Docs.hs
index 29556c9205..644378d007 100644
--- a/src/Language/PureScript/Lsp/Docs.hs
+++ b/src/Language/PureScript/Lsp/Docs.hs
@@ -1,6 +1,7 @@
 module Language.PureScript.Lsp.Docs where
 
 import Control.Arrow ((>>>))
+import Language.LSP.Server (MonadLsp, getConfig)
 import Language.PureScript.AST.SourcePos qualified as P
 import Language.PureScript.Docs qualified as Docs
 import Language.PureScript.Docs.AsMarkdown (declAsMarkdown, runDocs)
@@ -9,22 +10,23 @@ import Language.PureScript.Docs.Types (Declaration (declChildren))
 import Language.PureScript.Docs.Types qualified as P
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
 
-readModuleDocs :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> m (Maybe Docs.Module)
+readModuleDocs :: (MonadLsp ServerConfig m) => P.ModuleName -> m (Maybe Docs.Module)
 readModuleDocs modName = do
-  outputDirectory <- asks (confOutputPath . lspConfig)
+  outputDirectory <- outputPath <$> getConfig
   liftIO $ catchError (Just <$> parseDocsJsonFile outputDirectory modName) (const $ pure Nothing)
 
-readDeclarationDocs :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Docs.Declaration)
+readDeclarationDocs :: (MonadLsp ServerConfig m) => P.ModuleName -> Text -> m (Maybe Docs.Declaration)
 readDeclarationDocs modName ident = do
   modMb <- readModuleDocs modName
   pure $ modMb >>= (P.modDeclarations >>> find ((== ident) . P.declTitle))
 
 -- todo: add child info and operator matching
-readDeclarationDocsWithNameType :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> LspNameType -> Text -> m (Maybe Text)
+readDeclarationDocsWithNameType :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> LspNameType -> Text -> m (Maybe Text)
 readDeclarationDocsWithNameType modName nameType ident = do
   modMb <- readModuleDocs modName
   pure $ modMb >>= (P.modDeclarations >>> getMarkdown)
@@ -53,18 +55,18 @@ readDeclarationDocsWithNameType modName nameType ident = do
       P.ChildDataConstructor _ -> nameType == DctorNameType && P.cdeclTitle cd == ident
       P.ChildTypeClassMember _ -> nameType == IdentNameType && P.cdeclTitle cd == ident
 
-readDeclarationDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe Text)
+readDeclarationDocsAsMarkdown :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> Text -> m (Maybe Text)
 readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$> readDeclarationDocs modName ident
 
-readQualifiedNameDocsAsMarkdown :: (MonadIO m, MonadReader LspEnvironment m) => P.Qualified P.Name -> m (Maybe Text)
+readQualifiedNameDocsAsMarkdown :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.Qualified P.Name -> m (Maybe Text)
 readQualifiedNameDocsAsMarkdown = \case
   (P.Qualified (P.ByModuleName modName) ident) -> readDeclarationDocsAsMarkdown modName (printName ident)
   _ -> pure Nothing
 
-readDeclarationDocsSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe P.SourceSpan)
+readDeclarationDocsSourceSpan :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> Text -> m (Maybe P.SourceSpan)
 readDeclarationDocsSourceSpan modName ident = readDeclarationDocs modName ident <&> (=<<) P.declSourceSpan
 
-readQualifiedNameDocsSourceSpan :: (MonadIO m, MonadReader LspEnvironment m) => P.Qualified P.Name -> m (Maybe P.SourceSpan)
+readQualifiedNameDocsSourceSpan :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.Qualified P.Name -> m (Maybe P.SourceSpan)
 readQualifiedNameDocsSourceSpan = \case
   (P.Qualified (P.ByModuleName modName) ident) -> readDeclarationDocsSourceSpan modName (printName ident)
   _ -> pure Nothing
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index cae2721361..513e362c8b 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -22,10 +22,11 @@ import Language.PureScript.Lsp.Handlers.Diagnostic (diagnosticAndCodeActionHandl
 import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (setTraceValue)
-import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild, clearCache, clearExportCache, clearRebuildCache)
+import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild, clearCache, clearExportCache, clearRebuildCache, getDbConn)
 import Protolude hiding (to)
 import Data.Aeson qualified as A
 import Language.PureScript.Lsp.Handlers.Index (indexHandler)
+import Language.PureScript.Make.Index (initDb, dropTables)
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -46,6 +47,8 @@ handlers =
         [ Server.notificationHandler Message.SMethod_Initialized $ \_not -> do
             void updateAvailableSrcs
             sendInfoMsg "Lsp initialized",
+          Server.notificationHandler Message.SMethod_WorkspaceDidChangeWatchedFiles $ \_not -> do
+            pure (),
           Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \_msg -> do
             pure (),
           Server.notificationHandler Message.SMethod_TextDocumentDidChange $ \_msg -> do
@@ -72,6 +75,14 @@ handlers =
             res $ Right A.Null,
           Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:rebuilds") $ \_req res -> do
             clearRebuildCache
+            res $ Right A.Null,
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"create-index-tables") $ \_req res -> do
+            conn <- getDbConn
+            liftIO $ initDb conn
+            res $ Right A.Null,
+          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"drop-index-tables") $ \_req res -> do
+            conn <- getDbConn
+            liftIO $ dropTables conn
             res $ Right A.Null
         ]
 
diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index efd970a4d0..46d110218c 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -12,11 +12,12 @@ import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Rebuild (codegenTargets)
-import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig, lspDbConnection))
 import Language.PureScript.Make.Index (initDb)
 import Protolude hiding (to)
 import System.IO.UTF8 (readUTF8FilesT)
-import Language.PureScript.Lsp.State (clearCache)
+import Language.PureScript.Lsp.State (clearCache, getDbConn)
+import Language.LSP.Server (getConfig)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig(outputPath))
 
 buildHandler :: Server.Handlers HandlerM
 buildHandler =
@@ -27,8 +28,8 @@ buildHandler =
 buildForLsp :: HandlerM [Types.Diagnostic]
 buildForLsp = do
   clearCache
-  config <- asks lspConfig
-  conn <- asks lspDbConnection
+  outDir <-  outputPath <$> getConfig
+  conn <- getDbConn
   liftIO $ initDb conn
   input <- updateAvailableSrcs
   moduleFiles <- liftIO $ readUTF8FilesT input
@@ -38,7 +39,7 @@ buildForLsp = do
         (P.Options False False codegenTargets)
         moduleFiles
         conn
-        (confOutputPath config)
+        outDir
         False
   pure $
     (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
diff --git a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
index 5c3c1366bc..1fd6f4e8e0 100644
--- a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs
@@ -8,10 +8,11 @@ import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Server qualified as Server
 import Language.PureScript.DB (dbFile)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.Types (LspConfig (confOutputPath), LspEnvironment (lspConfig))
 import Protolude hiding (to)
 import System.Directory (createDirectoryIfMissing, listDirectory, removePathForcibly)
 import System.FilePath ((</>))
+import Language.PureScript.Lsp.ServerConfig (ServerConfig(outputPath))
+import Language.LSP.Server (getConfig)
 
 deleteOutputHandler :: Server.Handlers HandlerM
 deleteOutputHandler =
@@ -21,7 +22,7 @@ deleteOutputHandler =
 
 deleteOutput :: HandlerM ()
 deleteOutput = do
-  outDir <- asks (confOutputPath . lspConfig)
+  outDir <- outputPath <$> getConfig
   liftIO $ createDirectoryIfMissing True outDir
   contents <- liftIO $ listDirectory outDir
   for_ contents \f -> do
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index d1189407b4..240a498a3b 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -13,23 +13,28 @@ import Language.PureScript qualified as P
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
-import Language.PureScript.Lsp.Types (LspEnvironment (lspDbConnection))
-import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexExtern)
+import Language.PureScript.Lsp.Types (LspEnvironment)
+import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexExtern, initDb)
 import Language.PureScript.Make.Monad (readExternsFile)
 import Protolude hiding (to)
 import System.Directory (doesFileExist, getDirectoryContents)
 import System.FilePath ((</>))
 import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutput)
 import Language.PureScript.Lsp.Handlers.Build (buildForLsp)
+import Language.PureScript.Lsp.State (getDbConn)
 
 indexHandler :: Server.Handlers HandlerM
 indexHandler =
   mconcat
     [ Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-fast") $ \_req res -> do
+        conn <- getDbConn
+        liftIO $ initDb conn
         externs <- findAvailableExterns
         for_ externs indexExternAndDecls
         res $ Right A.Null,
       Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \_req res -> do
+        conn <- getDbConn
+        liftIO $ initDb conn
         deleteOutput
         diags <- buildForLsp
         res $ Right $ A.toJSON diags
@@ -37,7 +42,7 @@ indexHandler =
   where
     indexExternAndDecls :: ExternsFile -> HandlerM ()
     indexExternAndDecls ef = do
-      conn <- asks lspDbConnection
+      conn <- getDbConn
       indexExtern conn ef
       for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn (P.efModuleName ef))
 
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index 8644cc05ee..2c998854e7 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -3,28 +3,30 @@ module Language.PureScript.Lsp.Log where
 import Data.Text qualified as T
 import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
 import Language.PureScript.Ide.Logging (displayTimeSpec)
-import Language.PureScript.Lsp.Types (LspConfig (confLogLevel), LspEnvironment (lspConfig), LspLogLevel (..))
+import Language.PureScript.Lsp.Types (LspEnvironment, LspLogLevel (..))
 import Protolude
 import System.Clock (Clock (Monotonic), TimeSpec, diffTimeSpec, getTime)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig(logLevel))
+import Language.LSP.Server (getConfig, MonadLsp)
 
-infoLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+infoLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m ()
 infoLsp = logLsp LogMsgInfo
 
-warnLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+warnLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m ()
 warnLsp = logLsp LogMsgWarning
 
-errorLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+errorLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m ()
 errorLsp = logLsp LogMsgError
 
-debugLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+debugLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m ()
 debugLsp = logLsp LogMsgDebug
 
-perfLsp :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m ()
+perfLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m ()
 perfLsp = logLsp LogMsgPerf
 
-logLsp :: (MonadIO m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text -> m ()
+logLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text -> m ()
 logLsp msgLogLevel msg = do
-  logLevel <- confLogLevel . lspConfig <$> ask
+  logLevel <- logLevel <$> getConfig
   when (shouldLog msgLogLevel logLevel) $ do
     now <- liftIO getCurrentTime
     liftIO $
@@ -39,10 +41,10 @@ logLsp msgLogLevel msg = do
             <> "\n\n"
         )
 
-logPerfStandard :: (MonadIO m, MonadReader LspEnvironment m) => Text -> m t -> m t
+logPerfStandard :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m t -> m t
 logPerfStandard label f = logPerf (labelTimespec label) f
 
-logPerf :: (MonadIO m, MonadReader LspEnvironment m) => (TimeSpec -> Text) -> m t -> m t
+logPerf :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => (TimeSpec -> Text) -> m t -> m t
 logPerf format f = do
   start <- getPerfTime
   result <- f
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index ebba25027a..51e204c6c6 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -8,7 +8,7 @@ import Control.Monad.Catch (MonadThrow (throwM))
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
-import Language.LSP.Server (MonadLsp)
+import Language.LSP.Server (MonadLsp, getConfig)
 import Language.PureScript (primEnv)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
@@ -18,9 +18,9 @@ import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild, setExportEnvCache, cacheDependencies)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig, lspDbConnection, lspStateVar), LspState, OpenFile (OpenFile))
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getMaxFilesInCache)
+import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild, setExportEnvCache, cacheDependencies, getDbConn)
+import Language.PureScript.Lsp.Types (LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile))
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Options qualified as P
@@ -29,7 +29,7 @@ import Protolude hiding (moduleName)
 
 rebuildFile ::
   ( MonadThrow m,
-    MonadReader LspEnvironment m,
+    MonadReader Language.PureScript.Lsp.Types.LspEnvironment m,
     MonadLsp ServerConfig m
   ) =>
   NormalizedUri ->
@@ -45,8 +45,8 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
     Right (pwarnings, m) -> do
       let moduleName = P.getModuleName m
       let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
-      outputDirectory <- asks (confOutputPath . lspConfig)
-      conn <- asks lspDbConnection
+      outputDirectory <- outputPath <$> getConfig
+      conn <- getDbConn
       stVar <- asks lspStateVar
       maxCache <- getMaxFilesInCache
       cachedBuild <- cachedRebuild fp
@@ -57,7 +57,7 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
               & addRebuildCaching stVar maxCache externs
       debugLsp $ "Cache found: " <> show (isJust cachedBuild)
       case cachedBuild of
-        Just (OpenFile _ _ externs env _) -> do
+        Just (Language.PureScript.Lsp.Types.OpenFile _ _ externs env _) -> do
           foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
           (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
           for_ externsMb (cacheDependencies moduleName)
@@ -86,7 +86,7 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
           addExternToExportEnv newExtern
           pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
 
-buildExportEnvCacheAndHandleErrors :: (MonadReader LspEnvironment m, MonadIO m, MonadThrow m) => m [ExternsFile] -> P.Module -> [ExternsFile] -> m (P.Env, Maybe [ExternsFile])
+buildExportEnvCacheAndHandleErrors :: (MonadReader Language.PureScript.Lsp.Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) => m [ExternsFile] -> P.Module -> [ExternsFile] -> m (P.Env, Maybe [ExternsFile])
 buildExportEnvCacheAndHandleErrors refectExterns m externs = do
   fromCache <- buildExportEnvCache m externs
   case fromCache of
@@ -121,7 +121,7 @@ shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushProgress ma =
   ma {P.progress = \_ -> pure ()}
 
-addRebuildCaching :: TVar LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
+addRebuildCaching :: TVar Language.PureScript.Lsp.Types.LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps ma =
   ma
     { P.codegen = \prevEnv env astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv astM) <* P.codegen ma prevEnv env astM m docs ext
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index f20cf7ad4c..18231a64fe 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -5,7 +5,7 @@ module Language.PureScript.Lsp.ServerConfig where
 import Data.Aeson (FromJSON, ToJSON)
 import Language.LSP.Protocol.Types (TraceValue (..))
 import Language.LSP.Server (MonadLsp, getConfig, setConfig)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (..), LspLogLevel (..))
+import Language.PureScript.Lsp.Types (LspLogLevel (..))
 import Protolude
 
 data ServerConfig = ServerConfig
@@ -20,24 +20,18 @@ data ServerConfig = ServerConfig
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
-defaultFromEnv :: LspEnvironment -> ServerConfig
-defaultFromEnv env =
+defaultConfig :: ServerConfig
+defaultConfig  =
   ServerConfig
-    { outputPath = confOutputPath $ lspConfig env,
-      globs = confGlobs $ lspConfig env,
-      inputSrcFromFile = confInputSrcFromFile $ lspConfig env,
-      logLevel = logLevel,
-      traceValue = Just $ case logLevel of
-        LogDebug -> TraceValue_Verbose
-        LogAll -> TraceValue_Verbose
-        LogWarning -> TraceValue_Messages
-        _ -> TraceValue_Off,
-      maxTypeLength = Nothing,
-      maxCompletions = Nothing, 
-      maxFilesInCache = Nothing
+    { outputPath = "./output",
+      globs = ["./src/**/*.purs"],
+      inputSrcFromFile = Nothing,
+      logLevel = LogWarning,
+      traceValue = Nothing,
+      maxTypeLength = Just defaultMaxTypeLength,
+      maxCompletions = Just defaultMaxCompletions, 
+      maxFilesInCache = Just defaultMaxFilesInCache
     }
-  where
-    logLevel = confLogLevel $ lspConfig env
 
 setTraceValue :: (MonadLsp ServerConfig m) => TraceValue -> m ()
 setTraceValue tv = do
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 8af5bab965..7f3daaedc1 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -1,7 +1,8 @@
 {-# LANGUAGE TypeOperators #-}
 
 module Language.PureScript.Lsp.State
-  ( cacheRebuild,
+  ( getDbConn, 
+    cacheRebuild,
     cacheRebuild',
     cachedRebuild,
     cacheDependencies,
@@ -39,6 +40,10 @@ import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
 import Language.PureScript.Names qualified as P
+import Database.SQLite.Simple (Connection)
+
+getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m  Connection
+getDbConn = liftIO . readTVarIO . lspDbConnection =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Module -> m ()
@@ -124,13 +129,13 @@ instance Exception BuildEnvCacheException
 addExternsToExportEnv :: (Foldable t, Monad f) => P.Env -> t ExternsFile -> f (Either MultipleErrors P.Env)
 addExternsToExportEnv env externs = fmap fst . runWriterT $ runExceptT $ foldM externsEnv env externs
 
-logBuildErrors :: (MonadIO m, MonadReader LspEnvironment m) => MultipleErrors -> m ()
+logBuildErrors :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => MultipleErrors -> m ()
 logBuildErrors = errorLsp . printBuildErrors
 
 printBuildErrors :: MultipleErrors -> Text
 printBuildErrors = T.pack . prettyPrintMultipleErrors P.noColorPPEOptions
 
-addExternToExportEnv :: (MonadIO m, MonadReader LspEnvironment m) => ExternsFile -> m ()
+addExternToExportEnv :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => ExternsFile -> m ()
 addExternToExportEnv ef = do
   stVar <- lspStateVar <$> ask
   error <- liftIO $ atomically $ do
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 154d4f2f05..ee220bd17c 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -18,21 +18,18 @@ import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (Env)
 import Language.PureScript.Sugar.Names qualified as P
 import Protolude
-import System.Directory (createDirectoryIfMissing)
 import Language.PureScript.AST qualified as P
 
 data LspEnvironment = LspEnvironment
-  { lspConfig :: LspConfig,
-    lspDbConnection :: Connection,
+  { lspDbConnection :: TVar Connection,
     lspStateVar :: TVar LspState
   }
 
-mkEnv :: LspConfig -> IO LspEnvironment
-mkEnv conf = do
-  createDirectoryIfMissing True $ confOutputPath conf
-  connection <- mkConnection $ confOutputPath conf
+mkEnv :: FilePath -> IO LspEnvironment
+mkEnv outputPath = do
+  connection <- newTVarIO =<< mkConnection outputPath
   st <- newTVarIO (LspState mempty P.primEnv mempty)
-  pure $ LspEnvironment conf connection st
+  pure $ LspEnvironment connection st
 
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 543267397b..5605978bfe 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -39,7 +39,7 @@ import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Ide.Types (ModuleMap)
 import Language.PureScript.Ide.Util (ideReadFile)
 import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printName, printEfDeclType)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment (lspConfig))
+import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment)
 import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
 import Language.PureScript.Make (ffiCodegen')
 import Language.PureScript.Make qualified as P
@@ -170,20 +170,12 @@ insertEfImport conn moduleName' ei = do
 
 initDb :: Connection -> IO ()
 initDb conn = do
-  dropTables conn
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_expressions (module_name TEXT, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, length INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS envs (module_name TEXT PRIMARY KEY, value TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_modules (name TEXT PRIMARY KEY, path TEXT, value TEXT, UNIQUE(name) on conflict replace, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_imports (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, imported_module TEXT, UNIQUE(module_name, imported_module) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_declarations (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, ident TEXT, top_level BOOLEAN, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS corefn_expressions (module_name TEXT references corefn_modules(name) ON DELETE CASCADE, value TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
-
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
 
   addDbIndexes conn

From 2625cd61ddbc55d6bfe82bd38e390eb093effd92 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 15 Oct 2024 14:19:35 +0200
Subject: [PATCH 151/297] remove unused lsp command opts

---
 app/Command/Lsp.hs | 32 +++-----------------------------
 1 file changed, 3 insertions(+), 29 deletions(-)

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index 4df9567078..8640bd3a6a 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -1,19 +1,14 @@
 module Command.Lsp (command) where
 
-import Language.PureScript.Lsp.Types (mkEnv, LspLogLevel(..))
 import Language.PureScript.Lsp as Lsp
+import Language.PureScript.Lsp.Types (mkEnv)
 import Options.Applicative qualified as Opts
 import Protolude
-import SharedCLI qualified
 import System.Directory (setCurrentDirectory)
 
 data ServerOptions = ServerOptions
   { _serverDirectory :: Maybe FilePath,
-    _serverGlobs :: [FilePath],
-    _serverGlobsFromFile :: Maybe FilePath,
-    _serverGlobsExcluded :: [FilePath],
-    _serverOutputPath :: FilePath,
-    _serverLoglevel :: LspLogLevel
+    _serverOutputPath :: FilePath
   }
   deriving (Show)
 
@@ -32,10 +27,7 @@ command = Opts.helper <*> subcommands
         ]
 
     server :: ServerOptions -> IO ()
-    server opts'@(ServerOptions dir _globs _globsFromFile _globsExcluded outputPath logLevel) = do
-      when
-        (logLevel == LogDebug || logLevel == LogAll)
-        (hPutStrLn stderr ("Parsed Options:" :: Text) *> hPutStrLn stderr (show opts' :: Text))
+    server (ServerOptions dir outputPath) = do
       maybe (pure ()) setCurrentDirectory dir
       env <- mkEnv outputPath
       startServer env
@@ -44,25 +36,7 @@ command = Opts.helper <*> subcommands
     serverOptions =
       ServerOptions
         <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
-        <*> many SharedCLI.inputFile
-        <*> SharedCLI.globInputFile
-        <*> many SharedCLI.excludeFiles
         <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
-        <*> ( parseLogLevel
-                <$> Opts.strOption
-                  ( Opts.long "log-level"
-                      `mappend` Opts.value ""
-                      `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\""
-                  )
-            )
-
-    parseLogLevel :: Text -> LspLogLevel
-    parseLogLevel s = case s of
-      "debug" -> LogDebug
-      "perf" -> LogPerf
-      "all" -> LogAll
-      "none" -> LogNone
-      _ -> LogWarning
 
     startServer env = do
       code <- Lsp.main env

From 91b2884c4617d9bceebad9d4fbbd5395f54a88ad Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 15 Oct 2024 18:40:08 +0200
Subject: [PATCH 152/297] use purescript-lsp config section

---
 app/Command/Lsp.hs                          |  1 +
 src/Language/PureScript/LSP.hs              | 25 +++++++++--------
 src/Language/PureScript/Lsp/Handlers.hs     |  4 ++-
 src/Language/PureScript/Lsp/ServerConfig.hs |  2 +-
 src/Language/PureScript/Lsp/State.hs        | 30 ++++++++++++++-------
 src/Language/PureScript/Lsp/Types.hs        |  5 +++-
 tests/TestLsp.hs                            |  2 +-
 7 files changed, 45 insertions(+), 24 deletions(-)

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index 8640bd3a6a..629eae5128 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -29,6 +29,7 @@ command = Opts.helper <*> subcommands
     server :: ServerOptions -> IO ()
     server (ServerOptions dir outputPath) = do
       maybe (pure ()) setCurrentDirectory dir
+      putErrLn $ "Starting server with output path: " <> outputPath
       env <- mkEnv outputPath
       startServer env
 
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index a14e7e9f71..d115aa06e5 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -13,15 +13,15 @@ import Data.Aeson.Types qualified as A
 import Data.Text qualified as T
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server (MonadLsp (getLspEnv), mapHandlers)
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Handlers (handlers)
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
-import Language.PureScript.Lsp.State (addRunningRequest, removeRunningRequest)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), defaultConfig)
+import Language.PureScript.Lsp.State (addRunningRequest, removeRunningRequest, putNewEnv)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
-import Language.LSP.Server (mapHandlers, MonadLsp (getLspEnv))
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
@@ -31,9 +31,15 @@ serverDefinition :: LspEnvironment -> Server.ServerDefinition ServerConfig
 serverDefinition lspEnv =
   Server.ServerDefinition
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
-      onConfigChange = const $ pure (),
+      onConfigChange = \newConfig -> do
+        oldConfig <- Server.getConfig
+        debugLsp $ "old config: " <> show oldConfig
+        debugLsp $ "new config: " <> show newConfig
+        when (outputPath oldConfig /= outputPath newConfig) do
+          debugLsp "Config output path changed"
+          liftIO $ putNewEnv lspEnv $ outputPath newConfig,
       defaultConfig = defaultConfig,
-      configSection = "purs-lsp-client",
+      configSection = "purescript-lsp",
       doInitialize = \env _ -> pure (Right env),
       staticHandlers = const (lspHandlers lspEnv),
       interpretHandler = \serverEnv ->
@@ -48,8 +54,7 @@ lspOptions :: Server.Options
 lspOptions =
   Server.defaultOptions
     { Server.optTextDocumentSync = Just syncOptions,
-      Server.optExecuteCommandCommands = Just ["lsp-purescript-command"],
-      Server.optCompletionTriggerCharacters = Just $ "._" <> ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] 
+      Server.optCompletionTriggerCharacters = Just $ "._" <> ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']
     }
 
 syncOptions :: Types.TextDocumentSyncOptions
@@ -72,8 +77,8 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
             LSP.IdString t -> Right t
       env <- getLspEnv
       debugLsp $ "Request: " <> show method
-      --  <>  case method of 
-      --     Method_CustomMethod a ->  _ a 
+      --  <>  case method of
+      --     Method_CustomMethod a ->  _ a
       --     _ -> show method
       liftIO $ do
         withAsync (runHandler env $ f msg k) \asyncAct -> do
@@ -106,5 +111,3 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
           _ -> pure ()
 
     runHandler env a = Server.runLspT env $ runReaderT a lspEnv
-
-
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 513e362c8b..b51db9d3e8 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -27,6 +27,7 @@ import Protolude hiding (to)
 import Data.Aeson qualified as A
 import Language.PureScript.Lsp.Handlers.Index (indexHandler)
 import Language.PureScript.Make.Index (initDb, dropTables)
+import Language.PureScript.Lsp.Log (debugLsp)
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -61,7 +62,8 @@ handlers =
                 fileName = Types.uriToFilePath uri
             traverse_ removedCachedRebuild fileName,
           Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
-            pure (),
+            debugLsp  "SMethod_WorkspaceDidChangeConfiguration"
+            void updateAvailableSrcs,
           Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
             setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index 18231a64fe..02e9f3f197 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -26,7 +26,7 @@ defaultConfig  =
     { outputPath = "./output",
       globs = ["./src/**/*.purs"],
       inputSrcFromFile = Nothing,
-      logLevel = LogWarning,
+      logLevel = LogAll,
       traceValue = Nothing,
       maxTypeLength = Just defaultMaxTypeLength,
       maxCompletions = Just defaultMaxCompletions, 
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 7f3daaedc1..e4572940b5 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE TypeOperators #-}
 
 module Language.PureScript.Lsp.State
-  ( getDbConn, 
+  ( getDbConn,
     cacheRebuild,
     cacheRebuild',
     cachedRebuild,
@@ -18,6 +18,7 @@ module Language.PureScript.Lsp.State
     cancelRequest,
     addRunningRequest,
     removeRunningRequest,
+    putNewEnv,
   )
 where
 
@@ -26,6 +27,7 @@ import Control.Monad.Trans.Writer (WriterT (runWriterT))
 import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Text qualified as T
+import Database.SQLite.Simple (Connection)
 import Language.LSP.Protocol.Types (type (|?) (..))
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript (MultipleErrors, prettyPrintMultipleErrors)
@@ -36,14 +38,14 @@ import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.Log (errorLsp)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
 import Language.PureScript.Lsp.Types
+import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
-import Language.PureScript.Names qualified as P
-import Database.SQLite.Simple (Connection)
+import Language.PureScript.DB (mkConnection)
 
-getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m  Connection
-getDbConn = liftIO . readTVarIO . lspDbConnection =<< ask
+getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
+getDbConn = liftIO . readTVarIO . lspDbConnectionVar =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Module -> m ()
@@ -72,10 +74,11 @@ cacheDependencies moduleName deps = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ modifyTVar st $ \x ->
     x
-      { openFiles = openFiles x <&> \(fp, ofile) ->
-          if ofModuleName ofile == moduleName
-            then (fp, ofile {ofDependencies = deps})
-            else (fp, ofile)
+      { openFiles =
+          openFiles x <&> \(fp, ofile) ->
+            if ofModuleName ofile == moduleName
+              then (fp, ofile {ofDependencies = deps})
+              else (fp, ofile)
       }
 
 removedCachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m ()
@@ -175,3 +178,12 @@ cancelRequest requestId = do
     eitherId = case requestId of
       InL i -> Left i
       InR t -> Right t
+
+putNewEnv :: LspEnvironment -> FilePath -> IO ()
+putNewEnv env  outputPath  = do
+  newConn <- mkConnection outputPath
+  atomically $ writeTVar (lspDbConnectionVar env) newConn
+  atomically $ writeTVar (lspStateVar env) emptyState
+  -- connVar <- lspDbConnectionVar <$> ask
+  -- newConn <- liftIO (readTVarIO (lspDbConnectionVar env))
+  -- liftIO . atomically $ writeTVar connVar newConn
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index ee220bd17c..2bc7a12ce4 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -21,7 +21,7 @@ import Protolude
 import Language.PureScript.AST qualified as P
 
 data LspEnvironment = LspEnvironment
-  { lspDbConnection :: TVar Connection,
+  { lspDbConnectionVar :: TVar Connection,
     lspStateVar :: TVar LspState
   }
 
@@ -31,6 +31,9 @@ mkEnv outputPath = do
   st <- newTVarIO (LspState mempty P.primEnv mempty)
   pure $ LspEnvironment connection st
 
+emptyState :: LspState
+emptyState = LspState mempty P.primEnv mempty
+
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
     confGlobs :: [FilePath],
diff --git a/tests/TestLsp.hs b/tests/TestLsp.hs
index dfccadb5ce..ba4b5f8238 100644
--- a/tests/TestLsp.hs
+++ b/tests/TestLsp.hs
@@ -65,7 +65,7 @@ sessionConfig :: SessionConfig
 sessionConfig = SessionConfig 30 True True True clientConfig True True True Nothing
   where
     clientConfig :: KeyMap A.Value
-    clientConfig = KeyMap.singleton "purs-lsp-client" (A.toJSON pursLspConfig)
+    clientConfig = KeyMap.singleton "purescript-lsp" (A.toJSON pursLspConfig)
 
     pursLspConfig :: Map Text.Text A.Value
     pursLspConfig = Map.empty

From d36e71fd7cd8d9d678e5382c59bda2c00969bc43 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 15 Oct 2024 18:42:16 +0200
Subject: [PATCH 153/297] remove logs

---
 src/Language/PureScript/Lsp/Handlers.hs            |  2 --
 src/Language/PureScript/Lsp/Handlers/Completion.hs | 12 +-----------
 src/Language/PureScript/Lsp/Handlers/Definition.hs |  4 ----
 src/Language/PureScript/Lsp/Handlers/Hover.hs      |  5 -----
 src/Language/PureScript/Lsp/Handlers/Index.hs      |  4 ++--
 5 files changed, 3 insertions(+), 24 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index b51db9d3e8..e1011e8a06 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -27,7 +27,6 @@ import Protolude hiding (to)
 import Data.Aeson qualified as A
 import Language.PureScript.Lsp.Handlers.Index (indexHandler)
 import Language.PureScript.Make.Index (initDb, dropTables)
-import Language.PureScript.Lsp.Log (debugLsp)
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -62,7 +61,6 @@ handlers =
                 fileName = Types.uriToFilePath uri
             traverse_ removedCachedRebuild fileName,
           Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
-            debugLsp  "SMethod_WorkspaceDidChangeConfiguration"
             void updateAvailableSrcs,
           Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
             setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index f7118ade5d..434f541c5e 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -17,7 +17,7 @@ import Language.PureScript.Ide.Imports (Import (..))
 import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
-import Language.PureScript.Lsp.Log (logPerfStandard, debugLsp)
+import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
@@ -47,29 +47,19 @@ completionAndResolveHandlers =
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
             let (range, word) = getWordAt (VFS._file_text vf) pos
-            debugLsp $ "word: " <> word
-            debugLsp $ "filePath: " <> show filePath
             mNameMb <- parseModuleNameFromFile uri
-            debugLsp $ "mNameMb: " <> show mNameMb
             forLsp mNameMb \mName -> do
               let withQualifier = getIdentModuleQualifier word
                   wordWithoutQual = maybe word snd withQualifier
-              debugLsp $ "withQualifier: " <> show withQualifier
-              debugLsp $ "wordWithoutQual: " <> wordWithoutQual
               limit <- getMaxCompletions
               matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
-              debugLsp $ "matchingImport: " <> show matchingImport
               decls <- logPerfStandard "get completion declarations" case (matchingImport, withQualifier) of
                 (Just (Import importModuleName _ _), _) -> do 
-                  debugLsp "getAstDeclarationsStartingWithOnlyInModule"
                   getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
                 (_, Just (wordModuleName, _)) -> do 
-                  debugLsp $ "getAstDeclarationsStartingWithAndSearchingModuleNames: " <> show wordModuleName
                   getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
                 _ ->  do
-                  debugLsp "getAstDeclarationsStartingWith"
                   getAstDeclarationsStartingWith mName wordWithoutQual
-              debugLsp $ "decls length: " <> show (length decls)
               res $
                 Right $
                   Types.InR $
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index ded5e3a90d..bb3cf50d6d 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -11,7 +11,6 @@ import Language.PureScript qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule)
-import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
@@ -59,7 +58,6 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
             respondWithDeclInOtherModule nameType importedModuleName (printName name)
           _ -> respondWithModule ss importedModuleName
 
-  debugLsp $ "Position: " <> show pos
 
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
@@ -76,12 +74,10 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
               & declAtLine srcPosLine
 
 
-      debugLsp $ "srcPosLine: " <> show srcPosLine
 
       forLsp declAtPos $ \decl -> do
         case decl of
           P.ImportDeclaration (ss, _) importedModuleName importType _ -> do 
-            debugLsp $ "found import at pos: " <> show importedModuleName
             case importType of
               P.Implicit -> respondWithModule ss importedModuleName
               P.Explicit imports -> respondWithImports ss importedModuleName imports
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 77d35c7668..2d7895fd82 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -17,7 +17,6 @@ import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, isSingleLine, spanToRange)
-import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
@@ -41,7 +40,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       respondWithDeclInModule :: P.SourceSpan -> LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInModule ss nameType modName ident = do
         declDocMb <- readDeclarationDocsWithNameType modName nameType ident
-        debugLsp $ "found docs: " <> show (isJust declDocMb)
         case declDocMb of
           Just docs -> markdownRes docs (Just $ spanToRange ss)
           _ -> do
@@ -98,18 +96,15 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               P.Explicit imports -> respondWithImports ss importedModuleName imports
               P.Hiding imports -> respondWithImports ss importedModuleName imports
           _ -> do
-            debugLsp $ "Decl at pos: " <> show decl
             let exprsAtPos = getExprsAtPos pos decl
                 findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
                 findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
                 findTypedExpr (_ : es) = findTypedExpr es
                 findTypedExpr [] = Nothing
 
-            debugLsp $ "Exprs at pos: " <> show (length exprsAtPos)
 
             case head exprsAtPos of
               Just expr -> do
-                debugLsp $ "found hover expr at pos: " <> show expr
                 case expr of
                   P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
                     respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 240a498a3b..0106c92be1 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -10,7 +10,7 @@ import Language.LSP.Server (MonadLsp, getConfig)
 import Language.LSP.Server qualified as Server
 import Language.PureScript (ExternsFile)
 import Language.PureScript qualified as P
-import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Log (errorLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
 import Language.PureScript.Lsp.Types (LspEnvironment)
@@ -75,7 +75,7 @@ findAvailableExterns = do
       res <- runExceptT $ readExternsFile path
       case res of
         Left err -> do
-          debugLsp $ "Error reading externs file: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
+          errorLsp $ "Error reading externs file: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
           pure Nothing
         Right (Just ef) -> pure $ Just ef
         _ -> pure Nothing

From ae624c2c1af07d0fa5310ec103c288208ed595de Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 15 Oct 2024 23:58:58 +0200
Subject: [PATCH 154/297] adds db path log

---
 src/Language/PureScript/DB.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/DB.hs b/src/Language/PureScript/DB.hs
index 25f2591ea2..95fe161d66 100644
--- a/src/Language/PureScript/DB.hs
+++ b/src/Language/PureScript/DB.hs
@@ -8,7 +8,9 @@ import System.Directory (createDirectoryIfMissing)
 mkConnection :: FilePath -> IO Connection
 mkConnection outputDir =  do
   createDirectoryIfMissing True outputDir
-  open (outputDir </> dbFile)
+  let path = outputDir </> dbFile
+  putErrLn $ "Opening sqlite database at " <> path
+  open path
 
 dbFile :: FilePath
 dbFile = "purescript.sqlite"
\ No newline at end of file

From 341f6735315e6ffb289d1aec4fa1fa0199737ad3 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 00:14:45 +0200
Subject: [PATCH 155/297] canonicalize DB path

---
 app/Command/Compile.hs               |  2 +-
 src/Language/PureScript/DB.hs        | 18 +++++++++++-------
 src/Language/PureScript/LSP.hs       | 11 ++++++-----
 src/Language/PureScript/Lsp/State.hs | 21 ++++++++++++---------
 src/Language/PureScript/Lsp/Types.hs |  2 +-
 5 files changed, 31 insertions(+), 23 deletions(-)

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index f88d9b4c64..68a43fb25a 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -72,7 +72,7 @@ compile PSCMakeOptions {..} = do
           "Usage: For basic information, try the `--help' option."
         ]
     exitFailure
-  conn <- mkConnection pscmOutputDir
+  (_, conn) <- mkConnection pscmOutputDir
   initDb conn
   moduleFiles <- readUTF8FilesT input
   (makeErrors, makeWarnings) <- P.compile pscmOpts moduleFiles conn pscmOutputDir pscmUsePrefix
diff --git a/src/Language/PureScript/DB.hs b/src/Language/PureScript/DB.hs
index 95fe161d66..d82357992c 100644
--- a/src/Language/PureScript/DB.hs
+++ b/src/Language/PureScript/DB.hs
@@ -1,16 +1,20 @@
-module Language.PureScript.DB where 
+module Language.PureScript.DB where
 
-import Protolude
 import Database.SQLite.Simple (Connection, open)
+import Protolude
+import System.Directory (canonicalizePath, createDirectoryIfMissing)
 import System.FilePath ((</>))
-import System.Directory (createDirectoryIfMissing)
 
-mkConnection :: FilePath -> IO Connection
-mkConnection outputDir =  do
+mkConnection :: FilePath -> IO (FilePath, Connection)
+mkConnection outputDir = do
   createDirectoryIfMissing True outputDir
-  let path = outputDir </> dbFile
+  path <- mkDbPath outputDir
   putErrLn $ "Opening sqlite database at " <> path
-  open path
+  conn <- open path
+  pure (path, conn)
+
+mkDbPath :: FilePath -> IO FilePath
+mkDbPath outputDir = canonicalizePath $ outputDir </> dbFile
 
 dbFile :: FilePath
 dbFile = "purescript.sqlite"
\ No newline at end of file
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index d115aa06e5..a9cf4f6006 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -19,9 +19,10 @@ import Language.PureScript.Lsp.Handlers (handlers)
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), defaultConfig)
-import Language.PureScript.Lsp.State (addRunningRequest, removeRunningRequest, putNewEnv)
+import Language.PureScript.Lsp.State (addRunningRequest, removeRunningRequest, putNewEnv, getDbPath)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
+import Language.PureScript.DB (mkDbPath)
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
@@ -32,11 +33,11 @@ serverDefinition lspEnv =
   Server.ServerDefinition
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = \newConfig -> do
-        oldConfig <- Server.getConfig
-        debugLsp $ "old config: " <> show oldConfig
         debugLsp $ "new config: " <> show newConfig
-        when (outputPath oldConfig /= outputPath newConfig) do
-          debugLsp "Config output path changed"
+        dbPath <- getDbPath 
+        newDbPath <- liftIO $ mkDbPath (outputPath newConfig)
+        when (newDbPath /= dbPath) do
+          debugLsp "DB path changed"
           liftIO $ putNewEnv lspEnv $ outputPath newConfig,
       defaultConfig = defaultConfig,
       configSection = "purescript-lsp",
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index e4572940b5..f8e2031d3c 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -18,6 +18,7 @@ module Language.PureScript.Lsp.State
     cancelRequest,
     addRunningRequest,
     removeRunningRequest,
+    getDbPath,
     putNewEnv,
   )
 where
@@ -31,6 +32,7 @@ import Database.SQLite.Simple (Connection)
 import Language.LSP.Protocol.Types (type (|?) (..))
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript (MultipleErrors, prettyPrintMultipleErrors)
+import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (..))
@@ -42,10 +44,9 @@ import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
-import Language.PureScript.DB (mkConnection)
 
 getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
-getDbConn = liftIO . readTVarIO . lspDbConnectionVar =<< ask
+getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Module -> m ()
@@ -179,11 +180,13 @@ cancelRequest requestId = do
       InL i -> Left i
       InR t -> Right t
 
+getDbPath :: (MonadReader LspEnvironment m, MonadIO m) => m FilePath
+getDbPath = do 
+  env <- ask
+  liftIO $ fst <$> readTVarIO (lspDbConnectionVar env)
+
 putNewEnv :: LspEnvironment -> FilePath -> IO ()
-putNewEnv env  outputPath  = do
-  newConn <- mkConnection outputPath
-  atomically $ writeTVar (lspDbConnectionVar env) newConn
-  atomically $ writeTVar (lspStateVar env) emptyState
-  -- connVar <- lspDbConnectionVar <$> ask
-  -- newConn <- liftIO (readTVarIO (lspDbConnectionVar env))
-  -- liftIO . atomically $ writeTVar connVar newConn
+putNewEnv env outputPath = do
+  (path, newConn) <- mkConnection outputPath
+  atomically $ writeTVar (lspDbConnectionVar env) (path, newConn)
+  atomically $ writeTVar (lspStateVar env) emptyState
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 2bc7a12ce4..2c539a15fe 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -21,7 +21,7 @@ import Protolude
 import Language.PureScript.AST qualified as P
 
 data LspEnvironment = LspEnvironment
-  { lspDbConnectionVar :: TVar Connection,
+  { lspDbConnectionVar :: TVar (FilePath, Connection),
     lspStateVar :: TVar LspState
   }
 

From e4cd06a0c79ca2498990077ac050e8e353cf1368 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 00:53:09 +0200
Subject: [PATCH 156/297] better methods logging

---
 src/Language/PureScript/LSP.hs | 24 +++++++++++-------------
 1 file changed, 11 insertions(+), 13 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index a9cf4f6006..06133f83d7 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -15,14 +15,14 @@ import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (MonadLsp (getLspEnv), mapHandlers)
 import Language.LSP.Server qualified as Server
+import Language.PureScript.DB (mkDbPath)
 import Language.PureScript.Lsp.Handlers (handlers)
-import Language.PureScript.Lsp.Log (debugLsp, errorLsp, warnLsp)
+import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), defaultConfig)
-import Language.PureScript.Lsp.State (addRunningRequest, removeRunningRequest, putNewEnv, getDbPath)
+import Language.PureScript.Lsp.State (addRunningRequest, getDbPath, putNewEnv, removeRunningRequest)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
-import Language.PureScript.DB (mkDbPath)
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
@@ -34,7 +34,7 @@ serverDefinition lspEnv =
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = \newConfig -> do
         debugLsp $ "new config: " <> show newConfig
-        dbPath <- getDbPath 
+        dbPath <- getDbPath
         newDbPath <- liftIO $ mkDbPath (outputPath newConfig)
         when (newDbPath /= dbPath) do
           debugLsp "DB path changed"
@@ -76,12 +76,9 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
       let reqId = case id of
             LSP.IdInt i -> Left i
             LSP.IdString t -> Right t
+          methodText = T.pack $ LSP.someMethodToMethodString $ LSP.SomeMethod method
       env <- getLspEnv
-      debugLsp $ "Request: " <> show method
-      --  <>  case method of
-      --     Method_CustomMethod a ->  _ a
-      --     _ -> show method
-      liftIO $ do
+      logPerfStandard methodText $ liftIO $ do
         withAsync (runHandler env $ f msg k) \asyncAct -> do
           addRunningRequest lspEnv reqId asyncAct
           result <- waitCatch asyncAct
@@ -89,16 +86,17 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
             Left e -> do
               case fromException e of
                 Just AsyncCancelled -> do
-                  warnLsp $ "Request cancelled. Method: " <> show method <> ". id: " <> show reqId
+                  warnLsp $ "Request cancelled. Method: " <> methodText <> ". id: " <> show reqId
                   k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing
                 _ -> do
-                  errorLsp $ "Request failed. Method: " <> show method <> ". id: " <> show reqId <> ". Error: " <> show e
+                  errorLsp $ "Request failed. Method: " <> methodText <> ". id: " <> show reqId <> ". Error: " <> show e
                   k $ Left $ LSP.TResponseError (Types.InR Types.ErrorCodes_InternalError) "Internal error" Nothing
             _ -> pure ()
           removeRunningRequest lspEnv reqId
 
     goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). Server.Handler HandlerM a -> Server.Handler HandlerM a
     goNotification f msg@(LSP.TNotificationMessage _ method _) = do
+      let methodText = T.pack $ LSP.someMethodToMethodString $ LSP.SomeMethod method
       env <- getLspEnv
       liftIO $ withAsync (runHandler env $ f msg) \asyncAct -> do
         result <- waitCatch asyncAct
@@ -106,9 +104,9 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
           Left e -> do
             runHandler env case fromException e of
               Just AsyncCancelled -> do
-                warnLsp $ "Notification cancelled. Method: " <> show method
+                warnLsp $ "Notification cancelled. Method: " <> methodText
               _ -> do
-                errorLsp $ "Notification failed. Method: " <> show method <> ". Error: " <> show e
+                errorLsp $ "Notification failed. Method: " <> methodText <> ". Error: " <> show e
           _ -> pure ()
 
     runHandler env a = Server.runLspT env $ runReaderT a lspEnv

From 7a967c434743039084517124b8933a3086153e66 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 01:27:17 +0200
Subject: [PATCH 157/297] show expression on hover

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  4 +-
 src/Language/PureScript/Make/Index.hs         | 78 +++++++------------
 2 files changed, 29 insertions(+), 53 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 2d7895fd82..6ce6e5ed51 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -24,6 +24,8 @@ import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (declAtLine)
 import Protolude hiding (to)
+import Text.PrettyPrint.Boxes (render)
+import Data.Text qualified as T
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
@@ -53,7 +55,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               P.Var _ (P.Qualified _ ident) -> P.runIdent ident
               P.Op _ (P.Qualified _ ident) -> P.runOpName ident
               P.Constructor _ (P.Qualified _ ident) -> P.runProperName ident
-              _ -> "<expression>"
+              _ -> T.pack $ render $ P.prettyPrintValue 3 expr
             printedType = prettyPrintTypeSingleLine tipe
 
         markdownRes (pursTypeStr word (Just printedType) []) (spanToRange <$> sa)
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 5605978bfe..e90fbd2551 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -1,56 +1,22 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE PackageImports #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.Make.Index where
 
 import Codec.Serialise (serialise)
-import Control.Exception (handle)
-import Control.Monad.Cont (MonadIO)
-import Control.Monad.Supply (SupplyT (SupplyT))
-import Data.Aeson qualified as A
-import Data.List qualified as List
-import Data.Map.Lazy qualified as M
-import Data.Maybe (fromJust)
-import Data.Set qualified as S
 import Data.Set qualified as Set
-import Data.Text qualified as T
 import Database.SQLite.Simple (Connection, NamedParam ((:=)))
 import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
-import Language.PureScript (declRefName)
 import Language.PureScript.AST qualified as P
-import Language.PureScript.AST.Declarations (exprSourceSpan)
-import Language.PureScript.AST.Declarations qualified as P
-import Language.PureScript.AST.Traversals qualified as P
-import Language.PureScript.CST qualified as CST
-import Language.PureScript.CoreFn qualified as CF
-import Language.PureScript.CoreFn.FromJSON qualified as CFJ
-import Language.PureScript.CoreFn.ToJSON qualified as CFJ
-import Language.PureScript.CoreFn.Traversals (traverseCoreFn)
-import Language.PureScript.Docs.Types qualified as Docs
-import Language.PureScript.Environment qualified as P
-import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
-import Language.PureScript.Ide.Error (IdeError (GeneralError, RebuildError))
-import Language.PureScript.Ide.Rebuild (updateCacheDb)
-import Language.PureScript.Ide.Types (ModuleMap)
-import Language.PureScript.Ide.Util (ideReadFile)
-import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printName, printEfDeclType)
-import Language.PureScript.Lsp.Types (LspConfig (..), LspEnvironment)
-import Language.PureScript.Lsp.Util (efDeclCategory, efDeclSourceSpan)
-import Language.PureScript.Make (ffiCodegen')
+import Language.PureScript.Lsp.NameType (externDeclNameType, lspNameType)
+import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printEfDeclType, printName)
+import Language.PureScript.Lsp.Util (efDeclSourceSpan)
 import Language.PureScript.Make qualified as P
-import Language.PureScript.ModuleDependencies qualified as P
 import Language.PureScript.Names qualified as P
-import Language.PureScript.Options qualified as P
-import Language.PureScript.Types (everywhereOnTypesM)
-import Paths_purescript qualified as Paths
 import Protolude hiding (moduleName)
-import "monad-logger" Control.Monad.Logger (MonadLogger, logDebugN)
-import Language.PureScript.Lsp.NameType (lspNameType, externDeclNameType)
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
@@ -64,7 +30,7 @@ addAstModuleIndexing conn ma =
     }
 
 indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> m ()
-indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) extern = liftIO do
+indexAstModule conn m@(P.Module _ss _comments moduleName' decls _exportRefs) extern = liftIO do
   path <- makeAbsolute externPath
   SQL.executeNamed
     conn
@@ -81,13 +47,14 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
         start = P.spanStart ss
         end = P.spanEnd ss
         name = P.declName decl
-        nameType =  name <&> lspNameType
+        nameType = name <&> lspNameType
     SQL.executeNamed
       conn
-      (SQL.Query 
-      "INSERT INTO ast_declarations \
-      \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
-      \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+      ( SQL.Query
+          "INSERT INTO ast_declarations \
+          \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
+          \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)"
+      )
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := printName <$> name,
         ":printed_type" := printDeclarationType decl,
@@ -103,19 +70,23 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls exportRefs) exte
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
-indexAstDeclFromExternDecl :: (MonadIO m) => Connection -> P.ModuleName -> P.ExternsDeclaration -> m ()
-indexAstDeclFromExternDecl conn moduleName' externDecl = liftIO do
-  let ss = efDeclSourceSpan externDecl
+indexAstDeclFromExternDecl :: (MonadIO m) => Connection -> P.ModuleName -> [P.ExternsDeclaration] -> P.ExternsDeclaration -> m ()
+indexAstDeclFromExternDecl conn moduleName' moduleDecls externDecl = liftIO do
+  let ss = case externDecl of
+        P.EDDataConstructor {..}
+          | Just typeCtr <- find (isTypeOfName edDataCtorTypeCtor) moduleDecls -> efDeclSourceSpan typeCtr
+        _ -> efDeclSourceSpan externDecl
       start = P.spanStart ss
       end = P.spanEnd ss
-      printedType :: Text 
+      printedType :: Text
       printedType = printEfDeclType externDecl
   SQL.executeNamed
     conn
-    (SQL.Query 
-    "INSERT INTO ast_declarations \
-    \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
-    \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)")
+    ( SQL.Query
+        "INSERT INTO ast_declarations \
+        \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
+        \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)"
+    )
     [ ":module_name" := P.runModuleName moduleName',
       ":name" := printEfDeclName externDecl,
       ":printed_type" := printedType,
@@ -128,6 +99,10 @@ indexAstDeclFromExternDecl conn moduleName' externDecl = liftIO do
       ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
       ":exported" := False
     ]
+  where
+    isTypeOfName :: P.ProperName 'P.TypeName -> P.ExternsDeclaration -> Bool
+    isTypeOfName name P.EDType {..} = edTypeName == name
+    isTypeOfName _ _ = False
 
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
@@ -167,7 +142,6 @@ insertEfImport conn moduleName' ei = do
       ":value" := serialise ei
     ]
 
-
 initDb :: Connection -> IO ()
 initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"

From 703a2e51033b6367802c8741ead3772f57ae641f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 02:07:15 +0200
Subject: [PATCH 158/297] only update available srcs when needed

---
 purescript.cabal                              |  1 +
 src/Language/PureScript/LSP.hs                | 13 ++++--
 src/Language/PureScript/Lsp/Cache/Query.hs    |  4 +-
 src/Language/PureScript/Lsp/Handlers.hs       |  2 +-
 .../PureScript/Lsp/Handlers/Definition.hs     | 13 ++++--
 src/Language/PureScript/Lsp/Handlers/Index.hs |  2 +-
 src/Language/PureScript/Lsp/Log.hs            |  3 +-
 src/Language/PureScript/Lsp/ServerConfig.hs   |  2 +-
 src/Language/PureScript/Lsp/State.hs          | 10 ++++-
 src/Language/PureScript/Lsp/Types.hs          | 43 +++----------------
 10 files changed, 42 insertions(+), 51 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index 3b49d80af7..9d87949151 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -356,6 +356,7 @@ library
     Language.PureScript.Lsp.Handlers.Hover
     Language.PureScript.Lsp.Handlers.Index
     Language.PureScript.Lsp.Log
+    Language.PureScript.Lsp.LogLevel
     Language.PureScript.Lsp.Monad
     Language.PureScript.Lsp.NameType
     Language.PureScript.Lsp.Prim
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 06133f83d7..703166e6b7 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -19,10 +19,11 @@ import Language.PureScript.DB (mkDbPath)
 import Language.PureScript.Lsp.Handlers (handlers)
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), defaultConfig)
-import Language.PureScript.Lsp.State (addRunningRequest, getDbPath, putNewEnv, removeRunningRequest)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath, globs), defaultConfig)
+import Language.PureScript.Lsp.State (addRunningRequest, getDbPath, putNewEnv, removeRunningRequest, getPreviousConfig, putPreviousConfig)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
+import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
@@ -33,12 +34,16 @@ serverDefinition lspEnv =
   Server.ServerDefinition
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = \newConfig -> do
-        debugLsp $ "new config: " <> show newConfig
         dbPath <- getDbPath
         newDbPath <- liftIO $ mkDbPath (outputPath newConfig)
         when (newDbPath /= dbPath) do
           debugLsp "DB path changed"
-          liftIO $ putNewEnv lspEnv $ outputPath newConfig,
+          liftIO $ putNewEnv lspEnv $ outputPath newConfig
+        prevConfig <- getPreviousConfig
+        when (globs newConfig /= globs prevConfig) do
+          debugLsp "Globs changed"
+          void updateAvailableSrcs
+        putPreviousConfig newConfig,
       defaultConfig = defaultConfig,
       configSection = "purescript-lsp",
       doInitialize = \env _ -> pure (Right env),
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index f88784eec6..d9df94eb49 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -40,7 +40,7 @@ getAstDeclarationLocationInModule lspNameType moduleName' name = do
       \AND name_type IS :name_type"
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := name,
-        ":name_type" := (map show lspNameType :: Maybe Text)
+        ":name_type" := lspNameType
       ]
   pure $ decls <&> \(spanName, sl, sc, el, ec) -> P.SourceSpan spanName (SourcePos sl sc) (SourcePos el ec)
 
@@ -56,7 +56,7 @@ getAstDeclarationTypeInModule lspNameType moduleName' name = do
       \AND name_type IS :name_type"
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := name,
-        ":name_type" := (map show lspNameType :: Maybe Text)
+        ":name_type" := lspNameType
       ]
   pure $ decls <&> fromOnly
 
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index e1011e8a06..513e362c8b 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -61,7 +61,7 @@ handlers =
                 fileName = Types.uriToFilePath uri
             traverse_ removedCachedRebuild fileName,
           Server.notificationHandler Message.SMethod_WorkspaceDidChangeConfiguration $ \_msg -> do
-            void updateAvailableSrcs,
+            pure (),
           Server.notificationHandler Message.SMethod_SetTrace $ \msg -> do
             setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index bb3cf50d6d..db9bdeec34 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -19,6 +19,7 @@ import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (declAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
+import Language.PureScript.Lsp.Log (debugLsp)
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -37,6 +38,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       respondWithDeclInOtherModule :: Maybe LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInOtherModule nameType modName ident = do
         declSpans <- getAstDeclarationLocationInModule nameType modName ident
+        debugLsp $ "SourceSpans: " <> show declSpans
         forLsp (head declSpans) $ \sourceSpan ->
           locationRes (P.spanName sourceSpan) (spanToRange sourceSpan)
 
@@ -54,9 +56,11 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
           Just import' -> do
             let name = P.declRefName import'
                 nameType = getImportRefNameType import'
-            
+            debugLsp $ "import: " <> show import'
             respondWithDeclInOtherModule nameType importedModuleName (printName name)
-          _ -> respondWithModule ss importedModuleName
+          _ -> do 
+            debugLsp $ "respondWithModule importedModuleName: " <> show importedModuleName
+            respondWithModule ss importedModuleName
 
 
   forLsp filePathMb \filePath -> do
@@ -78,6 +82,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       forLsp declAtPos $ \decl -> do
         case decl of
           P.ImportDeclaration (ss, _) importedModuleName importType _ -> do 
+            debugLsp $ "ImportDeclaration iomportedModuleName: " <> show importedModuleName
             case importType of
               P.Implicit -> respondWithModule ss importedModuleName
               P.Explicit imports -> respondWithImports ss importedModuleName imports
@@ -111,13 +116,15 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
                         _ -> nullRes
 
                 exprsAtPos = getExprsAtPos pos decl
-
+            debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
             case head exprsAtPos of
               Just expr -> do
                 case expr of
                   P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
+                    debugLsp $ "Var BySourcePos : " <> show srcPos
                     posRes filePath srcPos
                   P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                    debugLsp $ "Var ByModuleName : " <> show modName <> "." <> P.runIdent ident
                     respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
                   P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
                   P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 0106c92be1..f42c02afd7 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -44,7 +44,7 @@ indexHandler =
     indexExternAndDecls ef = do
       conn <- getDbConn
       indexExtern conn ef
-      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn (P.efModuleName ef))
+      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn (P.efModuleName ef) (P.efDeclarations ef))
 
 -- \| Finds all the externs inside the output folder and returns the
 -- corresponding module names
diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs
index 2c998854e7..a297d89e78 100644
--- a/src/Language/PureScript/Lsp/Log.hs
+++ b/src/Language/PureScript/Lsp/Log.hs
@@ -3,11 +3,12 @@ module Language.PureScript.Lsp.Log where
 import Data.Text qualified as T
 import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
 import Language.PureScript.Ide.Logging (displayTimeSpec)
-import Language.PureScript.Lsp.Types (LspEnvironment, LspLogLevel (..))
+import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude
 import System.Clock (Clock (Monotonic), TimeSpec, diffTimeSpec, getTime)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig(logLevel))
 import Language.LSP.Server (getConfig, MonadLsp)
+import Language.PureScript.Lsp.LogLevel (LspLogLevel(..))
 
 infoLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m ()
 infoLsp = logLsp LogMsgInfo
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index 02e9f3f197..53d6343feb 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -5,7 +5,7 @@ module Language.PureScript.Lsp.ServerConfig where
 import Data.Aeson (FromJSON, ToJSON)
 import Language.LSP.Protocol.Types (TraceValue (..))
 import Language.LSP.Server (MonadLsp, getConfig, setConfig)
-import Language.PureScript.Lsp.Types (LspLogLevel (..))
+import Language.PureScript.Lsp.LogLevel (LspLogLevel (..))
 import Protolude
 
 data ServerConfig = ServerConfig
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index f8e2031d3c..0f9dc74748 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -20,6 +20,8 @@ module Language.PureScript.Lsp.State
     removeRunningRequest,
     getDbPath,
     putNewEnv,
+    putPreviousConfig,
+    getPreviousConfig,
   )
 where
 
@@ -189,4 +191,10 @@ putNewEnv :: LspEnvironment -> FilePath -> IO ()
 putNewEnv env outputPath = do
   (path, newConn) <- mkConnection outputPath
   atomically $ writeTVar (lspDbConnectionVar env) (path, newConn)
-  atomically $ writeTVar (lspStateVar env) emptyState
\ No newline at end of file
+  atomically $ writeTVar (lspStateVar env) emptyState
+
+getPreviousConfig :: (MonadReader LspEnvironment m, MonadIO m) => m ServerConfig
+getPreviousConfig = liftIO . readTVarIO . previousConfig =<< ask
+
+putPreviousConfig :: (MonadReader LspEnvironment m, MonadIO m) => ServerConfig -> m ()
+putPreviousConfig config = liftIO . atomically . flip writeTVar config . previousConfig =<< ask
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 2c539a15fe..d4e00f7ac5 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -1,14 +1,10 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE PackageImports #-}
 
 module Language.PureScript.Lsp.Types where
 
 import Control.Concurrent.STM (TVar, newTVarIO)
--- import Language.PureScript.Ide.Types (IdeLogLevel)
-
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as A
-import Data.Aeson.Types qualified as AT
 import Database.SQLite.Simple (Connection)
 import Language.LSP.Protocol.Types (Range)
 import Language.PureScript.DB (mkConnection)
@@ -19,17 +15,21 @@ import Language.PureScript.Sugar.Names (Env)
 import Language.PureScript.Sugar.Names qualified as P
 import Protolude
 import Language.PureScript.AST qualified as P
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
+import Language.PureScript.Lsp.LogLevel (LspLogLevel)
 
 data LspEnvironment = LspEnvironment
   { lspDbConnectionVar :: TVar (FilePath, Connection),
-    lspStateVar :: TVar LspState
+    lspStateVar :: TVar LspState,
+    previousConfig :: TVar  ServerConfig
   }
 
 mkEnv :: FilePath -> IO LspEnvironment
 mkEnv outputPath = do
   connection <- newTVarIO =<< mkConnection outputPath
   st <- newTVarIO (LspState mempty P.primEnv mempty)
-  pure $ LspEnvironment connection st
+  prevConfig <- newTVarIO defaultConfig
+  pure $ LspEnvironment connection st prevConfig
 
 emptyState :: LspState
 emptyState = LspState mempty P.primEnv mempty
@@ -67,37 +67,6 @@ data CompleteItemData = CompleteItemData
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
-data LspLogLevel
-  = LogAll
-  | LogDebug
-  | LogPerf
-  | LogInfo
-  | LogWarning
-  | LogError
-  | LogNone
-  deriving (Show, Eq, Ord, Generic)
-
-instance A.ToJSON LspLogLevel where
-  toJSON = \case
-    LogAll -> A.String "all"
-    LogDebug -> A.String "debug"
-    LogPerf -> A.String "perf"
-    LogInfo -> A.String "info"
-    LogWarning -> A.String "warning"
-    LogError -> A.String "error"
-    LogNone -> A.String "none"
-
-instance FromJSON LspLogLevel where
-  parseJSON v = case v of
-    A.String "all" -> pure LogAll
-    A.String "debug" -> pure LogDebug
-    A.String "perf" -> pure LogPerf
-    A.String "info" -> pure LogInfo
-    A.String "warning" -> pure LogWarning
-    A.String "error" -> pure LogError
-    A.String "none" -> pure LogNone
-    A.String _ -> AT.unexpected v
-    _ -> AT.typeMismatch "String" v
 
 decodeCompleteItemData :: Maybe A.Value -> A.Result (Maybe CompleteItemData)
 decodeCompleteItemData Nothing = pure Nothing

From aff15818424fa1166a29bc7a051026d5bb0910e5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 02:29:24 +0200
Subject: [PATCH 159/297] index ast modules from externs

---
 src/Language/PureScript/Lsp/Handlers/Definition.hs |  1 +
 src/Language/PureScript/Lsp/Handlers/Index.hs      |  3 ++-
 src/Language/PureScript/Make/Index.hs              | 12 ++++++++++++
 3 files changed, 15 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index db9bdeec34..e065bba83e 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -37,6 +37,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       respondWithDeclInOtherModule :: Maybe LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInOtherModule nameType modName ident = do
+        debugLsp $ "respondWithDeclInOtherModule: " <> show nameType <> " " <> show modName <> " " <> show ident
         declSpans <- getAstDeclarationLocationInModule nameType modName ident
         debugLsp $ "SourceSpans: " <> show declSpans
         forLsp (head declSpans) $ \sourceSpan ->
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index f42c02afd7..c21c41e2b3 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -14,7 +14,7 @@ import Language.PureScript.Lsp.Log (errorLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
 import Language.PureScript.Lsp.Types (LspEnvironment)
-import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexExtern, initDb)
+import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexExtern, initDb, indexAstModuleFromExtern)
 import Language.PureScript.Make.Monad (readExternsFile)
 import Protolude hiding (to)
 import System.Directory (doesFileExist, getDirectoryContents)
@@ -44,6 +44,7 @@ indexHandler =
     indexExternAndDecls ef = do
       conn <- getDbConn
       indexExtern conn ef
+      indexAstModuleFromExtern conn ef
       for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn (P.efModuleName ef) (P.efDeclarations ef))
 
 -- \| Finds all the externs inside the output folder and returns the
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index e90fbd2551..997d06abe6 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -70,6 +70,18 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls _exportRefs) ext
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
+indexAstModuleFromExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()
+indexAstModuleFromExtern conn extern = liftIO do
+  path <- makeAbsolute externPath
+  SQL.executeNamed
+    conn
+    (SQL.Query "INSERT OR REPLACE INTO ast_modules (module_name, path) VALUES (:module_name, :path)")
+    [ ":module_name" := P.runModuleName (efModuleName extern),
+      ":path" := path
+    ]
+  where
+    externPath = P.spanName (P.efSourceSpan extern)
+
 indexAstDeclFromExternDecl :: (MonadIO m) => Connection -> P.ModuleName -> [P.ExternsDeclaration] -> P.ExternsDeclaration -> m ()
 indexAstDeclFromExternDecl conn moduleName' moduleDecls externDecl = liftIO do
   let ss = case externDecl of

From ae05715c9189980db6e1ef3edf44855a856c1874 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 02:33:05 +0200
Subject: [PATCH 160/297] move loglevel to own module and log perf on indexing

---
 src/Language/PureScript/Lsp/Handlers/Index.hs | 14 +++----
 src/Language/PureScript/Lsp/LogLevel.hs       | 41 +++++++++++++++++++
 2 files changed, 48 insertions(+), 7 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/LogLevel.hs

diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index c21c41e2b3..2b7c702072 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -10,18 +10,18 @@ import Language.LSP.Server (MonadLsp, getConfig)
 import Language.LSP.Server qualified as Server
 import Language.PureScript (ExternsFile)
 import Language.PureScript qualified as P
-import Language.PureScript.Lsp.Log (errorLsp)
+import Language.PureScript.Lsp.Handlers.Build (buildForLsp)
+import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutput)
+import Language.PureScript.Lsp.Log (errorLsp, logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
+import Language.PureScript.Lsp.State (getDbConn)
 import Language.PureScript.Lsp.Types (LspEnvironment)
-import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexExtern, initDb, indexAstModuleFromExtern)
+import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexAstModuleFromExtern, indexExtern, initDb)
 import Language.PureScript.Make.Monad (readExternsFile)
 import Protolude hiding (to)
 import System.Directory (doesFileExist, getDirectoryContents)
 import System.FilePath ((</>))
-import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutput)
-import Language.PureScript.Lsp.Handlers.Build (buildForLsp)
-import Language.PureScript.Lsp.State (getDbConn)
 
 indexHandler :: Server.Handlers HandlerM
 indexHandler =
@@ -29,8 +29,8 @@ indexHandler =
     [ Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-fast") $ \_req res -> do
         conn <- getDbConn
         liftIO $ initDb conn
-        externs <- findAvailableExterns
-        for_ externs indexExternAndDecls
+        externs <- logPerfStandard "findAvailableExterns" findAvailableExterns
+        logPerfStandard "insert externs" $ for_ externs indexExternAndDecls
         res $ Right A.Null,
       Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \_req res -> do
         conn <- getDbConn
diff --git a/src/Language/PureScript/Lsp/LogLevel.hs b/src/Language/PureScript/Lsp/LogLevel.hs
new file mode 100644
index 0000000000..8548115f73
--- /dev/null
+++ b/src/Language/PureScript/Lsp/LogLevel.hs
@@ -0,0 +1,41 @@
+module Language.PureScript.Lsp.LogLevel where
+
+
+-- import Language.PureScript.Ide.Types (IdeLogLevel)
+
+import Data.Aeson (FromJSON)
+import Data.Aeson qualified as A
+import Data.Aeson.Types qualified as AT
+import Protolude
+
+data LspLogLevel
+  = LogAll
+  | LogDebug
+  | LogPerf
+  | LogInfo
+  | LogWarning
+  | LogError
+  | LogNone
+  deriving (Show, Eq, Ord, Generic)
+
+instance A.ToJSON LspLogLevel where
+  toJSON = \case
+    LogAll -> A.String "all"
+    LogDebug -> A.String "debug"
+    LogPerf -> A.String "perf"
+    LogInfo -> A.String "info"
+    LogWarning -> A.String "warning"
+    LogError -> A.String "error"
+    LogNone -> A.String "none"
+
+instance FromJSON LspLogLevel where
+  parseJSON v = case v of
+    A.String "all" -> pure LogAll
+    A.String "debug" -> pure LogDebug
+    A.String "perf" -> pure LogPerf
+    A.String "info" -> pure LogInfo
+    A.String "warning" -> pure LogWarning
+    A.String "error" -> pure LogError
+    A.String "none" -> pure LogNone
+    A.String _ -> AT.unexpected v
+    _ -> AT.typeMismatch "String" v
\ No newline at end of file

From f3f0fb89ac2d69bdf1951105166bc11071693594 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 12:56:30 +0200
Subject: [PATCH 161/297] adds running method debug

---
 src/Language/PureScript/LSP.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index 703166e6b7..c3d6a2b5ca 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -83,6 +83,7 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
             LSP.IdString t -> Right t
           methodText = T.pack $ LSP.someMethodToMethodString $ LSP.SomeMethod method
       env <- getLspEnv
+      debugLsp methodText
       logPerfStandard methodText $ liftIO $ do
         withAsync (runHandler env $ f msg k) \asyncAct -> do
           addRunningRequest lspEnv reqId asyncAct

From 69bdc98588d2a763d641dbbb2cd8339257c78d49 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 16 Oct 2024 12:59:42 +0200
Subject: [PATCH 162/297] make ast declarations unique

---
 src/Language/PureScript/Make/Index.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 997d06abe6..3ef8e9e6a2 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -159,7 +159,10 @@ initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_declarations (module_name TEXT, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN)"
+  SQL.execute_ conn 
+   "CREATE TABLE IF NOT EXISTS ast_declarations \
+   \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, \
+   \UNIQUE(module_name, name_type, name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"

From 887289097551906241d84290310902371b1ebfae Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 00:17:28 +0200
Subject: [PATCH 163/297] adds hover and go to definition for type class
 instances

---
 src/Language/PureScript/Lsp/Cache/Query.hs    |  3 +
 .../PureScript/Lsp/Handlers/Definition.hs     | 56 ++++++++---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 98 ++++++++++++++++---
 src/Language/PureScript/Lsp/Handlers/Index.hs |  2 +-
 src/Language/PureScript/Lsp/Util.hs           | 11 ++-
 src/Language/PureScript/Make/Index.hs         | 58 ++++++++---
 6 files changed, 179 insertions(+), 49 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index d9df94eb49..ee2d30d59b 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -78,6 +78,7 @@ getAstDeclarationsStartingWith moduleName' prefix = do
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
              \AND instr(name, :prefix) == 1 \
+             \AND generated = false \
              \ORDER BY name ASC \
              \LIMIT :limit \
              \OFFSET :offset"
@@ -108,6 +109,7 @@ getAstDeclarationsStartingWithAndSearchingModuleNames moduleName' moduleNameCont
              \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
              \AND instr(ast_declarations.module_name, :module_name_contains) <> 0 \
              \AND instr(name, :prefix) == 1 \
+             \AND generated = false \
              \ORDER BY name ASC \
              \LIMIT :limit \
              \OFFSET :offset"
@@ -137,6 +139,7 @@ getAstDeclarationsStartingWithOnlyInModule moduleName' prefix = do
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE ast_declarations.module_name = :module_name \
              \AND instr(name, :prefix) == 1 \
+             \AND generated = false \
              \ORDER BY name ASC \
              \LIMIT :limit \
              \OFFSET :offset"
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index e065bba83e..99b1a33c59 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -11,15 +11,16 @@ import Language.PureScript qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule)
+import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine, posInSpan, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
-import Language.PureScript.Lsp.Log (debugLsp)
+import Data.Text qualified as T
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -59,11 +60,10 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
                 nameType = getImportRefNameType import'
             debugLsp $ "import: " <> show import'
             respondWithDeclInOtherModule nameType importedModuleName (printName name)
-          _ -> do 
+          _ -> do
             debugLsp $ "respondWithModule importedModuleName: " <> show importedModuleName
             respondWithModule ss importedModuleName
 
-
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -74,20 +74,26 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
           srcPosLine = fromIntegral _line + 1
 
-          declAtPos =
+          declsAtPos =
             withoutPrim
-              & declAtLine srcPosLine
-
+              & declsAtLine srcPosLine
 
-
-      forLsp declAtPos $ \decl -> do
+      forLsp (head declsAtPos) $ \decl -> do
         case decl of
-          P.ImportDeclaration (ss, _) importedModuleName importType _ -> do 
+          P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
             debugLsp $ "ImportDeclaration iomportedModuleName: " <> show importedModuleName
             case importType of
               P.Implicit -> respondWithModule ss importedModuleName
               P.Explicit imports -> respondWithImports ss importedModuleName imports
               P.Hiding imports -> respondWithImports ss importedModuleName imports
+          P.TypeInstanceDeclaration _ (P.SourceSpan span start end , _) _ _ _ _ (P.Qualified (P.ByModuleName modName) className) _ _ 
+               | posInSpan pos classNameSS -> respondWithDeclInOtherModule (Just TyClassNameType) modName classNameTxt
+            where 
+              
+              classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
+
+              classNameTxt :: Text 
+              classNameTxt = P.runProperName className
           _ -> do
             let respondWithTypeLocation = do
                   let tipes =
@@ -95,11 +101,10 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
                           filter (not . isNullSourceTypeSpan) $
                             getTypesAtPos pos decl
 
-                      onOneLine = filter isSingleLine tipes
-                  case onOneLine of
+                  case tipes of
                     [] -> nullRes
                     _ -> do
-                      let smallest = minimumBy (comparing getTypeColumns) onOneLine
+                      let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
                       case smallest of
                         P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
                         P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
@@ -116,9 +121,9 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
                           _ -> nullRes
                         _ -> nullRes
 
-                exprsAtPos = getExprsAtPos pos decl
+                exprsAtPos = getExprsAtPos pos =<< declsAtPos
             debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
-            case head exprsAtPos of
+            case smallestExpr exprsAtPos of
               Just expr -> do
                 case expr of
                   P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
@@ -136,15 +141,34 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
                   _ -> respondWithTypeLocation
               _ -> respondWithTypeLocation
 
+smallestExpr :: [P.Expr] -> Maybe P.Expr
+smallestExpr [] = Nothing
+smallestExpr es = Just $ minimumBy (comparing (fromMaybe (maxInt, maxInt) . getExprRowsAndColumns)) es
+
+getExprRowsAndColumns :: P.Expr -> Maybe (Int, Int)
+getExprRowsAndColumns expr =
+  P.exprSourceSpan expr <&> \ss ->
+    let spanRowStart = P.sourcePosLine (P.spanStart ss)
+        spanRowEnd = P.sourcePosLine (P.spanEnd ss)
+        spanColStart = P.sourcePosColumn (P.spanStart ss)
+        spanColEnd = P.sourcePosColumn (P.spanEnd ss)
+     in (spanRowEnd - spanRowStart, spanColEnd - spanColStart)
+
 isNullSourceTypeSpan :: P.SourceType -> Bool
 isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
 
 isSingleLine :: P.SourceType -> Bool
 isSingleLine st = P.sourcePosLine (P.spanStart (fst (getAnnForType st))) == P.sourcePosLine (P.spanEnd (fst (getAnnForType st)))
 
+getTypeRowsAndColumns :: P.SourceType -> (Int, Int)
+getTypeRowsAndColumns st = (getTypeRows st, getTypeColumns st)
+
 getTypeColumns :: P.SourceType -> Int
 getTypeColumns st = P.sourcePosColumn (P.spanEnd (fst (getAnnForType st))) - P.sourcePosColumn (P.spanStart (fst (getAnnForType st)))
 
+getTypeRows :: P.SourceType -> Int
+getTypeRows st = P.sourcePosLine (P.spanEnd (fst (getAnnForType st))) - P.sourcePosLine (P.spanStart (fst (getAnnForType st)))
+
 fromPrim :: P.SourceType -> Bool
 fromPrim st = case st of
   P.TypeConstructor _ (P.Qualified (P.ByModuleName (P.ModuleName "Prim")) _) -> True
@@ -205,7 +229,7 @@ getTypesAtPos pos decl = P.everythingOnTypes (<>) getAtPos =<< (view _1 $ P.accu
     getAtPos :: P.SourceType -> [P.SourceType]
     getAtPos st = [st | posInSpan pos (fst $ getAnnForType st)]
 
-findDeclRefAtPos :: Foldable t => Types.Position -> t P.DeclarationRef -> Maybe P.DeclarationRef
+findDeclRefAtPos :: (Foldable t) => Types.Position -> t P.DeclarationRef -> Maybe P.DeclarationRef
 findDeclRefAtPos pos imports = find (posInSpan pos . P.declRefSourceSpan) imports
 
 getImportRefNameType :: P.DeclarationRef -> Maybe LspNameType
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 6ce6e5ed51..c3d3ae5738 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -5,6 +5,7 @@
 module Language.PureScript.Lsp.Handlers.Hover where
 
 import Control.Lens ((^.))
+import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
@@ -16,16 +17,16 @@ import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
-import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, isSingleLine, spanToRange)
+import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeRowsAndColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, smallestExpr, spanToRange)
+import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declAtLine)
+import Language.PureScript.Lsp.Util (declsAtLine, posInSpan)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
-import Data.Text qualified as T
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
@@ -86,26 +87,38 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 
           srcPosLine = fromIntegral _line + 1
 
-          declAtPos =
+          declsAtPos =
             withoutPrim
-              & declAtLine srcPosLine
+              & declsAtLine srcPosLine
+
+      debugLsp $ "declsAtPos: " <> show declsAtPos
 
-      forLsp declAtPos $ \decl -> do
+      forLsp (head declsAtPos) $ \decl -> do
         case decl of
           P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
             case importType of
               P.Implicit -> respondWithModule ss importedModuleName
               P.Explicit imports -> respondWithImports ss importedModuleName imports
               P.Hiding imports -> respondWithImports ss importedModuleName imports
+
+          P.TypeInstanceDeclaration _ (P.SourceSpan span start end , _) _ _ _ _ (P.Qualified (P.ByModuleName modName) className) _ _ 
+               | posInSpan pos classNameSS -> respondWithDeclInModule classNameSS TyClassNameType modName classNameTxt
+            where 
+              
+              classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
+
+              classNameTxt :: Text 
+              classNameTxt = P.runProperName className
           _ -> do
-            let exprsAtPos = getExprsAtPos pos decl
+            let exprsAtPos = getExprsAtPos pos =<< declsAtPos
                 findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
                 findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
                 findTypedExpr (_ : es) = findTypedExpr es
                 findTypedExpr [] = Nothing
 
+            debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
 
-            case head exprsAtPos of
+            case smallestExpr exprsAtPos of
               Just expr -> do
                 case expr of
                   P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
@@ -121,20 +134,22 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                         filter (not . isNullSourceTypeSpan) $
                           getTypesAtPos pos decl
 
-                    onOneLine = filter isSingleLine tipes
-                case onOneLine of
+                debugLsp $ "tipes: " <> show (length tipes)
+
+                case tipes of
                   [] -> nullRes
                   _ -> do
-                    let smallest = minimumBy (comparing getTypeColumns) onOneLine
+                    let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
+                    debugLsp $ "smallest: " <> show smallest
                     case smallest of
                       P.TypeConstructor (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
                         respondWithDeclInModule ss TyNameType modName $ P.runProperName ident
                       P.TypeOp (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
                         respondWithDeclInModule ss TyOpNameType modName $ P.runOpName ident
-                      P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of 
+                      P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of
                         (P.Qualified (P.ByModuleName modName) ident) -> do
                           respondWithDeclInModule ss TyClassNameType modName $ P.runProperName ident
-                        _ -> nullRes 
+                        _ -> nullRes
                       _ -> nullRes
 
 pursTypeStr :: Text -> Maybe Text -> [P.Comment] -> Text
@@ -151,4 +166,59 @@ pursTypeStr word type' comments =
       Nothing -> ""
 
 pursMd :: Text -> Text
-pursMd t = "```purescript\n" <> t <> "\n```"
\ No newline at end of file
+pursMd t = "```purescript\n" <> t <> "\n```"
+
+-- x =
+--   [ TypeInstanceDeclaration
+--       ( SourceSpan
+--           { spanStart =
+--               SourcePos
+--                 { sourcePosLine = 18,
+--                   sourcePosColumn = 1
+--                 },
+--             spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}
+--           },
+--         []
+--       )
+--       (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 31}, spanEnd = SourcePos {sourcePosLine = 18, sourcePosColumn = 49}}, [])
+--       (ChainId (,SourcePos {sourcePosLine = 18, sourcePosColumn = 1}))
+--       0
+--       (Right (Ident "monadEffectEffect"))
+--       []
+--       (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect"}))
+--       [TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 43}, spanEnd = SourcePos {sourcePosLine = 18, sourcePosColumn = 49}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))]
+--       (ExplicitInstance [ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}, []), valdeclIdent = Ident "liftEffect", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (PositionedValue (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) [] (Var (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) (Qualified (ByModuleName (ModuleName "Control.Category")) (Ident "identity"))))]})]),
+--     ValueDeclaration
+--       ( ValueDeclarationData
+--           { valdeclSourceAnn =
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1},
+--                     spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}
+--                   },
+--                 []
+--               ),
+--             valdeclIdent = Ident "monadEffectEffect",
+--             valdeclName = Private,
+--             valdeclBinders = [],
+--             valdeclExpression =
+--               [ GuardedExpr
+--                   []
+--                   ( TypedValue
+--                       True
+--                       ( App
+--                           ( TypedValue
+--                               True
+--                               ( Constructor
+--                                   (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}})
+--                                   (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect$Dict"}))
+--                               )
+--                               (ForAll (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) TypeVarVisible "m" (Just (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "liftEffect"}) (ForAll (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) "a"))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 40}}, []) "m") (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) "a"))) (Just (SkolemScope {runSkolemScope = 0}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "Monad0"}) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 15, sourcePosColumn = 13}, spanEnd = SourcePos {sourcePosLine = 15, sourcePosColumn = 14}}, []) "m"))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect$Dict"}))) (TypeVar (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) "m"))) (Just (SkolemScope {runSkolemScope = 1})))
+--                           )
+--                           (TypedValue True (Literal (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) (ObjectLiteral [("liftEffect", TypedValue True (TypedValue True (PositionedValue (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) [] (App (Var (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) (Qualified (ByModuleName (ModuleName "Control.Category")) (Ident "identity"))) (Var (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}) (Qualified (ByModuleName (ModuleName "Control.Category")) (Ident "categoryFn"))))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (Skolem (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}, []) "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) 0 (SkolemScope {runSkolemScope = 2})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (Skolem (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}, []) "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) 0 (SkolemScope {runSkolemScope = 2}))))) (ForAll (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) "a"))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) "a"))) (Just (SkolemScope {runSkolemScope = 2})))), ("Monad0", TypedValue True (Abs (VarBinder (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) UnusedIdent) (TypedValue False (Var (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}) (Qualified (ByModuleName (ModuleName "Effect")) (Ident "monadEffect"))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))))))])) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "liftEffect"}) (ForAll (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) "a"))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) "a"))) (Just (SkolemScope {runSkolemScope = 0}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "Monad0"}) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))))))
+--                       )
+--                       (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 43}, spanEnd = SourcePos {sourcePosLine = 18, sourcePosColumn = 49}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))))
+--                   )
+--               ]
+--           }
+--       )
+--   ]""
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 2b7c702072..275380f607 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -45,7 +45,7 @@ indexHandler =
       conn <- getDbConn
       indexExtern conn ef
       indexAstModuleFromExtern conn ef
-      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn (P.efModuleName ef) (P.efDeclarations ef))
+      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn ef)
 
 -- \| Finds all the externs inside the output folder and returns the
 -- corresponding module names
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 5b43a7d3fa..5695e7f84b 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -154,14 +154,15 @@ declSourceSpanWithExpr d = maybe span (widenSourceSpan span) exprSpan
          in foldl' go Nothing valdeclExpression
       _ -> Nothing
 
-declAtLine :: Int -> [P.Declaration] -> Maybe P.Declaration
-declAtLine l = go . sortBy (comparing declStartLine)
+declsAtLine :: Int -> [P.Declaration] -> [P.Declaration]
+declsAtLine l = go . sortBy (comparing declStartLine)
   where
+    go (d : ds) | declStartLine d == l = d : go ds
     go (d : d' : ds)
-      | declStartLine d <= l && declStartLine d' > l = Just d
+      | declStartLine d <= l && declStartLine d' > l =  d : go (d' : ds)
       | otherwise = go (d' : ds)
-    go [d] | declStartLine d <= l = Just d
-    go _ = Nothing
+    go [d] | declStartLine d <= l = [ d]
+    go _ = []
 
 declStartLine :: P.Declaration -> Int
 declStartLine = P.sourcePosLine . AST.spanStart . P.declSourceSpan
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 3ef8e9e6a2..a5b618e2c2 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -5,10 +5,12 @@ module Language.PureScript.Make.Index where
 
 import Codec.Serialise (serialise)
 import Data.Set qualified as Set
+import Data.Text qualified as T
 import Database.SQLite.Simple (Connection, NamedParam ((:=)))
 import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
 import Language.PureScript.AST qualified as P
+import Language.PureScript.AST.Declarations qualified as E
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.NameType (externDeclNameType, lspNameType)
@@ -48,16 +50,17 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls _exportRefs) ext
         end = P.spanEnd ss
         name = P.declName decl
         nameType = name <&> lspNameType
+        printedType = printDeclarationType decl
     SQL.executeNamed
       conn
       ( SQL.Query
           "INSERT INTO ast_declarations \
-          \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
-          \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)"
+          \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+          \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
       )
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := printName <$> name,
-        ":printed_type" := printDeclarationType decl,
+        ":printed_type" := printedType,
         ":name_type" := nameType,
         ":start_line" := P.sourcePosLine start,
         ":end_line" := P.sourcePosLine end,
@@ -65,7 +68,8 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls _exportRefs) ext
         ":end_col" := P.sourcePosColumn end,
         ":lines" := P.sourcePosLine end - P.sourcePosLine start,
         ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
-        ":exported" := Set.member decl exports
+        ":exported" := Set.member decl exports,
+        ":generated" := "$Dict" `T.isInfixOf` printedType
       ]
   where
     externPath = P.spanName (P.efSourceSpan extern)
@@ -82,8 +86,8 @@ indexAstModuleFromExtern conn extern = liftIO do
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
-indexAstDeclFromExternDecl :: (MonadIO m) => Connection -> P.ModuleName -> [P.ExternsDeclaration] -> P.ExternsDeclaration -> m ()
-indexAstDeclFromExternDecl conn moduleName' moduleDecls externDecl = liftIO do
+indexAstDeclFromExternDecl :: (MonadIO m) => Connection ->  ExternsFile -> P.ExternsDeclaration -> m ()
+indexAstDeclFromExternDecl conn extern externDecl = liftIO do
   let ss = case externDecl of
         P.EDDataConstructor {..}
           | Just typeCtr <- find (isTypeOfName edDataCtorTypeCtor) moduleDecls -> efDeclSourceSpan typeCtr
@@ -96,8 +100,8 @@ indexAstDeclFromExternDecl conn moduleName' moduleDecls externDecl = liftIO do
     conn
     ( SQL.Query
         "INSERT INTO ast_declarations \
-        \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported) \
-        \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported)"
+        \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+        \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
     )
     [ ":module_name" := P.runModuleName moduleName',
       ":name" := printEfDeclName externDecl,
@@ -109,13 +113,40 @@ indexAstDeclFromExternDecl conn moduleName' moduleDecls externDecl = liftIO do
       ":end_col" := P.sourcePosColumn end,
       ":lines" := P.sourcePosLine end - P.sourcePosLine start,
       ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
-      ":exported" := False
+      ":exported" := Set.member declName exportedNames,
+      ":generated" := "$Dict" `T.isInfixOf` printedType
     ]
   where
     isTypeOfName :: P.ProperName 'P.TypeName -> P.ExternsDeclaration -> Bool
     isTypeOfName name P.EDType {..} = edTypeName == name
     isTypeOfName _ _ = False
 
+    moduleName' = efModuleName extern
+
+    moduleDecls = P.efDeclarations extern
+
+    exportedNames :: Set P.Name
+    exportedNames =
+      Set.fromList $
+        P.efExports extern >>= \case
+          E.TypeClassRef _ name -> [P.TyClassName name]
+          E.TypeRef _ name _ -> [P.TyName name]
+          E.ValueRef _ name -> [P.IdentName name]
+          E.TypeOpRef _ name -> [P.TyOpName name]
+          E.ValueOpRef _ name -> [P.ValOpName name]
+          E.TypeInstanceRef _ name _ -> [P.IdentName name]
+          E.ModuleRef _ name -> [P.ModName name]
+          E.ReExportRef _ _ _ -> []
+
+    declName :: P.Name 
+    declName = case externDecl of
+      P.EDType {..} -> P.TyName edTypeName
+      P.EDTypeSynonym {..} -> P.TyName edTypeSynonymName
+      P.EDDataConstructor {..} -> P.DctorName edDataCtorName
+      P.EDValue {..} -> P.IdentName edValueName
+      P.EDClass {..} -> P.TyClassName edClassName
+      P.EDInstance {..} -> P.IdentName edInstanceName
+
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma
@@ -159,10 +190,11 @@ initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys = ON;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn 
-   "CREATE TABLE IF NOT EXISTS ast_declarations \
-   \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, \
-   \UNIQUE(module_name, name_type, name) on conflict replace)"
+  SQL.execute_
+    conn
+    "CREATE TABLE IF NOT EXISTS ast_declarations \
+    \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, generated BOOLEAN, \
+    \UNIQUE(module_name, name_type, name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"

From f427864a959b81e11166dd8de9a7349a56c78665 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 10:35:03 +0200
Subject: [PATCH 164/297] adds hover and goto def for class members

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 146 +++++++++---------
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 138 +++++++++--------
 src/Language/PureScript/Lsp/Util.hs           |  16 +-
 3 files changed, 162 insertions(+), 138 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 99b1a33c59..f580bf64e0 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -3,6 +3,7 @@
 module Language.PureScript.Lsp.Handlers.Definition where
 
 import Control.Lens (Field1 (_1), view, (^.))
+import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
@@ -20,7 +21,6 @@ import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude hiding (to)
-import Data.Text qualified as T
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -64,6 +64,81 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
             debugLsp $ "respondWithModule importedModuleName: " <> show importedModuleName
             respondWithModule ss importedModuleName
 
+      handleDecls :: FilePath -> [P.Declaration] -> HandlerM ()
+      handleDecls filePath decls = do
+        let srcPosLine = fromIntegral _line + 1
+
+            declsAtPos =
+              decls
+                & declsAtLine srcPosLine
+
+        forLsp (head declsAtPos) $ \decl -> do
+          case decl of
+            P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
+              debugLsp $ "ImportDeclaration iomportedModuleName: " <> show importedModuleName
+              case importType of
+                P.Implicit -> respondWithModule ss importedModuleName
+                P.Explicit imports -> respondWithImports ss importedModuleName imports
+                P.Hiding imports -> respondWithImports ss importedModuleName imports
+            P.TypeInstanceDeclaration _ (P.SourceSpan span start end, _) _ _ _ constraints (P.Qualified (P.ByModuleName modName) className) _args body
+              | posInSpan pos classNameSS -> respondWithDeclInOtherModule (Just TyClassNameType) modName classNameTxt
+              | Just (P.Constraint _ (P.Qualified (P.ByModuleName conModName) conClassName) _ _ _) <- find (posInSpan pos . fst . P.constraintAnn) constraints -> do
+                  respondWithDeclInOtherModule (Just TyClassNameType) conModName $ P.runProperName conClassName
+              | P.ExplicitInstance members <- body -> do
+                  handleDecls filePath members
+              where
+                classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
+
+                classNameTxt :: Text
+                classNameTxt = P.runProperName className
+            -- P.TypeInstanceDeclaration _ _ _ _ _ _ _ -> nullRes
+            _ -> do
+              let respondWithTypeLocation = do
+                    let tipes =
+                          filter (not . fromPrim) $
+                            filter (not . isNullSourceTypeSpan) $
+                              getTypesAtPos pos decl
+
+                    case tipes of
+                      [] -> nullRes
+                      _ -> do
+                        let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
+                        case smallest of
+                          P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                          P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                            respondWithDeclInOtherModule (Just TyNameType) modName $ P.runProperName ident
+                          P.TypeOp _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                          P.TypeOp _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                            respondWithDeclInOtherModule (Just TyOpNameType) modName $ P.runOpName ident
+                          P.ConstrainedType _ c _ -> case P.constraintClass c of
+                            (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
+                            (P.Qualified (P.ByModuleName modName) ident) -> do
+                              respondWithDeclInOtherModule (Just TyClassNameType) modName $ P.runProperName ident
+                          P.TypeVar _ name -> case findForallSpan name tipes of
+                            Just srcSpan -> posRes filePath (P.spanStart srcSpan)
+                            _ -> nullRes
+                          _ -> nullRes
+
+                  exprsAtPos = getExprsAtPos pos =<< declsAtPos
+              debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
+              case smallestExpr exprsAtPos of
+                Just expr -> do
+                  case expr of
+                    P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
+                      debugLsp $ "Var BySourcePos : " <> show srcPos
+                      posRes filePath srcPos
+                    P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                      debugLsp $ "Var ByModuleName : " <> show modName <> "." <> P.runIdent ident
+                      respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
+                    P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                    P.Op _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                      respondWithDeclInOtherModule (Just ValOpNameType) modName $ P.runOpName ident
+                    P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
+                    P.Constructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                      respondWithDeclInOtherModule (Just DctorNameType) modName $ P.runProperName ident
+                    _ -> respondWithTypeLocation
+                _ -> respondWithTypeLocation
+
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -72,74 +147,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
               & P.getModuleDeclarations
               & filter (not . isPrimImport)
 
-          srcPosLine = fromIntegral _line + 1
-
-          declsAtPos =
-            withoutPrim
-              & declsAtLine srcPosLine
-
-      forLsp (head declsAtPos) $ \decl -> do
-        case decl of
-          P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
-            debugLsp $ "ImportDeclaration iomportedModuleName: " <> show importedModuleName
-            case importType of
-              P.Implicit -> respondWithModule ss importedModuleName
-              P.Explicit imports -> respondWithImports ss importedModuleName imports
-              P.Hiding imports -> respondWithImports ss importedModuleName imports
-          P.TypeInstanceDeclaration _ (P.SourceSpan span start end , _) _ _ _ _ (P.Qualified (P.ByModuleName modName) className) _ _ 
-               | posInSpan pos classNameSS -> respondWithDeclInOtherModule (Just TyClassNameType) modName classNameTxt
-            where 
-              
-              classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
-
-              classNameTxt :: Text 
-              classNameTxt = P.runProperName className
-          _ -> do
-            let respondWithTypeLocation = do
-                  let tipes =
-                        filter (not . fromPrim) $
-                          filter (not . isNullSourceTypeSpan) $
-                            getTypesAtPos pos decl
-
-                  case tipes of
-                    [] -> nullRes
-                    _ -> do
-                      let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
-                      case smallest of
-                        P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                        P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                          respondWithDeclInOtherModule (Just TyNameType) modName $ P.runProperName ident
-                        P.TypeOp _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                        P.TypeOp _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                          respondWithDeclInOtherModule (Just TyOpNameType) modName $ P.runOpName ident
-                        P.ConstrainedType _ c _ -> case P.constraintClass c of
-                          (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
-                          (P.Qualified (P.ByModuleName modName) ident) -> do
-                            respondWithDeclInOtherModule (Just TyClassNameType) modName $ P.runProperName ident
-                        P.TypeVar _ name -> case findForallSpan name tipes of
-                          Just srcSpan -> posRes filePath (P.spanStart srcSpan)
-                          _ -> nullRes
-                        _ -> nullRes
-
-                exprsAtPos = getExprsAtPos pos =<< declsAtPos
-            debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
-            case smallestExpr exprsAtPos of
-              Just expr -> do
-                case expr of
-                  P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
-                    debugLsp $ "Var BySourcePos : " <> show srcPos
-                    posRes filePath srcPos
-                  P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                    debugLsp $ "Var ByModuleName : " <> show modName <> "." <> P.runIdent ident
-                    respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
-                  P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                  P.Op _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                    respondWithDeclInOtherModule (Just ValOpNameType) srcPos $ P.runOpName ident
-                  P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                  P.Constructor _ (P.Qualified (P.ByModuleName srcPos) ident) -> do
-                    respondWithDeclInOtherModule (Just DctorNameType) srcPos $ P.runProperName ident
-                  _ -> respondWithTypeLocation
-              _ -> respondWithTypeLocation
+      handleDecls filePath withoutPrim
 
 smallestExpr :: [P.Expr] -> Maybe P.Expr
 smallestExpr [] = Nothing
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index c3d3ae5738..4da604958a 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -77,6 +77,77 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               respondWithDeclInModule ss nameType' importedModuleName (printName name)
           _ -> respondWithModule ss importedModuleName
 
+      handleDecls :: [P.Declaration] -> HandlerM ()
+      handleDecls decls = do
+        let srcPosLine = fromIntegral _line + 1
+
+            declsAtPos =
+              decls
+                & declsAtLine srcPosLine
+
+        debugLsp $ "declsAtPos: " <> show declsAtPos
+
+        forLsp (head declsAtPos) $ \decl -> do
+          case decl of
+            P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
+              case importType of
+                P.Implicit -> respondWithModule ss importedModuleName
+                P.Explicit imports -> respondWithImports ss importedModuleName imports
+                P.Hiding imports -> respondWithImports ss importedModuleName imports
+            P.TypeInstanceDeclaration _ (P.SourceSpan span start end, _) _ _ _ constraints (P.Qualified (P.ByModuleName modName) className) _args body
+              | posInSpan pos classNameSS -> respondWithDeclInModule classNameSS TyClassNameType modName classNameTxt
+              | Just (P.Constraint (ss, _) (P.Qualified (P.ByModuleName conModName) conClassName) _ _ _) <- find (posInSpan pos . fst . P.constraintAnn) constraints -> do
+                  respondWithDeclInModule ss TyClassNameType conModName $ P.runProperName conClassName
+              | P.ExplicitInstance members <- body, not $ null $ declsAtLine srcPosLine members  -> do
+                  handleDecls members
+              where
+                classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
+
+                classNameTxt :: Text
+                classNameTxt = P.runProperName className
+            _ -> do
+              let exprsAtPos = getExprsAtPos pos =<< declsAtPos
+                  findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
+                  findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
+                  findTypedExpr (_ : es) = findTypedExpr es
+                  findTypedExpr [] = Nothing
+
+              debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
+
+              case smallestExpr exprsAtPos of
+                Just expr -> do
+                  case expr of
+                    P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
+                      respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
+                    P.Op ss (P.Qualified (P.ByModuleName modName) ident) -> do
+                      respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+                    P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
+                      respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
+                    _ -> forLsp (findTypedExpr $ getTypedValuesAtPos pos decl) (respondWithSourceType expr)
+                _ -> do
+                  let tipes =
+                        filter (not . fromPrim) $
+                          filter (not . isNullSourceTypeSpan) $
+                            getTypesAtPos pos decl
+
+                  debugLsp $ "tipes: " <> show (length tipes)
+
+                  case tipes of
+                    [] -> nullRes
+                    _ -> do
+                      let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
+                      debugLsp $ "smallest: " <> show smallest
+                      case smallest of
+                        P.TypeConstructor (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
+                          respondWithDeclInModule ss TyNameType modName $ P.runProperName ident
+                        P.TypeOp (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
+                          respondWithDeclInModule ss TyOpNameType modName $ P.runOpName ident
+                        P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of
+                          (P.Qualified (P.ByModuleName modName) ident) -> do
+                            respondWithDeclInModule ss TyClassNameType modName $ P.runProperName ident
+                          _ -> nullRes
+                        _ -> nullRes
+
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -85,72 +156,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               & P.getModuleDeclarations
               & filter (not . isPrimImport)
 
-          srcPosLine = fromIntegral _line + 1
-
-          declsAtPos =
-            withoutPrim
-              & declsAtLine srcPosLine
-
-      debugLsp $ "declsAtPos: " <> show declsAtPos
-
-      forLsp (head declsAtPos) $ \decl -> do
-        case decl of
-          P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
-            case importType of
-              P.Implicit -> respondWithModule ss importedModuleName
-              P.Explicit imports -> respondWithImports ss importedModuleName imports
-              P.Hiding imports -> respondWithImports ss importedModuleName imports
-
-          P.TypeInstanceDeclaration _ (P.SourceSpan span start end , _) _ _ _ _ (P.Qualified (P.ByModuleName modName) className) _ _ 
-               | posInSpan pos classNameSS -> respondWithDeclInModule classNameSS TyClassNameType modName classNameTxt
-            where 
-              
-              classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
-
-              classNameTxt :: Text 
-              classNameTxt = P.runProperName className
-          _ -> do
-            let exprsAtPos = getExprsAtPos pos =<< declsAtPos
-                findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
-                findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
-                findTypedExpr (_ : es) = findTypedExpr es
-                findTypedExpr [] = Nothing
-
-            debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
-
-            case smallestExpr exprsAtPos of
-              Just expr -> do
-                case expr of
-                  P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                    respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
-                  P.Op ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                    respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
-                  P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                    respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
-                  _ -> forLsp (findTypedExpr $ getTypedValuesAtPos pos decl) (respondWithSourceType expr)
-              _ -> do
-                let tipes =
-                      filter (not . fromPrim) $
-                        filter (not . isNullSourceTypeSpan) $
-                          getTypesAtPos pos decl
-
-                debugLsp $ "tipes: " <> show (length tipes)
-
-                case tipes of
-                  [] -> nullRes
-                  _ -> do
-                    let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
-                    debugLsp $ "smallest: " <> show smallest
-                    case smallest of
-                      P.TypeConstructor (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
-                        respondWithDeclInModule ss TyNameType modName $ P.runProperName ident
-                      P.TypeOp (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
-                        respondWithDeclInModule ss TyOpNameType modName $ P.runOpName ident
-                      P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of
-                        (P.Qualified (P.ByModuleName modName) ident) -> do
-                          respondWithDeclInModule ss TyClassNameType modName $ P.runProperName ident
-                        _ -> nullRes
-                      _ -> nullRes
+      handleDecls withoutPrim
 
 pursTypeStr :: Text -> Maybe Text -> [P.Comment] -> Text
 pursTypeStr word type' comments =
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 5695e7f84b..41c33535fb 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -157,16 +157,26 @@ declSourceSpanWithExpr d = maybe span (widenSourceSpan span) exprSpan
 declsAtLine :: Int -> [P.Declaration] -> [P.Declaration]
 declsAtLine l = go . sortBy (comparing declStartLine)
   where
-    go (d : ds) | declStartLine d == l = d : go ds
+    go (d : ds) | declStartLine d <= l && declEndLine d >= l = d : go ds
     go (d : d' : ds)
-      | declStartLine d <= l && declStartLine d' > l =  d : go (d' : ds)
+      | declStartLine d <= l && declStartLine d' > l && unsureEndLine d = d : go (d' : ds)
       | otherwise = go (d' : ds)
-    go [d] | declStartLine d <= l = [ d]
+    go [d] | declStartLine d <= l = [d]
     go _ = []
 
+    unsureEndLine = \case 
+      P.ValueDeclaration{}  -> True
+      P.ExternDeclaration{} -> True
+      P.TypeClassDeclaration {} -> True
+      P.TypeInstanceDeclaration {} -> True
+      _ -> True
+
 declStartLine :: P.Declaration -> Int
 declStartLine = P.sourcePosLine . AST.spanStart . P.declSourceSpan
 
+declEndLine :: P.Declaration -> Int
+declEndLine = P.sourcePosLine . AST.spanEnd . P.declSourceSpan
+
 findExprSourceSpan :: P.Expr -> Maybe AST.SourceSpan
 findExprSourceSpan = goExpr
   where

From f54e648db81d90b88ce6f9d9aaae48bbcdfa6ea6 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 11:42:30 +0200
Subject: [PATCH 165/297] adds monad base control to HandlerM

---
 src/Language/PureScript/LSP.hs       | 12 +++++-----
 src/Language/PureScript/Lsp/Monad.hs | 36 +++++++++++++++++++++++++---
 2 files changed, 39 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index c3d6a2b5ca..eba2b33f93 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -16,14 +16,14 @@ import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (MonadLsp (getLspEnv), mapHandlers)
 import Language.LSP.Server qualified as Server
 import Language.PureScript.DB (mkDbPath)
+import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
 import Language.PureScript.Lsp.Handlers (handlers)
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
-import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath, globs), defaultConfig)
-import Language.PureScript.Lsp.State (addRunningRequest, getDbPath, putNewEnv, removeRunningRequest, getPreviousConfig, putPreviousConfig)
+import Language.PureScript.Lsp.Monad (HandlerM, runHandlerM)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (globs, outputPath), defaultConfig)
+import Language.PureScript.Lsp.State (addRunningRequest, getDbPath, getPreviousConfig, putNewEnv, putPreviousConfig, removeRunningRequest)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
-import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
 
 main :: LspEnvironment -> IO Int
 main lspEnv = do
@@ -50,7 +50,7 @@ serverDefinition lspEnv =
       staticHandlers = const (lspHandlers lspEnv),
       interpretHandler = \serverEnv ->
         Server.Iso
-          ( Server.runLspT serverEnv . flip runReaderT lspEnv
+          ( runHandlerM serverEnv lspEnv
           )
           liftIO,
       options = lspOptions
@@ -115,4 +115,4 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
                 errorLsp $ "Notification failed. Method: " <> methodText <> ". Error: " <> show e
           _ -> pure ()
 
-    runHandler env a = Server.runLspT env $ runReaderT a lspEnv
+    runHandler env = runHandlerM env lspEnv
diff --git a/src/Language/PureScript/Lsp/Monad.hs b/src/Language/PureScript/Lsp/Monad.hs
index a65c8d5b69..4783b52885 100644
--- a/src/Language/PureScript/Lsp/Monad.hs
+++ b/src/Language/PureScript/Lsp/Monad.hs
@@ -1,8 +1,38 @@
+{-# LANGUAGE InstanceSigs #-}
+
 module Language.PureScript.Lsp.Monad where
 
-import Language.LSP.Server (LspT)
+import Control.Monad.Base (MonadBase (liftBase))
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Trans.Control (MonadBaseControl (StM, liftBaseWith, restoreM), RunInBase)
+import Language.LSP.Server (LanguageContextEnv, LspT (LspT), MonadLsp, runLspT)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types
 import Protolude
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Control.Monad.Catch (MonadThrow)
+
+newtype HandlerM a = HandlerM (ReaderT LspEnvironment (LspT ServerConfig IO) a)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow, MonadReader LspEnvironment, MonadLsp ServerConfig)
+
+instance MonadBase IO HandlerM where
+  liftBase = liftIO
+
+instance MonadBaseControl IO HandlerM where
+  type StM HandlerM a = a
+
+  liftBaseWith :: (RunInBase HandlerM IO -> IO a) -> HandlerM a
+  liftBaseWith f = HandlerM $
+    ReaderT $ \lspEnv ->
+      LspT $
+        ReaderT $
+          \serverConfig ->
+            liftBaseWith $ \q -> f $ q . runHandlerM serverConfig lspEnv
+
+  restoreM :: StM HandlerM a -> HandlerM a
+  restoreM = pure
+
+unHandlerM :: HandlerM a -> ReaderT LspEnvironment (LspT ServerConfig IO) a
+unHandlerM (HandlerM a) = a
 
-type HandlerM = ReaderT LspEnvironment (LspT ServerConfig IO) 
+runHandlerM :: LanguageContextEnv ServerConfig -> LspEnvironment -> HandlerM a -> IO a
+runHandlerM env lspEnv (HandlerM a) = runLspT env $ runReaderT a lspEnv

From fe862562458979efb34b63bb04e396fa0e4182c3 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 12:03:26 +0200
Subject: [PATCH 166/297] read externs concurrently

---
 src/Language/PureScript/Lsp/Handlers/Index.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 275380f607..586f138b58 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -3,6 +3,7 @@
 
 module Language.PureScript.Lsp.Handlers.Index (indexHandler) where
 
+import Control.Concurrent.Async.Lifted (mapConcurrently, forConcurrently_)
 import Data.Aeson qualified as A
 import Data.Text qualified as T
 import Language.LSP.Protocol.Message qualified as Message
@@ -22,6 +23,7 @@ import Language.PureScript.Make.Monad (readExternsFile)
 import Protolude hiding (to)
 import System.Directory (doesFileExist, getDirectoryContents)
 import System.FilePath ((</>))
+import Control.Monad.Trans.Control (MonadBaseControl)
 
 indexHandler :: Server.Handlers HandlerM
 indexHandler =
@@ -30,7 +32,7 @@ indexHandler =
         conn <- getDbConn
         liftIO $ initDb conn
         externs <- logPerfStandard "findAvailableExterns" findAvailableExterns
-        logPerfStandard "insert externs" $ for_ externs indexExternAndDecls
+        logPerfStandard "insert externs" $ forConcurrently_ externs indexExternAndDecls
         res $ Right A.Null,
       Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \_req res -> do
         conn <- getDbConn
@@ -52,6 +54,7 @@ indexHandler =
 findAvailableExterns ::
   forall m.
   ( MonadLsp ServerConfig m,
+    MonadBaseControl IO m,
     MonadReader LspEnvironment m
   ) =>
   m [ExternsFile]
@@ -59,7 +62,7 @@ findAvailableExterns = do
   oDir <- outputPath <$> getConfig
   directories <- liftIO $ getDirectoryContents oDir
   moduleNames <- liftIO $ filterM (containsExterns oDir) directories
-  catMaybes <$> for moduleNames (readExtern oDir)
+  catMaybes <$> mapConcurrently (readExtern oDir) moduleNames
   where
     -- Takes the output directory and a filepath like "Data.Array" and
     -- looks up, whether that folder contains an externs file

From b678342bb8433df174aafd9adaa47041455505b5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 12:25:33 +0200
Subject: [PATCH 167/297] use lifted async for lsp handlers

---
 src/Language/PureScript/LSP.hs | 23 ++++++++++-------------
 1 file changed, 10 insertions(+), 13 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index eba2b33f93..f428dfbf16 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -7,13 +7,14 @@
 module Language.PureScript.Lsp (main, serverDefinition) where
 
 import Control.Concurrent.Async.Lifted (AsyncCancelled (AsyncCancelled))
+import Control.Concurrent.Async.Lifted qualified as Lifted
 import Control.Monad.IO.Unlift
 import Data.Aeson qualified as A
 import Data.Aeson.Types qualified as A
 import Data.Text qualified as T
 import Language.LSP.Protocol.Message qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
-import Language.LSP.Server (MonadLsp (getLspEnv), mapHandlers)
+import Language.LSP.Server (mapHandlers)
 import Language.LSP.Server qualified as Server
 import Language.PureScript.DB (mkDbPath)
 import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
@@ -82,13 +83,12 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
             LSP.IdInt i -> Left i
             LSP.IdString t -> Right t
           methodText = T.pack $ LSP.someMethodToMethodString $ LSP.SomeMethod method
-      env <- getLspEnv
       debugLsp methodText
-      logPerfStandard methodText $ liftIO $ do
-        withAsync (runHandler env $ f msg k) \asyncAct -> do
+      logPerfStandard methodText $ do
+        Lifted.withAsync (f msg k) \asyncAct -> do
           addRunningRequest lspEnv reqId asyncAct
-          result <- waitCatch asyncAct
-          runHandler env case result of
+          result <- Lifted.waitCatch asyncAct
+          case result of
             Left e -> do
               case fromException e of
                 Just AsyncCancelled -> do
@@ -103,16 +103,13 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
     goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). Server.Handler HandlerM a -> Server.Handler HandlerM a
     goNotification f msg@(LSP.TNotificationMessage _ method _) = do
       let methodText = T.pack $ LSP.someMethodToMethodString $ LSP.SomeMethod method
-      env <- getLspEnv
-      liftIO $ withAsync (runHandler env $ f msg) \asyncAct -> do
-        result <- waitCatch asyncAct
+      Lifted.withAsync (f msg) \asyncAct -> do
+        result <- Lifted.waitCatch asyncAct
         case result of
           Left e -> do
-            runHandler env case fromException e of
+            case fromException e of
               Just AsyncCancelled -> do
                 warnLsp $ "Notification cancelled. Method: " <> methodText
               _ -> do
                 errorLsp $ "Notification failed. Method: " <> methodText <> ". Error: " <> show e
-          _ -> pure ()
-
-    runHandler env = runHandlerM env lspEnv
+          _ -> pure ()
\ No newline at end of file

From adabb521dae9e1635f0d90d31988f42003bb2406 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 12:33:02 +0200
Subject: [PATCH 168/297] use record syntax for unHandlerM

---
 src/Language/PureScript/Lsp/Monad.hs | 9 ++++-----
 1 file changed, 4 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Monad.hs b/src/Language/PureScript/Lsp/Monad.hs
index 4783b52885..b6595bb21e 100644
--- a/src/Language/PureScript/Lsp/Monad.hs
+++ b/src/Language/PureScript/Lsp/Monad.hs
@@ -3,15 +3,17 @@
 module Language.PureScript.Lsp.Monad where
 
 import Control.Monad.Base (MonadBase (liftBase))
+import Control.Monad.Catch (MonadThrow)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Trans.Control (MonadBaseControl (StM, liftBaseWith, restoreM), RunInBase)
 import Language.LSP.Server (LanguageContextEnv, LspT (LspT), MonadLsp, runLspT)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types
 import Protolude
-import Control.Monad.Catch (MonadThrow)
 
-newtype HandlerM a = HandlerM (ReaderT LspEnvironment (LspT ServerConfig IO) a)
+newtype HandlerM a = HandlerM
+  { unHandlerM :: ReaderT LspEnvironment (LspT ServerConfig IO) a
+  }
   deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow, MonadReader LspEnvironment, MonadLsp ServerConfig)
 
 instance MonadBase IO HandlerM where
@@ -31,8 +33,5 @@ instance MonadBaseControl IO HandlerM where
   restoreM :: StM HandlerM a -> HandlerM a
   restoreM = pure
 
-unHandlerM :: HandlerM a -> ReaderT LspEnvironment (LspT ServerConfig IO) a
-unHandlerM (HandlerM a) = a
-
 runHandlerM :: LanguageContextEnv ServerConfig -> LspEnvironment -> HandlerM a -> IO a
 runHandlerM env lspEnv (HandlerM a) = runLspT env $ runReaderT a lspEnv

From d415019325bbba408a66e8982c1e4dc8b7d2c8f0 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 14:35:53 +0200
Subject: [PATCH 169/297] adds outputPath to default config

---
 app/Command/Lsp.hs                          |  6 +++---
 src/Language/PureScript/LSP.hs              | 12 ++++++------
 src/Language/PureScript/Lsp/ServerConfig.hs |  6 +++---
 src/Language/PureScript/Lsp/Types.hs        |  2 +-
 4 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/app/Command/Lsp.hs b/app/Command/Lsp.hs
index 629eae5128..71df1e8816 100644
--- a/app/Command/Lsp.hs
+++ b/app/Command/Lsp.hs
@@ -31,7 +31,7 @@ command = Opts.helper <*> subcommands
       maybe (pure ()) setCurrentDirectory dir
       putErrLn $ "Starting server with output path: " <> outputPath
       env <- mkEnv outputPath
-      startServer env
+      startServer outputPath env
 
     serverOptions :: Opts.Parser ServerOptions
     serverOptions =
@@ -39,8 +39,8 @@ command = Opts.helper <*> subcommands
         <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
         <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
 
-    startServer env = do
-      code <- Lsp.main env
+    startServer outputPath env = do
+      code <- Lsp.main outputPath env
       exitWith
         ( case code of
             0 -> ExitSuccess
diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index f428dfbf16..a4f47952e8 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -26,12 +26,12 @@ import Language.PureScript.Lsp.State (addRunningRequest, getDbPath, getPreviousC
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 
-main :: LspEnvironment -> IO Int
-main lspEnv = do
-  Server.runServer $ serverDefinition lspEnv
+main :: FilePath -> LspEnvironment -> IO Int
+main outputPath lspEnv = do
+  Server.runServer $ serverDefinition outputPath lspEnv
 
-serverDefinition :: LspEnvironment -> Server.ServerDefinition ServerConfig
-serverDefinition lspEnv =
+serverDefinition :: FilePath -> LspEnvironment -> Server.ServerDefinition ServerConfig
+serverDefinition initialOutputPath lspEnv =
   Server.ServerDefinition
     { parseConfig = \_current json -> first T.pack $ A.parseEither A.parseJSON json,
       onConfigChange = \newConfig -> do
@@ -45,7 +45,7 @@ serverDefinition lspEnv =
           debugLsp "Globs changed"
           void updateAvailableSrcs
         putPreviousConfig newConfig,
-      defaultConfig = defaultConfig,
+      defaultConfig = defaultConfig initialOutputPath,
       configSection = "purescript-lsp",
       doInitialize = \env _ -> pure (Right env),
       staticHandlers = const (lspHandlers lspEnv),
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index 53d6343feb..1bdad9c2fb 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -20,10 +20,10 @@ data ServerConfig = ServerConfig
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
-defaultConfig :: ServerConfig
-defaultConfig  =
+defaultConfig :: FilePath -> ServerConfig
+defaultConfig outputPath =
   ServerConfig
-    { outputPath = "./output",
+    { outputPath = outputPath,
       globs = ["./src/**/*.purs"],
       inputSrcFromFile = Nothing,
       logLevel = LogAll,
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index d4e00f7ac5..76fd88b357 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -28,7 +28,7 @@ mkEnv :: FilePath -> IO LspEnvironment
 mkEnv outputPath = do
   connection <- newTVarIO =<< mkConnection outputPath
   st <- newTVarIO (LspState mempty P.primEnv mempty)
-  prevConfig <- newTVarIO defaultConfig
+  prevConfig <- newTVarIO $ defaultConfig outputPath
   pure $ LspEnvironment connection st prevConfig
 
 emptyState :: LspState

From 6aeb89c0036d01a321bf76ee7ee63d3ac1a5d2dc Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 17:15:46 +0200
Subject: [PATCH 170/297] remove unused arg from codegen

---
 src/Language/PureScript/Ide/Rebuild.hs  | 2 +-
 src/Language/PureScript/Lsp/Rebuild.hs  | 2 +-
 src/Language/PureScript/Make.hs         | 2 +-
 src/Language/PureScript/Make/Actions.hs | 6 +++---
 src/Language/PureScript/Make/Index.hs   | 4 ++--
 5 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 8078123101..b3080e1804 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -184,7 +184,7 @@ shushProgress ma =
 -- | Stops any kind of codegen
 shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
-  ma { P.codegen = \_ _ _ _ _ _-> pure ()
+  ma { P.codegen = \_ _ _ _ _ -> pure ()
      , P.ffiCodegen = \_ -> pure ()
      }
 
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 51e204c6c6..9e8923d82c 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -124,5 +124,5 @@ shushProgress ma =
 addRebuildCaching :: TVar Language.PureScript.Lsp.Types.LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps ma =
   ma
-    { P.codegen = \prevEnv env astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv astM) <* P.codegen ma prevEnv env astM m docs ext
+    { P.codegen = \prevEnv astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv astM) <* P.codegen ma prevEnv astM m docs ext
     }
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 49b3f14dae..cb3779fd1e 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -153,7 +153,7 @@ rebuildModuleWithProvidedEnv MakeActions {..} exEnv env externs m@(Module _ _ mo
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env env' mod' renamed docs exts
+  evalSupplyT nextVar'' $ codegen env mod' renamed docs exts
   return exts
 
 -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index eb1b6a5ab4..418723c925 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -113,7 +113,7 @@ data MakeActions m = MakeActions
   , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
   -- ^ Read the externs file for a module as a string and also return the actual
   -- path for the file.
-  , codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
+  , codegen :: Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
   -- ^ Run the code generator for the module and write any required output files.
   , ffiCodegen :: CF.Module CF.Ann -> m ()
   -- ^ Check ffi and print it in the output directory.
@@ -246,8 +246,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
       writeJSONFile (outputFilename modName "docs.json") docsMod
 
-  codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
-  codegen _prevEnv _env _m m docs exts = do
+  codegen :: Environment ->  Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
+  codegen _prevEnv _m m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
     codegenTargets <- lift $ asks optionsCodegenTargets
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index a5b618e2c2..1e5cfd1661 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -28,7 +28,7 @@ addAllIndexing conn ma =
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \prevEnv env astM m docs ext -> lift (indexAstModule conn astM ext) <* P.codegen ma prevEnv env astM m docs ext
+    { P.codegen = \prevEnv astM m docs ext -> lift (indexAstModule conn astM ext) <* P.codegen ma prevEnv astM m docs ext
     }
 
 indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> m ()
@@ -150,7 +150,7 @@ indexAstDeclFromExternDecl conn extern externDecl = liftIO do
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma
-    { P.codegen = \prevEnv env astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma prevEnv env astM m docs ext
+    { P.codegen = \prevEnv astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma prevEnv astM m docs ext
     }
 
 indexExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()

From a23e99f1f44c6ee0e8e7fec05c6e627447cb2f53 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 17:29:27 +0200
Subject: [PATCH 171/297] rebuild module even when typechecking fails

---
 src/Language/PureScript/Lsp/Rebuild.hs |  5 +++--
 src/Language/PureScript/Lsp/State.hs   | 19 ++++++++++++++++++-
 src/Language/PureScript/Make.hs        |  8 +++++---
 3 files changed, 26 insertions(+), 6 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 9e8923d82c..75f99a3619 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -19,7 +19,7 @@ import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild, setExportEnvCache, cacheDependencies, getDbConn)
+import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild, setExportEnvCache, cacheDependencies, getDbConn, updateCachedModule, updateCachedModule')
 import Language.PureScript.Lsp.Types (LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile))
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
@@ -43,6 +43,7 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
     Left parseError ->
       pure $ RebuildError $ CST.toMultipleErrors fp parseError
     Right (pwarnings, m) -> do
+      updateCachedModule m
       let moduleName = P.getModuleName m
       let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
       outputDirectory <- outputPath <$> getConfig
@@ -63,7 +64,7 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
           for_ externsMb (cacheDependencies moduleName)
           res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
             P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-              newExtern <- P.rebuildModuleWithProvidedEnv (makeEnv foreigns externs) exportEnv env externs m Nothing
+              newExtern <- P.rebuildModuleWithProvidedEnv (Just $ updateCachedModule' stVar) (makeEnv foreigns externs) exportEnv env externs m Nothing
               updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
               pure newExtern
           handleRebuildResult fp pwarnings res
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 0f9dc74748..e0fb5eed55 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -4,6 +4,8 @@ module Language.PureScript.Lsp.State
   ( getDbConn,
     cacheRebuild,
     cacheRebuild',
+    updateCachedModule,
+    updateCachedModule',
     cachedRebuild,
     cacheDependencies,
     clearCache,
@@ -65,6 +67,21 @@ cacheRebuild' st maxFiles ef deps prevEnv module' = atomically . modifyTVar st $
   where
     fp = P.spanName $ efSourceSpan ef
 
+updateCachedModule :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m ()
+updateCachedModule module' = do
+  st <- lspStateVar <$> ask
+  updateCachedModule' st module'
+
+updateCachedModule' :: (MonadIO m) => TVar LspState -> P.Module -> m ()
+updateCachedModule' st module' = liftIO . atomically $ modifyTVar st $ \x ->
+  x
+    { openFiles =
+        openFiles x <&> \(fp, ofile) ->
+          if ofModuleName ofile == P.getModuleName module'
+            then (fp, ofile {ofModule = module'})
+            else (fp, ofile)
+    }
+
 cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe OpenFile)
 cachedRebuild fp = do
   st <- lspStateVar <$> ask
@@ -183,7 +200,7 @@ cancelRequest requestId = do
       InR t -> Right t
 
 getDbPath :: (MonadReader LspEnvironment m, MonadIO m) => m FilePath
-getDbPath = do 
+getDbPath = do
   env <- ask
   liftIO $ fst <$> readTVarIO (lspDbConnectionVar env)
 
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index cb3779fd1e..3438e64e2d 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -23,7 +23,7 @@ import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
 import Control.Monad.Trans.Control (MonadBaseControl (..))
 import Control.Monad.Trans.State (runStateT)
 import Control.Monad.Writer.Class (MonadWriter (..), censor)
-import Control.Monad.Writer.Strict (runWriterT)
+import Control.Monad.Writer.Strict (runWriterT, MonadTrans (lift))
 import Data.Foldable (fold, for_)
 import Data.Function (on)
 import Data.List (foldl', sortOn)
@@ -91,11 +91,12 @@ rebuildModuleWithIndex ::
   m ExternsFile
 rebuildModuleWithIndex act exEnv externs m moduleIndex = do
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
-  rebuildModuleWithProvidedEnv act exEnv env externs m moduleIndex
+  rebuildModuleWithProvidedEnv Nothing act exEnv env externs m moduleIndex
 
 rebuildModuleWithProvidedEnv ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  Maybe (Module -> m ()) ->
   MakeActions m ->
   Env ->
   Environment ->
@@ -103,12 +104,13 @@ rebuildModuleWithProvidedEnv ::
   Module ->
   Maybe (Int, Int) ->
   m ExternsFile
-rebuildModuleWithProvidedEnv MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do
+rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
     (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
+    for_ onDesugared $ lift . \f -> f desugared
     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
     (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
     let usedImports' =

From 249a5a705b66f8a048807dc4383625e60f0df744 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 17 Oct 2024 18:50:21 +0200
Subject: [PATCH 172/297] use parser to get qualifier name

---
 src/Language/PureScript/Lsp/Imports.hs | 41 ++++++++++++++++++--------
 1 file changed, 29 insertions(+), 12 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 777305615d..c68895a754 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -1,8 +1,13 @@
-module Language.PureScript.Lsp.Imports where
+module Language.PureScript.Lsp.Imports
+  ( getMatchingImport,
+    addImportToTextEdit,
+    getIdentModuleQualifier,
+    parseModuleNameFromFile,
+  )
+where
 
 import Control.Lens (set)
 import Control.Monad.Catch (MonadThrow)
-import Data.List (init, last)
 import Data.Maybe as Maybe
 import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed qualified as Rope
@@ -11,6 +16,8 @@ import Language.LSP.Protocol.Types as LSP
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
+import Language.PureScript.CST qualified as CST
+import Language.PureScript.CST.Monad qualified as CSTM
 import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
 import Language.PureScript.Lsp.Log (errorLsp, warnLsp)
@@ -65,10 +72,20 @@ getImportEdits (CompleteItemData path moduleName' importedModuleName name word (
 
 getIdentModuleQualifier :: Text -> Maybe (P.ModuleName, Text)
 getIdentModuleQualifier word =
-  case T.splitOn "." word of
-    [] -> Nothing
-    [_] -> Nothing
-    xs -> Just (P.ModuleName $ T.intercalate "." $ init xs, last xs)
+  case parseRest (parseOne CST.parseExprP) word of
+    Just (CST.ExprIdent _ (CST.QualifiedName _ (Just modName) ident)) ->
+      Just (modName, CST.getIdent ident)
+    _ -> Nothing
+
+parseOne :: CST.Parser a -> CST.Parser a
+parseOne p = CSTM.token CST.TokLayoutStart *> p <* CSTM.token CST.TokLayoutEnd
+
+parseRest :: CST.Parser a -> Text -> Maybe a
+parseRest p =
+  fmap snd
+    . hush
+    . CST.runTokenParser (p <* CSTM.token CST.TokEof)
+    . CST.lexTopLevel
 
 addDeclarationToImports :: P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> Text -> Maybe LspNameType -> [Import] -> Maybe ([Import], Maybe P.ModuleName)
 addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName nameType imports
@@ -144,9 +161,9 @@ parseModuleNameFromFile ::
   (MonadThrow m, MonadLsp ServerConfig m, MonadReader LspEnvironment m) =>
   NormalizedUri ->
   m (Maybe P.ModuleName)
-parseModuleNameFromFile = parseImportsFromFile >=> \case 
-  Left err -> do 
-    warnLsp $ "Failed to parse module name from file: " <> err
-    pure Nothing
-  Right (mn, _, _, _) -> pure $ Just mn
-
+parseModuleNameFromFile =
+  parseImportsFromFile >=> \case
+    Left err -> do
+      warnLsp $ "Failed to parse module name from file: " <> err
+      pure Nothing
+    Right (mn, _, _, _) -> pure $ Just mn

From 6f8fac52c11d9a01b6954a9368223ee909774ec2 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 18 Oct 2024 10:03:53 +0200
Subject: [PATCH 173/297] rebuild without cache if imports fail

---
 src/Language/PureScript/Lsp/Cache.hs   |  14 +--
 src/Language/PureScript/Lsp/Rebuild.hs | 127 +++++++++++++++++++------
 src/Language/PureScript/Lsp/State.hs   |  14 +--
 src/Language/PureScript/Lsp/Types.hs   |  18 +++-
 4 files changed, 123 insertions(+), 50 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index c1f5edd363..ec8f90e6d8 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE PackageImports #-}
-
 module Language.PureScript.Lsp.Cache where
 
 import Codec.Serialise (deserialise)
@@ -13,7 +11,7 @@ import Language.PureScript.Externs qualified as P
 import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Lsp.DB qualified as DB
-import Language.PureScript.Lsp.Types (LspEnvironment)
+import Language.PureScript.Lsp.Types (LspEnvironment, ExternDependency)
 import Language.PureScript.Names qualified as P
 import Protolude
 import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute, canonicalizePath)
@@ -30,14 +28,10 @@ selectAllExterns :: (MonadIO m, MonadReader LspEnvironment m) => m [ExternsFile]
 selectAllExterns = do
   DB.query_ (Query "SELECT value FROM externs") <&> fmap (deserialise . fromOnly)
 
-selectDependenciesMap :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m (Map P.ModuleName ExternsFile)
-selectDependenciesMap importedModuleNames =
-  Map.fromList . fmap (\ef -> (efModuleName ef, ef)) <$> selectDependencies importedModuleNames
 
-selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m [ExternsFile]
+selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m [ExternDependency]
 selectDependencies (P.Module _ _ _ decls _) = do
-  res <- DB.queryNamed (Query query') [":module_names" := A.encode (fmap P.runModuleName importedModuleNames)]
-  pure $ deserialise . fromOnly <$> res
+  DB.queryNamed (Query query') [":module_names" := A.encode (fmap P.runModuleName importedModuleNames)]
   where
     query' =
       unlines
@@ -56,7 +50,7 @@ selectDependencies (P.Module _ _ _ decls _) = do
           "module_names as (select distinct(module_name), level",
           "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
           "order by level desc)",
-          "select value from externs ",
+          "select value, level from externs ",
           "join module_names on externs.module_name = module_names.module_name ",
           "order by level desc, module_names.module_name desc;"
         ]
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 75f99a3619..dc555d9658 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,28 +1,32 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+-- {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, codegenTargets) where
 
+import Control.Category ((>>>))
 import Control.Concurrent.STM (TVar)
 import Control.Monad.Catch (MonadThrow (throwM))
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
 import Language.LSP.Server (MonadLsp, getConfig)
-import Language.PureScript (primEnv)
+import Language.PureScript (ExternsFile (efModuleName), primEnv)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Errors qualified as P
-import Language.PureScript.Externs (ExternsFile)
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedRebuild, setExportEnvCache, cacheDependencies, getDbConn, updateCachedModule, updateCachedModule')
-import Language.PureScript.Lsp.Types (LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile))
+import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheDependencies, cacheRebuild', cachedRebuild, getDbConn, mergeExportEnvCache, updateCachedModule, updateCachedModule')
+import Language.PureScript.Lsp.Types (ExternDependency (edExtern, edLevel), LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile, ofDependencies))
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
+import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Language.PureScript.Sugar.Names qualified as P
 import Protolude hiding (moduleName)
@@ -51,34 +55,48 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
       stVar <- asks lspStateVar
       maxCache <- getMaxFilesInCache
       cachedBuild <- cachedRebuild fp
-      let makeEnv foreigns externs =
+      let makeEnv :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
+          makeEnv foreigns externs =
             P.buildMakeActions outputDirectory filePathMap foreigns False
               & shushProgress
               & addAllIndexing conn
               & addRebuildCaching stVar maxCache externs
-      debugLsp $ "Cache found: " <> show (isJust cachedBuild)
       case cachedBuild of
-        Just (Language.PureScript.Lsp.Types.OpenFile _ _ externs env _) -> do
-          foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-          (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
-          for_ externsMb (cacheDependencies moduleName)
-          res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
-            P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-              newExtern <- P.rebuildModuleWithProvidedEnv (Just $ updateCachedModule' stVar) (makeEnv foreigns externs) exportEnv env externs m Nothing
-              updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
-              pure newExtern
-          handleRebuildResult fp pwarnings res
+        Just open -> do
+          rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m open
         Nothing -> do
-          externs <- logPerfStandard "Select depenencies" $ selectDependencies m
-          foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-          (exportEnv, _) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (pure externs) m externs
-          res <- logPerfStandard "Rebuild Module" $ liftIO $ do
-            P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-              newExtern <- P.rebuildModule' (makeEnv foreigns externs) exportEnv externs m
-              updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
-              pure newExtern
-          handleRebuildResult fp pwarnings res
+          rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
   where
+    rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m (Language.PureScript.Lsp.Types.OpenFile moduleName _ externDeps env _) = do
+      let externs = fmap edExtern externDeps
+      foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+      (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
+      for_ externsMb (cacheDependencies moduleName)
+      res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
+        P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+          newExtern <- P.rebuildModuleWithProvidedEnv (Just $ updateCachedModule' stVar) (makeEnv foreigns externDeps) exportEnv env externs m Nothing
+          updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+          pure newExtern
+      case fst res of
+        Left errs -> debugLsp $ "Rebuild error detected: " <> show errs
+        _ -> pure ()
+      case fst res of
+        Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
+          warnLsp "Module not found error detected, rebuilding without cache"
+          rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
+        _ -> handleRebuildResult fp pwarnings res
+
+    rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m = do
+      externDeps <- logPerfStandard "Select depenencies" $ selectDependencies m
+      let externs = fmap edExtern externDeps
+      foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+      exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
+      res <- logPerfStandard "Rebuild Module" $ liftIO $ do
+        P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+          newExtern <- P.rebuildModule' (makeEnv foreigns externDeps) exportEnv externs m
+          updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+          pure newExtern
+      handleRebuildResult fp pwarnings res
     handleRebuildResult fp pwarnings (result, warnings) = do
       case result of
         Left errors ->
@@ -87,24 +105,71 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
           addExternToExportEnv newExtern
           pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
 
-buildExportEnvCacheAndHandleErrors :: (MonadReader Language.PureScript.Lsp.Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) => m [ExternsFile] -> P.Module -> [ExternsFile] -> m (P.Env, Maybe [ExternsFile])
-buildExportEnvCacheAndHandleErrors refectExterns m externs = do
+couldBeFromNewImports :: P.ErrorMessage -> Bool
+couldBeFromNewImports =
+  P.unwrapErrorMessage >>> \case
+    P.ModuleNotFound {} -> True
+    P.UnknownName qName | (P.ModName _) <- P.disqualify qName -> True
+    _ -> False
+
+cachedImportsAreInActual ::
+  ( MonadReader Language.PureScript.Lsp.Types.LspEnvironment m,
+    MonadLsp ServerConfig m
+  ) =>
+  P.Module ->
+  OpenFile ->
+  m Bool
+cachedImportsAreInActual (P.Module _ _ _ decls _) (OpenFile {ofDependencies}) =
+  let cachedDirectDeps = Set.fromList $ efModuleName . edExtern <$> filter ((== 1) . edLevel) ofDependencies
+      actualDirectDeps =
+        Set.fromList $
+          decls >>= \case
+            P.ImportDeclaration _ importName _ _ -> [importName]
+            _ -> []
+   in do
+        debugLsp $ "Cached direct deps: " <> show (Set.map P.runModuleName cachedDirectDeps)
+        debugLsp $ "Actual direct deps: " <> show (Set.map P.runModuleName actualDirectDeps)
+        pure $ cachedDirectDeps `Set.isSubsetOf` actualDirectDeps
+
+buildExportEnvCacheAndHandleErrors ::
+  (MonadReader Language.PureScript.Lsp.Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
+  m [ExternDependency] ->
+  P.Module ->
+  [ExternsFile] ->
+  m (P.Env, Maybe [ExternDependency])
+buildExportEnvCacheAndHandleErrors refetchExterns m externs = do
   fromCache <- buildExportEnvCache m externs
   case fromCache of
     Left err -> do
       warnLsp $ "Error building export env cache: " <> show err
-      externs' <- refectExterns
-      envRes <- addExternsToExportEnv primEnv externs'
+      externs' <- refetchExterns
+      envRes <- addExternsToExportEnv primEnv $ edExtern <$> externs'
       case envRes of
         Left err' ->
           throwM $
             CouldNotRebuildExportEnv $
               P.prettyPrintMultipleErrors P.noColorPPEOptions err'
         Right env -> do
-          setExportEnvCache env
+          mergeExportEnvCache env
           pure (env, Just externs')
     Right env -> pure (env, Nothing)
 
+addExternsToExportEnvOrThrow ::
+  (MonadReader Language.PureScript.Lsp.Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
+  P.Env ->
+  [ExternsFile] ->
+  m P.Env
+addExternsToExportEnvOrThrow env externs = do
+  res <- addExternsToExportEnv env externs
+  case res of
+    Left err ->
+      throwM $
+        CouldNotRebuildExportEnv $
+          P.prettyPrintMultipleErrors P.noColorPPEOptions err
+    Right newEnv -> do
+      mergeExportEnvCache newEnv
+      pure newEnv
+
 data RebuildResult
   = RebuildError P.MultipleErrors
   | RebuildWarning P.MultipleErrors
@@ -122,7 +187,7 @@ shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
 shushProgress ma =
   ma {P.progress = \_ -> pure ()}
 
-addRebuildCaching :: TVar Language.PureScript.Lsp.Types.LspState -> Int -> [ExternsFile] -> P.MakeActions P.Make -> P.MakeActions P.Make
+addRebuildCaching :: TVar Language.PureScript.Lsp.Types.LspState -> Int -> [ExternDependency] -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps ma =
   ma
     { P.codegen = \prevEnv astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv astM) <* P.codegen ma prevEnv astM m docs ext
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index e0fb5eed55..ea3ff806bd 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -11,7 +11,7 @@ module Language.PureScript.Lsp.State
     clearCache,
     clearRebuildCache,
     clearExportCache,
-    setExportEnvCache,
+    mergeExportEnvCache,
     removedCachedRebuild,
     buildExportEnvCache,
     addExternToExportEnv,
@@ -40,7 +40,6 @@ import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (..))
-import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.Log (errorLsp)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
 import Language.PureScript.Lsp.Types
@@ -53,13 +52,13 @@ getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternsFile] -> P.Environment -> P.Module -> m ()
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternDependency] -> P.Environment -> P.Module -> m ()
 cacheRebuild ef deps prevEnv module' = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
   liftIO $ cacheRebuild' st maxFiles ef deps prevEnv module'
 
-cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [P.ExternsFile] -> P.Environment -> P.Module -> IO ()
+cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [ExternDependency] -> P.Environment -> P.Module -> IO ()
 cacheRebuild' st maxFiles ef deps prevEnv module' = atomically . modifyTVar st $ \x ->
   x
     { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv module') : filter ((/= fp) . fst) (openFiles x)
@@ -89,7 +88,7 @@ cachedRebuild fp = do
     st' <- readTVar st
     pure $ List.lookup fp $ openFiles st'
 
-cacheDependencies :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> [ExternsFile] -> m ()
+cacheDependencies :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> [ExternDependency] -> m ()
 cacheDependencies moduleName deps = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ modifyTVar st $ \x ->
@@ -139,8 +138,9 @@ buildExportEnvCache module' externs = do
             writeTVar st $ st' {exportEnv = newEnv}
             pure $ Right newEnv
 
-setExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Env -> m ()
-setExportEnvCache env = do
+
+mergeExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Env -> m ()
+mergeExportEnvCache env = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ modifyTVar st $ \x -> x {exportEnv = env}
 
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 76fd88b357..df1f21ec29 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -5,7 +5,7 @@ module Language.PureScript.Lsp.Types where
 import Control.Concurrent.STM (TVar, newTVarIO)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as A
-import Database.SQLite.Simple (Connection)
+import Database.SQLite.Simple (Connection, FromRow (fromRow), ToRow (toRow), field)
 import Language.LSP.Protocol.Types (Range)
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
@@ -17,6 +17,7 @@ import Protolude
 import Language.PureScript.AST qualified as P
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Lsp.LogLevel (LspLogLevel)
+import Codec.Serialise (deserialise, serialise)
 
 data LspEnvironment = LspEnvironment
   { lspDbConnectionVar :: TVar (FilePath, Connection),
@@ -51,12 +52,25 @@ data LspState = LspState
 data OpenFile = OpenFile
   { ofModuleName :: P.ModuleName,
     ofExternsFile :: P.ExternsFile,
-    ofDependencies :: [P.ExternsFile],
+    ofDependencies :: [ExternDependency],
     ofStartingEnv :: P.Environment,
     ofModule ::  P.Module
   }
   deriving (Show)
 
+  
+data ExternDependency = ExternDependency
+  { edExtern :: P.ExternsFile,
+    edLevel :: Int
+  } deriving (Show)
+
+instance FromRow ExternDependency where
+  fromRow = ExternDependency <$> (deserialise <$> field) <*> field
+
+instance ToRow ExternDependency where
+  toRow (ExternDependency ef level) = toRow (serialise ef, level)
+
+
 data CompleteItemData = CompleteItemData
   { cidPath :: FilePath,
     cidModuleName :: P.ModuleName,

From 5693acdeb7111ccc19cc879e0eaeb9c472609b09 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 18 Oct 2024 11:28:29 +0200
Subject: [PATCH 174/297] rebuild without cache if imports fail

---
 src/Language/PureScript/Lsp/Diagnostics.hs |  18 ++--
 src/Language/PureScript/Lsp/Monad.hs       |   2 +-
 src/Language/PureScript/Lsp/Rebuild.hs     | 103 +++++++++++++--------
 3 files changed, 77 insertions(+), 46 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index adcd81c5bc..4d037efe8d 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -2,23 +2,25 @@ module Language.PureScript.Lsp.Diagnostics where
 
 import Control.Lens ((^.))
 import Control.Monad.Catch (MonadThrow)
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson qualified as A
 import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
+import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server (MonadLsp)
 import Language.PureScript qualified as P
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
-import Language.PureScript.Lsp.Rebuild (rebuildFile, RebuildResult (RebuildError, RebuildWarning))
+import Language.PureScript.Lsp.Rebuild (RebuildResult (RebuildError, RebuildWarning), rebuildFile)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
-import Language.LSP.Server (MonadLsp)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 
 getFileDiagnotics ::
   ( LSP.HasParams s a1,
@@ -26,14 +28,16 @@ getFileDiagnotics ::
     LSP.HasUri a2 Uri,
     MonadLsp ServerConfig m,
     MonadThrow m,
-    MonadReader LspEnvironment m
+    MonadReader LspEnvironment m,
+    MonadBaseControl IO m
   ) =>
+  Maybe LSP.ProgressToken ->
   s ->
   m [Diagnostic]
-getFileDiagnotics msg = do
+getFileDiagnotics progressToken msg = do
   let uri :: Types.NormalizedUri
       uri = getMsgUri msg & Types.toNormalizedUri
-  res <- rebuildFile uri
+  res <- rebuildFile progressToken uri
   pure $ getResultDiagnostics res
 
 getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
@@ -46,7 +50,7 @@ getResultDiagnostics res = case res of
   RebuildError errors -> errorsToDiagnostics Types.DiagnosticSeverity_Error errors
   RebuildWarning errors -> errorsToDiagnostics Types.DiagnosticSeverity_Warning errors
 
-errorsToDiagnostics :: Types.DiagnosticSeverity ->  P.MultipleErrors -> [Types.Diagnostic]
+errorsToDiagnostics :: Types.DiagnosticSeverity -> P.MultipleErrors -> [Types.Diagnostic]
 errorsToDiagnostics severity errs =
   errorMessageDiagnostic severity <$> runMultipleErrors errs
 
diff --git a/src/Language/PureScript/Lsp/Monad.hs b/src/Language/PureScript/Lsp/Monad.hs
index b6595bb21e..846fc35ca7 100644
--- a/src/Language/PureScript/Lsp/Monad.hs
+++ b/src/Language/PureScript/Lsp/Monad.hs
@@ -34,4 +34,4 @@ instance MonadBaseControl IO HandlerM where
   restoreM = pure
 
 runHandlerM :: LanguageContextEnv ServerConfig -> LspEnvironment -> HandlerM a -> IO a
-runHandlerM env lspEnv (HandlerM a) = runLspT env $ runReaderT a lspEnv
+runHandlerM env lspEnv (HandlerM a) = runLspT env $ runReaderT a lspEnv
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index dc555d9658..146f9814df 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,18 +1,22 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# LANGUAGE NumDecimals #-}
 
 -- {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, codegenTargets) where
 
 import Control.Category ((>>>))
-import Control.Concurrent.STM (TVar)
+import Control.Concurrent.Lifted (fork, threadDelay)
+import Control.Concurrent.STM (TChan, TVar, newTChan, readTChan, writeTChan)
 import Control.Monad.Catch (MonadThrow (throwM))
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Concurrent.Async.Lifted (race)
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
-import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
-import Language.LSP.Server (MonadLsp, getConfig)
+import Language.LSP.Protocol.Types (NormalizedUri, ProgressToken, fromNormalizedUri, uriToFilePath)
+import Language.LSP.Server (MonadLsp, ProgressAmount (ProgressAmount), ProgressCancellable (Cancellable), getConfig, withProgress)
 import Language.PureScript (ExternsFile (efModuleName), primEnv)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
@@ -29,45 +33,64 @@ import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Language.PureScript.Sugar.Names qualified as P
-import Protolude hiding (moduleName)
+import Protolude hiding (moduleName, race, race_, threadDelay)
 
 rebuildFile ::
+  forall m.
   ( MonadThrow m,
     MonadReader Language.PureScript.Lsp.Types.LspEnvironment m,
+    MonadBaseControl IO m,
     MonadLsp ServerConfig m
   ) =>
+  Maybe ProgressToken ->
   NormalizedUri ->
   m RebuildResult
-rebuildFile uri = logPerfStandard "Rebuild file " do
-  fp <- case fromNormalizedUri uri & uriToFilePath of
-    Just x -> pure x
-    Nothing -> throwM $ CouldNotConvertUriToFilePath uri
-  input <- lspReadFileText uri
-  case sequence $ CST.parseFromFile fp input of
-    Left parseError ->
-      pure $ RebuildError $ CST.toMultipleErrors fp parseError
-    Right (pwarnings, m) -> do
-      updateCachedModule m
-      let moduleName = P.getModuleName m
-      let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
-      outputDirectory <- outputPath <$> getConfig
-      conn <- getDbConn
-      stVar <- asks lspStateVar
-      maxCache <- getMaxFilesInCache
-      cachedBuild <- cachedRebuild fp
-      let makeEnv :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
-          makeEnv foreigns externs =
-            P.buildMakeActions outputDirectory filePathMap foreigns False
-              & shushProgress
-              & addAllIndexing conn
-              & addRebuildCaching stVar maxCache externs
-      case cachedBuild of
-        Just open -> do
-          rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m open
-        Nothing -> do
-          rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
+rebuildFile progressToken uri =
+  logPerfStandard "Rebuild file " do
+    withProgress "Rebuilding module" progressToken Cancellable \updateProgress -> do
+      fp <- case fromNormalizedUri uri & uriToFilePath of
+        Just x -> pure x
+        Nothing -> throwM $ CouldNotConvertUriToFilePath uri
+      updateProgress $ ProgressAmount Nothing (Just "Reading file")
+      input <- lspReadFileText uri
+      case sequence $ CST.parseFromFile fp input of
+        Left parseError ->
+          pure $ RebuildError $ CST.toMultipleErrors fp parseError
+        Right (pwarnings, m) -> do
+          updateCachedModule m
+          let moduleName = P.getModuleName m
+          let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+          outputDirectory <- outputPath <$> getConfig
+          conn <- getDbConn
+          stVar <- asks lspStateVar
+          maxCache <- getMaxFilesInCache
+          cachedBuild <- cachedRebuild fp
+          chan :: TChan (Maybe P.ProgressMessage) <- liftIO . atomically $ newTChan
+          let updateProgressFromChanel :: m ()
+              updateProgressFromChanel = do
+                progressMb <- join . hush <$> race (threadDelay 3.0e9) (liftIO $ atomically $ readTChan chan)
+                for_ progressMb \pm -> do
+                  void $ updateProgress $ ProgressAmount Nothing (Just $ P.renderProgressMessage "Compiling" pm)
+                  updateProgressFromChanel
+
+          void $ fork updateProgressFromChanel
+
+          let makeEnv :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
+              makeEnv foreigns externs =
+                P.buildMakeActions outputDirectory filePathMap foreigns False
+                  & broadcastProgress chan
+                  & addAllIndexing conn
+                  & addRebuildCaching stVar maxCache externs
+          res <- case cachedBuild of
+            Just open -> do
+              rebuildFromOpenFileCache updateProgress outputDirectory fp pwarnings stVar makeEnv m open
+            Nothing -> do
+              rebuildWithoutCache updateProgress moduleName makeEnv outputDirectory fp pwarnings m
+          liftIO . atomically $ writeTChan chan Nothing
+          pure res
   where
-    rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m (Language.PureScript.Lsp.Types.OpenFile moduleName _ externDeps env _) = do
+    rebuildFromOpenFileCache updateProgress outputDirectory fp pwarnings stVar makeEnv m (Language.PureScript.Lsp.Types.OpenFile moduleName _ externDeps env _) = do
+      void $ updateProgress $ ProgressAmount Nothing (Just "Rebuilding with cache")
       let externs = fmap edExtern externDeps
       foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
       (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
@@ -83,10 +106,11 @@ rebuildFile uri = logPerfStandard "Rebuild file " do
       case fst res of
         Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
           warnLsp "Module not found error detected, rebuilding without cache"
-          rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
+          rebuildWithoutCache updateProgress moduleName makeEnv outputDirectory fp pwarnings m
         _ -> handleRebuildResult fp pwarnings res
 
-    rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m = do
+    rebuildWithoutCache updateProgress moduleName makeEnv outputDirectory fp pwarnings m = do
+      void $ updateProgress $ ProgressAmount Nothing (Just "Rebuilding without cache")
       externDeps <- logPerfStandard "Select depenencies" $ selectDependencies m
       let externs = fmap edExtern externDeps
       foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
@@ -183,9 +207,12 @@ codegenTargets :: Set P.CodegenTarget
 codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
 -- | Shuts the compiler up about progress messages
-shushProgress :: (Monad m) => P.MakeActions m -> P.MakeActions m
-shushProgress ma =
-  ma {P.progress = \_ -> pure ()}
+-- broadcastProgress :: (MonadLsp ServerConfig m) => TChan P.ProgressMessage -> P.MakeActions P.Make -> m (P.MakeActions P.Make)
+broadcastProgress :: (MonadIO m) => TChan (Maybe P.ProgressMessage) -> P.MakeActions m -> P.MakeActions m
+broadcastProgress chan ma = do
+  ma
+    { P.progress = liftIO . atomically . writeTChan chan . Just
+    }
 
 addRebuildCaching :: TVar Language.PureScript.Lsp.Types.LspState -> Int -> [ExternDependency] -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps ma =

From d502cd5194698ac5f283f44f860af8bf8ac2175b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 15:09:37 +0200
Subject: [PATCH 175/297] adds constructors to indexing

---
 src/Language/PureScript/Lsp/Diagnostics.hs    |  10 +-
 src/Language/PureScript/Lsp/Handlers.hs       |  11 +-
 src/Language/PureScript/Lsp/Handlers/Build.hs |  54 +++---
 .../PureScript/Lsp/Handlers/Completion.hs     |   4 +-
 .../PureScript/Lsp/Handlers/Diagnostic.hs     |   2 +-
 src/Language/PureScript/Lsp/Handlers/Index.hs |  11 +-
 src/Language/PureScript/Lsp/Rebuild.hs        |  96 +++++------
 src/Language/PureScript/Make/Index.hs         | 162 +++++++++++-------
 8 files changed, 189 insertions(+), 161 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 4d037efe8d..a76728e271 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -2,13 +2,11 @@ module Language.PureScript.Lsp.Diagnostics where
 
 import Control.Lens ((^.))
 import Control.Monad.Catch (MonadThrow)
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson qualified as A
 import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
-import Language.LSP.Protocol.Types qualified as LSP
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript qualified as P
@@ -28,16 +26,14 @@ getFileDiagnotics ::
     LSP.HasUri a2 Uri,
     MonadLsp ServerConfig m,
     MonadThrow m,
-    MonadReader LspEnvironment m,
-    MonadBaseControl IO m
+    MonadReader LspEnvironment m
   ) =>
-  Maybe LSP.ProgressToken ->
   s ->
   m [Diagnostic]
-getFileDiagnotics progressToken msg = do
+getFileDiagnotics msg = do
   let uri :: Types.NormalizedUri
       uri = getMsgUri msg & Types.toNormalizedUri
-  res <- rebuildFile progressToken uri
+  res <- rebuildFile uri
   pure $ getResultDiagnostics res
 
 getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 513e362c8b..a3ba11fc77 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -7,6 +7,7 @@
 module Language.PureScript.Lsp.Handlers where
 
 import Control.Lens ((^.))
+import Data.Aeson qualified as A
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types (Uri)
@@ -20,13 +21,12 @@ import Language.PureScript.Lsp.Handlers.Definition (definitionHandler)
 import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutputHandler)
 import Language.PureScript.Lsp.Handlers.Diagnostic (diagnosticAndCodeActionHandlers)
 import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
+import Language.PureScript.Lsp.Handlers.Index (indexHandler)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (setTraceValue)
-import Language.PureScript.Lsp.State (cancelRequest, removedCachedRebuild, clearCache, clearExportCache, clearRebuildCache, getDbConn)
+import Language.PureScript.Lsp.State (cancelRequest, clearCache, clearExportCache, clearRebuildCache, getDbConn, removedCachedRebuild)
+import Language.PureScript.Make.Index (dropTables, initDb)
 import Protolude hiding (to)
-import Data.Aeson qualified as A
-import Language.PureScript.Lsp.Handlers.Index (indexHandler)
-import Language.PureScript.Make.Index (initDb, dropTables)
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -66,7 +66,7 @@ handlers =
             setTraceValue $ msg ^. LSP.params . LSP.value, -- probably no need to do this
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
             let reqId = msg ^. LSP.params . LSP.id
-            cancelRequest reqId, 
+            cancelRequest reqId,
           Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache") $ \_req res -> do
             clearCache
             res $ Right A.Null,
@@ -84,6 +84,7 @@ handlers =
             conn <- getDbConn
             liftIO $ dropTables conn
             res $ Right A.Null
+
         ]
 
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index 46d110218c..bd26ce63e7 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -16,31 +16,41 @@ import Language.PureScript.Make.Index (initDb)
 import Protolude hiding (to)
 import System.IO.UTF8 (readUTF8FilesT)
 import Language.PureScript.Lsp.State (clearCache, getDbConn)
-import Language.LSP.Server (getConfig)
+import Language.LSP.Server (getConfig, withIndefiniteProgress, ProgressCancellable (Cancellable))
 import Language.PureScript.Lsp.ServerConfig (ServerConfig(outputPath))
+import Language.LSP.Protocol.Lens qualified as LSP
+import Control.Lens ((^.))
 
 buildHandler :: Server.Handlers HandlerM
 buildHandler =
-  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
-    diags <- buildForLsp
+  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \req res -> do
+    let progressToken = cast $ req ^. LSP.id
+    diags <- buildForLsp progressToken
     res $ Right $ A.toJSON diags
 
-buildForLsp :: HandlerM [Types.Diagnostic]
-buildForLsp = do
-  clearCache
-  outDir <-  outputPath <$> getConfig
-  conn <- getDbConn
-  liftIO $ initDb conn
-  input <- updateAvailableSrcs
-  moduleFiles <- liftIO $ readUTF8FilesT input
-  (result, warnings) <-
-    liftIO $
-      compile
-        (P.Options False False codegenTargets)
-        moduleFiles
-        conn
-        outDir
-        False
-  pure $
-    (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
-      <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
+    where 
+
+-- Either get progress to work or remove it
+buildForLsp :: Maybe Types.ProgressToken -> HandlerM [Types.Diagnostic]
+buildForLsp  id = do
+  withIndefiniteProgress "Rebuilding all files" id Cancellable $ \updateProgress -> do 
+    clearCache
+    outDir <-  outputPath <$> getConfig
+    conn <- getDbConn
+    liftIO $ initDb conn
+    updateProgress "Updating available sources"
+    input <- updateAvailableSrcs
+    updateProgress "Reading module files"
+    moduleFiles <- liftIO $ readUTF8FilesT input
+    updateProgress "Compiling"
+    (result, warnings) <-
+      liftIO $
+        compile
+          (P.Options False False codegenTargets)
+          moduleFiles
+          conn
+          outDir
+          False
+    pure $
+      (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
+        <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 434f541c5e..27b4115178 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -17,7 +17,7 @@ import Language.PureScript.Ide.Imports (Import (..))
 import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
-import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.Log (logPerfStandard, debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
@@ -48,9 +48,11 @@ completionAndResolveHandlers =
           forLsp vfMb \vf -> do
             let (range, word) = getWordAt (VFS._file_text vf) pos
             mNameMb <- parseModuleNameFromFile uri
+            debugLsp $ "word: " <> show word
             forLsp mNameMb \mName -> do
               let withQualifier = getIdentModuleQualifier word
                   wordWithoutQual = maybe word snd withQualifier
+              debugLsp $ "withQualifier: " <> show withQualifier
               limit <- getMaxCompletions
               matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
               decls <- logPerfStandard "get completion declarations" case (matchingImport, withQualifier) of
diff --git a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
index cd6ed73cad..a976b33a4c 100644
--- a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
@@ -24,7 +24,7 @@ diagnosticAndCodeActionHandlers =
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         let params = req ^. LSP.params
             diags = params ^. LSP.context . LSP.diagnostics
-            uri = getMsgUri req            
+            uri = getMsgUri req
         res $
           Right $
             Types.InL $
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 586f138b58..67859e0087 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -18,12 +18,14 @@ import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
 import Language.PureScript.Lsp.State (getDbConn)
 import Language.PureScript.Lsp.Types (LspEnvironment)
-import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexAstModuleFromExtern, indexExtern, initDb)
+import Language.PureScript.Make.Index (indexAstDeclFromExternDecl, indexAstModuleFromExtern, indexExtern, initDb, getExportedNames)
 import Language.PureScript.Make.Monad (readExternsFile)
 import Protolude hiding (to)
 import System.Directory (doesFileExist, getDirectoryContents)
 import System.FilePath ((</>))
 import Control.Monad.Trans.Control (MonadBaseControl)
+import Language.LSP.Protocol.Lens qualified as LSP
+import Control.Lens ((^.))
 
 indexHandler :: Server.Handlers HandlerM
 indexHandler =
@@ -34,11 +36,12 @@ indexHandler =
         externs <- logPerfStandard "findAvailableExterns" findAvailableExterns
         logPerfStandard "insert externs" $ forConcurrently_ externs indexExternAndDecls
         res $ Right A.Null,
-      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \_req res -> do
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \req res -> do
+        let progressToken = cast $ req ^. LSP.id
         conn <- getDbConn
         liftIO $ initDb conn
         deleteOutput
-        diags <- buildForLsp
+        diags <- buildForLsp progressToken
         res $ Right $ A.toJSON diags
     ]
   where
@@ -47,7 +50,7 @@ indexHandler =
       conn <- getDbConn
       indexExtern conn ef
       indexAstModuleFromExtern conn ef
-      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn ef)
+      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn ef (getExportedNames ef))
 
 -- \| Finds all the externs inside the output folder and returns the
 -- corresponding module names
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 146f9814df..fe7dbaa00e 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,22 +1,20 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 {-# LANGUAGE NumDecimals #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 -- {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, codegenTargets) where
 
 import Control.Category ((>>>))
-import Control.Concurrent.Lifted (fork, threadDelay)
-import Control.Concurrent.STM (TChan, TVar, newTChan, readTChan, writeTChan)
+import Control.Concurrent.STM (TChan, TVar, writeTChan)
 import Control.Monad.Catch (MonadThrow (throwM))
-import Control.Monad.Trans.Control (MonadBaseControl)
-import Control.Concurrent.Async.Lifted (race)
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
-import Language.LSP.Protocol.Types (NormalizedUri, ProgressToken, fromNormalizedUri, uriToFilePath)
-import Language.LSP.Server (MonadLsp, ProgressAmount (ProgressAmount), ProgressCancellable (Cancellable), getConfig, withProgress)
+import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
+import Language.LSP.Server (MonadLsp, getConfig)
 import Language.PureScript (ExternsFile (efModuleName), primEnv)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
@@ -39,58 +37,43 @@ rebuildFile ::
   forall m.
   ( MonadThrow m,
     MonadReader Language.PureScript.Lsp.Types.LspEnvironment m,
-    MonadBaseControl IO m,
     MonadLsp ServerConfig m
   ) =>
-  Maybe ProgressToken ->
   NormalizedUri ->
   m RebuildResult
-rebuildFile progressToken uri =
-  logPerfStandard "Rebuild file " do
-    withProgress "Rebuilding module" progressToken Cancellable \updateProgress -> do
-      fp <- case fromNormalizedUri uri & uriToFilePath of
-        Just x -> pure x
-        Nothing -> throwM $ CouldNotConvertUriToFilePath uri
-      updateProgress $ ProgressAmount Nothing (Just "Reading file")
-      input <- lspReadFileText uri
-      case sequence $ CST.parseFromFile fp input of
-        Left parseError ->
-          pure $ RebuildError $ CST.toMultipleErrors fp parseError
-        Right (pwarnings, m) -> do
-          updateCachedModule m
-          let moduleName = P.getModuleName m
-          let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
-          outputDirectory <- outputPath <$> getConfig
-          conn <- getDbConn
-          stVar <- asks lspStateVar
-          maxCache <- getMaxFilesInCache
-          cachedBuild <- cachedRebuild fp
-          chan :: TChan (Maybe P.ProgressMessage) <- liftIO . atomically $ newTChan
-          let updateProgressFromChanel :: m ()
-              updateProgressFromChanel = do
-                progressMb <- join . hush <$> race (threadDelay 3.0e9) (liftIO $ atomically $ readTChan chan)
-                for_ progressMb \pm -> do
-                  void $ updateProgress $ ProgressAmount Nothing (Just $ P.renderProgressMessage "Compiling" pm)
-                  updateProgressFromChanel
-
-          void $ fork updateProgressFromChanel
-
-          let makeEnv :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
-              makeEnv foreigns externs =
-                P.buildMakeActions outputDirectory filePathMap foreigns False
-                  & broadcastProgress chan
-                  & addAllIndexing conn
-                  & addRebuildCaching stVar maxCache externs
-          res <- case cachedBuild of
-            Just open -> do
-              rebuildFromOpenFileCache updateProgress outputDirectory fp pwarnings stVar makeEnv m open
-            Nothing -> do
-              rebuildWithoutCache updateProgress moduleName makeEnv outputDirectory fp pwarnings m
-          liftIO . atomically $ writeTChan chan Nothing
-          pure res
+rebuildFile uri =
+  logPerfStandard "Rebuild module" do
+    fp <- case fromNormalizedUri uri & uriToFilePath of
+      Just x -> pure x
+      Nothing -> throwM $ CouldNotConvertUriToFilePath uri
+    input <- lspReadFileText uri
+    case sequence $ CST.parseFromFile fp input of
+      Left parseError ->
+        pure $ RebuildError $ CST.toMultipleErrors fp parseError
+      Right (pwarnings, m) -> do
+        updateCachedModule m
+        let moduleName = P.getModuleName m
+        let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+        outputDirectory <- outputPath <$> getConfig
+        conn <- getDbConn
+        stVar <- asks lspStateVar
+        maxCache <- getMaxFilesInCache
+        cachedBuild <- cachedRebuild fp
+        let makeEnv :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
+            makeEnv foreigns externs =
+              P.buildMakeActions outputDirectory filePathMap foreigns False
+                -- & broadcastProgress chan
+                & addAllIndexing conn
+                & addRebuildCaching stVar maxCache externs
+        case cachedBuild of
+          Just open -> do
+            rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m open
+          Nothing -> do
+            rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
   where
-    rebuildFromOpenFileCache updateProgress outputDirectory fp pwarnings stVar makeEnv m (Language.PureScript.Lsp.Types.OpenFile moduleName _ externDeps env _) = do
-      void $ updateProgress $ ProgressAmount Nothing (Just "Rebuilding with cache")
+    -- liftIO . atomically $ writeTChan chan Nothing
+
+    rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m (Language.PureScript.Lsp.Types.OpenFile moduleName _ externDeps env _) = do
       let externs = fmap edExtern externDeps
       foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
       (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
@@ -106,11 +89,10 @@ rebuildFile progressToken uri =
       case fst res of
         Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
           warnLsp "Module not found error detected, rebuilding without cache"
-          rebuildWithoutCache updateProgress moduleName makeEnv outputDirectory fp pwarnings m
+          rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
         _ -> handleRebuildResult fp pwarnings res
 
-    rebuildWithoutCache updateProgress moduleName makeEnv outputDirectory fp pwarnings m = do
-      void $ updateProgress $ ProgressAmount Nothing (Just "Rebuilding without cache")
+    rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m = do
       externDeps <- logPerfStandard "Select depenencies" $ selectDependencies m
       let externs = fmap edExtern externDeps
       foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 1e5cfd1661..8e4ae44e6b 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -9,12 +9,14 @@ import Data.Text qualified as T
 import Database.SQLite.Simple (Connection, NamedParam ((:=)))
 import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
+import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.AST.Declarations qualified as E
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
-import Language.PureScript.Lsp.NameType (externDeclNameType, lspNameType)
+import Language.PureScript.Lsp.NameType (externDeclNameType, lspNameType, LspNameType (DctorNameType))
 import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printEfDeclType, printName)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan)
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Names qualified as P
@@ -28,11 +30,11 @@ addAllIndexing conn ma =
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \prevEnv astM m docs ext -> lift (indexAstModule conn astM ext) <* P.codegen ma prevEnv astM m docs ext
+    { P.codegen = \prevEnv astM m docs ext -> lift (indexAstModule conn astM ext (getExportedNames ext)) <* P.codegen ma prevEnv astM m docs ext
     }
 
-indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> m ()
-indexAstModule conn m@(P.Module _ss _comments moduleName' decls _exportRefs) extern = liftIO do
+indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> Set P.Name -> m ()
+indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) extern exportedNames = liftIO do
   path <- makeAbsolute externPath
   SQL.executeNamed
     conn
@@ -42,38 +44,68 @@ indexAstModule conn m@(P.Module _ss _comments moduleName' decls _exportRefs) ext
     ]
   SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName moduleName')
 
-  let exports = Set.fromList $ P.exportedDeclarations m
-
   forM_ decls \decl -> do
     let (ss, _) = P.declSourceAnn decl
         start = P.spanStart ss
         end = P.spanEnd ss
-        name = P.declName decl
-        nameType = name <&> lspNameType
+        nameMb = P.declName decl
+        nameType = nameMb <&> lspNameType
         printedType = printDeclarationType decl
-    SQL.executeNamed
-      conn
-      ( SQL.Query
-          "INSERT INTO ast_declarations \
-          \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
-          \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
-      )
-      [ ":module_name" := P.runModuleName moduleName',
-        ":name" := printName <$> name,
-        ":printed_type" := printedType,
-        ":name_type" := nameType,
-        ":start_line" := P.sourcePosLine start,
-        ":end_line" := P.sourcePosLine end,
-        ":start_col" := P.sourcePosColumn start,
-        ":end_col" := P.sourcePosColumn end,
-        ":lines" := P.sourcePosLine end - P.sourcePosLine start,
-        ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
-        ":exported" := Set.member decl exports,
-        ":generated" := "$Dict" `T.isInfixOf` printedType
-      ]
+    for_ nameMb \name -> do
+      let exported = Set.member name exportedNames
+      SQL.executeNamed
+        conn
+        ( SQL.Query
+            "INSERT INTO ast_declarations \
+            \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+            \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
+        )
+        [ ":module_name" := P.runModuleName moduleName',
+          ":name" := printName name,
+          ":printed_type" := printedType,
+          ":name_type" := nameType,
+          ":start_line" := P.sourcePosLine start,
+          ":end_line" := P.sourcePosLine end,
+          ":start_col" := P.sourcePosColumn start,
+          ":end_col" := P.sourcePosColumn end,
+          ":lines" := P.sourcePosLine end - P.sourcePosLine start,
+          ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
+          ":exported" := exported,
+          ":generated" := "$Dict" `T.isInfixOf` printedType
+        ]
+
+      when exported $ do
+        for_ (declCtrs decl) \ctr ->
+          let (ss', _) = P.dataCtorAnn ctr
+              start' = P.spanStart ss'
+              end' = P.spanEnd ss'
+           in SQL.executeNamed
+                conn
+                ( SQL.Query
+                    "INSERT INTO ast_declarations \
+                    \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+                    \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
+                )
+                [ ":module_name" := P.runModuleName moduleName',
+                  ":name" := P.runProperName (P.dataCtorName ctr),
+                  ":printed_type" := printName name,
+                  ":name_type" := DctorNameType,
+                  ":start_line" := P.sourcePosLine start',
+                  ":end_line" := P.sourcePosLine end',
+                  ":start_col" := P.sourcePosColumn start',
+                  ":end_col" := P.sourcePosColumn end',
+                  ":lines" := P.sourcePosLine end - P.sourcePosLine start',
+                  ":cols" := P.sourcePosColumn end - P.sourcePosColumn start',
+                  ":exported" := True,
+                  ":generated" := "$Dict" `T.isInfixOf` printedType
+                ]
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
+    declCtrs = \case
+      P.DataDeclaration _ _ _ _ ctors -> ctors
+      _ -> []
+
 indexAstModuleFromExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()
 indexAstModuleFromExtern conn extern = liftIO do
   path <- makeAbsolute externPath
@@ -86,8 +118,8 @@ indexAstModuleFromExtern conn extern = liftIO do
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
-indexAstDeclFromExternDecl :: (MonadIO m) => Connection ->  ExternsFile -> P.ExternsDeclaration -> m ()
-indexAstDeclFromExternDecl conn extern externDecl = liftIO do
+indexAstDeclFromExternDecl :: (MonadLsp ServerConfig m) => Connection -> ExternsFile -> Set P.Name -> P.ExternsDeclaration -> m ()
+indexAstDeclFromExternDecl conn extern exportedNames externDecl = do
   let ss = case externDecl of
         P.EDDataConstructor {..}
           | Just typeCtr <- find (isTypeOfName edDataCtorTypeCtor) moduleDecls -> efDeclSourceSpan typeCtr
@@ -96,26 +128,28 @@ indexAstDeclFromExternDecl conn extern externDecl = liftIO do
       end = P.spanEnd ss
       printedType :: Text
       printedType = printEfDeclType externDecl
-  SQL.executeNamed
-    conn
-    ( SQL.Query
-        "INSERT INTO ast_declarations \
-        \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
-        \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
-    )
-    [ ":module_name" := P.runModuleName moduleName',
-      ":name" := printEfDeclName externDecl,
-      ":printed_type" := printedType,
-      ":name_type" := externDeclNameType externDecl,
-      ":start_line" := P.sourcePosLine start,
-      ":end_line" := P.sourcePosLine end,
-      ":start_col" := P.sourcePosColumn start,
-      ":end_col" := P.sourcePosColumn end,
-      ":lines" := P.sourcePosLine end - P.sourcePosLine start,
-      ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
-      ":exported" := Set.member declName exportedNames,
-      ":generated" := "$Dict" `T.isInfixOf` printedType
-    ]
+
+  liftIO $
+    SQL.executeNamed
+      conn
+      ( SQL.Query
+          "INSERT INTO ast_declarations \
+          \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+          \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
+      )
+      [ ":module_name" := P.runModuleName moduleName',
+        ":name" := printEfDeclName externDecl,
+        ":printed_type" := printedType,
+        ":name_type" := externDeclNameType externDecl,
+        ":start_line" := P.sourcePosLine start,
+        ":end_line" := P.sourcePosLine end,
+        ":start_col" := P.sourcePosColumn start,
+        ":end_col" := P.sourcePosColumn end,
+        ":lines" := P.sourcePosLine end - P.sourcePosLine start,
+        ":cols" := P.sourcePosColumn end - P.sourcePosColumn start,
+        ":exported" := Set.member declName exportedNames,
+        ":generated" := "$Dict" `T.isInfixOf` printedType
+      ]
   where
     isTypeOfName :: P.ProperName 'P.TypeName -> P.ExternsDeclaration -> Bool
     isTypeOfName name P.EDType {..} = edTypeName == name
@@ -125,20 +159,7 @@ indexAstDeclFromExternDecl conn extern externDecl = liftIO do
 
     moduleDecls = P.efDeclarations extern
 
-    exportedNames :: Set P.Name
-    exportedNames =
-      Set.fromList $
-        P.efExports extern >>= \case
-          E.TypeClassRef _ name -> [P.TyClassName name]
-          E.TypeRef _ name _ -> [P.TyName name]
-          E.ValueRef _ name -> [P.IdentName name]
-          E.TypeOpRef _ name -> [P.TyOpName name]
-          E.ValueOpRef _ name -> [P.ValOpName name]
-          E.TypeInstanceRef _ name _ -> [P.IdentName name]
-          E.ModuleRef _ name -> [P.ModName name]
-          E.ReExportRef _ _ _ -> []
-
-    declName :: P.Name 
+    declName :: P.Name
     declName = case externDecl of
       P.EDType {..} -> P.TyName edTypeName
       P.EDTypeSynonym {..} -> P.TyName edTypeSynonymName
@@ -147,6 +168,19 @@ indexAstDeclFromExternDecl conn extern externDecl = liftIO do
       P.EDClass {..} -> P.TyClassName edClassName
       P.EDInstance {..} -> P.IdentName edInstanceName
 
+getExportedNames :: ExternsFile -> Set P.Name
+getExportedNames extern =
+  Set.fromList $
+    P.efExports extern >>= \case
+      E.TypeClassRef _ name -> [P.TyClassName name]
+      E.TypeRef _ name ctrs -> [P.TyName name] <> fmap P.DctorName (fold ctrs)
+      E.ValueRef _ name -> [P.IdentName name]
+      E.TypeOpRef _ name -> [P.TyOpName name]
+      E.ValueOpRef _ name -> [P.ValOpName name]
+      E.TypeInstanceRef _ name _ -> [P.IdentName name]
+      E.ModuleRef _ name -> [P.ModName name]
+      E.ReExportRef _ _ _ -> []
+
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma

From 41e06b2529e89cc4de39305a4211af18132449a2 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 16:13:10 +0200
Subject: [PATCH 176/297] ctr imports working

---
 src/Language/PureScript/Lsp/Cache/Query.hs    | 21 ++++++-----
 .../PureScript/Lsp/Handlers/Completion.hs     |  6 ++--
 src/Language/PureScript/Lsp/Imports.hs        | 35 ++++++++++++-------
 src/Language/PureScript/Lsp/NameType.hs       |  3 +-
 src/Language/PureScript/Lsp/Types.hs          |  2 ++
 5 files changed, 41 insertions(+), 26 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index ee2d30d59b..85a883b6c3 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -18,14 +18,16 @@ import Protolude
 ------------ AST -------------------------------------------------------------------------------------------------------
 ------------------------------------------------------------------------------------------------------------------------
 
-getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> m (Maybe (Text, Maybe LspNameType))
-getAstDeclarationInModule moduleName' name = do
+getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> Maybe LspNameType -> m (Maybe (Text, Text))
+getAstDeclarationInModule moduleName' name nameType = do
   decls <-
     DB.queryNamed
-      "SELECT name, name_type FROM ast_declarations WHERE module_name = :module_name AND name = :name"
+      "SELECT name, printed_type FROM ast_declarations WHERE module_name = :module_name AND name = :name AND name_type IS :name_type"
       [ ":module_name" := P.runModuleName moduleName',
-        ":name" := name
+        ":name" := name,
+        ":name_type" := nameType
       ]
+
   pure $ listToMaybe decls
 
 getAstDeclarationLocationInModule :: (MonadIO m, MonadReader LspEnvironment m) => Maybe LspNameType -> P.ModuleName -> Text -> m [P.SourceSpan]
@@ -73,7 +75,7 @@ getAstDeclarationsStartingWith moduleName' prefix = do
     ( SQL.Query $
         "SELECT ast_declarations.name, "
           <> printedTypeTruncated typeLen
-          <> "ast_declarations.module_name FROM ast_declarations \
+          <> "ast_declarations.module_name, ast_declarations.name_type FROM ast_declarations \
              \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
@@ -103,7 +105,7 @@ getAstDeclarationsStartingWithAndSearchingModuleNames moduleName' moduleNameCont
     ( SQL.Query $
         "SELECT ast_declarations.name, "
           <> printedTypeTruncated typeLen
-          <> "ast_declarations.module_name FROM ast_declarations \
+          <> "ast_declarations.module_name, ast_declarations.name_type FROM ast_declarations \
              \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE (ast_declarations.module_name = :module_name OR ast_declarations.exported) \
@@ -134,7 +136,7 @@ getAstDeclarationsStartingWithOnlyInModule moduleName' prefix = do
     ( SQL.Query $
         "SELECT ast_declarations.name, "
           <> printedTypeTruncated typeLen
-          <> "ast_declarations.module_name FROM ast_declarations \
+          <> "ast_declarations.module_name, ast_declarations.name_type FROM ast_declarations \
              \INNER JOIN ast_modules on ast_declarations.module_name = ast_modules.module_name \
              \INNER JOIN available_srcs on ast_modules.path = available_srcs.path \
              \WHERE ast_declarations.module_name = :module_name \
@@ -167,9 +169,10 @@ printedTypeTruncated typeLen =
 data CompletionResult = CompletionResult
   { crName :: Text,
     crType :: Text,
-    crModule :: P.ModuleName
+    crModule :: P.ModuleName,
+    crNameType :: Maybe LspNameType
   }
   deriving (Show, Generic)
 
 instance SQL.FromRow CompletionResult where
-  fromRow = CompletionResult <$> SQL.field <*> SQL.field <*> (P.ModuleName <$> SQL.field)
\ No newline at end of file
+  fromRow = CompletionResult <$> SQL.field <*> SQL.field <*> (P.ModuleName <$> SQL.field) <*> SQL.field 
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 27b4115178..708c096a57 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -14,7 +14,7 @@ import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.Ide.Imports (Import (..))
-import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
+import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType, crNameType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
 import Language.PureScript.Lsp.Log (logPerfStandard, debugLsp)
@@ -93,14 +93,14 @@ completionAndResolveHandlers =
                                   _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
                                   _commitCharacters = Nothing, --  Maybe [Text]
                                   _command = Nothing, --  Maybe Types.Command
-                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label word range
+                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label (crNameType cr) word range
                                 },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         let completionItem = req ^. LSP.params
             result = completionItem ^. LSP.data_ & decodeCompleteItemData
 
         case result of
-          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _ _)) -> do
+          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _ _ _)) -> do
             docsMb <- readDeclarationDocsAsMarkdown declModule label
             withImports <- addImportToTextEdit completionItem cid
             let addDocs :: Types.CompletionItem -> Types.CompletionItem
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index c68895a754..45abdf2fbb 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -8,19 +8,21 @@ where
 
 import Control.Lens (set)
 import Control.Monad.Catch (MonadThrow)
+import Data.List (nub)
 import Data.Maybe as Maybe
 import Data.Text qualified as T
 import Data.Text.Utf16.Rope.Mixed qualified as Rope
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Types as LSP
 import Language.LSP.Server (MonadLsp)
+import Language.PureScript (DeclarationRef)
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.CST.Monad qualified as CSTM
 import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
-import Language.PureScript.Lsp.Log (errorLsp, warnLsp)
+import Language.PureScript.Lsp.Log (debugLsp, errorLsp, warnLsp)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ReadFile (lspReadFileRope)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
@@ -45,20 +47,22 @@ addImportToTextEdit completionItem completeItemData = do
   pure $ set LSP.additionalTextEdits importEdits completionItem
 
 getImportEdits :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit])
-getImportEdits (CompleteItemData path moduleName' importedModuleName name word (Range wordStart _)) = do
+getImportEdits cid@(CompleteItemData path moduleName' importedModuleName name nameType word (Range wordStart _)) = do
+  debugLsp $ "CompletionItemData: " <> show cid
+  debugLsp $ "wordQualifierMb: " <> show (getIdentModuleQualifier word)
   parseRes <- parseImportsFromFile (filePathToNormalizedUri path)
   case parseRes of
     Left err -> do
       errorLsp $ "In " <> T.pack path <> " failed to parse imports from file: " <> err
       pure Nothing
     Right (_mn, before, imports, _after) -> do
-      declMb <- getAstDeclarationInModule importedModuleName name
+      declMb <- getAstDeclarationInModule importedModuleName name nameType
       case declMb of
         Nothing -> do
-          errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> name
+          errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> show (importedModuleName, name, nameType)
           pure Nothing
-        Just (declName, nameType) -> do
-          case addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName nameType imports of
+        Just (declName, declType) -> do
+          case addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports of
             Nothing -> pure Nothing
             Just (newImports, moduleQualifier) -> do
               let importEdits = importsToTextEdit before newImports
@@ -87,16 +91,13 @@ parseRest p =
     . CST.runTokenParser (p <* CSTM.token CST.TokEof)
     . CST.lexTopLevel
 
-addDeclarationToImports :: P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> Text -> Maybe LspNameType -> [Import] -> Maybe ([Import], Maybe P.ModuleName)
-addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName nameType imports
+addDeclarationToImports :: P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> Text -> Text -> Maybe LspNameType -> [Import] -> Maybe ([Import], Maybe P.ModuleName)
+addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports
   | importingSelf = Nothing
   | Just existing <- alreadyImportedModuleMb,
     Just ref <- refMb = case existing of
       Import _ (P.Explicit refs') mName
-        | wordQualifierMb == mName ->
-            if ref `notElem` refs'
-              then Just (Import importedModuleName (P.Explicit (refs' <> [ref])) Nothing : withoutOldImport, mName)
-              else Nothing
+        | wordQualifierMb == mName -> Just (Import importedModuleName (P.Explicit (insertImportRef ref refs')) Nothing : withoutOldImport, mName)
         | otherwise -> Just (imports, mName)
       Import _ P.Implicit mName -> Just (imports, mName)
       Import _ (P.Hiding refs') mName
@@ -122,7 +123,7 @@ addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName
         ValOpNameType -> Just $ P.ValueOpRef nullSourceSpan (P.OpName declName)
         TyNameType -> Just $ P.TypeRef nullSourceSpan (P.ProperName declName) Nothing
         TyOpNameType -> Just $ P.TypeOpRef nullSourceSpan (P.OpName declName)
-        DctorNameType -> Nothing
+        DctorNameType -> Just $ P.TypeRef nullSourceSpan (P.ProperName declType) (Just [P.ProperName declName])
         TyClassNameType -> Just $ P.TypeClassRef nullSourceSpan (P.ProperName declName)
         ModNameType -> Just $ P.ModuleRef nullSourceSpan (P.ModuleName declName)
 
@@ -131,6 +132,14 @@ addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName
 
     importingSelf = moduleName' == importedModuleName
 
+insertImportRef :: DeclarationRef -> [DeclarationRef] -> [DeclarationRef]
+insertImportRef (P.TypeRef _ ty ctrs) ((P.TypeRef ss ty' ctrs') : refs)
+  | ty == ty' = P.TypeRef ss ty (nub <$> liftA2 (<>) ctrs ctrs') : refs
+insertImportRef ref (ref' : refs)
+  | ref == ref' = refs
+  | otherwise = ref' : insertImportRef ref refs
+insertImportRef ref [] = [ref]
+
 importsToTextEdit :: [Text] -> [Import] -> TextEdit
 importsToTextEdit before imports =
   TextEdit
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index 2e7831875f..a219a7c5bb 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -7,6 +7,7 @@ import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.PureScript.Names
 import Protolude
 import Language.PureScript.Externs (ExternsDeclaration(..))
+import Data.Aeson qualified as A
 
 data LspNameType
   = IdentNameType
@@ -16,7 +17,7 @@ data LspNameType
   | DctorNameType
   | TyClassNameType
   | ModNameType
-  deriving (Show, Read, Eq, Generic)
+  deriving (Show, Read, Eq, Generic, A.ToJSON, A.FromJSON)
 
 instance ToField LspNameType where
   toField = toField . (show :: LspNameType -> Text)
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index df1f21ec29..b9abe38439 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -18,6 +18,7 @@ import Language.PureScript.AST qualified as P
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Lsp.LogLevel (LspLogLevel)
 import Codec.Serialise (deserialise, serialise)
+import Language.PureScript.Lsp.NameType (LspNameType)
 
 data LspEnvironment = LspEnvironment
   { lspDbConnectionVar :: TVar (FilePath, Connection),
@@ -76,6 +77,7 @@ data CompleteItemData = CompleteItemData
     cidModuleName :: P.ModuleName,
     cidImportedModuleName :: P.ModuleName,
     cidName :: Text,
+    cidNameType :: Maybe LspNameType,
     cidWord :: Text,
     wordRange :: Range
   }

From 8ed7ed35c5d562737f6a1922fb8795c1d5f79ce6 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 16:19:41 +0200
Subject: [PATCH 177/297] dont loose import on equal

---
 src/Language/PureScript/Lsp/Imports.hs | 16 ++++++++++++++--
 1 file changed, 14 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 45abdf2fbb..d9ae25b618 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -62,6 +62,7 @@ getImportEdits cid@(CompleteItemData path moduleName' importedModuleName name na
           errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> show (importedModuleName, name, nameType)
           pure Nothing
         Just (declName, declType) -> do
+          debugLsp $ "Got declaration: " <> show (declName, declType)
           case addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports of
             Nothing -> pure Nothing
             Just (newImports, moduleQualifier) -> do
@@ -91,7 +92,18 @@ parseRest p =
     . CST.runTokenParser (p <* CSTM.token CST.TokEof)
     . CST.lexTopLevel
 
-addDeclarationToImports :: P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> Text -> Text -> Maybe LspNameType -> [Import] -> Maybe ([Import], Maybe P.ModuleName)
+addDeclarationToImports ::
+  P.ModuleName ->
+  P.ModuleName ->
+  Maybe P.ModuleName ->
+  Text ->
+  Text ->
+  Maybe LspNameType ->
+  [Import] ->
+  Maybe
+    ( [Import],
+      Maybe P.ModuleName
+    )
 addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports
   | importingSelf = Nothing
   | Just existing <- alreadyImportedModuleMb,
@@ -136,7 +148,7 @@ insertImportRef :: DeclarationRef -> [DeclarationRef] -> [DeclarationRef]
 insertImportRef (P.TypeRef _ ty ctrs) ((P.TypeRef ss ty' ctrs') : refs)
   | ty == ty' = P.TypeRef ss ty (nub <$> liftA2 (<>) ctrs ctrs') : refs
 insertImportRef ref (ref' : refs)
-  | ref == ref' = refs
+  | ref == ref' = ref' : refs
   | otherwise = ref' : insertImportRef ref refs
 insertImportRef ref [] = [ref]
 

From b0647a6636f9e29b3ab5df20549d367fefa89951 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 17:03:39 +0200
Subject: [PATCH 178/297] adds operator search

---
 src/Language/PureScript/Lsp/Cache/Query.hs    |  2 ++
 .../PureScript/Lsp/Handlers/Completion.hs     |  4 +--
 src/Language/PureScript/Lsp/Imports.hs        |  4 +--
 src/Language/PureScript/Lsp/Util.hs           | 27 ++++++++++++-------
 4 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 85a883b6c3..3d7180ac7c 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -13,6 +13,7 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, ge
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
+import Language.PureScript.Lsp.Log (debugLsp)
 
 ------------------------------------------------------------------------------------------------------------------------
 ------------ AST -------------------------------------------------------------------------------------------------------
@@ -68,6 +69,7 @@ getAstDeclarationsStartingWith ::
   Text ->
   m [CompletionResult]
 getAstDeclarationsStartingWith moduleName' prefix = do
+  debugLsp $ "prefix: " <> prefix
   limit <- getMaxCompletions
   typeLen <- getMaxTypeLength
   let offset = 0 :: Int
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 708c096a57..f0fa00afee 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -21,7 +21,7 @@ import Language.PureScript.Lsp.Log (logPerfStandard, debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
-import Language.PureScript.Lsp.Util (getWordAt)
+import Language.PureScript.Lsp.Util (getSymbolAt)
 import Protolude hiding (to)
 
 completionAndResolveHandlers :: Server.Handlers HandlerM
@@ -46,7 +46,7 @@ completionAndResolveHandlers =
         forLsp filePathMb \filePath -> do
           vfMb <- Server.getVirtualFile uri
           forLsp vfMb \vf -> do
-            let (range, word) = getWordAt (VFS._file_text vf) pos
+            let (range, word) = getSymbolAt (VFS._file_text vf) pos
             mNameMb <- parseModuleNameFromFile uri
             debugLsp $ "word: " <> show word
             forLsp mNameMb \mName -> do
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index d9ae25b618..272ae37d07 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -101,8 +101,8 @@ addDeclarationToImports ::
   Maybe LspNameType ->
   [Import] ->
   Maybe
-    ( [Import],
-      Maybe P.ModuleName
+    ( [Import], -- new imports 
+      Maybe P.ModuleName -- module qualifier
     )
 addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports
   | importingSelf = Nothing
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 41c33535fb..25e40776d6 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -40,18 +40,30 @@ getDeclarationAtPos :: Types.Position -> [P.Declaration] -> Maybe P.Declaration
 getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn)
 
 getWordAt :: Rope -> Types.Position -> (Types.Range, Text)
-getWordAt file pos@(Types.Position {..}) =
+getWordAt = getByPredAt isWordBreak
+
+isWordBreak :: Char -> Bool
+isWordBreak = not . (isAlphaNum ||^ (== '_') ||^ (== '.'))
+
+getSymbolAt :: Rope -> Types.Position -> (Types.Range, Text)
+getSymbolAt = getByPredAt isSymbolBreak 
+
+isSymbolBreak :: Char -> Bool
+isSymbolBreak = isSpace ||^ (== '(') ||^ (== ')') ||^ (== '{') ||^ (== '}') ||^ (== '[') ||^ (== ']') ||^ (== ',') 
+
+getByPredAt :: (Char -> Bool) -> Rope -> Types.Position -> (Types.Range, Text)
+getByPredAt charPred file pos@(Types.Position {..}) =
   if Rope.lengthInLines file < fromIntegral _line || _line < 0
     then (Types.Range pos pos, "")
     else
       let (_, after) = splitAtLine (fromIntegral _line) file
           (ropeLine, _) = splitAtLine 1 after
           line' = Rope.toText ropeLine
-          (wordStartCol, wordEndCol, _word) = getWordOnLine line' _character
+          (wordStartCol, wordEndCol, _word) = getOnLine charPred line' _character
        in (Types.Range (Types.Position _line $ fromIntegral wordStartCol) (Types.Position _line $ fromIntegral wordEndCol), _word)
 
-getWordOnLine :: Text -> UInt -> (Int, Int, Text)
-getWordOnLine line' col =
+getOnLine :: (Char -> Bool) -> Text -> UInt -> (Int, Int, Text)
+getOnLine charPred line' col =
   if T.length line' < fromIntegral col || col < 0
     then (fromIntegral col, fromIntegral col, "")
     else
@@ -62,18 +74,15 @@ getWordOnLine line' col =
     getNextWs :: Int -> Text -> Int
     getNextWs idx txt | idx >= T.length txt = idx
     getNextWs idx txt = case T.index txt idx of
-      ch | isWordBreak ch -> idx
+      ch | charPred ch -> idx
       _ -> getNextWs (idx + 1) txt
 
     getPrevWs :: Int -> Text -> Int
     getPrevWs 0 _ = 0
     getPrevWs idx txt = case T.index txt idx of
-      ch | isWordBreak ch -> idx + 1
+      ch | charPred ch -> idx + 1
       _ -> getPrevWs (idx - 1) txt
 
-    isWordBreak :: Char -> Bool
-    isWordBreak = not . (isAlphaNum ||^ (== '_') ||^ (== '.'))
-
 data ExternsDeclarationCategory
   = EDCType
   | EDCTypeSynonym

From ef36c078f29f330d54a28ecc5704a5988cb12492 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 18:01:04 +0200
Subject: [PATCH 179/297] adds printed types for operators when indexing

---
 src/Language/PureScript/Lsp/Util.hs   | 10 ++-
 src/Language/PureScript/Make/Index.hs | 89 +++++++++++++++------------
 2 files changed, 58 insertions(+), 41 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 25e40776d6..f90f6a4824 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -23,6 +23,7 @@ import Language.PureScript.Comments qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
+import Language.PureScript.Names qualified as P
 
 posInSpan :: Types.Position -> AST.SourceSpan -> Bool
 posInSpan (Types.Position line col) (AST.SourceSpan _ (AST.SourcePos startLine startCol) (AST.SourcePos endLine endCol)) =
@@ -198,4 +199,11 @@ findExprSourceSpan = goExpr
         P.exprSourceSpan
         (const Nothing)
         (const Nothing)
-        (const Nothing)
\ No newline at end of file
+        (const Nothing)
+
+
+getOperatorValueName :: P.Declaration -> Maybe (P.Qualified P.Name)
+getOperatorValueName = \case 
+  P.FixityDeclaration _ (Left (P.ValueFixity _ n _)) -> Just (either P.IdentName P.DctorName <$> n)
+  P.FixityDeclaration _ (Right (P.TypeFixity _ n _)) -> Just (P.TyName <$> n)
+  _ -> Nothing
\ No newline at end of file
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 8e4ae44e6b..8dff2e968d 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -11,13 +11,12 @@ import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
-import Language.PureScript.AST.Declarations qualified as E
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
-import Language.PureScript.Lsp.NameType (externDeclNameType, lspNameType, LspNameType (DctorNameType))
+import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), externDeclNameType, lspNameType)
 import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printEfDeclType, printName)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
-import Language.PureScript.Lsp.Util (efDeclSourceSpan)
+import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Names qualified as P
 import Protolude hiding (moduleName)
@@ -50,7 +49,9 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
         end = P.spanEnd ss
         nameMb = P.declName decl
         nameType = nameMb <&> lspNameType
-        printedType = printDeclarationType decl
+        printedType = case getOperatorValueName decl >>= disqualifyIfInModule >>= getDeclFromName of
+          Nothing -> printDeclarationType decl
+          Just decl' -> printDeclarationType decl'
     for_ nameMb \name -> do
       let exported = Set.member name exportedNames
       SQL.executeNamed
@@ -74,37 +75,45 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
           ":generated" := "$Dict" `T.isInfixOf` printedType
         ]
 
-      when exported $ do
-        for_ (declCtrs decl) \ctr ->
-          let (ss', _) = P.dataCtorAnn ctr
-              start' = P.spanStart ss'
-              end' = P.spanEnd ss'
-           in SQL.executeNamed
-                conn
-                ( SQL.Query
-                    "INSERT INTO ast_declarations \
-                    \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
-                    \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
-                )
-                [ ":module_name" := P.runModuleName moduleName',
-                  ":name" := P.runProperName (P.dataCtorName ctr),
-                  ":printed_type" := printName name,
-                  ":name_type" := DctorNameType,
-                  ":start_line" := P.sourcePosLine start',
-                  ":end_line" := P.sourcePosLine end',
-                  ":start_col" := P.sourcePosColumn start',
-                  ":end_col" := P.sourcePosColumn end',
-                  ":lines" := P.sourcePosLine end - P.sourcePosLine start',
-                  ":cols" := P.sourcePosColumn end - P.sourcePosColumn start',
-                  ":exported" := True,
-                  ":generated" := "$Dict" `T.isInfixOf` printedType
-                ]
+      for_ (declCtrs decl) \ctr ->
+        let (ss', _) = P.dataCtorAnn ctr
+            start' = P.spanStart ss'
+            end' = P.spanEnd ss'
+         in SQL.executeNamed
+              conn
+              ( SQL.Query
+                  "INSERT INTO ast_declarations \
+                  \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+                  \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
+              )
+              [ ":module_name" := P.runModuleName moduleName',
+                ":name" := P.runProperName (P.dataCtorName ctr),
+                ":printed_type" := printName name,
+                ":name_type" := DctorNameType,
+                ":start_line" := P.sourcePosLine start',
+                ":end_line" := P.sourcePosLine end',
+                ":start_col" := P.sourcePosColumn start',
+                ":end_col" := P.sourcePosColumn end',
+                ":lines" := P.sourcePosLine end - P.sourcePosLine start',
+                ":cols" := P.sourcePosColumn end - P.sourcePosColumn start',
+                ":exported" := exported,
+                ":generated" := "$Dict" `T.isInfixOf` printedType
+              ]
   where
     externPath = P.spanName (P.efSourceSpan extern)
 
-    declCtrs = \case
-      P.DataDeclaration _ _ _ _ ctors -> ctors
-      _ -> []
+    getDeclFromName :: P.Name -> Maybe P.Declaration
+    getDeclFromName name = find (\decl -> P.declName decl == Just name) decls
+
+    disqualifyIfInModule :: P.Qualified P.Name -> Maybe P.Name
+    disqualifyIfInModule (P.Qualified (P.ByModuleName moduleName) name) | moduleName == moduleName' = Just name
+    disqualifyIfInModule (P.Qualified (P.BySourcePos _) name) = Just name
+    disqualifyIfInModule _ = Nothing
+
+declCtrs :: P.Declaration -> [P.DataConstructorDeclaration]
+declCtrs = \case
+  P.DataDeclaration _ _ _ _ ctors -> ctors
+  _ -> []
 
 indexAstModuleFromExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()
 indexAstModuleFromExtern conn extern = liftIO do
@@ -172,14 +181,14 @@ getExportedNames :: ExternsFile -> Set P.Name
 getExportedNames extern =
   Set.fromList $
     P.efExports extern >>= \case
-      E.TypeClassRef _ name -> [P.TyClassName name]
-      E.TypeRef _ name ctrs -> [P.TyName name] <> fmap P.DctorName (fold ctrs)
-      E.ValueRef _ name -> [P.IdentName name]
-      E.TypeOpRef _ name -> [P.TyOpName name]
-      E.ValueOpRef _ name -> [P.ValOpName name]
-      E.TypeInstanceRef _ name _ -> [P.IdentName name]
-      E.ModuleRef _ name -> [P.ModName name]
-      E.ReExportRef _ _ _ -> []
+      P.TypeClassRef _ name -> [P.TyClassName name]
+      P.TypeRef _ name ctrs -> [P.TyName name] <> fmap P.DctorName (fold ctrs)
+      P.ValueRef _ name -> [P.IdentName name]
+      P.TypeOpRef _ name -> [P.TyOpName name]
+      P.ValueOpRef _ name -> [P.ValOpName name]
+      P.TypeInstanceRef _ name _ -> [P.IdentName name]
+      P.ModuleRef _ name -> [P.ModName name]
+      P.ReExportRef _ _ _ -> []
 
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =

From 72144e323a911dca2d97c1bfb761edc00778b1d3 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 18:14:20 +0200
Subject: [PATCH 180/297] adds completion kinds

---
 .../PureScript/Lsp/Handlers/Completion.hs     | 35 +++++++++++++------
 src/Language/PureScript/Make/Index.hs         |  2 +-
 2 files changed, 25 insertions(+), 12 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index f0fa00afee..d95c589cbe 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -6,6 +6,7 @@ import Control.Lens ((^.))
 import Control.Lens.Getter (to)
 import Control.Lens.Setter (set)
 import Data.Aeson qualified as A
+import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as LSP
@@ -14,11 +15,12 @@ import Language.LSP.Server qualified as Server
 import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.Ide.Imports (Import (..))
-import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crType, crNameType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
+import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crNameType, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
-import Language.PureScript.Lsp.Log (logPerfStandard, debugLsp)
+import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (getSymbolAt)
@@ -56,11 +58,11 @@ completionAndResolveHandlers =
               limit <- getMaxCompletions
               matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
               decls <- logPerfStandard "get completion declarations" case (matchingImport, withQualifier) of
-                (Just (Import importModuleName _ _), _) -> do 
+                (Just (Import importModuleName _ _), _) -> do
                   getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual
-                (_, Just (wordModuleName, _)) -> do 
+                (_, Just (wordModuleName, _)) -> do
                   getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual
-                _ ->  do
+                _ -> do
                   getAstDeclarationsStartingWith mName wordWithoutQual
               res $
                 Right $
@@ -69,14 +71,26 @@ completionAndResolveHandlers =
                       Types.CompletionList (length decls >= limit) Nothing $
                         decls <&> \cr ->
                           let label = crName cr
-                            in Types.CompletionItem
+                              nameType = crNameType cr
+                              declModName = crModule cr
+                              
+                           in Types.CompletionItem
                                 { _label = label,
                                   _labelDetails =
                                     Just $
                                       Types.CompletionItemLabelDetails
                                         (Just $ " " <> crType cr)
-                                        (Just $ P.runModuleName (crModule cr)),
-                                  _kind = Nothing, --  Maybe Types.CompletionItemKind TODO: add kind
+                                        (Just $ P.runModuleName declModName),
+                                  _kind =
+                                    nameType <&> \case
+                                      IdentNameType | "->" `T.isInfixOf` crType cr -> Types.CompletionItemKind_Function
+                                      IdentNameType -> Types.CompletionItemKind_Value
+                                      TyNameType -> Types.CompletionItemKind_Class
+                                      DctorNameType -> Types.CompletionItemKind_Constructor
+                                      TyClassNameType -> Types.CompletionItemKind_Interface
+                                      ValOpNameType -> Types.CompletionItemKind_Operator
+                                      TyOpNameType -> Types.CompletionItemKind_TypeParameter
+                                      ModNameType -> Types.CompletionItemKind_Module,
                                   _tags = Nothing,
                                   _detail = Nothing,
                                   _documentation = Nothing,
@@ -87,13 +101,12 @@ completionAndResolveHandlers =
                                   _insertText = Nothing, --  Maybe Text
                                   _insertTextFormat = Nothing, --  Maybe Types.InsertTextFormat
                                   _insertTextMode = Nothing, --  Maybe Types.InsertTextMode
-                                  _textEdit = Nothing, --  Maybe
-                                  --                (Types.TextEdit Types.|? Types.InsertReplaceEdit)
+                                  _textEdit = Just $ Types.InL $ Types.TextEdit range label,
                                   _textEditText = Nothing, --  Maybe Text
                                   _additionalTextEdits = Nothing, --  Maybe [Types.TextEdit]
                                   _commitCharacters = Nothing, --  Maybe [Text]
                                   _command = Nothing, --  Maybe Types.Command
-                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName (crModule cr) label (crNameType cr) word range
+                                  _data_ = Just $ A.toJSON $ Just $ CompleteItemData filePath mName declModName label nameType word range
                                 },
       Server.requestHandler Message.SMethod_CompletionItemResolve $ \req res -> do
         let completionItem = req ^. LSP.params
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 8dff2e968d..85e06e6662 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -50,7 +50,7 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
         nameMb = P.declName decl
         nameType = nameMb <&> lspNameType
         printedType = case getOperatorValueName decl >>= disqualifyIfInModule >>= getDeclFromName of
-          Nothing -> printDeclarationType decl
+          Nothing -> printDeclarationType decl -- TODO add check for operators in other modules
           Just decl' -> printDeclarationType decl'
     for_ nameMb \name -> do
       let exported = Set.member name exportedNames

From 5e77425cb2d7c21e94ade9246fa8c7468c33c493 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 22:52:02 +0200
Subject: [PATCH 181/297] names name type not null

---
 src/Language/PureScript/Lsp/Cache/Query.hs    |  4 +-
 .../PureScript/Lsp/Handlers/Completion.hs     | 10 ++---
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  2 +-
 src/Language/PureScript/Lsp/Imports.hs        | 38 +++++++++----------
 src/Language/PureScript/Lsp/Types.hs          |  2 +-
 src/Language/PureScript/Make/Index.hs         |  5 ++-
 6 files changed, 30 insertions(+), 31 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 3d7180ac7c..b214d133dd 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -19,7 +19,7 @@ import Language.PureScript.Lsp.Log (debugLsp)
 ------------ AST -------------------------------------------------------------------------------------------------------
 ------------------------------------------------------------------------------------------------------------------------
 
-getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> Maybe LspNameType -> m (Maybe (Text, Text))
+getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> LspNameType -> m (Maybe (Text, Text))
 getAstDeclarationInModule moduleName' name nameType = do
   decls <-
     DB.queryNamed
@@ -172,7 +172,7 @@ data CompletionResult = CompletionResult
   { crName :: Text,
     crType :: Text,
     crModule :: P.ModuleName,
-    crNameType :: Maybe LspNameType
+    crNameType :: LspNameType
   }
   deriving (Show, Generic)
 
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index d95c589cbe..9315630321 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -16,7 +16,7 @@ import Language.LSP.VFS qualified as VFS
 import Language.PureScript qualified as P
 import Language.PureScript.Ide.Imports (Import (..))
 import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crNameType, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
@@ -73,7 +73,6 @@ completionAndResolveHandlers =
                           let label = crName cr
                               nameType = crNameType cr
                               declModName = crModule cr
-                              
                            in Types.CompletionItem
                                 { _label = label,
                                   _labelDetails =
@@ -82,7 +81,7 @@ completionAndResolveHandlers =
                                         (Just $ " " <> crType cr)
                                         (Just $ P.runModuleName declModName),
                                   _kind =
-                                    nameType <&> \case
+                                    Just case nameType of
                                       IdentNameType | "->" `T.isInfixOf` crType cr -> Types.CompletionItemKind_Function
                                       IdentNameType -> Types.CompletionItemKind_Value
                                       TyNameType -> Types.CompletionItemKind_Class
@@ -113,8 +112,9 @@ completionAndResolveHandlers =
             result = completionItem ^. LSP.data_ & decodeCompleteItemData
 
         case result of
-          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label _ _ _)) -> do
-            docsMb <- readDeclarationDocsAsMarkdown declModule label
+          A.Success (Just cid@(CompleteItemData _filePath _mName declModule label nameType _ _)) -> do
+            docsMb <- readDeclarationDocsWithNameType declModule nameType label
+            debugLsp $ "docs found for " <> show (declModule, label) <> show (isJust docsMb)
             withImports <- addImportToTextEdit completionItem cid
             let addDocs :: Types.CompletionItem -> Types.CompletionItem
                 addDocs =
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 4da604958a..d2d7149dc6 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -85,7 +85,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               decls
                 & declsAtLine srcPosLine
 
-        debugLsp $ "declsAtPos: " <> show declsAtPos
+        debugLsp $ "declsAtPos: " <> show (length declsAtPos)
 
         forLsp (head declsAtPos) $ \decl -> do
           case decl of
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 272ae37d07..2f26f7430d 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -62,7 +62,6 @@ getImportEdits cid@(CompleteItemData path moduleName' importedModuleName name na
           errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> show (importedModuleName, name, nameType)
           pure Nothing
         Just (declName, declType) -> do
-          debugLsp $ "Got declaration: " <> show (declName, declType)
           case addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports of
             Nothing -> pure Nothing
             Just (newImports, moduleQualifier) -> do
@@ -98,24 +97,23 @@ addDeclarationToImports ::
   Maybe P.ModuleName ->
   Text ->
   Text ->
-  Maybe LspNameType ->
+  LspNameType ->
   [Import] ->
   Maybe
-    ( [Import], -- new imports 
+    ( [Import], -- new imports
       Maybe P.ModuleName -- module qualifier
     )
 addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports
   | importingSelf = Nothing
-  | Just existing <- alreadyImportedModuleMb,
-    Just ref <- refMb = case existing of
+  | Just existing <- alreadyImportedModuleMb  = case existing of
       Import _ (P.Explicit refs') mName
-        | wordQualifierMb == mName -> Just (Import importedModuleName (P.Explicit (insertImportRef ref refs')) Nothing : withoutOldImport, mName)
+        | wordQualifierMb == mName -> Just (Import importedModuleName (P.Explicit (insertImportRef newRef refs')) Nothing : withoutOldImport, mName)
         | otherwise -> Just (imports, mName)
       Import _ P.Implicit mName -> Just (imports, mName)
       Import _ (P.Hiding refs') mName
         | wordQualifierMb == mName ->
-            if ref `elem` refs'
-              then Just (Import importedModuleName (P.Hiding (filter (/= ref) refs')) Nothing : withoutOldImport, mName)
+            if newRef `elem` refs'
+              then Just (Import importedModuleName (P.Hiding (filter (/= newRef) refs')) Nothing : withoutOldImport, mName)
               else Nothing
         | otherwise -> Just (imports, mName)
   | isJust wordQualifierMb = Just (Import importedModuleName P.Implicit wordQualifierMb : imports, wordQualifierMb)
@@ -126,18 +124,18 @@ addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName
     withoutOldImport = maybe identity (\im -> filter (/= im)) alreadyImportedModuleMb imports
 
     refs :: [P.DeclarationRef]
-    refs = toList refMb
-
-    refMb :: Maybe P.DeclarationRef
-    refMb =
-      nameType >>= \case
-        IdentNameType -> Just $ P.ValueRef nullSourceSpan (P.Ident declName)
-        ValOpNameType -> Just $ P.ValueOpRef nullSourceSpan (P.OpName declName)
-        TyNameType -> Just $ P.TypeRef nullSourceSpan (P.ProperName declName) Nothing
-        TyOpNameType -> Just $ P.TypeOpRef nullSourceSpan (P.OpName declName)
-        DctorNameType -> Just $ P.TypeRef nullSourceSpan (P.ProperName declType) (Just [P.ProperName declName])
-        TyClassNameType -> Just $ P.TypeClassRef nullSourceSpan (P.ProperName declName)
-        ModNameType -> Just $ P.ModuleRef nullSourceSpan (P.ModuleName declName)
+    refs = pure newRef
+
+    newRef :: P.DeclarationRef
+    newRef =
+      case nameType of
+        IdentNameType -> P.ValueRef nullSourceSpan (P.Ident declName)
+        ValOpNameType -> P.ValueOpRef nullSourceSpan (P.OpName declName)
+        TyNameType -> P.TypeRef nullSourceSpan (P.ProperName declName) Nothing
+        TyOpNameType -> P.TypeOpRef nullSourceSpan (P.OpName declName)
+        DctorNameType -> P.TypeRef nullSourceSpan (P.ProperName declType) (Just [P.ProperName declName])
+        TyClassNameType -> P.TypeClassRef nullSourceSpan (P.ProperName declName)
+        ModNameType -> P.ModuleRef nullSourceSpan (P.ModuleName declName)
 
     alreadyImportedModuleMb =
       find (\(Import mn' _ _) -> mn' == importedModuleName) imports
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index b9abe38439..c43430eb22 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -77,7 +77,7 @@ data CompleteItemData = CompleteItemData
     cidModuleName :: P.ModuleName,
     cidImportedModuleName :: P.ModuleName,
     cidName :: Text,
-    cidNameType :: Maybe LspNameType,
+    cidNameType :: LspNameType,
     cidWord :: Text,
     wordRange :: Range
   }
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 85e06e6662..ee9dfcf6cf 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -48,12 +48,13 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
         start = P.spanStart ss
         end = P.spanEnd ss
         nameMb = P.declName decl
-        nameType = nameMb <&> lspNameType
         printedType = case getOperatorValueName decl >>= disqualifyIfInModule >>= getDeclFromName of
           Nothing -> printDeclarationType decl -- TODO add check for operators in other modules
           Just decl' -> printDeclarationType decl'
     for_ nameMb \name -> do
-      let exported = Set.member name exportedNames
+      let 
+          exported = Set.member name exportedNames
+          nameType = lspNameType name
       SQL.executeNamed
         conn
         ( SQL.Query

From e3baba7dfa8d213d1ac0d1242b6ba6e4a5c34596 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 23:07:25 +0200
Subject: [PATCH 182/297] insert externs concurrently

---
 src/Language/PureScript/Lsp/Handlers/Index.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 67859e0087..4ebb447387 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -50,7 +50,7 @@ indexHandler =
       conn <- getDbConn
       indexExtern conn ef
       indexAstModuleFromExtern conn ef
-      for_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn ef (getExportedNames ef))
+      forConcurrently_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn ef (getExportedNames ef))
 
 -- \| Finds all the externs inside the output folder and returns the
 -- corresponding module names

From 52499f5a11419a7731a6469d8a14065cfea14f1f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 21 Oct 2024 23:09:00 +0200
Subject: [PATCH 183/297] remove progress indicator as not working

---
 src/Language/PureScript/Lsp/Handlers/Build.hs | 61 +++++++++----------
 src/Language/PureScript/Lsp/Handlers/Index.hs |  7 +--
 2 files changed, 30 insertions(+), 38 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index bd26ce63e7..392330a9fa 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Lsp.Handlers.Build where
 import Data.Aeson qualified as A
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.PureScript qualified as P
 import Language.PureScript.Compile (compile)
@@ -12,45 +13,39 @@ import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
 import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Rebuild (codegenTargets)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
+import Language.PureScript.Lsp.State (clearCache, getDbConn)
 import Language.PureScript.Make.Index (initDb)
 import Protolude hiding (to)
 import System.IO.UTF8 (readUTF8FilesT)
-import Language.PureScript.Lsp.State (clearCache, getDbConn)
-import Language.LSP.Server (getConfig, withIndefiniteProgress, ProgressCancellable (Cancellable))
-import Language.PureScript.Lsp.ServerConfig (ServerConfig(outputPath))
-import Language.LSP.Protocol.Lens qualified as LSP
-import Control.Lens ((^.))
+import Language.PureScript.Lsp.Log (debugLsp)
 
 buildHandler :: Server.Handlers HandlerM
 buildHandler =
-  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \req res -> do
-    let progressToken = cast $ req ^. LSP.id
-    diags <- buildForLsp progressToken
+  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do
+    diags <- buildForLsp
     res $ Right $ A.toJSON diags
 
-    where 
-
 -- Either get progress to work or remove it
-buildForLsp :: Maybe Types.ProgressToken -> HandlerM [Types.Diagnostic]
-buildForLsp  id = do
-  withIndefiniteProgress "Rebuilding all files" id Cancellable $ \updateProgress -> do 
-    clearCache
-    outDir <-  outputPath <$> getConfig
-    conn <- getDbConn
-    liftIO $ initDb conn
-    updateProgress "Updating available sources"
-    input <- updateAvailableSrcs
-    updateProgress "Reading module files"
-    moduleFiles <- liftIO $ readUTF8FilesT input
-    updateProgress "Compiling"
-    (result, warnings) <-
-      liftIO $
-        compile
-          (P.Options False False codegenTargets)
-          moduleFiles
-          conn
-          outDir
-          False
-    pure $
-      (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
-        <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
+buildForLsp :: HandlerM [Types.Diagnostic]
+buildForLsp = do
+  clearCache
+  outDir <- outputPath <$> getConfig
+  conn <- getDbConn
+  liftIO $ initDb conn
+  debugLsp "Updating available sources"
+  input <- updateAvailableSrcs
+  debugLsp "Reading module files"
+  moduleFiles <- liftIO $ readUTF8FilesT input
+  debugLsp "Compiling"
+  (result, warnings) <-
+    liftIO $
+      compile
+        (P.Options False False codegenTargets)
+        moduleFiles
+        conn
+        outDir
+        False
+  pure $
+    (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
+      <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs
index 4ebb447387..9bdac8fad2 100644
--- a/src/Language/PureScript/Lsp/Handlers/Index.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Index.hs
@@ -24,8 +24,6 @@ import Protolude hiding (to)
 import System.Directory (doesFileExist, getDirectoryContents)
 import System.FilePath ((</>))
 import Control.Monad.Trans.Control (MonadBaseControl)
-import Language.LSP.Protocol.Lens qualified as LSP
-import Control.Lens ((^.))
 
 indexHandler :: Server.Handlers HandlerM
 indexHandler =
@@ -36,12 +34,11 @@ indexHandler =
         externs <- logPerfStandard "findAvailableExterns" findAvailableExterns
         logPerfStandard "insert externs" $ forConcurrently_ externs indexExternAndDecls
         res $ Right A.Null,
-      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \req res -> do
-        let progressToken = cast $ req ^. LSP.id
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-full") $ \_req res -> do
         conn <- getDbConn
         liftIO $ initDb conn
         deleteOutput
-        diags <- buildForLsp progressToken
+        diags <- buildForLsp 
         res $ Right $ A.toJSON diags
     ]
   where

From dde90b71914ea46ae49c75694245cdc77c8080ff Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 22 Oct 2024 16:27:14 +0200
Subject: [PATCH 184/297] removes module and position from error messages

---
 purescript.cabal                              |   1 +
 src/Language/PureScript/Errors.hs             |   6 +
 src/Language/PureScript/Lsp/Cache/Query.hs    |   2 +-
 src/Language/PureScript/Lsp/Diagnostics.hs    |   2 +-
 .../PureScript/Lsp/Handlers/Definition.hs     | 211 ++----------------
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  60 +----
 6 files changed, 25 insertions(+), 257 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index 9d87949151..b47a3f5606 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -341,6 +341,7 @@ library
     Language.PureScript.Linter.Imports
     Language.PureScript.Linter.Wildcards
     Language.PureScript.Lsp
+    Language.PureScript.Lsp.AtPosition
     Language.PureScript.Lsp.DB
     Language.PureScript.Lsp.Docs
     Language.PureScript.Lsp.Imports
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 40cd90afbe..6185c5750f 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -2042,6 +2042,12 @@ withoutPosition (ErrorMessage hints se) = ErrorMessage (filter go hints) se
   where
   go (PositionedError _) = False
   go _ = True
+  
+withoutModule :: ErrorMessage -> ErrorMessage
+withoutModule (ErrorMessage hints se) = ErrorMessage (filter go hints) se
+  where
+  go (ErrorInModule _) = False
+  go _ = True
 
 positionedError :: SourceSpan -> ErrorMessageHint
 positionedError = PositionedError . pure
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index b214d133dd..e5c5b6fee4 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -31,7 +31,7 @@ getAstDeclarationInModule moduleName' name nameType = do
 
   pure $ listToMaybe decls
 
-getAstDeclarationLocationInModule :: (MonadIO m, MonadReader LspEnvironment m) => Maybe LspNameType -> P.ModuleName -> Text -> m [P.SourceSpan]
+getAstDeclarationLocationInModule :: (MonadIO m, MonadReader LspEnvironment m) =>  LspNameType -> P.ModuleName -> Text -> m [P.SourceSpan]
 getAstDeclarationLocationInModule lspNameType moduleName' name = do
   decls :: [([Char], Int, Int, Int, Int)] <-
     DB.queryNamed
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index a76728e271..7005cef06f 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -70,7 +70,7 @@ errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
         (Just $ Types.InR $ errorCode msg)
         (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
         (T.pack <$> spanName)
-        (T.pack $ render $ prettyPrintSingleError noColorPPEOptions msg)
+        (T.pack $ render $ prettyPrintSingleError noColorPPEOptions $ Errors.withoutPosition $ Errors.withoutModule msg)
         Nothing
         Nothing
         (Just $ A.toJSON textEdits)
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index f580bf64e0..2969ed398f 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -2,29 +2,25 @@
 
 module Language.PureScript.Lsp.Handlers.Definition where
 
-import Control.Lens (Field1 (_1), view, (^.))
-import Data.Text qualified as T
+import Control.Lens ((^.))
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.PureScript qualified as P
-import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.State (cachedRebuild)
-import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
-import Language.PureScript.Types (getAnnForType)
-import Protolude hiding (to)
+import Language.PureScript.Lsp.Util (posInSpan, sourcePosToPosition)
+import Protolude
+import Language.PureScript.Lsp.AtPosition (atPosition, findDeclRefAtPos, getImportRefNameType, spanToRange)
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
-  let Types.DefinitionParams docIdent pos@(Types.Position {..}) _prog _prog' = req ^. LSP.params
+  let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
 
       nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
@@ -36,11 +32,9 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
-      respondWithDeclInOtherModule :: Maybe LspNameType -> P.ModuleName -> Text -> HandlerM ()
+      respondWithDeclInOtherModule :: LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInOtherModule nameType modName ident = do
-        debugLsp $ "respondWithDeclInOtherModule: " <> show nameType <> " " <> show modName <> " " <> show ident
         declSpans <- getAstDeclarationLocationInModule nameType modName ident
-        debugLsp $ "SourceSpans: " <> show declSpans
         forLsp (head declSpans) $ \sourceSpan ->
           locationRes (P.spanName sourceSpan) (spanToRange sourceSpan)
 
@@ -64,189 +58,12 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
             debugLsp $ "respondWithModule importedModuleName: " <> show importedModuleName
             respondWithModule ss importedModuleName
 
-      handleDecls :: FilePath -> [P.Declaration] -> HandlerM ()
-      handleDecls filePath decls = do
-        let srcPosLine = fromIntegral _line + 1
-
-            declsAtPos =
-              decls
-                & declsAtLine srcPosLine
-
-        forLsp (head declsAtPos) $ \decl -> do
-          case decl of
-            P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
-              debugLsp $ "ImportDeclaration iomportedModuleName: " <> show importedModuleName
-              case importType of
-                P.Implicit -> respondWithModule ss importedModuleName
-                P.Explicit imports -> respondWithImports ss importedModuleName imports
-                P.Hiding imports -> respondWithImports ss importedModuleName imports
-            P.TypeInstanceDeclaration _ (P.SourceSpan span start end, _) _ _ _ constraints (P.Qualified (P.ByModuleName modName) className) _args body
-              | posInSpan pos classNameSS -> respondWithDeclInOtherModule (Just TyClassNameType) modName classNameTxt
-              | Just (P.Constraint _ (P.Qualified (P.ByModuleName conModName) conClassName) _ _ _) <- find (posInSpan pos . fst . P.constraintAnn) constraints -> do
-                  respondWithDeclInOtherModule (Just TyClassNameType) conModName $ P.runProperName conClassName
-              | P.ExplicitInstance members <- body -> do
-                  handleDecls filePath members
-              where
-                classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
-
-                classNameTxt :: Text
-                classNameTxt = P.runProperName className
-            -- P.TypeInstanceDeclaration _ _ _ _ _ _ _ -> nullRes
-            _ -> do
-              let respondWithTypeLocation = do
-                    let tipes =
-                          filter (not . fromPrim) $
-                            filter (not . isNullSourceTypeSpan) $
-                              getTypesAtPos pos decl
-
-                    case tipes of
-                      [] -> nullRes
-                      _ -> do
-                        let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
-                        case smallest of
-                          P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                          P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                            respondWithDeclInOtherModule (Just TyNameType) modName $ P.runProperName ident
-                          P.TypeOp _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                          P.TypeOp _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                            respondWithDeclInOtherModule (Just TyOpNameType) modName $ P.runOpName ident
-                          P.ConstrainedType _ c _ -> case P.constraintClass c of
-                            (P.Qualified (P.BySourcePos srcPos) _) -> posRes filePath srcPos
-                            (P.Qualified (P.ByModuleName modName) ident) -> do
-                              respondWithDeclInOtherModule (Just TyClassNameType) modName $ P.runProperName ident
-                          P.TypeVar _ name -> case findForallSpan name tipes of
-                            Just srcSpan -> posRes filePath (P.spanStart srcSpan)
-                            _ -> nullRes
-                          _ -> nullRes
-
-                  exprsAtPos = getExprsAtPos pos =<< declsAtPos
-              debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
-              case smallestExpr exprsAtPos of
-                Just expr -> do
-                  case expr of
-                    P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
-                      debugLsp $ "Var BySourcePos : " <> show srcPos
-                      posRes filePath srcPos
-                    P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                      debugLsp $ "Var ByModuleName : " <> show modName <> "." <> P.runIdent ident
-                      respondWithDeclInOtherModule (Just IdentNameType) modName $ P.runIdent ident
-                    P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                    P.Op _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                      respondWithDeclInOtherModule (Just ValOpNameType) modName $ P.runOpName ident
-                    P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> posRes filePath srcPos
-                    P.Constructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                      respondWithDeclInOtherModule (Just DctorNameType) modName $ P.runProperName ident
-                    _ -> respondWithTypeLocation
-                _ -> respondWithTypeLocation
-
   forLsp filePathMb \filePath -> do
-    cacheOpenMb <- cachedRebuild filePath
-    forLsp cacheOpenMb \OpenFile {..} -> do
-      let withoutPrim =
-            ofModule
-              & P.getModuleDeclarations
-              & filter (not . isPrimImport)
-
-      handleDecls filePath withoutPrim
-
-smallestExpr :: [P.Expr] -> Maybe P.Expr
-smallestExpr [] = Nothing
-smallestExpr es = Just $ minimumBy (comparing (fromMaybe (maxInt, maxInt) . getExprRowsAndColumns)) es
-
-getExprRowsAndColumns :: P.Expr -> Maybe (Int, Int)
-getExprRowsAndColumns expr =
-  P.exprSourceSpan expr <&> \ss ->
-    let spanRowStart = P.sourcePosLine (P.spanStart ss)
-        spanRowEnd = P.sourcePosLine (P.spanEnd ss)
-        spanColStart = P.sourcePosColumn (P.spanStart ss)
-        spanColEnd = P.sourcePosColumn (P.spanEnd ss)
-     in (spanRowEnd - spanRowStart, spanColEnd - spanColStart)
-
-isNullSourceTypeSpan :: P.SourceType -> Bool
-isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
-
-isSingleLine :: P.SourceType -> Bool
-isSingleLine st = P.sourcePosLine (P.spanStart (fst (getAnnForType st))) == P.sourcePosLine (P.spanEnd (fst (getAnnForType st)))
-
-getTypeRowsAndColumns :: P.SourceType -> (Int, Int)
-getTypeRowsAndColumns st = (getTypeRows st, getTypeColumns st)
-
-getTypeColumns :: P.SourceType -> Int
-getTypeColumns st = P.sourcePosColumn (P.spanEnd (fst (getAnnForType st))) - P.sourcePosColumn (P.spanStart (fst (getAnnForType st)))
-
-getTypeRows :: P.SourceType -> Int
-getTypeRows st = P.sourcePosLine (P.spanEnd (fst (getAnnForType st))) - P.sourcePosLine (P.spanStart (fst (getAnnForType st)))
-
-fromPrim :: P.SourceType -> Bool
-fromPrim st = case st of
-  P.TypeConstructor _ (P.Qualified (P.ByModuleName (P.ModuleName "Prim")) _) -> True
-  P.TypeOp _ (P.Qualified (P.ByModuleName (P.ModuleName "Prim")) _) -> True
-  _ -> False
-
-isPrimImport :: P.Declaration -> Bool
-isPrimImport (P.ImportDeclaration _ (P.ModuleName "Prim") _ _) = True
-isPrimImport (P.ImportDeclaration ss _ _ _) | ss == P.nullSourceAnn = True
-isPrimImport _ = False
-
-findForallSpan :: Text -> [P.SourceType] -> Maybe P.SourceSpan
-findForallSpan _ [] = Nothing
-findForallSpan var (P.ForAll ss _ fa _ _ _ : rest) =
-  if fa == var then Just (fst ss) else findForallSpan var rest
-findForallSpan var (_ : rest) = findForallSpan var rest
-
-spanToRange :: P.SourceSpan -> Types.Range
-spanToRange (P.SourceSpan _ start end) =
-  Types.Range
-    (sourcePosToPosition start)
-    (sourcePosToPosition end)
-
-getExprsAtPos :: Types.Position -> P.Declaration -> [P.Expr]
-getExprsAtPos pos declaration = execState (goDecl declaration) []
-  where
-    goDecl :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
-    goDecl = onDecl
-
-    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
-
-    handleExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
-    handleExpr expr = do
-      when (maybe False (posInSpan pos) (P.exprSourceSpan expr)) do
-        modify (expr :)
-      pure expr
-
-getTypedValuesAtPos :: Types.Position -> P.Declaration -> [P.Expr]
-getTypedValuesAtPos pos declaration = execState (goDecl declaration) []
-  where
-    goDecl :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
-    goDecl = onDecl
-
-    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
-
-    handleExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
-    handleExpr expr = do
-      case expr of
-        P.TypedValue _ e t -> do
-          when (maybe False (posInSpan pos) (P.exprSourceSpan e) || posInSpan pos (fst $ getAnnForType t)) do
-            modify (expr :)
-        _ -> pure ()
-      pure expr
-
-getTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
-getTypesAtPos pos decl = P.everythingOnTypes (<>) getAtPos =<< (view _1 $ P.accumTypes getAtPos) decl
-  where
-    getAtPos :: P.SourceType -> [P.SourceType]
-    getAtPos st = [st | posInSpan pos (fst $ getAnnForType st)]
-
-findDeclRefAtPos :: (Foldable t) => Types.Position -> t P.DeclarationRef -> Maybe P.DeclarationRef
-findDeclRefAtPos pos imports = find (posInSpan pos . P.declRefSourceSpan) imports
-
-getImportRefNameType :: P.DeclarationRef -> Maybe LspNameType
-getImportRefNameType = \case
-  P.TypeClassRef _ _ -> Just TyClassNameType
-  P.TypeRef _ _ _ -> Just TyNameType
-  P.TypeOpRef _ _ -> Just TyOpNameType
-  P.ValueRef _ _ -> Just IdentNameType
-  P.ValueOpRef _ _ -> Just ValOpNameType
-  P.ModuleRef _ _ -> Just ModNameType
-  P.ReExportRef _ _ _ -> Just ModNameType
-  _ -> Nothing
\ No newline at end of file
+    atPosition
+      nullRes
+      respondWithDeclInOtherModule
+      respondWithImports
+      respondWithModule
+      posRes 
+      filePath 
+      pos
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index d2d7149dc6..07de3a85dc 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -17,7 +17,7 @@ import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
-import Language.PureScript.Lsp.Handlers.Definition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeRowsAndColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, smallestExpr, spanToRange)
+import Language.PureScript.Lsp.AtPosition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeRowsAndColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, smallestExpr, spanToRange)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
@@ -73,8 +73,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           Just import' -> do
             let name = P.declRefName import'
                 nameType = getImportRefNameType import'
-            forLsp nameType \nameType' -> do
-              respondWithDeclInModule ss nameType' importedModuleName (printName name)
+            respondWithDeclInModule ss nameType importedModuleName (printName name)
           _ -> respondWithModule ss importedModuleName
 
       handleDecls :: [P.Declaration] -> HandlerM ()
@@ -173,58 +172,3 @@ pursTypeStr word type' comments =
 
 pursMd :: Text -> Text
 pursMd t = "```purescript\n" <> t <> "\n```"
-
--- x =
---   [ TypeInstanceDeclaration
---       ( SourceSpan
---           { spanStart =
---               SourcePos
---                 { sourcePosLine = 18,
---                   sourcePosColumn = 1
---                 },
---             spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}
---           },
---         []
---       )
---       (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 31}, spanEnd = SourcePos {sourcePosLine = 18, sourcePosColumn = 49}}, [])
---       (ChainId (,SourcePos {sourcePosLine = 18, sourcePosColumn = 1}))
---       0
---       (Right (Ident "monadEffectEffect"))
---       []
---       (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect"}))
---       [TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 43}, spanEnd = SourcePos {sourcePosLine = 18, sourcePosColumn = 49}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))]
---       (ExplicitInstance [ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 3}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}, []), valdeclIdent = Ident "liftEffect", valdeclName = Public, valdeclBinders = [], valdeclExpression = [GuardedExpr [] (PositionedValue (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) [] (Var (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) (Qualified (ByModuleName (ModuleName "Control.Category")) (Ident "identity"))))]})]),
---     ValueDeclaration
---       ( ValueDeclarationData
---           { valdeclSourceAnn =
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1},
---                     spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}
---                   },
---                 []
---               ),
---             valdeclIdent = Ident "monadEffectEffect",
---             valdeclName = Private,
---             valdeclBinders = [],
---             valdeclExpression =
---               [ GuardedExpr
---                   []
---                   ( TypedValue
---                       True
---                       ( App
---                           ( TypedValue
---                               True
---                               ( Constructor
---                                   (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}})
---                                   (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect$Dict"}))
---                               )
---                               (ForAll (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) TypeVarVisible "m" (Just (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "liftEffect"}) (ForAll (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) "a"))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 40}}, []) "m") (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) "a"))) (Just (SkolemScope {runSkolemScope = 0}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "Monad0"}) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 15, sourcePosColumn = 13}, spanEnd = SourcePos {sourcePosLine = 15, sourcePosColumn = 14}}, []) "m"))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect$Dict"}))) (TypeVar (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) "m"))) (Just (SkolemScope {runSkolemScope = 1})))
---                           )
---                           (TypedValue True (Literal (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) (ObjectLiteral [("liftEffect", TypedValue True (TypedValue True (PositionedValue (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) [] (App (Var (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) (Qualified (ByModuleName (ModuleName "Control.Category")) (Ident "identity"))) (Var (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}) (Qualified (ByModuleName (ModuleName "Control.Category")) (Ident "categoryFn"))))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (Skolem (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}, []) "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) 0 (SkolemScope {runSkolemScope = 2})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (Skolem (SourceSpan {spanStart = SourcePos {sourcePosLine = 19, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}, []) "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) 0 (SkolemScope {runSkolemScope = 2}))))) (ForAll (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) "a"))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) "a"))) (Just (SkolemScope {runSkolemScope = 2})))), ("Monad0", TypedValue True (Abs (VarBinder (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 1}, spanEnd = SourcePos {sourcePosLine = 19, sourcePosColumn = 24}}) UnusedIdent) (TypedValue False (Var (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}) (Qualified (ByModuleName (ModuleName "Effect")) (Ident "monadEffect"))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))))))])) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "liftEffect"}) (ForAll (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) TypeVarInvisible "a" (Just (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 36}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 38}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 34}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 35}}, []) "a"))) (TypeApp (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 39}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))) (TypeVar (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 41}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) "a"))) (Just (SkolemScope {runSkolemScope = 0}))) (RCons (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Label {runLabel = "Monad0"}) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"})))))) (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Control.Monad")) (ProperName {runProperName = "Monad$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 27}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 33}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))))) (KindApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (REmpty (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, [])) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 16, sourcePosColumn = 17}, spanEnd = SourcePos {sourcePosLine = 16, sourcePosColumn = 42}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))))))))
---                       )
---                       (TypeApp (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Effect.Class")) (ProperName {runProperName = "MonadEffect$Dict"}))) (TypeConstructor (SourceSpan {spanStart = SourcePos {sourcePosLine = 18, sourcePosColumn = 43}, spanEnd = SourcePos {sourcePosLine = 18, sourcePosColumn = 49}}, []) (Qualified (ByModuleName (ModuleName "Effect")) (ProperName {runProperName = "Effect"}))))
---                   )
---               ]
---           }
---       )
---   ]""
\ No newline at end of file

From 59f93f1ef39b8ef541adb7a995d4843e7cb461f4 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 22 Oct 2024 22:47:09 +0200
Subject: [PATCH 185/297] adds apply all changes quickfix

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 247 ++++++++++++++++++
 src/Language/PureScript/Lsp/Diagnostics.hs    | 119 +++++++--
 src/Language/PureScript/Lsp/Handlers/Build.hs |   4 +-
 .../PureScript/Lsp/Handlers/Diagnostic.hs     |  87 ++++--
 4 files changed, 408 insertions(+), 49 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/AtPosition.hs

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
new file mode 100644
index 0000000000..6720653b35
--- /dev/null
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Language.PureScript.Lsp.AtPosition where
+
+import Control.Lens (Field1 (_1), view)
+import Data.Text qualified as T
+import Language.LSP.Protocol.Types qualified as Types
+-- import Language.PureScript.Lsp.Monad (m)
+
+import Language.LSP.Server (MonadLsp)
+import Language.PureScript qualified as P
+import Language.PureScript.AST.SourcePos (nullSourceSpan)
+import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.NameType (LspNameType (..))
+import Language.PureScript.Lsp.ServerConfig (ServerConfig)
+import Language.PureScript.Lsp.State (cachedRebuild)
+import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
+import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
+import Language.PureScript.Types (getAnnForType)
+import Protolude
+
+-- data AtPosition = AtPosition
+--   { apExpr :: [P.Expr],
+--     apBinders :: [P.Binder],
+--     apType :: [P.SourceType],
+--     apDecl :: Maybe P.Declaration,
+--     apImport :: Maybe (P.SourceSpan, P.DeclarationRef),
+--     apModuleImport :: Maybe (P.SourceSpan, P.ModuleName)
+--   }
+
+
+-- nullAtPosition :: AtPosition
+-- nullAtPosition = AtPosition [] [] [] Nothing Nothing Nothing
+
+-- getAtPosition :: [P.Declaration] -> Types.Position -> AtPosition
+-- getAtPosition decls pos@(Types.Position{..}) = case head $ declsAtLine (fromIntegral _line + 1) decls of 
+--     Nothing -> nullAtPosition
+--     Just decl -> AtPosition
+--       { apExpr = getExprsAtPos pos decl,
+--         apType = getTypesAtPos pos decl,
+--         apDecl = Just decl,
+--         apImport = findDeclRefAtPos pos (P.getModuleImports decl) <&> \import' -> (P.declRefSourceSpan import', import'),
+--         apModuleImport = find (posInSpan pos . fst) (P.getModuleImports decl) 
+--       }
+
+atPosition ::
+  forall m.
+  ( MonadReader LspEnvironment m,
+    MonadLsp ServerConfig m
+  ) =>
+  m () ->
+  (LspNameType -> P.ModuleName -> Text -> m ()) ->
+  (P.SourceSpan -> P.ModuleName -> [P.DeclarationRef] -> m ()) ->
+  (P.SourceSpan -> P.ModuleName -> m ()) ->
+  (FilePath -> P.SourcePos -> m ()) ->
+  FilePath ->
+  Types.Position ->
+  m ()
+atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule filePath pos@(Types.Position {..}) = do
+  cacheOpenMb <- cachedRebuild filePath
+  forLsp cacheOpenMb \OpenFile {..} -> do
+    let withoutPrim =
+          ofModule
+            & P.getModuleDeclarations
+            & filter (not . isPrimImport)
+    handleDecls withoutPrim
+  where
+    forLsp :: Maybe a -> (a -> m ()) -> m ()
+    forLsp a f = maybe nullRes f a
+
+    handleDecls :: [P.Declaration] -> m ()
+    handleDecls decls = do
+      let srcPosLine = fromIntegral _line + 1
+
+          declsAtPos =
+            decls
+              & declsAtLine srcPosLine
+
+      forLsp (head declsAtPos) $ \decl -> do
+        case decl of
+          P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
+            debugLsp $ "ImportDeclaration iomportedModuleName: " <> show importedModuleName
+            case importType of
+              P.Implicit -> handleModule ss importedModuleName
+              P.Explicit imports -> handleImportRef ss importedModuleName imports
+              P.Hiding imports -> handleImportRef ss importedModuleName imports
+          P.TypeInstanceDeclaration _ (P.SourceSpan span start end, _) _ _ _ constraints (P.Qualified (P.ByModuleName modName) className) _args body
+            | posInSpan pos classNameSS -> handleDecl TyClassNameType modName classNameTxt
+            | Just (P.Constraint _ (P.Qualified (P.ByModuleName conModName) conClassName) _ _ _) <- find (posInSpan pos . fst . P.constraintAnn) constraints -> do
+                handleDecl TyClassNameType conModName $ P.runProperName conClassName
+            | P.ExplicitInstance members <- body -> do
+                handleDecls members
+            where
+              classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
+
+              classNameTxt :: Text
+              classNameTxt = P.runProperName className
+          -- P.TypeInstanceDeclaration _ _ _ _ _ _ _ -> nullRes
+          _ -> do
+            let respondWithTypeLocation = do
+                  let tipes =
+                        filter (not . fromPrim) $
+                          filter (not . isNullSourceTypeSpan) $
+                            getTypesAtPos pos decl
+
+                  case tipes of
+                    [] -> nullRes
+                    _ -> do
+                      let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
+                      case smallest of
+                        P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> handleExprInModule filePath srcPos
+                        P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                          handleDecl TyNameType modName $ P.runProperName ident
+                        P.TypeOp _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> handleExprInModule filePath srcPos
+                        P.TypeOp _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                          handleDecl TyOpNameType modName $ P.runOpName ident
+                        P.ConstrainedType _ c _ -> case P.constraintClass c of
+                          (P.Qualified (P.BySourcePos srcPos) _) -> handleExprInModule filePath srcPos
+                          (P.Qualified (P.ByModuleName modName) ident) -> do
+                            handleDecl TyClassNameType modName $ P.runProperName ident
+                        P.TypeVar _ name -> case findForallSpan name tipes of
+                          Just srcSpan -> handleExprInModule filePath (P.spanStart srcSpan)
+                          _ -> nullRes
+                        _ -> nullRes
+
+                exprsAtPos = getExprsAtPos pos =<< declsAtPos
+            debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
+            case smallestExpr exprsAtPos of
+              Just expr -> do
+                case expr of
+                  P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
+                    debugLsp $ "Var BySourcePos : " <> show srcPos
+                    handleExprInModule filePath srcPos
+                  P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                    debugLsp $ "Var ByModuleName : " <> show modName <> "." <> P.runIdent ident
+                    handleDecl IdentNameType modName $ P.runIdent ident
+                  P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> handleExprInModule filePath srcPos
+                  P.Op _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                    handleDecl ValOpNameType modName $ P.runOpName ident
+                  P.Constructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> handleExprInModule filePath srcPos
+                  P.Constructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
+                    handleDecl DctorNameType modName $ P.runProperName ident
+                  _ -> respondWithTypeLocation
+              _ -> respondWithTypeLocation
+
+smallestExpr :: [P.Expr] -> Maybe P.Expr
+smallestExpr [] = Nothing
+smallestExpr es = Just $ minimumBy (comparing (fromMaybe (maxInt, maxInt) . getExprRowsAndColumns)) es
+
+getExprRowsAndColumns :: P.Expr -> Maybe (Int, Int)
+getExprRowsAndColumns expr =
+  P.exprSourceSpan expr <&> \ss ->
+    let spanRowStart = P.sourcePosLine (P.spanStart ss)
+        spanRowEnd = P.sourcePosLine (P.spanEnd ss)
+        spanColStart = P.sourcePosColumn (P.spanStart ss)
+        spanColEnd = P.sourcePosColumn (P.spanEnd ss)
+     in (spanRowEnd - spanRowStart, spanColEnd - spanColStart)
+
+isNullSourceTypeSpan :: P.SourceType -> Bool
+isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
+
+isSingleLine :: P.SourceType -> Bool
+isSingleLine st = P.sourcePosLine (P.spanStart (fst (getAnnForType st))) == P.sourcePosLine (P.spanEnd (fst (getAnnForType st)))
+
+getTypeRowsAndColumns :: P.SourceType -> (Int, Int)
+getTypeRowsAndColumns st = (getTypeRows st, getTypeColumns st)
+
+getTypeColumns :: P.SourceType -> Int
+getTypeColumns st = P.sourcePosColumn (P.spanEnd (fst (getAnnForType st))) - P.sourcePosColumn (P.spanStart (fst (getAnnForType st)))
+
+getTypeRows :: P.SourceType -> Int
+getTypeRows st = P.sourcePosLine (P.spanEnd (fst (getAnnForType st))) - P.sourcePosLine (P.spanStart (fst (getAnnForType st)))
+
+fromPrim :: P.SourceType -> Bool
+fromPrim st = case st of
+  P.TypeConstructor _ (P.Qualified (P.ByModuleName (P.ModuleName "Prim")) _) -> True
+  P.TypeOp _ (P.Qualified (P.ByModuleName (P.ModuleName "Prim")) _) -> True
+  _ -> False
+
+isPrimImport :: P.Declaration -> Bool
+isPrimImport (P.ImportDeclaration _ (P.ModuleName "Prim") _ _) = True
+isPrimImport (P.ImportDeclaration ss _ _ _) | ss == P.nullSourceAnn = True
+isPrimImport _ = False
+
+findForallSpan :: Text -> [P.SourceType] -> Maybe P.SourceSpan
+findForallSpan _ [] = Nothing
+findForallSpan var (P.ForAll ss _ fa _ _ _ : rest) =
+  if fa == var then Just (fst ss) else findForallSpan var rest
+findForallSpan var (_ : rest) = findForallSpan var rest
+
+spanToRange :: P.SourceSpan -> Types.Range
+spanToRange (P.SourceSpan _ start end) =
+  Types.Range
+    (sourcePosToPosition start)
+    (sourcePosToPosition end)
+
+getExprsAtPos :: Types.Position -> P.Declaration -> [P.Expr]
+getExprsAtPos pos declaration = execState (goDecl declaration) []
+  where
+    goDecl :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
+    goDecl = onDecl
+
+    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
+
+    handleExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
+    handleExpr expr = do
+      when (maybe False (posInSpan pos) (P.exprSourceSpan expr)) do
+        modify (expr :)
+      pure expr
+
+getTypedValuesAtPos :: Types.Position -> P.Declaration -> [P.Expr]
+getTypedValuesAtPos pos declaration = execState (goDecl declaration) []
+  where
+    goDecl :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
+    goDecl = onDecl
+
+    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
+
+    handleExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
+    handleExpr expr = do
+      case expr of
+        P.TypedValue _ e t -> do
+          when (maybe False (posInSpan pos) (P.exprSourceSpan e) || posInSpan pos (fst $ getAnnForType t)) do
+            modify (expr :)
+        _ -> pure ()
+      pure expr
+
+getTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
+getTypesAtPos pos decl = P.everythingOnTypes (<>) getAtPos =<< (view _1 $ P.accumTypes getAtPos) decl
+  where
+    getAtPos :: P.SourceType -> [P.SourceType]
+    getAtPos st = [st | posInSpan pos (fst $ getAnnForType st)]
+
+findDeclRefAtPos :: (Foldable t) => Types.Position -> t P.DeclarationRef -> Maybe P.DeclarationRef
+findDeclRefAtPos pos imports = find (posInSpan pos . P.declRefSourceSpan) imports
+
+getImportRefNameType :: P.DeclarationRef -> LspNameType
+getImportRefNameType = \case
+  P.TypeClassRef _ _ -> TyClassNameType
+  P.TypeRef _ _ _ -> TyNameType
+  P.TypeOpRef _ _ -> TyOpNameType
+  P.ValueRef _ _ -> IdentNameType
+  P.ValueOpRef _ _ -> ValOpNameType
+  P.ModuleRef _ _ -> ModNameType
+  P.ReExportRef _ _ _ -> ModNameType
+  P.TypeInstanceRef _ _ _ -> IdentNameType
+
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 7005cef06f..9199b843fd 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -1,6 +1,8 @@
-module Language.PureScript.Lsp.Diagnostics where
+{-# LANGUAGE DeriveAnyClass #-}
 
-import Control.Lens ((^.))
+module Language.PureScript.Lsp.Diagnostics (TitledTextEdit (..), addJsonEdits, errorMessageDiagnostic, getFileDiagnotics, getMsgUri) where
+
+import Control.Lens (set, (^.))
 import Control.Monad.Catch (MonadThrow)
 import Data.Aeson qualified as A
 import Data.List.NonEmpty qualified as NEL
@@ -34,46 +36,56 @@ getFileDiagnotics msg = do
   let uri :: Types.NormalizedUri
       uri = getMsgUri msg & Types.toNormalizedUri
   res <- rebuildFile uri
-  pure $ getResultDiagnostics res
+  pure $ addJsonEdits $ getResultDiagnostics res
+
+addJsonEdits :: [(Types.Diagnostic, [TitledTextEdit])] -> [Types.Diagnostic]
+addJsonEdits diags =
+  let allEdits :: [Types.TextEdit]
+      allEdits =
+        if length diags > 1 then diags >>= fmap tteEdit . snd else []
+
+      importEdits :: [Types.TextEdit]
+      importEdits =
+        if length diags > 1 then diags >>= fmap tteEdit . filter tteIsUnusedImport . snd else []
+   in diags
+        <&> \(diag, edits) ->
+          let
+            withApplyAlls = 
+               edits
+                 <&> addAllEdits allEdits
+                  <&> addImportEdits importEdits
+
+          in
+           set LSP.data_ (Just $ A.toJSON withApplyAlls) diag
 
 getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
 getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
 
 getResultDiagnostics ::
   RebuildResult ->
-  [Types.Diagnostic]
+  [(Types.Diagnostic, [TitledTextEdit])]
 getResultDiagnostics res = case res of
   RebuildError errors -> errorsToDiagnostics Types.DiagnosticSeverity_Error errors
   RebuildWarning errors -> errorsToDiagnostics Types.DiagnosticSeverity_Warning errors
 
-errorsToDiagnostics :: Types.DiagnosticSeverity -> P.MultipleErrors -> [Types.Diagnostic]
+errorsToDiagnostics :: Types.DiagnosticSeverity -> P.MultipleErrors -> [(Types.Diagnostic, [TitledTextEdit])]
 errorsToDiagnostics severity errs =
   errorMessageDiagnostic severity <$> runMultipleErrors errs
 
-errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> Types.Diagnostic
+errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> (Types.Diagnostic, [TitledTextEdit])
 errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
-  let textEdits :: [Types.TextEdit]
-      textEdits =
-        toSuggestion msg
-          & maybeToList
-            >>= suggestionToEdit
-
-      suggestionToEdit :: JsonErrors.ErrorSuggestion -> [Types.TextEdit]
-      suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
-        let rangeStart = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
-            rangeEnd = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
-         in pure $ Types.TextEdit (Types.Range rangeStart rangeEnd) replacement
-      suggestionToEdit _ = []
-   in Types.Diagnostic
-        (Types.Range start end)
-        (Just severity)
-        (Just $ Types.InR $ errorCode msg)
-        (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
-        (T.pack <$> spanName)
-        (T.pack $ render $ prettyPrintSingleError noColorPPEOptions $ Errors.withoutPosition $ Errors.withoutModule msg)
-        Nothing
-        Nothing
-        (Just $ A.toJSON textEdits)
+  ( Types.Diagnostic
+      (Types.Range start end)
+      (Just severity)
+      (Just $ Types.InR $ errorCode msg)
+      (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
+      (T.pack <$> spanName)
+      (T.pack $ render $ prettyPrintSingleError noColorPPEOptions $ Errors.withoutPosition $ Errors.withoutModule msg)
+      Nothing
+      Nothing
+      Nothing,
+    maybeToList (getErrorTextEdit msg)
+  )
   where
     notFound = Types.Position 0 0
     (spanName, start, end) = getPositions $ errorSpan msg
@@ -87,3 +99,54 @@ errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
             Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startCol - 1),
             Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endCol - 1)
           )
+
+getErrorTextEdit :: ErrorMessage -> Maybe TitledTextEdit
+getErrorTextEdit msg = do
+  edit <- toSuggestion msg >>= suggestionToEdit
+  pure $ TitledTextEdit (errorTitle msg) (isUnusedImport msg) edit [] []
+
+isUnusedImport :: ErrorMessage -> Bool
+isUnusedImport (ErrorMessage _hints (Errors.UnusedImport {})) = True
+isUnusedImport (ErrorMessage _hints (Errors.UnusedExplicitImport {})) = True
+isUnusedImport (ErrorMessage _hints (Errors.UnusedDctorImport {})) = True
+isUnusedImport (ErrorMessage _hints (Errors.UnusedDctorExplicitImport {})) = True
+isUnusedImport _ = False
+
+errorTitle :: ErrorMessage -> Text
+errorTitle msg = case Errors.unwrapErrorMessage msg of
+  Errors.UnusedImport {} -> "Remove unused import"
+  Errors.DuplicateImport {} -> "Remove duplicate import"
+  Errors.UnusedExplicitImport {} -> "Remove unused explicit import"
+  Errors.UnusedDctorImport {} -> "Remove unused data constructor import"
+  Errors.UnusedDctorExplicitImport {} -> "Remove unused data constructor explicit import"
+  Errors.ImplicitImport {} -> "Make implicit import explicit"
+  Errors.ImplicitQualifiedImport {} -> "Make implicit qualified import explicit"
+  Errors.ImplicitQualifiedImportReExport {} -> "Make implicit qualified import re-export explicit"
+  Errors.HidingImport {} -> "Address hidden import"
+  Errors.MissingTypeDeclaration {} -> "Add missing type declaration"
+  Errors.MissingKindDeclaration {} -> "Add missing kind declaration"
+  Errors.WildcardInferredType {} -> "Add wildcard inferred type"
+  Errors.WarningParsingCSTModule {} -> "Address parser warning"
+  _ -> errorCode msg
+
+suggestionToEdit :: JsonErrors.ErrorSuggestion -> Maybe Types.TextEdit
+suggestionToEdit (JsonErrors.ErrorSuggestion replacement (Just JsonErrors.ErrorPosition {..})) =
+  let rangeStart = Types.Position (fromIntegral $ startLine - 1) (fromIntegral $ startColumn - 1)
+      rangeEnd = Types.Position (fromIntegral $ endLine - 1) (fromIntegral $ endColumn - 1)
+   in pure $ Types.TextEdit (Types.Range rangeStart rangeEnd) replacement
+suggestionToEdit _ = Nothing
+
+data TitledTextEdit = TitledTextEdit
+  { tteTitle :: Text,
+    tteIsUnusedImport :: Bool,
+    tteEdit :: Types.TextEdit,
+    tteAllEdits :: [Types.TextEdit],
+    tteImportEdits :: [Types.TextEdit]
+  }
+  deriving (Show, Eq, Generic, A.ToJSON, A.FromJSON)
+
+addAllEdits :: [Types.TextEdit] -> TitledTextEdit -> TitledTextEdit
+addAllEdits edits tte = tte {tteAllEdits = tteAllEdits tte <> edits}
+
+addImportEdits :: [Types.TextEdit] -> TitledTextEdit -> TitledTextEdit
+addImportEdits edits tte = if tteIsUnusedImport tte then tte {tteImportEdits = tteImportEdits tte <> edits} else tte
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index 392330a9fa..dd73d211a1 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -10,7 +10,7 @@ import Language.LSP.Server qualified as Server
 import Language.PureScript qualified as P
 import Language.PureScript.Compile (compile)
 import Language.PureScript.Lsp.Cache (updateAvailableSrcs)
-import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic)
+import Language.PureScript.Lsp.Diagnostics (errorMessageDiagnostic, addJsonEdits)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.Rebuild (codegenTargets)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath))
@@ -46,6 +46,6 @@ buildForLsp = do
         conn
         outDir
         False
-  pure $
+  pure $ addJsonEdits $
     (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
       <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
index a976b33a4c..cde3428395 100644
--- a/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE BlockArguments #-}
+
 module Language.PureScript.Lsp.Handlers.Diagnostic where
 
 import Control.Lens ((^.))
@@ -7,7 +9,7 @@ import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
-import Language.PureScript.Lsp.Diagnostics (getFileDiagnotics, getMsgUri)
+import Language.PureScript.Lsp.Diagnostics (TitledTextEdit (..), getFileDiagnotics, getMsgUri)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Protolude hiding (to)
 
@@ -23,28 +25,75 @@ diagnosticAndCodeActionHandlers =
                 Types.RelatedFullDocumentDiagnosticReport Types.AString Nothing diagnostics Nothing,
       Server.requestHandler Message.SMethod_TextDocumentCodeAction $ \req res -> do
         let params = req ^. LSP.params
+            diags :: [Types.Diagnostic]
             diags = params ^. LSP.context . LSP.diagnostics
             uri = getMsgUri req
+
         res $
           Right $
             Types.InL $
-              diags <&> \diag ->
-                let textEdits = case A.fromJSON <$> diag ^. LSP.data_ of
+              diags >>= \diag ->
+                let titledEdits :: [TitledTextEdit]
+                    titledEdits = case A.fromJSON <$> diag ^. LSP.data_ of
                       Just (A.Success tes) -> tes
                       _ -> []
-                 in Types.InR $
-                      Types.CodeAction
-                        "Apply suggestion"
-                        (Just Types.CodeActionKind_QuickFix)
-                        (Just diags)
-                        (Just True)
-                        Nothing -- disabled
-                        ( Just $
-                            Types.WorkspaceEdit
-                              (Just $ Map.singleton uri textEdits)
-                              Nothing
-                              Nothing
-                        )
-                        Nothing
-                        Nothing
-    ]
\ No newline at end of file
+
+                    unusedImportEdits :: [Types.TextEdit]
+                    unusedImportEdits = titledEdits >>= tteImportEdits
+
+                    textEdits :: [Types.TextEdit]
+                    textEdits = map tteEdit titledEdits
+
+                    allEdits :: [Types.TextEdit]
+                    allEdits = titledEdits >>= tteAllEdits
+                 in [ Types.InR $
+                        Types.CodeAction
+                          (foldMap tteTitle $ head titledEdits)
+                          (Just Types.CodeActionKind_QuickFix)
+                          (Just [diag])
+                          (Just True)
+                          Nothing
+                          ( Just $
+                              Types.WorkspaceEdit
+                                (Just $ Map.singleton uri textEdits)
+                                Nothing
+                                Nothing
+                          )
+                          Nothing
+                          Nothing
+                    ]
+                      <> [ Types.InR $
+                             Types.CodeAction
+                               "Remove all unused imports"
+                               (Just Types.CodeActionKind_QuickFix)
+                               Nothing
+                               (Just True)
+                               Nothing
+                               ( Just $
+                                   Types.WorkspaceEdit
+                                     (Just $ Map.singleton uri unusedImportEdits)
+                                     Nothing
+                                     Nothing
+                               )
+                               Nothing
+                               Nothing
+                           | length unusedImportEdits > 1
+                         ]
+                      <> [ Types.InR $
+                             Types.CodeAction
+                               "Apply all suggestions"
+                               (Just Types.CodeActionKind_QuickFix)
+                               (Just diags)
+                               (Just True)
+                               Nothing
+                               ( Just $
+                                   Types.WorkspaceEdit
+                                     (Just $ Map.singleton uri allEdits)
+                                     Nothing
+                                     Nothing
+                               )
+                               Nothing
+                               Nothing
+                           | length allEdits > 1
+                         ]
+    ]

From bb9c5d19bca0646c97c7b325f184745a628427f5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 22 Oct 2024 23:24:07 +0200
Subject: [PATCH 186/297] adds purs-tidy formatter

---
 purescript.cabal                               |  1 +
 src/Language/PureScript/Lsp/Handlers.hs        |  4 +++-
 src/Language/PureScript/Lsp/Handlers/Format.hs | 18 ++++++++++++++++++
 3 files changed, 22 insertions(+), 1 deletion(-)
 create mode 100644 src/Language/PureScript/Lsp/Handlers/Format.hs

diff --git a/purescript.cabal b/purescript.cabal
index b47a3f5606..638ec41e1a 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -354,6 +354,7 @@ library
     Language.PureScript.Lsp.Handlers.Definition
     Language.PureScript.Lsp.Handlers.DeleteOutput
     Language.PureScript.Lsp.Handlers.Diagnostic
+    Language.PureScript.Lsp.Handlers.Format
     Language.PureScript.Lsp.Handlers.Hover
     Language.PureScript.Lsp.Handlers.Index
     Language.PureScript.Lsp.Log
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index a3ba11fc77..ac38831dba 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -23,10 +23,12 @@ import Language.PureScript.Lsp.Handlers.Diagnostic (diagnosticAndCodeActionHandl
 import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
 import Language.PureScript.Lsp.Handlers.Index (indexHandler)
 import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (setTraceValue)
 import Language.PureScript.Lsp.State (cancelRequest, clearCache, clearExportCache, clearRebuildCache, getDbConn, removedCachedRebuild)
 import Language.PureScript.Make.Index (dropTables, initDb)
 import Protolude hiding (to)
+import System.Process (readProcess)
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -67,6 +69,7 @@ handlers =
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
             let reqId = msg ^. LSP.params . LSP.id
             cancelRequest reqId,
+
           Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache") $ \_req res -> do
             clearCache
             res $ Right A.Null,
@@ -84,7 +87,6 @@ handlers =
             conn <- getDbConn
             liftIO $ dropTables conn
             res $ Right A.Null
-
         ]
 
 sendInfoMsg :: (Server.MonadLsp config f) => Text -> f ()
diff --git a/src/Language/PureScript/Lsp/Handlers/Format.hs b/src/Language/PureScript/Lsp/Handlers/Format.hs
new file mode 100644
index 0000000000..e2b71d0dcd
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/Format.hs
@@ -0,0 +1,18 @@
+module Language.PureScript.Lsp.Handlers.Format where
+
+import Control.Lens ((^.))
+import Language.LSP.Protocol.Lens qualified as LSP
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server qualified as Server
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.ReadFile (lspReadFileText)
+import Protolude
+import System.Process (readProcess)
+
+formatHandler :: Server.Handlers HandlerM
+formatHandler = Server.requestHandler Message.SMethod_TextDocumentFormatting $ \req res -> do
+  let uri = req ^. LSP.params . LSP.textDocument . LSP.uri
+  contents <- lspReadFileText $ Types.toNormalizedUri uri
+  formatted <-  liftIO $ readProcess "purs-tidy" ["format"] (toS contents)
+  res $ Right $ Types.InL [Types.TextEdit (Types.Range (Types.Position 0 0) (Types.Position 100000 0)) (toS formatted)]
\ No newline at end of file

From 5ff71626d1183900bd45da8cc0ff228302501e6b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 23 Oct 2024 00:12:31 +0200
Subject: [PATCH 187/297] adds import sorting to formatting

---
 src/Language/PureScript/Lsp/Handlers.hs        |  7 +++----
 src/Language/PureScript/Lsp/Handlers/Format.hs | 13 +++++++++++--
 src/Language/PureScript/Lsp/Imports.hs         |  6 ++++++
 3 files changed, 20 insertions(+), 6 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index ac38831dba..855b59cc29 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -20,15 +20,14 @@ import Language.PureScript.Lsp.Handlers.Completion (completionAndResolveHandlers
 import Language.PureScript.Lsp.Handlers.Definition (definitionHandler)
 import Language.PureScript.Lsp.Handlers.DeleteOutput (deleteOutputHandler)
 import Language.PureScript.Lsp.Handlers.Diagnostic (diagnosticAndCodeActionHandlers)
+import Language.PureScript.Lsp.Handlers.Format (formatHandler)
 import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
 import Language.PureScript.Lsp.Handlers.Index (indexHandler)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (setTraceValue)
 import Language.PureScript.Lsp.State (cancelRequest, clearCache, clearExportCache, clearRebuildCache, getDbConn, removedCachedRebuild)
 import Language.PureScript.Make.Index (dropTables, initDb)
-import Protolude hiding (to)
-import System.Process (readProcess)
+import Protolude
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -39,6 +38,7 @@ handlers =
       definitionHandler,
       deleteOutputHandler,
       diagnosticAndCodeActionHandlers,
+      formatHandler,
       hoverHandler,
       indexHandler
     ]
@@ -69,7 +69,6 @@ handlers =
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
             let reqId = msg ^. LSP.params . LSP.id
             cancelRequest reqId,
-
           Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache") $ \_req res -> do
             clearCache
             res $ Right A.Null,
diff --git a/src/Language/PureScript/Lsp/Handlers/Format.hs b/src/Language/PureScript/Lsp/Handlers/Format.hs
index e2b71d0dcd..045aec6002 100644
--- a/src/Language/PureScript/Lsp/Handlers/Format.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Format.hs
@@ -5,6 +5,8 @@ import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
+import Language.PureScript.Lsp.Imports (parseImportsFromFile, printImports)
+import Language.PureScript.Lsp.Log (warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Protolude
@@ -13,6 +15,13 @@ import System.Process (readProcess)
 formatHandler :: Server.Handlers HandlerM
 formatHandler = Server.requestHandler Message.SMethod_TextDocumentFormatting $ \req res -> do
   let uri = req ^. LSP.params . LSP.textDocument . LSP.uri
-  contents <- lspReadFileText $ Types.toNormalizedUri uri
-  formatted <-  liftIO $ readProcess "purs-tidy" ["format"] (toS contents)
+      normalizedUri = Types.toNormalizedUri uri
+  parsedImportsRes <- parseImportsFromFile normalizedUri
+  contents <- case parsedImportsRes of
+    Left err -> do
+      warnLsp $ "Failed to parse imports from file: " <> err
+      lspReadFileText $ Types.toNormalizedUri uri
+    Right imoprts -> pure $ printImports imoprts
+
+  formatted <- liftIO $ readProcess "purs-tidy" ["format"] (toS contents)
   res $ Right $ Types.InL [Types.TextEdit (Types.Range (Types.Position 0 0) (Types.Position 100000 0)) (toS formatted)]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 2f26f7430d..1b7f990a56 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -3,6 +3,8 @@ module Language.PureScript.Lsp.Imports
     addImportToTextEdit,
     getIdentModuleQualifier,
     parseModuleNameFromFile,
+    parseImportsFromFile,
+    printImports,
   )
 where
 
@@ -176,6 +178,10 @@ parseImportsFromFile fp = do
   rope <- lspReadFileRope fp
   pure $ sliceImportSection (Rope.lines rope)
 
+
+printImports :: (P.ModuleName, [Text], [Import], [Text]) -> Text 
+printImports (_mn, before, imports, after) = T.unlines $ before <> prettyPrintImportSection imports <> after
+
 parseModuleNameFromFile ::
   (MonadThrow m, MonadLsp ServerConfig m, MonadReader LspEnvironment m) =>
   NormalizedUri ->

From c22246334e4f07ce674f59c54e03c5a097488b5c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 23 Oct 2024 14:56:16 +0200
Subject: [PATCH 188/297] display data and ctr types better

---
 src/Language/PureScript/Lsp/Cache/Query.hs |  4 +-
 src/Language/PureScript/Lsp/Imports.hs     | 10 ++---
 src/Language/PureScript/Lsp/Print.hs       | 45 ++++++++++++++++++++-
 src/Language/PureScript/Make/Index.hs      | 47 ++++++++++++++--------
 4 files changed, 81 insertions(+), 25 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index e5c5b6fee4..13c6e470a1 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -19,11 +19,11 @@ import Language.PureScript.Lsp.Log (debugLsp)
 ------------ AST -------------------------------------------------------------------------------------------------------
 ------------------------------------------------------------------------------------------------------------------------
 
-getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> LspNameType -> m (Maybe (Text, Text))
+getAstDeclarationInModule :: (MonadIO m, MonadReader LspEnvironment m) => P.ModuleName -> Text -> LspNameType -> m (Maybe (Text, Maybe Text))
 getAstDeclarationInModule moduleName' name nameType = do
   decls <-
     DB.queryNamed
-      "SELECT name, printed_type FROM ast_declarations WHERE module_name = :module_name AND name = :name AND name_type IS :name_type"
+      "SELECT name, ctr_type FROM ast_declarations WHERE module_name = :module_name AND name = :name AND name_type IS :name_type"
       [ ":module_name" := P.runModuleName moduleName',
         ":name" := name,
         ":name_type" := nameType
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 1b7f990a56..16325ce653 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -63,8 +63,8 @@ getImportEdits cid@(CompleteItemData path moduleName' importedModuleName name na
         Nothing -> do
           errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> show (importedModuleName, name, nameType)
           pure Nothing
-        Just (declName, declType) -> do
-          case addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports of
+        Just (declName, ctrType) -> do
+          case addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName ctrType nameType imports of
             Nothing -> pure Nothing
             Just (newImports, moduleQualifier) -> do
               let importEdits = importsToTextEdit before newImports
@@ -98,14 +98,14 @@ addDeclarationToImports ::
   P.ModuleName ->
   Maybe P.ModuleName ->
   Text ->
-  Text ->
+  Maybe Text ->
   LspNameType ->
   [Import] ->
   Maybe
     ( [Import], -- new imports
       Maybe P.ModuleName -- module qualifier
     )
-addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName declType nameType imports
+addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName ctrType nameType imports
   | importingSelf = Nothing
   | Just existing <- alreadyImportedModuleMb  = case existing of
       Import _ (P.Explicit refs') mName
@@ -135,7 +135,7 @@ addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName
         ValOpNameType -> P.ValueOpRef nullSourceSpan (P.OpName declName)
         TyNameType -> P.TypeRef nullSourceSpan (P.ProperName declName) Nothing
         TyOpNameType -> P.TypeOpRef nullSourceSpan (P.OpName declName)
-        DctorNameType -> P.TypeRef nullSourceSpan (P.ProperName declType) (Just [P.ProperName declName])
+        DctorNameType -> P.TypeRef nullSourceSpan (P.ProperName $ fromMaybe "Ctr type not found" ctrType) (Just [P.ProperName declName])
         TyClassNameType -> P.TypeClassRef nullSourceSpan (P.ProperName declName)
         ModNameType -> P.ModuleRef nullSourceSpan (P.ModuleName declName)
 
diff --git a/src/Language/PureScript/Lsp/Print.hs b/src/Language/PureScript/Lsp/Print.hs
index 310c3ecfb5..aa9eb18303 100644
--- a/src/Language/PureScript/Lsp/Print.hs
+++ b/src/Language/PureScript/Lsp/Print.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE LambdaCase #-}
 
 module Language.PureScript.Lsp.Print where
@@ -28,6 +27,50 @@ printDeclarationTypeMb decl =
     accumTypes (pure . T.pack . P.prettyPrintType maxBound) ^. _1 $
       decl
 
+printType :: P.Type a -> Text
+printType = T.pack . P.prettyPrintType maxBound
+
+printCtrType :: P.SourcePos -> P.ProperName 'P.TypeName -> P.DataConstructorDeclaration -> Text
+printCtrType pos tyName = printType . getCtrType pos tyName
+
+getCtrType :: P.SourcePos -> P.ProperName 'P.TypeName -> P.DataConstructorDeclaration -> P.Type ()
+getCtrType pos tyName ctr = foldr addCtrField (P.TypeConstructor () $ P.Qualified (P.BySourcePos pos) tyName) (P.dataCtorFields ctr)
+
+addCtrField :: (P.Ident, P.SourceType) -> P.Type () -> P.Type ()
+addCtrField (_ident, ty) acc = ty `arrow` acc
+
+printDataDeclType :: P.ProperName 'P.TypeName -> [(Text, Maybe P.SourceType)] -> Text
+printDataDeclType tyName = printType . getDataDeclType tyName
+
+getDataDeclType :: P.ProperName 'P.TypeName -> [(Text, Maybe P.SourceType)] -> P.Type ()
+getDataDeclType tyName args = P.KindedType () tipe kind
+  where
+    tipe :: P.Type ()
+    tipe = foldr addDataDeclArgType (P.TypeVar () $ P.runProperName tyName) args
+
+    kind = foldr addDataDeclArgKind (P.TypeVar () "Type") args
+
+addDataDeclArgType :: (Text, Maybe P.SourceType) -> P.Type () -> P.Type ()
+addDataDeclArgType (ident, _) acc = P.TypeApp () acc (P.TypeVar () ident)
+
+addDataDeclArgKind :: (Text, Maybe P.SourceType) -> P.Type () -> P.Type ()
+addDataDeclArgKind (_ident, tyMb) acc = ty `arrow` acc
+  where
+    ty :: P.Type ()
+    ty = maybe (P.TypeVar () "Type") void tyMb
+
+arrow :: P.Type a -> P.Type () -> P.Type ()
+arrow l r = P.BinaryNoParensType () arrowSymbol (void l) r
+
+arrowSymbol :: P.Type ()
+arrowSymbol = P.TypeOp () (mkQual (P.OpName "->"))
+
+mkQual :: a -> P.Qualified a
+mkQual = P.Qualified (P.BySourcePos nullSourcePos)
+
+nullSourcePos :: P.SourcePos
+nullSourcePos = P.SourcePos 0 0
+
 printName :: P.Name -> Text
 printName = \case
   P.IdentName ident -> P.runIdent ident
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index ee9dfcf6cf..02f3a0eb5d 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -14,7 +14,7 @@ import Language.PureScript.AST qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), externDeclNameType, lspNameType)
-import Language.PureScript.Lsp.Print (printDeclarationType, printEfDeclName, printEfDeclType, printName)
+import Language.PureScript.Lsp.Print (printCtrType, printDataDeclType, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Make qualified as P
@@ -49,12 +49,19 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
         end = P.spanEnd ss
         nameMb = P.declName decl
         printedType = case getOperatorValueName decl >>= disqualifyIfInModule >>= getDeclFromName of
-          Nothing -> printDeclarationType decl -- TODO add check for operators in other modules
           Just decl' -> printDeclarationType decl'
+          Nothing -> case decl of
+            P.TypeDeclaration declData -> printType $ P.tydeclType declData
+            P.DataDeclaration _ _ tyName args _ -> printDataDeclType tyName args
+            _ -> printDeclarationType decl
     for_ nameMb \name -> do
-      let 
-          exported = Set.member name exportedNames
+      let exported = Set.member name exportedNames
           nameType = lspNameType name
+          printedName = printName name
+      when (printName name == "Tuple") $ do 
+        putErrLn $ ("Tuple: " :: Text) <> show decl
+        putErrLn $ ("type: " :: Text) <> printedType
+
       SQL.executeNamed
         conn
         ( SQL.Query
@@ -63,7 +70,7 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
             \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
         )
         [ ":module_name" := P.runModuleName moduleName',
-          ":name" := printName name,
+          ":name" := printedName,
           ":printed_type" := printedType,
           ":name_type" := nameType,
           ":start_line" := P.sourcePosLine start,
@@ -75,22 +82,26 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
           ":exported" := exported,
           ":generated" := "$Dict" `T.isInfixOf` printedType
         ]
+      for_ (declCtrs decl) $
+        \(sa, tyName, ctrs) ->
+          for_ ctrs $ \ctr -> do
+            let (ss', _) = P.dataCtorAnn ctr
+                start' = P.spanStart ss'
+                end' = P.spanEnd ss'
+                ctrPrintedType = printCtrType (P.spanStart $ fst sa) tyName ctr
 
-      for_ (declCtrs decl) \ctr ->
-        let (ss', _) = P.dataCtorAnn ctr
-            start' = P.spanStart ss'
-            end' = P.spanEnd ss'
-         in SQL.executeNamed
+            SQL.executeNamed
               conn
               ( SQL.Query
                   "INSERT INTO ast_declarations \
-                  \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
-                  \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
+                  \         (module_name, name, printed_type, name_type, ctr_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+                  \ VALUES (:module_name, :name, :printed_type, :name_type, :ctr_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
               )
               [ ":module_name" := P.runModuleName moduleName',
                 ":name" := P.runProperName (P.dataCtorName ctr),
-                ":printed_type" := printName name,
+                ":printed_type" := ctrPrintedType,
                 ":name_type" := DctorNameType,
+                ":ctr_type" := printedName,
                 ":start_line" := P.sourcePosLine start',
                 ":end_line" := P.sourcePosLine end',
                 ":start_col" := P.sourcePosColumn start',
@@ -111,10 +122,10 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
     disqualifyIfInModule (P.Qualified (P.BySourcePos _) name) = Just name
     disqualifyIfInModule _ = Nothing
 
-declCtrs :: P.Declaration -> [P.DataConstructorDeclaration]
+declCtrs :: P.Declaration -> Maybe (P.SourceAnn, P.ProperName 'P.TypeName, [P.DataConstructorDeclaration])
 declCtrs = \case
-  P.DataDeclaration _ _ _ _ ctors -> ctors
-  _ -> []
+  P.DataDeclaration sa _ n _ ctors -> Just (sa, n, ctors)
+  _ -> Nothing
 
 indexAstModuleFromExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()
 indexAstModuleFromExtern conn extern = liftIO do
@@ -237,7 +248,7 @@ initDb conn = do
   SQL.execute_
     conn
     "CREATE TABLE IF NOT EXISTS ast_declarations \
-    \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, generated BOOLEAN, \
+    \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, ctr_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, generated BOOLEAN, \
     \UNIQUE(module_name, name_type, name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
@@ -249,6 +260,8 @@ addDbIndexes :: Connection -> IO ()
 addDbIndexes conn = do
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_module_name ON ast_declarations (module_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_name ON ast_declarations (name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_name_type ON ast_declarations (name_type)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_ctr_type ON ast_declarations (ctr_type)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_start_line ON ast_declarations (start_line)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS ast_declarations_end_line ON ast_declarations (end_line)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS externs_path ON externs (path)"

From ea57f219bc31e22c88ca9848e93283ec0420ae73 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 23 Oct 2024 15:19:45 +0200
Subject: [PATCH 189/297] remove logs

---
 src/Language/PureScript/Make/Index.hs | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 02f3a0eb5d..2391a2b71b 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -58,9 +58,6 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
       let exported = Set.member name exportedNames
           nameType = lspNameType name
           printedName = printName name
-      when (printName name == "Tuple") $ do 
-        putErrLn $ ("Tuple: " :: Text) <> show decl
-        putErrLn $ ("type: " :: Text) <> printedType
 
       SQL.executeNamed
         conn

From d52bd4dc2e9a9e597a54b2d77d70e6c3da8778d9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 23 Oct 2024 15:20:01 +0200
Subject: [PATCH 190/297] display name types in autocomplete

---
 src/Language/PureScript/Lsp/Handlers/Completion.hs | 12 +++++++-----
 src/Language/PureScript/Lsp/NameType.hs            | 11 +++++++++++
 2 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 9315630321..baf66a7a25 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -20,7 +20,7 @@ import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.NameType (LspNameType (..))
+import Language.PureScript.Lsp.NameType (LspNameType (..), readableType)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (getSymbolAt)
@@ -79,7 +79,7 @@ completionAndResolveHandlers =
                                     Just $
                                       Types.CompletionItemLabelDetails
                                         (Just $ " " <> crType cr)
-                                        (Just $ P.runModuleName declModName),
+                                        (Just $ readableType (crNameType cr) <> " in " <> P.runModuleName declModName),
                                   _kind =
                                     Just case nameType of
                                       IdentNameType | "->" `T.isInfixOf` crType cr -> Types.CompletionItemKind_Function
@@ -116,12 +116,14 @@ completionAndResolveHandlers =
             docsMb <- readDeclarationDocsWithNameType declModule nameType label
             debugLsp $ "docs found for " <> show (declModule, label) <> show (isJust docsMb)
             withImports <- addImportToTextEdit completionItem cid
-            let addDocs :: Types.CompletionItem -> Types.CompletionItem
+            let setDocs docs = set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
+
+                addDocs :: Types.CompletionItem -> Types.CompletionItem
                 addDocs =
                   docsMb & maybe
-                    identity
+                    (setDocs $ readableType nameType)
                     \docs ->
-                      set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
+                      setDocs (readableType nameType <> "\n\n" <> docs)
             res $
               Right $
                 withImports
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index a219a7c5bb..9f715095d6 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -19,6 +19,17 @@ data LspNameType
   | ModNameType
   deriving (Show, Read, Eq, Generic, A.ToJSON, A.FromJSON)
 
+
+readableType :: LspNameType -> Text
+readableType = \case
+  IdentNameType -> "Value"
+  ValOpNameType -> "Operator"
+  TyNameType -> "Type"
+  TyOpNameType -> "Type Operator"
+  DctorNameType -> "Constructor"
+  TyClassNameType -> "Type Class"
+  ModNameType -> "Module"
+
 instance ToField LspNameType where
   toField = toField . (show :: LspNameType -> Text)
 

From b8da8a882b133a9212c9f08a9b6d3472f3097296 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 23 Oct 2024 15:25:10 +0200
Subject: [PATCH 191/297] check for more possible errors due to cache

---
 src/Language/PureScript/Lsp/Rebuild.hs | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index fe7dbaa00e..d531ec68b4 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,7 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE NumDecimals #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 -- {-# OPTIONS_GHC -Wno-unused-top-binds #-}
@@ -71,8 +69,6 @@ rebuildFile uri =
           Nothing -> do
             rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
   where
-    -- liftIO . atomically $ writeTChan chan Nothing
-
     rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m (Language.PureScript.Lsp.Types.OpenFile moduleName _ externDeps env _) = do
       let externs = fmap edExtern externDeps
       foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
@@ -115,6 +111,8 @@ couldBeFromNewImports :: P.ErrorMessage -> Bool
 couldBeFromNewImports =
   P.unwrapErrorMessage >>> \case
     P.ModuleNotFound {} -> True
+    P.UnknownImport {} -> True
+    P.UnknownImportDataConstructor {} -> True
     P.UnknownName qName | (P.ModName _) <- P.disqualify qName -> True
     _ -> False
 

From 5f83c13503ec0e8b21a343251f6b9231d446da1d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 23 Oct 2024 16:54:44 +0200
Subject: [PATCH 192/297] dont show value inline for completion

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 52 +++++++++++--------
 .../PureScript/Lsp/Handlers/Completion.hs     |  9 ++--
 src/Language/PureScript/Lsp/NameType.hs       | 10 ++--
 src/Language/PureScript/Lsp/Util.hs           |  2 +-
 4 files changed, 43 insertions(+), 30 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 6720653b35..405a154ec6 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.Lsp.AtPosition where
 
-import Control.Lens (Field1 (_1), view)
+import Control.Lens (Field1 (_1), view, At)
 import Data.Text qualified as T
 import Language.LSP.Protocol.Types qualified as Types
 -- import Language.PureScript.Lsp.Monad (m)
@@ -18,30 +20,39 @@ import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
 import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude
+import Language.PureScript.AST.Declarations (declSourceSpan)
 
--- data AtPosition = AtPosition
---   { apExpr :: [P.Expr],
---     apBinders :: [P.Binder],
---     apType :: [P.SourceType],
---     apDecl :: Maybe P.Declaration,
---     apImport :: Maybe (P.SourceSpan, P.DeclarationRef),
---     apModuleImport :: Maybe (P.SourceSpan, P.ModuleName)
---   }
+data AtPosition = AtPosition
+  { apDeclTopLevel :: Maybe P.Declaration,
+    apDecls :: [P.Declaration],
+    apExprs :: [P.Expr],
+    apBinders :: [P.Binder],
+    apCaseAlternatives :: [P.CaseAlternative],
+    apDoNotationElements :: [P.DoNotationElement],
+    apGuards :: [P.Guard],
+    apTypes :: [P.SourceType],
+    apImport :: Maybe (P.SourceSpan, P.ModuleName, Maybe P.DeclarationRef)
+  } deriving (Show)
 
+nullAtPosition :: AtPosition
+nullAtPosition = AtPosition Nothing [] [] [] [] [] [] [] Nothing
+
+topLevelDeclAtPosition :: P.Declaration -> AtPosition
+topLevelDeclAtPosition decl = nullAtPosition { apDeclTopLevel = Just decl }
 
--- nullAtPosition :: AtPosition
--- nullAtPosition = AtPosition [] [] [] Nothing Nothing Nothing
 
 -- getAtPosition :: [P.Declaration] -> Types.Position -> AtPosition
--- getAtPosition decls pos@(Types.Position{..}) = case head $ declsAtLine (fromIntegral _line + 1) decls of 
---     Nothing -> nullAtPosition
---     Just decl -> AtPosition
---       { apExpr = getExprsAtPos pos decl,
---         apType = getTypesAtPos pos decl,
---         apDecl = Just decl,
---         apImport = findDeclRefAtPos pos (P.getModuleImports decl) <&> \import' -> (P.declRefSourceSpan import', import'),
---         apModuleImport = find (posInSpan pos . fst) (P.getModuleImports decl) 
---       }
+-- getAtPosition decls pos@(Types.Position {..}) = case head $ declsAtLine (fromIntegral _line + 1) decls of
+--   Nothing -> nullAtPosition
+--   Just decl -> execS
+--     where
+--       (handleDecl, _, _ , _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan)
+
+-- getBindersAtPos :: Types.Position -> P.Declaration -> [P.Binder]
+-- getBindersAtPos pos decl
+
+-- ()
+-- importDecl = case decl of
 
 atPosition ::
   forall m.
@@ -244,4 +255,3 @@ getImportRefNameType = \case
   P.ModuleRef _ _ -> ModNameType
   P.ReExportRef _ _ _ -> ModNameType
   P.TypeInstanceRef _ _ _ -> IdentNameType
-
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index baf66a7a25..e23821e4b7 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -20,7 +20,7 @@ import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.NameType (LspNameType (..), readableType)
+import Language.PureScript.Lsp.NameType (LspNameType (..), readableType, readableTypeIn)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
 import Language.PureScript.Lsp.Types (CompleteItemData (CompleteItemData), decodeCompleteItemData)
 import Language.PureScript.Lsp.Util (getSymbolAt)
@@ -79,7 +79,7 @@ completionAndResolveHandlers =
                                     Just $
                                       Types.CompletionItemLabelDetails
                                         (Just $ " " <> crType cr)
-                                        (Just $ readableType (crNameType cr) <> " in " <> P.runModuleName declModName),
+                                        (Just $ readableTypeIn (crNameType cr) <> P.runModuleName declModName),
                                   _kind =
                                     Just case nameType of
                                       IdentNameType | "->" `T.isInfixOf` crType cr -> Types.CompletionItemKind_Function
@@ -114,16 +114,15 @@ completionAndResolveHandlers =
         case result of
           A.Success (Just cid@(CompleteItemData _filePath _mName declModule label nameType _ _)) -> do
             docsMb <- readDeclarationDocsWithNameType declModule nameType label
-            debugLsp $ "docs found for " <> show (declModule, label) <> show (isJust docsMb)
             withImports <- addImportToTextEdit completionItem cid
             let setDocs docs = set LSP.documentation (Just $ Types.InR $ Types.MarkupContent Types.MarkupKind_Markdown docs)
 
                 addDocs :: Types.CompletionItem -> Types.CompletionItem
                 addDocs =
                   docsMb & maybe
-                    (setDocs $ readableType nameType)
+                    (setDocs $ readableType nameType <> " in " <> P.runModuleName declModule)
                     \docs ->
-                      setDocs (readableType nameType <> "\n\n" <> docs)
+                      setDocs (readableType nameType <> " in " <> P.runModuleName declModule <> "\n\n" <> docs)
             res $
               Right $
                 withImports
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index 9f715095d6..b805f5afb9 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -2,12 +2,12 @@
 
 module Language.PureScript.Lsp.NameType where
 
+import Data.Aeson qualified as A
 import Database.SQLite.Simple.FromField (FromField (fromField))
 import Database.SQLite.Simple.ToField (ToField (toField))
+import Language.PureScript.Externs (ExternsDeclaration (..))
 import Language.PureScript.Names
 import Protolude
-import Language.PureScript.Externs (ExternsDeclaration(..))
-import Data.Aeson qualified as A
 
 data LspNameType
   = IdentNameType
@@ -19,7 +19,6 @@ data LspNameType
   | ModNameType
   deriving (Show, Read, Eq, Generic, A.ToJSON, A.FromJSON)
 
-
 readableType :: LspNameType -> Text
 readableType = \case
   IdentNameType -> "Value"
@@ -30,6 +29,11 @@ readableType = \case
   TyClassNameType -> "Type Class"
   ModNameType -> "Module"
 
+readableTypeIn :: LspNameType -> Text
+readableTypeIn = \case
+  IdentNameType -> ""
+  lnt -> readableType lnt <> " in "
+
 instance ToField LspNameType where
   toField = toField . (show :: LspNameType -> Text)
 
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index f90f6a4824..7eb6a0a0e0 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -179,7 +179,7 @@ declsAtLine l = go . sortBy (comparing declStartLine)
       P.ExternDeclaration{} -> True
       P.TypeClassDeclaration {} -> True
       P.TypeInstanceDeclaration {} -> True
-      _ -> True
+      _ -> False
 
 declStartLine :: P.Declaration -> Int
 declStartLine = P.sourcePosLine . AST.spanStart . P.declSourceSpan

From 6ca3705fe0180f98bd664c38d738abffa564b498 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 24 Oct 2024 01:04:49 +0200
Subject: [PATCH 193/297] adds everything at types

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 251 +++++++++++++++---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 151 +++++------
 2 files changed, 293 insertions(+), 109 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 405a154ec6..449b26f401 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -4,13 +4,15 @@
 
 module Language.PureScript.Lsp.AtPosition where
 
-import Control.Lens (Field1 (_1), view, At)
-import Data.Text qualified as T
-import Language.LSP.Protocol.Types qualified as Types
+import Control.Lens (At, Field1 (_1), Field2 (_2), Field3 (_3), un, view)
 -- import Language.PureScript.Lsp.Monad (m)
 
+import Data.List qualified as List
+import Data.Text qualified as T
+import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript qualified as P
+import Language.PureScript.AST.Declarations (declSourceSpan)
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
@@ -18,41 +20,214 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
 import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
+import Language.PureScript.Traversals (defS)
 import Language.PureScript.Types (getAnnForType)
 import Protolude
-import Language.PureScript.AST.Declarations (declSourceSpan)
 
-data AtPosition = AtPosition
+data AtPos
+  = APExpr P.SourceSpan Bool P.Expr
+  | APBinder P.SourceSpan Bool P.Binder
+  | APCaseAlternative P.SourceSpan P.CaseAlternative
+  | APDoNotationElement P.SourceSpan Bool P.DoNotationElement
+  | APGuard P.SourceSpan P.Guard
+  | APType P.SourceType
+  | APImport P.SourceSpan P.ModuleName P.ImportDeclarationType (Maybe P.DeclarationRef)
+  | APDecl P.Declaration
+
+getSmallestAtPos :: EverythingAtPos -> Maybe AtPos
+getSmallestAtPos = \case
+  EverythingAtPos {apImport = Just import'} ->
+    Just $ uncurry4 APImport import'
+  EverythingAtPos {apTypes = types}
+    | not . null $ types ->
+        Just $ APType $ minimumBy (comparing getTypeRowsAndColumns) types
+  EverythingAtPos {apBinders = binders}
+    | not . null $ binders ->
+        Just $ uncurry3 APBinder $ minimumBy (comparing (spanSize . view _1)) binders
+  EverythingAtPos {apExprs = exprs}
+    | not . null $ exprs ->
+        Just $ uncurry3 APExpr $ minimumBy (comparing (spanSize . view _1)) exprs
+  EverythingAtPos {apCaseAlternatives = caseAlts}
+    | not . null $ caseAlts ->
+        Just $ uncurry APCaseAlternative $ minimumBy (comparing (spanSize . view _1)) caseAlts
+  EverythingAtPos {apDoNotationElements = doNotElems}
+    | not . null $ doNotElems ->
+        Just $ uncurry3 APDoNotationElement $ minimumBy (comparing (spanSize . view _1)) doNotElems
+  EverythingAtPos {apGuards = guards}
+    | not . null $ guards ->
+        Just $ uncurry APGuard $ minimumBy (comparing (spanSize . view _1)) guards
+  EverythingAtPos {apDecls = decls}
+    | not . null $ decls ->
+        Just $ APDecl $ minimumBy (comparing (spanSize . declSourceSpan)) decls
+  EverythingAtPos {apDeclTopLevel = Just decl} ->
+    Just $ APDecl decl
+  _ -> Nothing
+
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 f (a, b, c, d) = f a b c d
+
+spanSize :: P.SourceSpan -> (Int, Int)
+spanSize (P.SourceSpan _ start end) = (P.sourcePosLine end - P.sourcePosLine start, P.sourcePosColumn end - P.sourcePosColumn start)
+
+data EverythingAtPos = EverythingAtPos
   { apDeclTopLevel :: Maybe P.Declaration,
     apDecls :: [P.Declaration],
-    apExprs :: [P.Expr],
-    apBinders :: [P.Binder],
-    apCaseAlternatives :: [P.CaseAlternative],
-    apDoNotationElements :: [P.DoNotationElement],
-    apGuards :: [P.Guard],
+    apExprs :: [(P.SourceSpan, Bool, P.Expr)],
+    apBinders :: [(P.SourceSpan, Bool, P.Binder)],
+    apCaseAlternatives :: [(P.SourceSpan, P.CaseAlternative)],
+    apDoNotationElements :: [(P.SourceSpan, Bool, P.DoNotationElement)],
+    apGuards :: [(P.SourceSpan, P.Guard)],
     apTypes :: [P.SourceType],
-    apImport :: Maybe (P.SourceSpan, P.ModuleName, Maybe P.DeclarationRef)
-  } deriving (Show)
-
-nullAtPosition :: AtPosition
-nullAtPosition = AtPosition Nothing [] [] [] [] [] [] [] Nothing
-
-topLevelDeclAtPosition :: P.Declaration -> AtPosition
-topLevelDeclAtPosition decl = nullAtPosition { apDeclTopLevel = Just decl }
-
-
--- getAtPosition :: [P.Declaration] -> Types.Position -> AtPosition
--- getAtPosition decls pos@(Types.Position {..}) = case head $ declsAtLine (fromIntegral _line + 1) decls of
---   Nothing -> nullAtPosition
---   Just decl -> execS
---     where
---       (handleDecl, _, _ , _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan)
-
--- getBindersAtPos :: Types.Position -> P.Declaration -> [P.Binder]
--- getBindersAtPos pos decl
-
--- ()
--- importDecl = case decl of
+    apImport :: Maybe (P.SourceSpan, P.ModuleName, P.ImportDeclarationType, Maybe P.DeclarationRef)
+  }
+  deriving (Show)
+
+
+nullEverythingAtPos :: EverythingAtPos
+nullEverythingAtPos = EverythingAtPos Nothing [] [] [] [] [] [] [] Nothing
+
+withSpansOnly :: EverythingAtPos -> EverythingAtPos
+withSpansOnly EverythingAtPos {..} =
+  EverythingAtPos
+    apDeclTopLevel
+    apDecls
+    (filter (view _2) apExprs)
+    (filter (view _2) apBinders)
+    []
+    (filter (view _2) apDoNotationElements)
+    []
+    apTypes
+    apImport
+
+withTypedValuesOnly :: EverythingAtPos -> EverythingAtPos
+withTypedValuesOnly EverythingAtPos {..} =
+  EverythingAtPos
+    apDeclTopLevel
+    apDecls
+    (filter (isJust . exprTypes . view _3) apExprs)
+    []
+    []
+    []
+    []
+    apTypes
+    apImport
+  where
+    (declTypes, exprTypes, binderTypes, _, _) = 
+        P.accumTypes (const $ Just ())
+
+
+getEverythingAtPos :: [P.Declaration] -> Types.Position -> EverythingAtPos
+getEverythingAtPos decls pos@(Types.Position {..}) = case head $ declsAtLine (fromIntegral _line + 1) decls of
+  Nothing -> nullEverythingAtPos
+  Just (P.ImportDeclaration (ss, _) importedModuleName importType _) ->
+    nullEverythingAtPos {apImport = Just (ss, importedModuleName, importType, ref)}
+    where
+      ref = findDeclRefAtPos pos case importType of
+        P.Implicit -> []
+        P.Explicit refs -> refs
+        P.Hiding refs -> refs
+  Just topDecl -> execState (handleDecl topDecl) nullEverythingAtPos
+    where
+      (handleDecl, _, _, _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan topDecl) onDecl onExpr onBinder onCaseAlternative onDoNotationElement onGuard
+
+      onDecl :: P.SourceSpan -> P.Declaration -> StateT EverythingAtPos Identity (P.SourceSpan, P.Declaration)
+      onDecl _ decl = do
+        let ss = declSourceSpan decl
+        when (posInSpan pos ss) do
+          modify $ addDecl decl
+        addTypesSt $ declTypes decl
+        pure (ss, decl)
+
+      onExpr ss expr = do
+        let ssMb = P.exprSourceSpan expr
+            ss' = fromMaybe ss ssMb
+        when (posInSpan pos ss) do
+          modify $ addExpr ss (isJust ssMb) expr
+        addTypesSt $ exprTypes expr
+        pure (ss', expr)
+
+      onBinder ss binder = do
+        let ssMb = binderSourceSpan binder
+            ss' = fromMaybe ss ssMb
+        when (posInSpan pos ss) do
+          modify $ addBinder ss (isJust ssMb) binder
+        addTypesSt $ binderTypes binder
+        pure (ss', binder)
+
+      onCaseAlternative :: P.SourceSpan -> P.CaseAlternative -> StateT EverythingAtPos Identity (P.SourceSpan, P.CaseAlternative)
+      onCaseAlternative ss caseAlt = do
+        when (posInSpan pos ss) do
+          modify $ addCaseAlternative ss caseAlt
+        addTypesSt $ caseAltTypes caseAlt
+        pure (ss, caseAlt)
+
+      onDoNotationElement :: P.SourceSpan -> P.DoNotationElement -> StateT EverythingAtPos Identity (P.SourceSpan, P.DoNotationElement)
+      onDoNotationElement ss doNotationElement = do
+        let ssMb = doNotationElementSpan doNotationElement
+            ss' = fromMaybe ss ssMb
+        when (posInSpan pos ss) do
+          modify $ addDoNotationElement ss' (isJust ssMb) doNotationElement
+        addTypesSt $ doNotTypes doNotationElement
+        pure (ss, doNotationElement)
+
+      onGuard :: P.SourceSpan -> P.Guard -> StateT EverythingAtPos Identity (P.SourceSpan, P.Guard)
+      onGuard ss guard' = do
+        when (posInSpan pos ss) do
+          modify (addGuard ss guard')
+        pure (ss, guard')
+
+      binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
+      binderSourceSpan = \case
+        P.NullBinder -> Nothing
+        P.LiteralBinder ss _ -> Just ss
+        P.VarBinder ss _ -> Just ss
+        P.ConstructorBinder ss _ _ -> Just ss
+        P.NamedBinder ss _ _ -> Just ss
+        P.PositionedBinder ss _ _ -> Just ss
+        P.TypedBinder ss _ -> Just (fst $ getAnnForType ss)
+        P.OpBinder ss _ -> Just ss
+        P.BinaryNoParensBinder {} -> Nothing
+        P.ParensInBinder {} -> Nothing
+
+      doNotationElementSpan :: P.DoNotationElement -> Maybe P.SourceSpan
+      doNotationElementSpan = \case
+        P.PositionedDoNotationElement ss _ _ -> Just ss
+        _ -> Nothing
+
+      (declTypes, exprTypes, binderTypes, caseAltTypes, doNotTypes) = P.accumTypes (getTypesAtPos pos)
+
+topLevelDeclEverythingAtPos :: P.Declaration -> EverythingAtPos
+topLevelDeclEverythingAtPos decl = nullEverythingAtPos {apDeclTopLevel = Just decl}
+
+addDecl :: P.Declaration -> EverythingAtPos -> EverythingAtPos
+addDecl decl atPos = atPos {apDecls = decl : apDecls atPos}
+
+addExpr :: P.SourceSpan -> Bool -> P.Expr -> EverythingAtPos -> EverythingAtPos
+addExpr ss hasOwnSs expr atPos = atPos {apExprs = (ss, hasOwnSs, expr) : apExprs atPos}
+
+addBinder :: P.SourceSpan -> Bool -> P.Binder -> EverythingAtPos -> EverythingAtPos
+addBinder ss hasOwnSs binder atPos = atPos {apBinders = (ss, hasOwnSs, binder) : apBinders atPos}
+
+addCaseAlternative :: P.SourceSpan -> P.CaseAlternative -> EverythingAtPos -> EverythingAtPos
+addCaseAlternative ss binder atPos = atPos {apCaseAlternatives = (ss, binder) : apCaseAlternatives atPos}
+
+addDoNotationElement :: P.SourceSpan -> Bool -> P.DoNotationElement -> EverythingAtPos -> EverythingAtPos
+addDoNotationElement ss hasOwnSs doNotationElement atPos =
+  atPos {apDoNotationElements = (ss, hasOwnSs, doNotationElement) : apDoNotationElements atPos}
+
+addGuard :: P.SourceSpan -> P.Guard -> EverythingAtPos -> EverythingAtPos
+addGuard ss guard' atPos = atPos {apGuards = (ss, guard') : apGuards atPos}
+
+addTypes :: [P.SourceType] -> EverythingAtPos -> EverythingAtPos
+addTypes tys atPos = atPos {apTypes = tys <> apTypes atPos}
+
+addTypesSt :: (MonadState EverythingAtPos m) => [P.SourceType] -> m ()
+addTypesSt tys = modify (addTypes tys)
+
+-- getDeclTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
 
 atPosition ::
   forall m.
@@ -112,7 +287,7 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
                   let tipes =
                         filter (not . fromPrim) $
                           filter (not . isNullSourceTypeSpan) $
-                            getTypesAtPos pos decl
+                            getDeclTypesAtPos pos decl
 
                   case tipes of
                     [] -> nullRes
@@ -236,12 +411,18 @@ getTypedValuesAtPos pos declaration = execState (goDecl declaration) []
         _ -> pure ()
       pure expr
 
-getTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
-getTypesAtPos pos decl = P.everythingOnTypes (<>) getAtPos =<< (view _1 $ P.accumTypes getAtPos) decl
+getDeclTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
+getDeclTypesAtPos pos decl = getTypesAtPos pos =<< (view _1 $ P.accumTypes getAtPos) decl
   where
     getAtPos :: P.SourceType -> [P.SourceType]
     getAtPos st = [st | posInSpan pos (fst $ getAnnForType st)]
 
+getTypesAtPos :: Types.Position -> P.SourceType -> [P.SourceType]
+getTypesAtPos pos st = P.everythingOnTypes (<>) getAtPos st
+  where
+    getAtPos :: P.SourceType -> [P.SourceType]
+    getAtPos st' = [st' | posInSpan pos (fst $ getAnnForType st')]
+
 findDeclRefAtPos :: (Foldable t) => Types.Position -> t P.DeclarationRef -> Maybe P.DeclarationRef
 findDeclRefAtPos pos imports = find (posInSpan pos . P.declRefSourceSpan) imports
 
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 07de3a85dc..e7fd073e2f 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -15,9 +15,9 @@ import Language.PureScript.AST.Declarations (Expr (..))
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
+import Language.PureScript.Lsp.AtPosition (findDeclRefAtPos, fromPrim, getDeclTypesAtPos, getEverythingAtPos, getExprsAtPos, getImportRefNameType, getTypeRowsAndColumns, getTypedValuesAtPos, isNullSourceTypeSpan, isPrimImport, smallestExpr, spanToRange)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
-import Language.PureScript.Lsp.AtPosition (findDeclRefAtPos, fromPrim, getExprsAtPos, getImportRefNameType, getTypeRowsAndColumns, getTypedValuesAtPos, getTypesAtPos, isNullSourceTypeSpan, isPrimImport, smallestExpr, spanToRange)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
@@ -76,77 +76,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             respondWithDeclInModule ss nameType importedModuleName (printName name)
           _ -> respondWithModule ss importedModuleName
 
-      handleDecls :: [P.Declaration] -> HandlerM ()
-      handleDecls decls = do
-        let srcPosLine = fromIntegral _line + 1
-
-            declsAtPos =
-              decls
-                & declsAtLine srcPosLine
-
-        debugLsp $ "declsAtPos: " <> show (length declsAtPos)
-
-        forLsp (head declsAtPos) $ \decl -> do
-          case decl of
-            P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
-              case importType of
-                P.Implicit -> respondWithModule ss importedModuleName
-                P.Explicit imports -> respondWithImports ss importedModuleName imports
-                P.Hiding imports -> respondWithImports ss importedModuleName imports
-            P.TypeInstanceDeclaration _ (P.SourceSpan span start end, _) _ _ _ constraints (P.Qualified (P.ByModuleName modName) className) _args body
-              | posInSpan pos classNameSS -> respondWithDeclInModule classNameSS TyClassNameType modName classNameTxt
-              | Just (P.Constraint (ss, _) (P.Qualified (P.ByModuleName conModName) conClassName) _ _ _) <- find (posInSpan pos . fst . P.constraintAnn) constraints -> do
-                  respondWithDeclInModule ss TyClassNameType conModName $ P.runProperName conClassName
-              | P.ExplicitInstance members <- body, not $ null $ declsAtLine srcPosLine members  -> do
-                  handleDecls members
-              where
-                classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
-
-                classNameTxt :: Text
-                classNameTxt = P.runProperName className
-            _ -> do
-              let exprsAtPos = getExprsAtPos pos =<< declsAtPos
-                  findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
-                  findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
-                  findTypedExpr (_ : es) = findTypedExpr es
-                  findTypedExpr [] = Nothing
-
-              debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
-
-              case smallestExpr exprsAtPos of
-                Just expr -> do
-                  case expr of
-                    P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                      respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
-                    P.Op ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                      respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
-                    P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
-                      respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
-                    _ -> forLsp (findTypedExpr $ getTypedValuesAtPos pos decl) (respondWithSourceType expr)
-                _ -> do
-                  let tipes =
-                        filter (not . fromPrim) $
-                          filter (not . isNullSourceTypeSpan) $
-                            getTypesAtPos pos decl
-
-                  debugLsp $ "tipes: " <> show (length tipes)
-
-                  case tipes of
-                    [] -> nullRes
-                    _ -> do
-                      let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
-                      debugLsp $ "smallest: " <> show smallest
-                      case smallest of
-                        P.TypeConstructor (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
-                          respondWithDeclInModule ss TyNameType modName $ P.runProperName ident
-                        P.TypeOp (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
-                          respondWithDeclInModule ss TyOpNameType modName $ P.runOpName ident
-                        P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of
-                          (P.Qualified (P.ByModuleName modName) ident) -> do
-                            respondWithDeclInModule ss TyClassNameType modName $ P.runProperName ident
-                          _ -> nullRes
-                        _ -> nullRes
-
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -155,8 +84,82 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               & P.getModuleDeclarations
               & filter (not . isPrimImport)
 
-      handleDecls withoutPrim
-
+      let everything = getEverythingAtPos pos (P.getModuleDeclarations ofModule)
+      case everything of 
+        EverythingAtPos { apTypes = types } | not $ null types -> do 
+          let ty = minimumBy (comparing getTypeRowsAndColumns) types
+          respondWith
+
+-- handleDecls :: [P.Declaration] -> HandlerM ()
+-- handleDecls decls = do
+--   let srcPosLine = fromIntegral _line + 1
+
+--       declsAtPos =
+--         decls
+--           & declsAtLine srcPosLine
+
+--   debugLsp $ "declsAtPos: " <> show (length declsAtPos)
+
+--   forLsp (head declsAtPos) $ \decl -> do
+--     case decl of
+--       P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
+--         case importType of
+--           P.Implicit -> respondWithModule ss importedModuleName
+--           P.Explicit imports -> respondWithImports ss importedModuleName imports
+--           P.Hiding imports -> respondWithImports ss importedModuleName imports
+--       P.TypeInstanceDeclaration _ (P.SourceSpan span start end, _) _ _ _ constraints (P.Qualified (P.ByModuleName modName) className) _args body
+--         | posInSpan pos classNameSS -> respondWithDeclInModule classNameSS TyClassNameType modName classNameTxt
+--         | Just (P.Constraint (ss, _) (P.Qualified (P.ByModuleName conModName) conClassName) _ _ _) <- find (posInSpan pos . fst . P.constraintAnn) constraints -> do
+--             respondWithDeclInModule ss TyClassNameType conModName $ P.runProperName conClassName
+--         | P.ExplicitInstance members <- body, not $ null $ declsAtLine srcPosLine members  -> do
+--             handleDecls members
+--         where
+--           classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
+
+--           classNameTxt :: Text
+--           classNameTxt = P.runProperName className
+--       _ -> do
+--         let exprsAtPos = getExprsAtPos pos =<< declsAtPos
+--             findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
+--             findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
+--             findTypedExpr (_ : es) = findTypedExpr es
+--             findTypedExpr [] = Nothing
+
+--         debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
+
+--         case smallestExpr exprsAtPos of
+--           Just expr -> do
+--             case expr of
+--               P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
+--                 respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
+--               P.Op ss (P.Qualified (P.ByModuleName modName) ident) -> do
+--                 respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+--               P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
+--                 respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
+--               _ -> forLsp (findTypedExpr $ getTypedValuesAtPos pos decl) (respondWithSourceType expr)
+--           _ -> do
+--             let tipes =
+--                   filter (not . fromPrim) $
+--                     filter (not . isNullSourceTypeSpan) $
+--                       getDeclTypesAtPos pos decl
+
+--             debugLsp $ "tipes: " <> show (length tipes)
+
+--             case tipes of
+--               [] -> nullRes
+--               _ -> do
+--                 let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
+--                 debugLsp $ "smallest: " <> show smallest
+--                 case smallest of
+--                   P.TypeConstructor (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
+--                     respondWithDeclInModule ss TyNameType modName $ P.runProperName ident
+--                   P.TypeOp (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
+--                     respondWithDeclInModule ss TyOpNameType modName $ P.runOpName ident
+--                   P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of
+--                     (P.Qualified (P.ByModuleName modName) ident) -> do
+--                       respondWithDeclInModule ss TyClassNameType modName $ P.runProperName ident
+--                     _ -> nullRes
+--                   _ -> nullRes
 pursTypeStr :: Text -> Maybe Text -> [P.Comment] -> Text
 pursTypeStr word type' comments =
   "```purescript\n"

From 5b44ffaf251ed94a8dc6b3ec6a60cd2cc03b7679 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 25 Oct 2024 00:46:05 +0200
Subject: [PATCH 194/297] hover working for expressions

---
 src/Language/PureScript/AST/SourcePos.hs      |  96 +++---
 src/Language/PureScript/Lsp/AtPosition.hs     | 320 ++++++++++++------
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 202 ++++++-----
 src/Language/PureScript/Lsp/Util.hs           |  27 +-
 src/Language/PureScript/Pretty/Values.hs      |   1 +
 5 files changed, 385 insertions(+), 261 deletions(-)

diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index 262d44b6a1..c65ed4657d 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -1,44 +1,47 @@
 {-# LANGUAGE DeriveAnyClass #-}
+
 -- |
 -- Source position information
---
 module Language.PureScript.AST.SourcePos where
 
-import Prelude
-
 import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
-import Data.Aeson ((.=), (.:))
+import Data.Aeson ((.:), (.=))
+import Data.Aeson qualified as A
 import Data.Text (Text)
+import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Language.PureScript.Comments (Comment)
-import Data.Aeson qualified as A
-import Data.Text qualified as T
 import System.FilePath (makeRelative)
+import Prelude
 
 -- | Source annotation - position information and comments.
 type SourceAnn = (SourceSpan, [Comment])
 
 -- | Source position information
 data SourcePos = SourcePos
-  { sourcePosLine :: Int
-    -- ^ Line number
-  , sourcePosColumn :: Int
-    -- ^ Column number
-  } deriving (Show, Eq, Ord, Generic, NFData, Serialise)
+  { -- | Line number
+    sourcePosLine :: Int,
+    -- | Column number
+    sourcePosColumn :: Int
+  }
+  deriving (Show, Eq, Ord, Generic, NFData, Serialise)
 
 displaySourcePos :: SourcePos -> Text
 displaySourcePos sp =
-  "line " <> T.pack (show (sourcePosLine sp)) <>
-    ", column " <> T.pack (show (sourcePosColumn sp))
+  "line "
+    <> T.pack (show (sourcePosLine sp))
+    <> ", column "
+    <> T.pack (show (sourcePosColumn sp))
 
 displaySourcePosShort :: SourcePos -> Text
 displaySourcePosShort sp =
-  T.pack (show (sourcePosLine sp)) <>
-    ":" <> T.pack (show (sourcePosColumn sp))
+  T.pack (show (sourcePosLine sp))
+    <> ":"
+    <> T.pack (show (sourcePosColumn sp))
 
 instance A.ToJSON SourcePos where
-  toJSON SourcePos{..} =
+  toJSON SourcePos {..} =
     A.toJSON [sourcePosLine, sourcePosColumn]
 
 instance A.FromJSON SourcePos where
@@ -47,44 +50,52 @@ instance A.FromJSON SourcePos where
     return $ SourcePos line col
 
 data SourceSpan = SourceSpan
-  { spanName :: String
-    -- ^ Source name
-  , spanStart :: SourcePos
-    -- ^ Start of the span
-  , spanEnd :: SourcePos
-    -- ^ End of the span
-  } deriving (Show, Eq, Ord, Generic, NFData, Serialise)
+  { -- | Source name
+    spanName :: String,
+    -- | Start of the span
+    spanStart :: SourcePos,
+    -- | End of the span
+    spanEnd :: SourcePos
+  }
+  deriving (Eq, Ord, Show, Generic, NFData, Serialise)
 
 displayStartEndPos :: SourceSpan -> Text
 displayStartEndPos sp =
-  "(" <>
-  displaySourcePos (spanStart sp) <> " - " <>
-  displaySourcePos (spanEnd sp) <> ")"
+  "("
+    <> displaySourcePos (spanStart sp)
+    <> " - "
+    <> displaySourcePos (spanEnd sp)
+    <> ")"
 
 displayStartEndPosShort :: SourceSpan -> Text
 displayStartEndPosShort sp =
-  displaySourcePosShort (spanStart sp) <> " - " <>
-  displaySourcePosShort (spanEnd sp)
+  displaySourcePosShort (spanStart sp)
+    <> " - "
+    <> displaySourcePosShort (spanEnd sp)
 
 displaySourceSpan :: FilePath -> SourceSpan -> Text
 displaySourceSpan relPath sp =
-  T.pack (makeRelative relPath (spanName sp)) <> ":" <>
-    displayStartEndPosShort sp <> " " <>
-    displayStartEndPos sp
+  T.pack (makeRelative relPath (spanName sp))
+    <> ":"
+    <> displayStartEndPosShort sp
+    <> " "
+    <> displayStartEndPos sp
+
 
 instance A.ToJSON SourceSpan where
-  toJSON SourceSpan{..} =
-    A.object [ "name"  .= spanName
-             , "start" .= spanStart
-             , "end"   .= spanEnd
-             ]
+  toJSON SourceSpan {..} =
+    A.object
+      [ "name" .= spanName,
+        "start" .= spanStart,
+        "end" .= spanEnd
+      ]
 
 instance A.FromJSON SourceSpan where
   parseJSON = A.withObject "SourceSpan" $ \o ->
-    SourceSpan     <$>
-      o .: "name"  <*>
-      o .: "start" <*>
-      o .: "end"
+    SourceSpan
+      <$> o .: "name"
+      <*> o .: "start"
+      <*> o .: "end"
 
 internalModuleSourceSpan :: String -> SourceSpan
 internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)
@@ -111,8 +122,9 @@ widenSourceSpan a NullSourceSpan = a
 widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) =
   SourceSpan n (min s1 s2) (max e1 e2)
   where
-  n | n1 == ""  = n2
-    | otherwise = n1
+    n
+      | n1 == "" = n2
+      | otherwise = n1
 
 widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn
 widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, [])
diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 449b26f401..0d2e592a3f 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -9,6 +9,7 @@ import Control.Lens (At, Field1 (_1), Field2 (_2), Field3 (_3), un, view)
 
 import Data.List qualified as List
 import Data.Text qualified as T
+import GHC.IO (unsafePerformIO)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript qualified as P
@@ -40,7 +41,7 @@ getSmallestAtPos = \case
     Just $ uncurry4 APImport import'
   EverythingAtPos {apTypes = types}
     | not . null $ types ->
-        Just $ APType $ minimumBy (comparing getTypeRowsAndColumns) types
+        Just $ APType $ minimumBy (comparing getTypeLinesAndColumns) types
   EverythingAtPos {apBinders = binders}
     | not . null $ binders ->
         Just $ uncurry3 APBinder $ minimumBy (comparing (spanSize . view _1)) binders
@@ -59,8 +60,6 @@ getSmallestAtPos = \case
   EverythingAtPos {apDecls = decls}
     | not . null $ decls ->
         Just $ APDecl $ minimumBy (comparing (spanSize . declSourceSpan)) decls
-  EverythingAtPos {apDeclTopLevel = Just decl} ->
-    Just $ APDecl decl
   _ -> Nothing
 
 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
@@ -73,8 +72,7 @@ spanSize :: P.SourceSpan -> (Int, Int)
 spanSize (P.SourceSpan _ start end) = (P.sourcePosLine end - P.sourcePosLine start, P.sourcePosColumn end - P.sourcePosColumn start)
 
 data EverythingAtPos = EverythingAtPos
-  { apDeclTopLevel :: Maybe P.Declaration,
-    apDecls :: [P.Declaration],
+  { apDecls :: [P.Declaration],
     apExprs :: [(P.SourceSpan, Bool, P.Expr)],
     apBinders :: [(P.SourceSpan, Bool, P.Binder)],
     apCaseAlternatives :: [(P.SourceSpan, P.CaseAlternative)],
@@ -85,14 +83,12 @@ data EverythingAtPos = EverythingAtPos
   }
   deriving (Show)
 
-
 nullEverythingAtPos :: EverythingAtPos
-nullEverythingAtPos = EverythingAtPos Nothing [] [] [] [] [] [] [] Nothing
+nullEverythingAtPos = EverythingAtPos [] [] [] [] [] [] [] Nothing
 
 withSpansOnly :: EverythingAtPos -> EverythingAtPos
 withSpansOnly EverythingAtPos {..} =
   EverythingAtPos
-    apDeclTopLevel
     apDecls
     (filter (view _2) apExprs)
     (filter (view _2) apBinders)
@@ -105,102 +101,105 @@ withSpansOnly EverythingAtPos {..} =
 withTypedValuesOnly :: EverythingAtPos -> EverythingAtPos
 withTypedValuesOnly EverythingAtPos {..} =
   EverythingAtPos
-    apDeclTopLevel
     apDecls
     (filter (isJust . exprTypes . view _3) apExprs)
-    []
+    (filter (isJust . binderTypes . view _3) apBinders)
     []
     []
     []
     apTypes
     apImport
   where
-    (declTypes, exprTypes, binderTypes, _, _) = 
-        P.accumTypes (const $ Just ())
-
+    (_, exprTypes, binderTypes, _, _) =
+      P.accumTypes (const $ Just ())
 
 getEverythingAtPos :: [P.Declaration] -> Types.Position -> EverythingAtPos
-getEverythingAtPos decls pos@(Types.Position {..}) = case head $ declsAtLine (fromIntegral _line + 1) decls of
-  Nothing -> nullEverythingAtPos
-  Just (P.ImportDeclaration (ss, _) importedModuleName importType _) ->
-    nullEverythingAtPos {apImport = Just (ss, importedModuleName, importType, ref)}
-    where
-      ref = findDeclRefAtPos pos case importType of
-        P.Implicit -> []
-        P.Explicit refs -> refs
-        P.Hiding refs -> refs
-  Just topDecl -> execState (handleDecl topDecl) nullEverythingAtPos
-    where
-      (handleDecl, _, _, _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan topDecl) onDecl onExpr onBinder onCaseAlternative onDoNotationElement onGuard
-
-      onDecl :: P.SourceSpan -> P.Declaration -> StateT EverythingAtPos Identity (P.SourceSpan, P.Declaration)
-      onDecl _ decl = do
-        let ss = declSourceSpan decl
-        when (posInSpan pos ss) do
-          modify $ addDecl decl
-        addTypesSt $ declTypes decl
-        pure (ss, decl)
-
-      onExpr ss expr = do
-        let ssMb = P.exprSourceSpan expr
-            ss' = fromMaybe ss ssMb
-        when (posInSpan pos ss) do
-          modify $ addExpr ss (isJust ssMb) expr
-        addTypesSt $ exprTypes expr
-        pure (ss', expr)
-
-      onBinder ss binder = do
-        let ssMb = binderSourceSpan binder
-            ss' = fromMaybe ss ssMb
-        when (posInSpan pos ss) do
-          modify $ addBinder ss (isJust ssMb) binder
-        addTypesSt $ binderTypes binder
-        pure (ss', binder)
-
-      onCaseAlternative :: P.SourceSpan -> P.CaseAlternative -> StateT EverythingAtPos Identity (P.SourceSpan, P.CaseAlternative)
-      onCaseAlternative ss caseAlt = do
-        when (posInSpan pos ss) do
-          modify $ addCaseAlternative ss caseAlt
-        addTypesSt $ caseAltTypes caseAlt
-        pure (ss, caseAlt)
-
-      onDoNotationElement :: P.SourceSpan -> P.DoNotationElement -> StateT EverythingAtPos Identity (P.SourceSpan, P.DoNotationElement)
-      onDoNotationElement ss doNotationElement = do
-        let ssMb = doNotationElementSpan doNotationElement
-            ss' = fromMaybe ss ssMb
-        when (posInSpan pos ss) do
-          modify $ addDoNotationElement ss' (isJust ssMb) doNotationElement
-        addTypesSt $ doNotTypes doNotationElement
-        pure (ss, doNotationElement)
-
-      onGuard :: P.SourceSpan -> P.Guard -> StateT EverythingAtPos Identity (P.SourceSpan, P.Guard)
-      onGuard ss guard' = do
-        when (posInSpan pos ss) do
-          modify (addGuard ss guard')
-        pure (ss, guard')
-
-      binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
-      binderSourceSpan = \case
-        P.NullBinder -> Nothing
-        P.LiteralBinder ss _ -> Just ss
-        P.VarBinder ss _ -> Just ss
-        P.ConstructorBinder ss _ _ -> Just ss
-        P.NamedBinder ss _ _ -> Just ss
-        P.PositionedBinder ss _ _ -> Just ss
-        P.TypedBinder ss _ -> Just (fst $ getAnnForType ss)
-        P.OpBinder ss _ -> Just ss
-        P.BinaryNoParensBinder {} -> Nothing
-        P.ParensInBinder {} -> Nothing
-
-      doNotationElementSpan :: P.DoNotationElement -> Maybe P.SourceSpan
-      doNotationElementSpan = \case
-        P.PositionedDoNotationElement ss _ _ -> Just ss
-        _ -> Nothing
-
-      (declTypes, exprTypes, binderTypes, caseAltTypes, doNotTypes) = P.accumTypes (getTypesAtPos pos)
-
-topLevelDeclEverythingAtPos :: P.Declaration -> EverythingAtPos
-topLevelDeclEverythingAtPos decl = nullEverythingAtPos {apDeclTopLevel = Just decl}
+getEverythingAtPos decls pos@(Types.Position {..}) =
+  case head $ declsAtLine (fromIntegral _line + 1) $ filter (not . isPrimImport) decls of
+    Nothing -> nullEverythingAtPos
+    Just (P.ImportDeclaration (ss, _) importedModuleName importType _) ->
+      nullEverythingAtPos {apImport = Just (maybe ss P.declRefSourceSpan ref, importedModuleName, importType, ref)}
+      where
+        ref = findDeclRefAtPos pos case importType of
+          P.Implicit -> []
+          P.Explicit refs -> refs
+          P.Hiding refs -> refs
+    Just topDecl -> execState (handleDecl topDecl) nullEverythingAtPos {apDecls = [topDecl]}
+      where
+        (handleDecl, _, _, _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan topDecl) onDecl onExpr onBinder onCaseAlternative onDoNotationElement onGuard
+
+        onDecl :: P.SourceSpan -> P.Declaration -> StateT EverythingAtPos Identity (P.SourceSpan, P.Declaration)
+        onDecl _ decl = do
+          let ss = declSourceSpan decl
+          when (posInSpan pos ss) do
+            modify $ addDecl decl
+          addTypesSt $ declTypes decl
+          pure (ss, decl)
+
+        onExpr ss expr = do
+          let ssMb = P.exprSourceSpan expr
+              ss' = fromMaybe ss ssMb
+          when (posInSpan pos ss' && not (isPlaceholder expr)) do
+            modify $ addExpr ss' (isJust ssMb) expr
+          addTypesSt $ exprTypes expr
+          pure (ss', expr)
+
+        onBinder ss binder = do
+          let ssMb = binderSourceSpan binder
+              ss' = fromMaybe ss ssMb
+          when (posInSpan pos ss') do
+            modify $ addBinder ss' (isJust ssMb) binder
+          addTypesSt $ binderTypes binder
+          pure (ss', binder)
+
+        onCaseAlternative :: P.SourceSpan -> P.CaseAlternative -> StateT EverythingAtPos Identity (P.SourceSpan, P.CaseAlternative)
+        onCaseAlternative ss caseAlt = do
+          when (posInSpan pos ss) do
+            modify $ addCaseAlternative ss caseAlt
+          addTypesSt $ caseAltTypes caseAlt
+          pure (ss, caseAlt)
+
+        onDoNotationElement :: P.SourceSpan -> P.DoNotationElement -> StateT EverythingAtPos Identity (P.SourceSpan, P.DoNotationElement)
+        onDoNotationElement ss doNotationElement = do
+          let ssMb = doNotationElementSpan doNotationElement
+              ss' = fromMaybe ss ssMb
+          when (posInSpan pos ss') do
+            modify $ addDoNotationElement ss' (isJust ssMb) doNotationElement
+          addTypesSt $ doNotTypes doNotationElement
+          pure (ss', doNotationElement)
+
+        onGuard :: P.SourceSpan -> P.Guard -> StateT EverythingAtPos Identity (P.SourceSpan, P.Guard)
+        onGuard ss guard' = do
+          when (posInSpan pos ss) do
+            modify (addGuard ss guard')
+          pure (ss, guard')
+
+        binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
+        binderSourceSpan = \case
+          P.NullBinder -> Nothing
+          P.LiteralBinder ss _ -> Just ss
+          P.VarBinder ss _ -> Just ss
+          P.ConstructorBinder ss _ _ -> Just ss
+          P.NamedBinder ss _ _ -> Just ss
+          P.PositionedBinder ss _ _ -> Just ss
+          P.TypedBinder ss _ -> Just (fst $ getAnnForType ss)
+          P.OpBinder ss _ -> Just ss
+          P.BinaryNoParensBinder {} -> Nothing
+          P.ParensInBinder {} -> Nothing
+
+        doNotationElementSpan :: P.DoNotationElement -> Maybe P.SourceSpan
+        doNotationElementSpan = \case
+          P.PositionedDoNotationElement ss _ _ -> Just ss
+          _ -> Nothing
+
+        (declTypes, exprTypes, binderTypes, caseAltTypes, doNotTypes) = P.accumTypes (getTypesAtPos pos)
+
+        isPlaceholder :: P.Expr -> Bool
+        isPlaceholder = \case
+          P.TypeClassDictionary {} -> True
+          P.DeferredDictionary {} -> True
+          P.DerivedInstancePlaceholder {} -> True
+          _ -> False
 
 addDecl :: P.Declaration -> EverythingAtPos -> EverythingAtPos
 addDecl decl atPos = atPos {apDecls = decl : apDecls atPos}
@@ -292,7 +291,7 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
                   case tipes of
                     [] -> nullRes
                     _ -> do
-                      let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
+                      let smallest = minimumBy (comparing getTypeLinesAndColumns) tipes
                       case smallest of
                         P.TypeConstructor _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> handleExprInModule filePath srcPos
                         P.TypeConstructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
@@ -331,16 +330,16 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
 
 smallestExpr :: [P.Expr] -> Maybe P.Expr
 smallestExpr [] = Nothing
-smallestExpr es = Just $ minimumBy (comparing (fromMaybe (maxInt, maxInt) . getExprRowsAndColumns)) es
+smallestExpr es = Just $ minimumBy (comparing (fromMaybe (maxInt, maxInt) . getExprLinesAndColumns)) es
 
-getExprRowsAndColumns :: P.Expr -> Maybe (Int, Int)
-getExprRowsAndColumns expr =
+getExprLinesAndColumns :: P.Expr -> Maybe (Int, Int)
+getExprLinesAndColumns expr =
   P.exprSourceSpan expr <&> \ss ->
-    let spanRowStart = P.sourcePosLine (P.spanStart ss)
-        spanRowEnd = P.sourcePosLine (P.spanEnd ss)
+    let spanLineStart = P.sourcePosLine (P.spanStart ss)
+        spanLineEnd = P.sourcePosLine (P.spanEnd ss)
         spanColStart = P.sourcePosColumn (P.spanStart ss)
         spanColEnd = P.sourcePosColumn (P.spanEnd ss)
-     in (spanRowEnd - spanRowStart, spanColEnd - spanColStart)
+     in (spanLineEnd - spanLineStart, spanColEnd - spanColStart)
 
 isNullSourceTypeSpan :: P.SourceType -> Bool
 isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
@@ -348,14 +347,14 @@ isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
 isSingleLine :: P.SourceType -> Bool
 isSingleLine st = P.sourcePosLine (P.spanStart (fst (getAnnForType st))) == P.sourcePosLine (P.spanEnd (fst (getAnnForType st)))
 
-getTypeRowsAndColumns :: P.SourceType -> (Int, Int)
-getTypeRowsAndColumns st = (getTypeRows st, getTypeColumns st)
+getTypeLinesAndColumns :: P.SourceType -> (Int, Int)
+getTypeLinesAndColumns st = (getTypeLines st, getTypeColumns st)
 
 getTypeColumns :: P.SourceType -> Int
 getTypeColumns st = P.sourcePosColumn (P.spanEnd (fst (getAnnForType st))) - P.sourcePosColumn (P.spanStart (fst (getAnnForType st)))
 
-getTypeRows :: P.SourceType -> Int
-getTypeRows st = P.sourcePosLine (P.spanEnd (fst (getAnnForType st))) - P.sourcePosLine (P.spanStart (fst (getAnnForType st)))
+getTypeLines :: P.SourceType -> Int
+getTypeLines st = P.sourcePosLine (P.spanEnd (fst (getAnnForType st))) - P.sourcePosLine (P.spanStart (fst (getAnnForType st)))
 
 fromPrim :: P.SourceType -> Bool
 fromPrim st = case st of
@@ -436,3 +435,114 @@ getImportRefNameType = \case
   P.ModuleRef _ _ -> ModNameType
   P.ReExportRef _ _ _ -> ModNameType
   P.TypeInstanceRef _ _ _ -> IdentNameType
+
+-- t =
+--   EverythingAtPos = Nothing,
+--       apDecls =
+--         [ ValueDeclaration
+--             ( ValueDeclarationData
+--                 { valdeclSourceAnn =
+--                     ( SourceSpan
+--                         { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 1},
+--                           spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                         },
+--                       []
+--                     ),
+--                   valdeclIdent = Ident "zzzzz",
+--                   valdeclName = Public,
+--                   valdeclBinders = [],
+--                   valdeclExpression =
+--                     [ GuardedExpr
+--                         []
+--                         ( TypedValue
+--                             True
+--                             ( PositionedValue
+--                                 ( SourceSpan
+--                                     { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                                       spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                                     }
+--                                 )
+--                                 []
+--                                 ( Literal
+--                                     ( SourceSpan
+--                                         { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                                           spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                                         }
+--                                     )
+--                                     (NumericLiteral (Left 333333))
+--                                 )
+--                             )
+--                             (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
+--                         )
+--                     ]
+--                 }
+--             )
+--         ],
+--       apExprs =
+--         [ ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                 spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--               },
+--             True,
+--             Literal
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                     spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                   }
+--               )
+--               (NumericLiteral (Left 333333))
+--           ),
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 1},
+--                 spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--               },
+--             True,
+--             PositionedValue
+--               ( SourceSpan
+--                   { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                     spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                   }
+--               )
+--               []
+--               ( Literal
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                         spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                       }
+--                   )
+--                   (NumericLiteral (Left 333333))
+--               )
+--           ),
+--           ( SourceSpan
+--               { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 1},
+--                 spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--               },
+--             False,
+--             P.TypedValue
+--               True
+--               ( PositionedValue
+--                   ( SourceSpan
+--                       { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                         spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                       }
+--                   )
+--                   []
+--                   ( Literal
+--                       ( SourceSpan
+--                           { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
+--                             spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
+--                           }
+--                       )
+--                       (NumericLiteral (Left 333333))
+--                   )
+--               )
+--               (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
+--           )
+--         ],
+--       apBinders = [],
+--       apCaseAlternatives = [],
+--       apDoNotationElements = [],
+--       apGuards = [],
+--       apTypes = [],
+--       apImport = Nothing
+--     }
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index e7fd073e2f..c0651e99b0 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -1,21 +1,26 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 
 module Language.PureScript.Lsp.Handlers.Hover where
 
-import Control.Lens ((^.))
+import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), (^.))
+import Control.Lens.Combinators (view)
+import Data.List (last)
 import Data.Text qualified as T
+import Language.Haskell.TH qualified as P
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.PureScript qualified as P
-import Language.PureScript.AST.Declarations (Expr (..))
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (findDeclRefAtPos, fromPrim, getDeclTypesAtPos, getEverythingAtPos, getExprsAtPos, getImportRefNameType, getTypeRowsAndColumns, getTypedValuesAtPos, isNullSourceTypeSpan, isPrimImport, smallestExpr, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), getEverythingAtPos, getImportRefNameType, spanSize, spanToRange)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Log (debugLsp)
@@ -24,7 +29,6 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (declsAtLine, posInSpan)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
 
@@ -33,7 +37,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
   let Types.HoverParams docIdent pos@(Types.Position {..}) _prog = req ^. LSP.params
       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
 
-      nullRes = res $ Right $ Types.InR Types.Null
+      nullRes = res $ Right $ Types.InL $ Types.Hover (Types.InR $ Types.InR []) Nothing
 
       markdownRes md range = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) range
 
@@ -50,16 +54,26 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             forLsp (head tipes) \tipe ->
               markdownRes tipe (Just $ spanToRange ss)
 
-      respondWithSourceType :: P.Expr -> (P.SourceType, Maybe P.SourceSpan) -> HandlerM ()
-      respondWithSourceType expr (tipe, sa) = do
-        let word = case expr of
-              P.Var _ (P.Qualified _ ident) -> P.runIdent ident
-              P.Op _ (P.Qualified _ ident) -> P.runOpName ident
-              P.Constructor _ (P.Qualified _ ident) -> P.runProperName ident
-              _ -> T.pack $ render $ P.prettyPrintValue 3 expr
-            printedType = prettyPrintTypeSingleLine tipe
+      respondWithSourceType :: P.SourceType -> HandlerM ()
+      respondWithSourceType tipe = do
+        let printedType = prettyPrintTypeSingleLine tipe
+        markdownRes (pursTypeStr "_" (Just printedType) []) (Just $ spanToRange $ fst $ P.getAnnForType tipe)
 
-        markdownRes (pursTypeStr word (Just printedType) []) (spanToRange <$> sa)
+      respondWithExprDebug :: Text -> P.SourceSpan -> P.Expr -> HandlerM ()
+      respondWithExprDebug label ss expr = do
+        let printedExpr = ellipsis 2000 $ show expr
+        markdownRes (label <> ": \n" <> pursMd printedExpr) (Just $ spanToRange ss)
+
+      respondWithExpr2Debug :: Text -> Text -> P.SourceSpan -> P.Expr -> P.Expr -> HandlerM ()
+      respondWithExpr2Debug label label' ss expr expr' = do
+        let printedExpr = ellipsis 2000 $ show expr
+            printedExpr' = ellipsis 2000 $ show expr'
+        markdownRes (label <> ": \n" <> pursMd printedExpr <> "\n\n" <> label' <> ": \n" <> printedExpr') (Just $ spanToRange ss)
+
+      respondWithTypedExpr :: P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
+      respondWithTypedExpr ss expr tipe = do
+        let printedType = prettyPrintTypeSingleLine tipe
+        markdownRes (pursTypeStr (dispayExprOnHover expr) (Just printedType) []) (Just $ spanToRange ss)
 
       respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
       respondWithModule ss modName = do
@@ -68,98 +82,82 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           Just docs | Just comments <- Docs.modComments docs -> markdownRes comments (Just $ spanToRange ss)
           _ -> nullRes
 
-      respondWithImports ss importedModuleName imports = do
-        case findDeclRefAtPos pos imports of
-          Just import' -> do
-            let name = P.declRefName import'
-                nameType = getImportRefNameType import'
-            respondWithDeclInModule ss nameType importedModuleName (printName name)
-          _ -> respondWithModule ss importedModuleName
+      respondWithImport :: P.SourceSpan -> P.ModuleName -> Maybe P.DeclarationRef -> HandlerM ()
+      respondWithImport ss importedModuleName (Just ref) = do
+        let name = P.declRefName ref
+            nameType = getImportRefNameType ref
+        respondWithDeclInModule ss nameType importedModuleName (printName name)
+      respondWithImport ss importedModuleName _ = respondWithModule ss importedModuleName
 
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
-      let withoutPrim =
-            ofModule
-              & P.getModuleDeclarations
-              & filter (not . isPrimImport)
-
-      let everything = getEverythingAtPos pos (P.getModuleDeclarations ofModule)
-      case everything of 
-        EverythingAtPos { apTypes = types } | not $ null types -> do 
-          let ty = minimumBy (comparing getTypeRowsAndColumns) types
-          respondWith
-
--- handleDecls :: [P.Declaration] -> HandlerM ()
--- handleDecls decls = do
---   let srcPosLine = fromIntegral _line + 1
-
---       declsAtPos =
---         decls
---           & declsAtLine srcPosLine
-
---   debugLsp $ "declsAtPos: " <> show (length declsAtPos)
-
---   forLsp (head declsAtPos) $ \decl -> do
---     case decl of
---       P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
---         case importType of
---           P.Implicit -> respondWithModule ss importedModuleName
---           P.Explicit imports -> respondWithImports ss importedModuleName imports
---           P.Hiding imports -> respondWithImports ss importedModuleName imports
---       P.TypeInstanceDeclaration _ (P.SourceSpan span start end, _) _ _ _ constraints (P.Qualified (P.ByModuleName modName) className) _args body
---         | posInSpan pos classNameSS -> respondWithDeclInModule classNameSS TyClassNameType modName classNameTxt
---         | Just (P.Constraint (ss, _) (P.Qualified (P.ByModuleName conModName) conClassName) _ _ _) <- find (posInSpan pos . fst . P.constraintAnn) constraints -> do
---             respondWithDeclInModule ss TyClassNameType conModName $ P.runProperName conClassName
---         | P.ExplicitInstance members <- body, not $ null $ declsAtLine srcPosLine members  -> do
---             handleDecls members
---         where
---           classNameSS = P.SourceSpan span start (P.SourcePos (P.sourcePosLine end) (P.sourcePosColumn start + T.length classNameTxt))
-
---           classNameTxt :: Text
---           classNameTxt = P.runProperName className
---       _ -> do
---         let exprsAtPos = getExprsAtPos pos =<< declsAtPos
---             findTypedExpr :: [Expr] -> Maybe (P.SourceType, Maybe P.SourceSpan)
---             findTypedExpr ((P.TypedValue _ e t) : _) = Just (t, P.exprSourceSpan e)
---             findTypedExpr (_ : es) = findTypedExpr es
---             findTypedExpr [] = Nothing
-
---         debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
-
---         case smallestExpr exprsAtPos of
---           Just expr -> do
---             case expr of
---               P.Var ss (P.Qualified (P.ByModuleName modName) ident) -> do
---                 respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
---               P.Op ss (P.Qualified (P.ByModuleName modName) ident) -> do
---                 respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
---               P.Constructor ss (P.Qualified (P.ByModuleName modName) ident) -> do
---                 respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
---               _ -> forLsp (findTypedExpr $ getTypedValuesAtPos pos decl) (respondWithSourceType expr)
---           _ -> do
---             let tipes =
---                   filter (not . fromPrim) $
---                     filter (not . isNullSourceTypeSpan) $
---                       getDeclTypesAtPos pos decl
-
---             debugLsp $ "tipes: " <> show (length tipes)
-
---             case tipes of
---               [] -> nullRes
---               _ -> do
---                 let smallest = minimumBy (comparing getTypeRowsAndColumns) tipes
---                 debugLsp $ "smallest: " <> show smallest
---                 case smallest of
---                   P.TypeConstructor (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
---                     respondWithDeclInModule ss TyNameType modName $ P.runProperName ident
---                   P.TypeOp (ss, _) (P.Qualified (P.ByModuleName modName) ident) -> do
---                     respondWithDeclInModule ss TyOpNameType modName $ P.runOpName ident
---                   P.ConstrainedType (ss, _) c _ -> case P.constraintClass c of
---                     (P.Qualified (P.ByModuleName modName) ident) -> do
---                       respondWithDeclInModule ss TyClassNameType modName $ P.runProperName ident
---                     _ -> nullRes
---                   _ -> nullRes
+      let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
+      debugLsp $ "pos: " <> show pos
+
+      case apImport everything of
+        Just (ss, importedModuleName, _, ref) -> do
+          debugLsp $ "Import: " <> show importedModuleName
+          respondWithImport ss importedModuleName ref
+        _ -> do 
+          let exprs = apExprs everything
+          noResponse <-
+            exprs & whileM \case
+              (ss, True, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                debugLsp $ "Var: " <> show ident
+                respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
+                pure False
+              (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                debugLsp $ "Op: " <> show ident
+                respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+                pure False
+              (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                debugLsp $ "Dctor: " <> show ident
+                respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
+                pure False
+              (ss, _, P.Literal _ (P.NumericLiteral (Left int))) -> do
+                markdownRes (pursTypeStr (show int) (Just "Int") []) (Just $ spanToRange ss)
+                pure False
+              (ss, _, P.Literal _ (P.NumericLiteral (Right n))) -> do
+                markdownRes (pursTypeStr (show n) (Just "Number") []) (Just $ spanToRange ss)
+                pure False
+              (ss, _, P.Literal _ (P.StringLiteral str)) -> do
+                markdownRes (pursTypeStr (show str) (Just "String") []) (Just $ spanToRange ss)
+                pure False
+              (ss, _, P.Literal _ (P.CharLiteral ch)) -> do
+                markdownRes (pursTypeStr (show ch) (Just "Char") []) (Just $ spanToRange ss)
+                pure False
+              (ss, _, P.Literal _ (P.BooleanLiteral b)) -> do
+                markdownRes (pursTypeStr (show b) (Just "Boolean") []) (Just $ spanToRange ss)
+                pure False
+              _ -> pure True
+
+          when noResponse do
+            nullRes
+
+whileM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+whileM _ [] = pure False
+whileM f (x : xs) = do
+  b <- f x
+  if b then whileM f xs else pure False
+
+findMap :: (a -> Maybe b) -> [a] -> Maybe b
+findMap f = head . mapMaybe f
+
+findTypedExpr :: [(P.SourceSpan, Bool, P.Expr)] -> Maybe (P.SourceSpan, P.Expr, P.SourceType)
+findTypedExpr ((ss, _, P.TypedValue _ e t) : _) = Just (ss, e, t)
+findTypedExpr (_ : es) = findTypedExpr es
+findTypedExpr [] = Nothing
+
+dispayExprOnHover :: P.Expr -> T.Text
+dispayExprOnHover expr = ellipsis 32 $ line1Only $ T.strip $ T.pack $ render $ P.prettyPrintValue 3 expr
+  where
+    line1Only = T.takeWhile (/= '\n')
+
+ellipsis :: Int -> Text -> Text
+ellipsis l t = if T.length t > l then T.take l t <> "..." else t
+
+
 pursTypeStr :: Text -> Maybe Text -> [P.Comment] -> Text
 pursTypeStr word type' comments =
   "```purescript\n"
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 7eb6a0a0e0..4da8a78c96 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -21,16 +21,20 @@ import Language.PureScript.AST.Declarations (declSourceAnn)
 import Language.PureScript.AST.SourcePos (widenSourceSpan)
 import Language.PureScript.Comments qualified as P
 import Language.PureScript.Externs qualified as P
+import Language.PureScript.Names qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude hiding (to)
-import Language.PureScript.Names qualified as P
 
 posInSpan :: Types.Position -> AST.SourceSpan -> Bool
 posInSpan (Types.Position line col) (AST.SourceSpan _ (AST.SourcePos startLine startCol) (AST.SourcePos endLine endCol)) =
-  startLine <= fromIntegral (line + 1)
-    && endLine >= fromIntegral (line + 1)
-    && startCol <= fromIntegral (col + 1)
-    && endCol >= fromIntegral (col + 1)
+  not (startLine == 1 && startCol == 1)  -- ignore generated spans
+    && startLine <= atLine
+    && endLine >= atLine
+    && startCol <= atCol
+    && endCol >= atCol
+  where
+    atLine = fromIntegral line + 1
+    atCol = fromIntegral col + 1
 
 posInSpanLines :: Types.Position -> AST.SourceSpan -> Bool
 posInSpanLines (Types.Position line _) (AST.SourceSpan _ (AST.SourcePos startLine _) (AST.SourcePos endLine _)) =
@@ -47,10 +51,10 @@ isWordBreak :: Char -> Bool
 isWordBreak = not . (isAlphaNum ||^ (== '_') ||^ (== '.'))
 
 getSymbolAt :: Rope -> Types.Position -> (Types.Range, Text)
-getSymbolAt = getByPredAt isSymbolBreak 
+getSymbolAt = getByPredAt isSymbolBreak
 
 isSymbolBreak :: Char -> Bool
-isSymbolBreak = isSpace ||^ (== '(') ||^ (== ')') ||^ (== '{') ||^ (== '}') ||^ (== '[') ||^ (== ']') ||^ (== ',') 
+isSymbolBreak = isSpace ||^ (== '(') ||^ (== ')') ||^ (== '{') ||^ (== '}') ||^ (== '[') ||^ (== ']') ||^ (== ',')
 
 getByPredAt :: (Char -> Bool) -> Rope -> Types.Position -> (Types.Range, Text)
 getByPredAt charPred file pos@(Types.Position {..}) =
@@ -174,9 +178,9 @@ declsAtLine l = go . sortBy (comparing declStartLine)
     go [d] | declStartLine d <= l = [d]
     go _ = []
 
-    unsureEndLine = \case 
-      P.ValueDeclaration{}  -> True
-      P.ExternDeclaration{} -> True
+    unsureEndLine = \case
+      P.ValueDeclaration {} -> True
+      P.ExternDeclaration {} -> True
       P.TypeClassDeclaration {} -> True
       P.TypeInstanceDeclaration {} -> True
       _ -> False
@@ -201,9 +205,8 @@ findExprSourceSpan = goExpr
         (const Nothing)
         (const Nothing)
 
-
 getOperatorValueName :: P.Declaration -> Maybe (P.Qualified P.Name)
-getOperatorValueName = \case 
+getOperatorValueName = \case
   P.FixityDeclaration _ (Left (P.ValueFixity _ n _)) -> Just (either P.IdentName P.DctorName <$> n)
   P.FixityDeclaration _ (Right (P.TypeFixity _ n _)) -> Just (P.TyName <$> n)
   _ -> Nothing
\ No newline at end of file
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 4d5a5ec604..6c5b6fe775 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Pretty.Values
   ( prettyPrintValue
   , prettyPrintBinder
   , prettyPrintBinderAtom
+  , prettyPrintLiteralValue
   ) where
 
 import Prelude hiding ((<>))

From 75121265c39c9606df7147e925532684fef40e7c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 25 Oct 2024 13:05:28 +0200
Subject: [PATCH 195/297] adds type value hovering

---
 src/Language/PureScript/AST/Declarations.hs   |   8 +-
 src/Language/PureScript/Lsp/AtPosition.hs     |  19 ++
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 180 ++++++++++++------
 3 files changed, 146 insertions(+), 61 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 3653337219..e8cfbce87f 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -795,7 +795,7 @@ exprSourceSpan (Op ss _) = Just ss
 exprSourceSpan (IfThenElse _ _ _) = Nothing
 exprSourceSpan (Constructor ss _) = Just ss
 exprSourceSpan (Case _ _) = Nothing
-exprSourceSpan (TypedValue _ _ _) = Nothing
+exprSourceSpan (TypedValue _ expr _) = exprSourceSpan expr
 exprSourceSpan (Let _ _ _) = Nothing
 exprSourceSpan (Do _ _) = Nothing
 exprSourceSpan (Ado _ _ _) = Nothing
@@ -807,12 +807,6 @@ exprSourceSpan (Hole _) = Nothing
 exprSourceSpan (PositionedValue ss _ _) = Just ss
 
 
--- findExprSourceSpan :: Expr -> Maybe SourceSpan
--- findExprSourceSpan = goExpr 
---   where 
---     ( ) = P.everythingOnValues
-
-
 -- |
 -- Metadata that tells where a let binding originated
 --
diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 0d2e592a3f..915838dd2a 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -226,6 +226,25 @@ addTypes tys atPos = atPos {apTypes = tys <> apTypes atPos}
 addTypesSt :: (MonadState EverythingAtPos m) => [P.SourceType] -> m ()
 addTypesSt tys = modify (addTypes tys)
 
+debugExpr :: P.Expr -> Text
+debugExpr =
+  T.replace ", sourcePosColumn = " ":"
+    . T.replace "SourcePos {sourcePosLine = " ""
+    . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
+    . T.replace "SourceSpan {spanStart = SourcePos {sourcePosLine =  " "start = "
+    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/simple-purs/src/B.purs\", " ""
+    . show
+
+debugSrcSpan :: P.SourceSpan -> Text
+debugSrcSpan = 
+  T.replace ", sourcePosColumn = " ":"
+    . T.replace "SourcePos {sourcePosLine = " ""
+    . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
+    . T.replace "SourceSpan {spanStart = SourcePos {sourcePosLine =  " "start = "
+    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/simple-purs/src/B.purs\", " ""
+    . show
+
+
 -- getDeclTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
 
 atPosition ::
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index c0651e99b0..b04a600247 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -2,8 +2,9 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
 
 module Language.PureScript.Lsp.Handlers.Hover where
 
@@ -11,7 +12,6 @@ import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), (^.))
 import Control.Lens.Combinators (view)
 import Data.List (last)
 import Data.Text qualified as T
-import Language.Haskell.TH qualified as P
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
@@ -29,15 +29,17 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
+import Language.PureScript.Lsp.Util (posInSpan, sourcePosToPosition)
+import Language.PureScript.Names (disqualify)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-  let Types.HoverParams docIdent pos@(Types.Position {..}) _prog = req ^. LSP.params
+  let Types.HoverParams docIdent startPos _prog = req ^. LSP.params
       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
 
-      nullRes = res $ Right $ Types.InL $ Types.Hover (Types.InR $ Types.InR []) Nothing
+      nullRes = res $ Right $ Types.InR Types.Null
 
       markdownRes md range = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) range
 
@@ -75,6 +77,11 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         let printedType = prettyPrintTypeSingleLine tipe
         markdownRes (pursTypeStr (dispayExprOnHover expr) (Just printedType) []) (Just $ spanToRange ss)
 
+      respondWithTypeBinder :: P.SourceSpan -> P.Binder -> P.SourceType -> HandlerM ()
+      respondWithTypeBinder ss binder tipe = do
+        let printedType = prettyPrintTypeSingleLine tipe
+        markdownRes (pursTypeStr (dispayBinderOnHover binder) (Just printedType) []) (Just $ spanToRange ss)
+
       respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
       respondWithModule ss modName = do
         docsMb <- readModuleDocs modName
@@ -89,60 +96,121 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         respondWithDeclInModule ss nameType importedModuleName (printName name)
       respondWithImport ss importedModuleName _ = respondWithModule ss importedModuleName
 
+      handleLiteral :: P.SourceSpan -> P.Literal a -> HandlerM Bool
+      handleLiteral ss = \case
+        P.NumericLiteral (Left int) -> do
+          markdownRes (pursTypeStr (show int) (Just "Int") []) (Just $ spanToRange ss)
+          pure False
+        P.NumericLiteral (Right n) -> do
+          markdownRes (pursTypeStr (show n) (Just "Number") []) (Just $ spanToRange ss)
+          pure False
+        P.StringLiteral str -> do
+          markdownRes (pursTypeStr (ellipsis 64 $ show str) (Just "String") []) (Just $ spanToRange ss)
+          pure False
+        P.CharLiteral ch -> do
+          markdownRes (pursTypeStr (show ch) (Just "Char") []) (Just $ spanToRange ss)
+          pure False
+        P.BooleanLiteral b -> do
+          markdownRes (pursTypeStr (show b) (Just "Boolean") []) (Just $ spanToRange ss)
+          pure False
+        _ -> pure True
+
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
-      let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
-      debugLsp $ "pos: " <> show pos
-
-      case apImport everything of
-        Just (ss, importedModuleName, _, ref) -> do
-          debugLsp $ "Import: " <> show importedModuleName
-          respondWithImport ss importedModuleName ref
-        _ -> do 
-          let exprs = apExprs everything
-          noResponse <-
-            exprs & whileM \case
-              (ss, True, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                debugLsp $ "Var: " <> show ident
-                respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
-                pure False
-              (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                debugLsp $ "Op: " <> show ident
-                respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
-                pure False
-              (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                debugLsp $ "Dctor: " <> show ident
-                respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
-                pure False
-              (ss, _, P.Literal _ (P.NumericLiteral (Left int))) -> do
-                markdownRes (pursTypeStr (show int) (Just "Int") []) (Just $ spanToRange ss)
-                pure False
-              (ss, _, P.Literal _ (P.NumericLiteral (Right n))) -> do
-                markdownRes (pursTypeStr (show n) (Just "Number") []) (Just $ spanToRange ss)
-                pure False
-              (ss, _, P.Literal _ (P.StringLiteral str)) -> do
-                markdownRes (pursTypeStr (show str) (Just "String") []) (Just $ spanToRange ss)
-                pure False
-              (ss, _, P.Literal _ (P.CharLiteral ch)) -> do
-                markdownRes (pursTypeStr (show ch) (Just "Char") []) (Just $ spanToRange ss)
-                pure False
-              (ss, _, P.Literal _ (P.BooleanLiteral b)) -> do
-                markdownRes (pursTypeStr (show b) (Just "Boolean") []) (Just $ spanToRange ss)
-                pure False
-              _ -> pure True
-
-          when noResponse do
-            nullRes
-
-whileM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
-whileM _ [] = pure False
-whileM f (x : xs) = do
+      let handlePos :: Types.Position -> HandlerM ()
+          handlePos pos = do
+            let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
+            debugLsp $ "pos: " <> show pos
+
+            case apImport everything of
+              Just (ss, importedModuleName, _, ref) -> do
+                debugLsp $ "Import: " <> show importedModuleName
+                respondWithImport ss importedModuleName ref
+              _ -> do
+                let exprs = apExprs everything
+                debugLsp $ "exprs found: " <> show (length exprs)
+                noExprFound <-
+                  exprs & allM \expr -> do
+                    case expr of
+                      (ss, _, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                        debugLsp $ "Var: " <> show ident
+                        respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
+                        pure False
+                      (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                        debugLsp $ "Op: " <> show ident
+                        respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+                        pure False
+                      (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                        debugLsp $ "Dctor: " <> show ident
+                        respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
+                        pure False
+                      (ss, _, P.TypedValue _ tExpr ty) | not (generatedExpr tExpr) -> do
+                        respondWithTypedExpr ss tExpr ty
+                        pure False
+                      (ss, _, P.Literal _ lit) -> do
+                        handleLiteral ss lit
+                      _ -> pure True
+
+                debugLsp $ "No expr found: " <> show noExprFound
+                when noExprFound do
+                  let binders = apBinders everything
+                  noBinderFound <-
+                    binders & allM \case
+                      (ss, _, P.TypedBinder st binder) | not (generatedBinder binder) -> do
+                        debugLsp $ "VarBinder: " <> show binder
+                        respondWithTypeBinder ss binder st
+                        pure False
+                      (ss, _, P.ConstructorBinder _ (P.Qualified (P.ByModuleName modName) ident) _) -> do
+                        debugLsp $ "DctorBinder: " <> show ident
+                        respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
+                        pure False
+                      (ss, _, P.OpBinder _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                        debugLsp $ "OpBinder: " <> show ident
+                        respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+                        pure False
+                      (ss, _, P.LiteralBinder _ lit) -> do
+                        handleLiteral ss lit
+                      _ -> pure True
+                  debugLsp $ "No binder found: " <> show noBinderFound
+                  pure ()
+      handlePos startPos
+
+allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+allM _ [] = pure True
+allM f (x : xs) = do
   b <- f x
-  if b then whileM f xs else pure False
+  if b then allM f xs else pure False
+
+generatedExpr :: P.Expr -> Bool
+generatedExpr = traceShow' "generatedExpr result" . \case
+  P.Var _ ident -> traceToErr "Var" $ generatedIdent $ P.disqualify ident
+  P.Abs b e -> traceShow' "Abs result" $ traceToErr "Abs" $  generatedBinder b || generatedExpr e
+  P.App e e' -> traceToErr "App" $ generatedExpr e || generatedExpr e'
+  P.TypedValue _ e _ -> traceToErr "TypedValue" $ generatedExpr e
+  P.PositionedValue _ _ e -> traceToErr "PositionedValue" $ generatedExpr e
+  _ -> traceToErr "Other expr"  False
+
+
+traceToErr ::  Text -> b -> b
+traceToErr a b = trace a b
 
-findMap :: (a -> Maybe b) -> [a] -> Maybe b
-findMap f = head . mapMaybe f
+traceWith :: Text -> (b -> Text) -> b -> b
+traceWith label f a = traceToErr (label <> ": " <> f a) a
+
+traceShow' :: Show b => Text -> b -> b
+traceShow' l = traceWith l show
+
+generatedBinder :: P.Binder -> Bool
+generatedBinder = \case
+  P.VarBinder ss ident -> traceToErr "VarBinder" $ traceShow' "is generated VarBinder" $ traceWith "null src span" show (ss == P.nullSourceSpan) || generatedIdent (traceShow' "ident" ident)
+  P.NamedBinder ss ident _ -> traceToErr "NamedBinder" $  (ss == P.nullSourceSpan) || generatedIdent ident
+  _ -> traceToErr "Other binder" False
+
+generatedIdent :: P.Ident -> Bool
+generatedIdent = \case
+  P.GenIdent {} -> traceToErr "GenIdent" True
+  _ -> traceToErr "Other ident" False
 
 findTypedExpr :: [(P.SourceSpan, Bool, P.Expr)] -> Maybe (P.SourceSpan, P.Expr, P.SourceType)
 findTypedExpr ((ss, _, P.TypedValue _ e t) : _) = Just (ss, e, t)
@@ -154,10 +222,14 @@ dispayExprOnHover expr = ellipsis 32 $ line1Only $ T.strip $ T.pack $ render $ P
   where
     line1Only = T.takeWhile (/= '\n')
 
+dispayBinderOnHover :: P.Binder -> T.Text
+dispayBinderOnHover binder = ellipsis 32 $ line1Only $ T.strip $ P.prettyPrintBinder binder
+  where
+    line1Only = T.takeWhile (/= '\n')
+
 ellipsis :: Int -> Text -> Text
 ellipsis l t = if T.length t > l then T.take l t <> "..." else t
 
-
 pursTypeStr :: Text -> Maybe Text -> [P.Comment] -> Text
 pursTypeStr word type' comments =
   "```purescript\n"

From 2d5cba5f53e309c1e8dc34b96745c6fda5c4cd90 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 25 Oct 2024 16:40:04 +0200
Subject: [PATCH 196/297] adds hover for direct where decls

---
 src/Language/PureScript/Lsp/AtPosition.hs     |  38 +++++-
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 123 +++++++++---------
 2 files changed, 100 insertions(+), 61 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 915838dd2a..a8b3659ae4 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -83,6 +83,25 @@ data EverythingAtPos = EverythingAtPos
   }
   deriving (Show)
 
+showCounts :: EverythingAtPos -> Text
+showCounts EverythingAtPos {..} =
+  "decls: "
+    <> show (length apDecls)
+    <> ",\nexprs: "
+    <> show (length apExprs)
+    <> ",\nbinders: "
+    <> show (length apBinders)
+    <> ",\ncaseAlts: "
+    <> show (length apCaseAlternatives)
+    <> ",\ndoNotElems: "
+    <> show (length apDoNotationElements)
+    <> ",\nguards: "
+    <> show (length apGuards)
+    <> ",\ntypes: "
+    <> show (length apTypes)
+    <> ",\nimport: "
+    <> show (isJust apImport)
+
 nullEverythingAtPos :: EverythingAtPos
 nullEverythingAtPos = EverythingAtPos [] [] [] [] [] [] [] Nothing
 
@@ -412,11 +431,24 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
         modify (expr :)
       pure expr
 
+getChildExprs :: P.Expr -> [P.Expr]
+getChildExprs parentExpr = execState (goExpr parentExpr) []
+  where
+    goExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
+    goExpr = onExpr
+
+    (_, onExpr, _) = P.everywhereOnValuesM pure handleExpr pure
+
+    handleExpr :: P.Expr -> StateT [P.Expr] Identity P.Expr
+    handleExpr expr = do
+      modify (expr :)
+      pure expr
+
 getTypedValuesAtPos :: Types.Position -> P.Declaration -> [P.Expr]
-getTypedValuesAtPos pos declaration = execState (goDecl declaration) []
+getTypedValuesAtPos pos declaration = execState (go declaration) []
   where
-    goDecl :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
-    goDecl = onDecl
+    go :: P.Declaration -> StateT [P.Expr] Identity P.Declaration
+    go = onDecl
 
     (onDecl, _, _) = P.everywhereOnValuesTopDownM pure handleExpr pure
 
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index b04a600247..a0daeed538 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -1,16 +1,17 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 {-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
-{-# OPTIONS_GHC -Wno-deprecations #-}
 
 module Language.PureScript.Lsp.Handlers.Hover where
 
 import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), (^.))
 import Control.Lens.Combinators (view)
 import Data.List (last)
+import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
@@ -20,7 +21,7 @@ import Language.PureScript qualified as P
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), getEverythingAtPos, getImportRefNameType, spanSize, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, showCounts, spanSize, spanToRange)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Log (debugLsp)
@@ -129,51 +130,55 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                 respondWithImport ss importedModuleName ref
               _ -> do
                 let exprs = apExprs everything
+                    handleExpr expr = do
+                      case expr of
+                        (ss, _, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                          debugLsp $ "Var: " <> show ident
+                          respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
+                          pure False
+                        (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                          debugLsp $ "Op: " <> show ident
+                          respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+                          pure False
+                        (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+                          debugLsp $ "Dctor: " <> show ident
+                          respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
+                          pure False
+                        (ss, _, P.TypedValue _ tExpr ty) | not (generatedExpr tExpr) -> do
+                          respondWithTypedExpr ss tExpr ty
+                          pure False
+                        (ss, _, P.Literal _ lit) -> do
+                          handleLiteral ss lit
+                        _ -> pure True
+
                 debugLsp $ "exprs found: " <> show (length exprs)
-                noExprFound <-
-                  exprs & allM \expr -> do
-                    case expr of
-                      (ss, _, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                        debugLsp $ "Var: " <> show ident
-                        respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
-                        pure False
-                      (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                        debugLsp $ "Op: " <> show ident
-                        respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
-                        pure False
-                      (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                        debugLsp $ "Dctor: " <> show ident
-                        respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
-                        pure False
-                      (ss, _, P.TypedValue _ tExpr ty) | not (generatedExpr tExpr) -> do
-                        respondWithTypedExpr ss tExpr ty
-                        pure False
-                      (ss, _, P.Literal _ lit) -> do
-                        handleLiteral ss lit
-                      _ -> pure True
+                noExprFound <- allM handleExpr exprs
 
                 debugLsp $ "No expr found: " <> show noExprFound
                 when noExprFound do
-                  let binders = apBinders everything
-                  noBinderFound <-
-                    binders & allM \case
-                      (ss, _, P.TypedBinder st binder) | not (generatedBinder binder) -> do
-                        debugLsp $ "VarBinder: " <> show binder
-                        respondWithTypeBinder ss binder st
-                        pure False
-                      (ss, _, P.ConstructorBinder _ (P.Qualified (P.ByModuleName modName) ident) _) -> do
-                        debugLsp $ "DctorBinder: " <> show ident
-                        respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
-                        pure False
-                      (ss, _, P.OpBinder _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                        debugLsp $ "OpBinder: " <> show ident
-                        respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+                  debugLsp $ showCounts everything
+                  let decls = apDecls everything & sortDeclsBySize
+                  void $
+                    apDecls everything & allM \case
+                      P.BoundValueDeclaration sa _binder expr -> do
+                        debugLsp "BoundValueDeclaration"
+                        let ss = fst sa
+                            children = getChildExprs expr
+                        children & allM \e -> handleExpr (ss, True, e)
+                      P.BindingGroupDeclaration bindingGroup -> do
+                        debugLsp "BindingGroupDeclaration"
+                        NE.toList bindingGroup & allM \((sa, _), _, expr) ->
+                          handleExpr (fst sa, True, expr)
+                      decl@(P.ValueDeclaration vd) -> do
+                        debugLsp $ "ValueDeclaration: " <> P.runIdent (P.valdeclIdent vd)
+                        let ss = P.declSourceSpan decl
+                            guaredExprs = P.valdeclExpression vd
+                            children = guaredExprs >>= getChildExprs . (\(P.GuardedExpr _ e) -> e)
+                        children & allM \expr ->
+                            handleExpr (ss, True, expr)
+                      decl -> do
+                        debugLsp $ "Decl: " <> ellipsis 100 (show decl)
                         pure False
-                      (ss, _, P.LiteralBinder _ lit) -> do
-                        handleLiteral ss lit
-                      _ -> pure True
-                  debugLsp $ "No binder found: " <> show noBinderFound
-                  pure ()
       handlePos startPos
 
 allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
@@ -183,34 +188,36 @@ allM f (x : xs) = do
   if b then allM f xs else pure False
 
 generatedExpr :: P.Expr -> Bool
-generatedExpr = traceShow' "generatedExpr result" . \case
-  P.Var _ ident -> traceToErr "Var" $ generatedIdent $ P.disqualify ident
-  P.Abs b e -> traceShow' "Abs result" $ traceToErr "Abs" $  generatedBinder b || generatedExpr e
-  P.App e e' -> traceToErr "App" $ generatedExpr e || generatedExpr e'
-  P.TypedValue _ e _ -> traceToErr "TypedValue" $ generatedExpr e
-  P.PositionedValue _ _ e -> traceToErr "PositionedValue" $ generatedExpr e
-  _ -> traceToErr "Other expr"  False
-
-
-traceToErr ::  Text -> b -> b
+generatedExpr = \case
+  P.Var _ ident -> generatedIdent $ P.disqualify ident
+  P.Abs b e -> generatedBinder b || generatedExpr e
+  P.App e e' -> generatedExpr e || generatedExpr e'
+  P.TypedValue _ e _ -> generatedExpr e
+  P.PositionedValue _ _ e -> generatedExpr e
+  _ -> False
+
+sortDeclsBySize :: [P.Declaration] -> [P.Declaration]
+sortDeclsBySize = sortBy (compare `on` (spanSize . P.declSourceSpan))
+
+traceToErr :: Text -> b -> b
 traceToErr a b = trace a b
 
 traceWith :: Text -> (b -> Text) -> b -> b
 traceWith label f a = traceToErr (label <> ": " <> f a) a
 
-traceShow' :: Show b => Text -> b -> b
+traceShow' :: (Show b) => Text -> b -> b
 traceShow' l = traceWith l show
 
 generatedBinder :: P.Binder -> Bool
 generatedBinder = \case
-  P.VarBinder ss ident -> traceToErr "VarBinder" $ traceShow' "is generated VarBinder" $ traceWith "null src span" show (ss == P.nullSourceSpan) || generatedIdent (traceShow' "ident" ident)
-  P.NamedBinder ss ident _ -> traceToErr "NamedBinder" $  (ss == P.nullSourceSpan) || generatedIdent ident
-  _ -> traceToErr "Other binder" False
+  P.VarBinder ss ident -> (ss == P.nullSourceSpan) || generatedIdent ident
+  P.NamedBinder ss ident _ -> (ss == P.nullSourceSpan) || generatedIdent ident
+  _ -> False
 
 generatedIdent :: P.Ident -> Bool
 generatedIdent = \case
-  P.GenIdent {} -> traceToErr "GenIdent" True
-  _ -> traceToErr "Other ident" False
+  P.GenIdent {} -> True
+  _ -> False
 
 findTypedExpr :: [(P.SourceSpan, Bool, P.Expr)] -> Maybe (P.SourceSpan, P.Expr, P.SourceType)
 findTypedExpr ((ss, _, P.TypedValue _ e t) : _) = Just (ss, e, t)

From 882b14ce164ea9e55fdf69fc2aa4b4e5ccff204b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sat, 26 Oct 2024 05:37:54 +0200
Subject: [PATCH 197/297] adds inferExprType

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 228 +++++++++++++++++-
 src/Language/PureScript/TypeChecker/Types.hs  |   2 +
 2 files changed, 226 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index a0daeed538..e607708221 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-deprecations #-}
@@ -8,8 +9,11 @@
 
 module Language.PureScript.Lsp.Handlers.Hover where
 
+import Control.Exception.Lifted (catch, handle)
 import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), (^.))
 import Control.Lens.Combinators (view)
+import Control.Monad.Supply (runSupplyT)
+import Control.Monad.Trans.Writer (WriterT (runWriterT))
 import Data.List (last)
 import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
@@ -17,6 +21,7 @@ import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
+import Language.PureScript (evalSupplyT)
 import Language.PureScript qualified as P
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
@@ -32,7 +37,8 @@ import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (posInSpan, sourcePosToPosition)
 import Language.PureScript.Names (disqualify)
-import Protolude hiding (to)
+import Language.PureScript.TypeChecker.Types (infer')
+import Protolude hiding (handle, to)
 import Text.PrettyPrint.Boxes (render)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -168,14 +174,15 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                       P.BindingGroupDeclaration bindingGroup -> do
                         debugLsp "BindingGroupDeclaration"
                         NE.toList bindingGroup & allM \((sa, _), _, expr) ->
-                          handleExpr (fst sa, True, expr)
+                          getChildExprs expr & allM \child -> handleExpr (fst sa, True, child)
                       decl@(P.ValueDeclaration vd) -> do
-                        debugLsp $ "ValueDeclaration: " <> P.runIdent (P.valdeclIdent vd)
+                        debugLsp $ "ValueDeclaration IDENT: " <> P.runIdent (P.valdeclIdent vd)
+                        debugLsp $ "ValueDeclaration: " <> show vd
                         let ss = P.declSourceSpan decl
                             guaredExprs = P.valdeclExpression vd
                             children = guaredExprs >>= getChildExprs . (\(P.GuardedExpr _ e) -> e)
                         children & allM \expr ->
-                            handleExpr (ss, True, expr)
+                          handleExpr (ss, True, expr)
                       decl -> do
                         debugLsp $ "Decl: " <> ellipsis 100 (show decl)
                         pure False
@@ -252,3 +259,216 @@ pursTypeStr word type' comments =
 
 pursMd :: Text -> Text
 pursMd t = "```purescript\n" <> t <> "\n```"
+
+data InferError
+  = FileNotCached
+  | CompilationError P.MultipleErrors
+  | InferException Text
+  deriving (Show, Exception)
+
+inferExprType :: FilePath -> P.Expr -> HandlerM (Either InferError P.SourceType)
+inferExprType filePath expr = do
+  cacheOpenMb <- cachedRebuild filePath
+  case cacheOpenMb of
+    Nothing -> pure $ Left FileNotCached
+    Just OpenFile {..} -> do
+      inferRes <- runWriterT $ runExceptT $ evalSupplyT 0 $ evalStateT (infer' expr) (P.emptyCheckState ofStartingEnv)
+      pure $ bimap CompilationError (\(P.TypedValue' _ _ t) -> t) $ fst inferRes
+
+inferExprType' :: FilePath -> P.Expr -> HandlerM P.SourceType
+inferExprType' fp =
+  inferExprType fp >=> \case
+    Right t -> pure t
+    Left e -> throwIO e
+
+-- asdf =
+-- ValueDeclaration
+--   : ValueDeclarationData
+--     { valdeclSourceAnn =
+--         ( SourceSpan
+--             { spanStart =
+--                 SourcePos {sourcePosLine = 27, sourcePosColumn = 3},
+--               spanEnd =
+--                 SourcePos {sourcePosLine = 27, sourcePosColumn = 18}
+--             },
+--           []
+--         ),
+--       valdeclIdent = Ident "asdfa",
+--       valdeclName = Public,
+--       valdeclBinders = [],
+--       valdeclExpression =
+--         [ GuardedExpr
+--             []
+--             ( PositionedValue
+--                 ( SourceSpan
+--                     {         spanStart =
+--                         SourcePos {sourcePosLine = 27, sourcePosColumn = 11},
+--                       spanEnd =
+--                         SourcePos {sourcePosLine = 27, sourcePosColumn = 18}
+--                     }
+--                 )
+--                 []
+--                 ( App
+--                     ( App
+--                         ( TypedValue
+--                             True
+--                             ( PositionedValue
+--                                 ( SourceSpan
+--                                     {                         spanStart =
+--                                         SourcePos {sourcePosLine = 27, sourcePosColumn = 11},
+--                                       spanEnd =
+--                                         SourcePos {sourcePosLine = 27, sourcePosColumn = 15}
+--                                     }
+--                                 )
+--                                 []
+--                                 ( Var
+--                                     ( SourceSpan
+--                                         {                             spanStart =
+--                                             SourcePos {sourcePosLine = 27, sourcePosColumn = 11},
+--                                           spanEnd =
+--                                             SourcePos {sourcePosLine = 27, sourcePosColumn = 15}
+--                                         }
+--                                     )
+--                                     (Qualified (ByModuleName (ModuleName "Data.Show")) (Ident "show"))
+--                                 )
+--                             )
+--                             ( ForAll
+--                                 ( SourceSpan
+--                                     { spanName = "",
+--                                       spanStart =
+--                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
+--                                       spanEnd =
+--                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
+--                                     },
+--                                   []
+--                                 )
+--                                 TypeVarVisible
+--                                 "a"
+--                                 ( Just
+--                                     ( TypeConstructor
+--                                         ( SourceSpan
+--                                             { spanName = "",
+--                                               spanStart =
+--                                                 SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
+--                                               spanEnd =
+--                                                 SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
+--                                             },
+--                                           []
+--                                         )
+--                                         (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
+--                                     )
+--                                 )
+--                                 ( ConstrainedType
+--                                     ( SourceSpan
+--                                         { spanName = "",
+--                                           spanStart =
+--                                             SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
+--                                           spanEnd =
+--                                             SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
+--                                         },
+--                                       []
+--                                     )
+--                                     ( Constraint
+--                                         { constraintAnn =
+--                                             ( SourceSpan
+--                                                 { spanName = "",
+--                                                   spanStart =
+--                                                     SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
+--                                                   spanEnd =
+--                                                     SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
+--                                                 },
+--                                               []
+--                                             ),
+--                                           constraintClass = Qualified (ByModuleName (ModuleName "Data.Show")) (ProperName {runProperName = "Show"}),
+--                                           constraintKindArgs = [],
+--                                           constraintArgs =
+--                                             [ TypeVar
+--                                                 ( SourceSpan
+--                                                     { spanName = "",
+--                                                       spanStart =
+--                                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
+--                                                       spanEnd =
+--                                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
+--                                                     },
+--                                                   []
+--                                                 )
+--                                                 "a"
+--                                             ],
+--                                           constraintData = Nothing
+--                                         }
+--                                     )
+--                                     ( TypeApp
+--                                         ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 11}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 22}},
+--                                           []
+--                                         )
+--                                         ( TypeApp
+--                                             ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 11}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 22}},
+--                                               []
+--                                             )
+--                                             ( TypeConstructor
+--                                                 ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 13}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 15}},
+--                                                   []
+--                                                 )
+--                                                 (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
+--                                             )
+--                                             ( TypeVar
+--                                                 ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 11}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 12}},
+--                                                   []
+--                                                 )
+--                                                 "a"
+--                                             )
+--                                         )
+--                                         ( TypeConstructor
+--                                             ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 22}},
+--                                               []
+--                                             )
+--                                             (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "String"}))
+--                                         )
+--                                     )
+--                                 )
+--                                 (Just (SkolemScope {runSkolemScope = 24}))
+--                             )
+--                         )
+--                         ( Var
+--                             ( SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}
+--                             )
+--                             (Qualified (ByModuleName (ModuleName "Data.Show")) (Ident "showInt"))
+--                         )
+--                     )
+--                     ( TypedValue
+--                         True
+--                         ( TypedValue
+--                             True
+--                             ( PositionedValue
+--                                 ( SourceSpan { spanStart = SourcePos {sourcePosLine = 27, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 27, sourcePosColumn = 18}}
+--                                 )
+--                                 []
+--                                 ( Literal
+--                                     ( SourceSpan { spanStart = SourcePos {sourcePosLine = 27, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 27, sourcePosColumn = 18}}
+--                                     )
+--                                     (NumericLiteral (Left 11))
+--                                 )
+--                             )
+--                             ( TypeConstructor
+--                                 ( SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},
+--                                   []
+--                                 )
+--                                 (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))
+--                             )
+--                         )
+--                         ( TypeConstructor
+--                             ( SourceSpan
+--                                 { spanName = "",
+--                                   spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
+--                                   spanEnd =
+--                                     SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
+--                                 },
+--                               []
+--                             )
+--                             (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))
+--                         )
+--                     )
+--                 )
+--             )
+--         ]
+--     }
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 3f758805c6..15e09939c9 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -3,8 +3,10 @@
 --
 module Language.PureScript.TypeChecker.Types
   ( BindingGroupType(..)
+  , TypedValue'(..)
   , typesOf
   , checkTypeKind
+  , infer'
   ) where
 
 {-

From c210d86e5e65b623b7bb211e23eace2f78b0a6a1 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 28 Oct 2024 15:31:23 +0100
Subject: [PATCH 198/297] hover via typed holes working

---
 src/Language/PureScript/AST/Declarations.hs   |  29 +
 src/Language/PureScript/Ide/Rebuild.hs        |   2 +-
 src/Language/PureScript/Lsp/AtPosition.hs     |  44 +-
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 328 +++++++--
 src/Language/PureScript/Lsp/Rebuild.hs        | 115 +--
 src/Language/PureScript/Lsp/State.hs          |  12 +-
 src/Language/PureScript/Lsp/Types.hs          |   2 +
 src/Language/PureScript/Lsp/Util.hs           |  23 +-
 src/Language/PureScript/Make.hs               |  51 +-
 src/Language/PureScript/Make/Actions.hs       | 684 +++++++++---------
 src/Language/PureScript/Make/Index.hs         |   4 +-
 11 files changed, 797 insertions(+), 497 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index e8cfbce87f..e25c305ae8 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -778,6 +778,35 @@ data Expr
   | PositionedValue SourceSpan [Comment] Expr
   deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
+exprCtr :: Expr -> Text 
+exprCtr (Literal _ _) = "Literal"
+exprCtr (UnaryMinus _ _) = "UnaryMinus"
+exprCtr (BinaryNoParens _ _ _) = "BinaryNoParens"
+exprCtr (Parens _) = "Parens"
+exprCtr (Accessor _ _) = "Accessor"
+exprCtr (ObjectUpdate _ _) = "ObjectUpdate"
+exprCtr (ObjectUpdateNested _ _) = "ObjectUpdateNested"
+exprCtr (Abs _ _) = "Abs"
+exprCtr (App _ _) = "App"
+exprCtr (VisibleTypeApp _ _) = "VisibleTypeApp"
+exprCtr (Unused _) = "Unused"
+exprCtr (Var _ _) = "Var"
+exprCtr (Op _ _) = "Op"
+exprCtr (IfThenElse _ _ _) = "IfThenElse"
+exprCtr (Constructor _ _) = "Constructor"
+exprCtr (Case _ _) = "Case"
+exprCtr (TypedValue _ _ _) = "TypedValue"
+exprCtr (Let _ _ _) = "Let"
+exprCtr (Do _ _) = "Do"
+exprCtr (Ado _ _ _) = "Ado"
+exprCtr (TypeClassDictionary _ _ _) = "TypeClassDictionary"
+exprCtr (DeferredDictionary _ _) = "DeferredDictionary"
+exprCtr (DerivedInstancePlaceholder _ _) = "DerivedInstancePlaceholder"
+exprCtr AnonymousArgument = "AnonymousArgument"
+exprCtr (Hole _) = "Hole"
+exprCtr (PositionedValue _ _ _) = "PositionedValue"
+
+
 exprSourceSpan :: Expr -> Maybe SourceSpan
 exprSourceSpan (Literal ss _) = Just ss
 exprSourceSpan (UnaryMinus ss _) = Just ss
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index b3080e1804..7b82c6c535 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -184,7 +184,7 @@ shushProgress ma =
 -- | Stops any kind of codegen
 shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
-  ma { P.codegen = \_ _ _ _ _ -> pure ()
+  ma { P.codegen = \_ _ _ _ _ _ -> pure ()
      , P.ffiCodegen = \_ -> pure ()
      }
 
diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index a8b3659ae4..40edcb19b6 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -20,7 +20,7 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
-import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
+import Language.PureScript.Lsp.Util (declsAtLine, getDeclarationAtPos, onDeclsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Traversals (defS)
 import Language.PureScript.Types (getAnnForType)
 import Protolude
@@ -72,7 +72,8 @@ spanSize :: P.SourceSpan -> (Int, Int)
 spanSize (P.SourceSpan _ start end) = (P.sourcePosLine end - P.sourcePosLine start, P.sourcePosColumn end - P.sourcePosColumn start)
 
 data EverythingAtPos = EverythingAtPos
-  { apDecls :: [P.Declaration],
+  { apTopLevelDecl :: Maybe P.Declaration,
+    apDecls :: [P.Declaration],
     apExprs :: [(P.SourceSpan, Bool, P.Expr)],
     apBinders :: [(P.SourceSpan, Bool, P.Binder)],
     apCaseAlternatives :: [(P.SourceSpan, P.CaseAlternative)],
@@ -103,11 +104,15 @@ showCounts EverythingAtPos {..} =
     <> show (isJust apImport)
 
 nullEverythingAtPos :: EverythingAtPos
-nullEverythingAtPos = EverythingAtPos [] [] [] [] [] [] [] Nothing
+nullEverythingAtPos = EverythingAtPos Nothing [] [] [] [] [] [] [] Nothing
+
+topLevelDecl :: P.Declaration -> EverythingAtPos
+topLevelDecl decl = nullEverythingAtPos {apTopLevelDecl = Just decl}
 
 withSpansOnly :: EverythingAtPos -> EverythingAtPos
 withSpansOnly EverythingAtPos {..} =
   EverythingAtPos
+    apTopLevelDecl
     apDecls
     (filter (view _2) apExprs)
     (filter (view _2) apBinders)
@@ -120,6 +125,7 @@ withSpansOnly EverythingAtPos {..} =
 withTypedValuesOnly :: EverythingAtPos -> EverythingAtPos
 withTypedValuesOnly EverythingAtPos {..} =
   EverythingAtPos
+    apTopLevelDecl
     apDecls
     (filter (isJust . exprTypes . view _3) apExprs)
     (filter (isJust . binderTypes . view _3) apBinders)
@@ -136,14 +142,14 @@ getEverythingAtPos :: [P.Declaration] -> Types.Position -> EverythingAtPos
 getEverythingAtPos decls pos@(Types.Position {..}) =
   case head $ declsAtLine (fromIntegral _line + 1) $ filter (not . isPrimImport) decls of
     Nothing -> nullEverythingAtPos
-    Just (P.ImportDeclaration (ss, _) importedModuleName importType _) ->
-      nullEverythingAtPos {apImport = Just (maybe ss P.declRefSourceSpan ref, importedModuleName, importType, ref)}
+    Just decl@(P.ImportDeclaration (ss, _) importedModuleName importType _) ->
+      (topLevelDecl decl) {apImport = Just (maybe ss P.declRefSourceSpan ref, importedModuleName, importType, ref)}
       where
         ref = findDeclRefAtPos pos case importType of
           P.Implicit -> []
           P.Explicit refs -> refs
           P.Hiding refs -> refs
-    Just topDecl -> execState (handleDecl topDecl) nullEverythingAtPos {apDecls = [topDecl]}
+    Just topDecl -> execState (handleDecl topDecl) (topLevelDecl topDecl) {apDecls = [topDecl]}
       where
         (handleDecl, _, _, _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan topDecl) onDecl onExpr onBinder onCaseAlternative onDoNotationElement onGuard
 
@@ -255,7 +261,7 @@ debugExpr =
     . show
 
 debugSrcSpan :: P.SourceSpan -> Text
-debugSrcSpan = 
+debugSrcSpan =
   T.replace ", sourcePosColumn = " ":"
     . T.replace "SourcePos {sourcePosLine = " ""
     . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
@@ -263,7 +269,6 @@ debugSrcSpan =
     . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/simple-purs/src/B.purs\", " ""
     . show
 
-
 -- getDeclTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
 
 atPosition ::
@@ -431,6 +436,29 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
         modify (expr :)
       pure expr
 
+modifySmallestExprAtPos :: (P.Expr -> P.Expr) -> Types.Position -> P.Module -> (P.Module, Maybe (P.Expr, P.Expr))
+modifySmallestExprAtPos fn pos@(Types.Position {..}) (P.Module ss c mName decls refs) =
+  (P.Module ss c mName (fmap fst declsAndExpr) refs, asum $ snd <$> declsAndExpr)
+  where
+    declsAndExpr = onDeclsAtLine (pure . modifySmallestDeclExprAtPos fn pos) (\d -> [(d, Nothing)]) (fromIntegral _line + 1) decls
+
+modifySmallestDeclExprAtPos :: (P.Expr -> P.Expr) -> Types.Position -> P.Declaration -> (P.Declaration, Maybe (P.Expr, P.Expr))
+modifySmallestDeclExprAtPos fn pos declaration = runState (onDecl declaration) Nothing
+  where
+    (onDecl, _, _) = P.everywhereOnValuesM pure handleExpr pure
+
+    handleExpr :: P.Expr -> StateT (Maybe (P.Expr, P.Expr)) Identity P.Expr
+    handleExpr expr = do
+      found <- get
+      !_ <- pure $ unsafePerformIO $ putErrLn $ P.exprCtr expr
+      !_ <- pure $ unsafePerformIO $ (putErrLn :: Text -> IO ()) (show $ maybe False (posInSpan pos) (P.exprSourceSpan expr))
+      if isNothing found && maybe False (posInSpan pos) (P.exprSourceSpan expr)
+        then do
+          let expr' = fn expr
+          modify (const $ Just (expr, expr'))
+          pure expr'
+        else pure expr
+
 getChildExprs :: P.Expr -> [P.Expr]
 getChildExprs parentExpr = execState (goExpr parentExpr) []
   where
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index e607708221..1bd0681188 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -9,35 +9,46 @@
 
 module Language.PureScript.Lsp.Handlers.Hover where
 
+import Control.Arrow ((>>>))
 import Control.Exception.Lifted (catch, handle)
 import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), (^.))
 import Control.Lens.Combinators (view)
 import Control.Monad.Supply (runSupplyT)
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
+import Control.Monad.Writer (MonadWriter (..), censor)
 import Data.List (last)
 import Data.List.NonEmpty qualified as NE
+import Data.Map qualified as M
 import Data.Text qualified as T
+import GHC.TopHandler (runIO)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.PureScript (evalSupplyT)
 import Language.PureScript qualified as P
+import Language.PureScript.AST.Binders (Binder (..))
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
+import Language.PureScript.Environment (tyBoolean, tyChar, tyInt, tyNumber, tyString)
+import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, showCounts, spanSize, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, modifySmallestExprAtPos, showCounts, spanSize, spanToRange)
+import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.State (cachedRebuild)
-import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (posInSpan, sourcePosToPosition)
+import Language.PureScript.Lsp.Rebuild (buildExportEnvCacheAndHandleErrors)
+import Language.PureScript.Lsp.State (cachedRebuild, getExportEnv)
+import Language.PureScript.Lsp.Types (ExternDependency (edExtern), OpenFile (..))
+import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Names (disqualify)
+import Language.PureScript.TypeChecker (getEnv)
 import Language.PureScript.TypeChecker.Types (infer')
+import Language.PureScript.TypeChecker.Unify (unifyTypes)
 import Protolude hiding (handle, to)
 import Text.PrettyPrint.Boxes (render)
 
@@ -48,7 +59,8 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 
       nullRes = res $ Right $ Types.InR Types.Null
 
-      markdownRes md range = res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) range
+      markdownRes md range =
+        res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) range
 
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
@@ -79,10 +91,16 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             printedExpr' = ellipsis 2000 $ show expr'
         markdownRes (label <> ": \n" <> pursMd printedExpr <> "\n\n" <> label' <> ": \n" <> printedExpr') (Just $ spanToRange ss)
 
-      respondWithTypedExpr :: P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
+      respondWithTypedExpr :: Maybe P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
       respondWithTypedExpr ss expr tipe = do
+        void $
+          expr & onChildExprs \e -> do
+            pure e
         let printedType = prettyPrintTypeSingleLine tipe
-        markdownRes (pursTypeStr (dispayExprOnHover expr) (Just printedType) []) (Just $ spanToRange ss)
+            printedExpr = case expr of
+              P.Op _ (P.Qualified _ op) -> P.runOpName op -- pretty printing ops ends in infinite loop
+              _ -> dispayExprOnHover expr
+        markdownRes (pursTypeStr printedExpr (Just printedType) []) (spanToRange <$> ss)
 
       respondWithTypeBinder :: P.SourceSpan -> P.Binder -> P.SourceType -> HandlerM ()
       respondWithTypeBinder ss binder tipe = do
@@ -123,70 +141,230 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         _ -> pure True
 
   forLsp filePathMb \filePath -> do
-    cacheOpenMb <- cachedRebuild filePath
-    forLsp cacheOpenMb \OpenFile {..} -> do
-      let handlePos :: Types.Position -> HandlerM ()
-          handlePos pos = do
-            let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
-            debugLsp $ "pos: " <> show pos
-
-            case apImport everything of
-              Just (ss, importedModuleName, _, ref) -> do
-                debugLsp $ "Import: " <> show importedModuleName
-                respondWithImport ss importedModuleName ref
-              _ -> do
-                let exprs = apExprs everything
-                    handleExpr expr = do
-                      case expr of
-                        (ss, _, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                          debugLsp $ "Var: " <> show ident
-                          respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
-                          pure False
-                        (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                          debugLsp $ "Op: " <> show ident
-                          respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
-                          pure False
-                        (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
-                          debugLsp $ "Dctor: " <> show ident
-                          respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
-                          pure False
-                        (ss, _, P.TypedValue _ tExpr ty) | not (generatedExpr tExpr) -> do
-                          respondWithTypedExpr ss tExpr ty
-                          pure False
-                        (ss, _, P.Literal _ lit) -> do
-                          handleLiteral ss lit
-                        _ -> pure True
-
-                debugLsp $ "exprs found: " <> show (length exprs)
-                noExprFound <- allM handleExpr exprs
-
-                debugLsp $ "No expr found: " <> show noExprFound
-                when noExprFound do
-                  debugLsp $ showCounts everything
-                  let decls = apDecls everything & sortDeclsBySize
-                  void $
-                    apDecls everything & allM \case
-                      P.BoundValueDeclaration sa _binder expr -> do
-                        debugLsp "BoundValueDeclaration"
-                        let ss = fst sa
-                            children = getChildExprs expr
-                        children & allM \e -> handleExpr (ss, True, e)
-                      P.BindingGroupDeclaration bindingGroup -> do
-                        debugLsp "BindingGroupDeclaration"
-                        NE.toList bindingGroup & allM \((sa, _), _, expr) ->
-                          getChildExprs expr & allM \child -> handleExpr (fst sa, True, child)
-                      decl@(P.ValueDeclaration vd) -> do
-                        debugLsp $ "ValueDeclaration IDENT: " <> P.runIdent (P.valdeclIdent vd)
-                        debugLsp $ "ValueDeclaration: " <> show vd
-                        let ss = P.declSourceSpan decl
-                            guaredExprs = P.valdeclExpression vd
-                            children = guaredExprs >>= getChildExprs . (\(P.GuardedExpr _ e) -> e)
-                        children & allM \expr ->
-                          handleExpr (ss, True, expr)
-                      decl -> do
-                        debugLsp $ "Decl: " <> ellipsis 100 (show decl)
-                        pure False
-      handlePos startPos
+    inferredRes <- inferExprViaTypeHole filePath startPos
+    case inferredRes of
+      Just (expr, ty) -> do
+        let ss = P.exprSourceSpan expr
+        respondWithTypedExpr ss expr ty
+      Nothing -> do
+        debugLsp "Inferred via type hole failed"
+        nullRes
+
+-- cacheOpenMb <- cachedRebuild filePath
+
+-- forLsp cacheOpenMb \OpenFile {..} -> do
+--   let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
+--   case head (apExprs everything) of
+--     Just (ss, _, e) -> do
+--       inferredRes <-  filePath e
+--       case inferredRes of
+--         Right ty -> respondWithTypedExpr ss e ty
+--         Left err -> do
+--           debugLsp $ "Error: " <> show err
+--           nullRes
+--     _ -> nullRes
+
+-- let handlePos :: Types.Position -> HandlerM ()
+--     handlePos pos = do
+--       let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
+--       debugLsp $ "pos: " <> show pos
+
+--       case apImport everything of
+--         Just (ss, importedModuleName, _, ref) -> do
+--           debugLsp $ "Import: " <> show importedModuleName
+--           respondWithImport ss importedModuleName ref
+--         _ -> do
+--           let exprs = apExprs everything
+--               handleExpr expr = do
+--                 case expr of
+--                   (ss, _, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+--                     debugLsp $ "Var: " <> show ident
+--                     respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
+--                     pure False
+--                   (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+--                     debugLsp $ "Op: " <> show ident
+--                     respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
+--                     pure False
+--                   (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
+--                     debugLsp $ "Dctor: " <> show ident
+--                     respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
+--                     pure False
+--                   (ss, _, P.TypedValue _ tExpr ty) | not (generatedExpr tExpr) -> do
+--                     respondWithTypedExpr ss tExpr ty
+--                     pure False
+--                   (ss, _, P.Literal _ lit) -> do
+--                     handleLiteral ss lit
+--                   _ -> pure True
+
+--           debugLsp $ "exprs found: " <> show (length exprs)
+--           noExprFound <- allM handleExpr exprs
+
+--           debugLsp $ "No expr found: " <> show noExprFound
+--           when noExprFound do
+--             debugLsp $ showCounts everything
+--             let decls = apDecls everything & sortDeclsBySize
+--             void $
+--               apDecls everything & allM \case
+--                 P.BoundValueDeclaration sa _binder expr -> do
+--                   debugLsp "BoundValueDeclaration"
+--                   let ss = fst sa
+--                       children = getChildExprs expr
+--                   children & allM \e -> handleExpr (ss, True, e)
+--                 P.BindingGroupDeclaration bindingGroup -> do
+--                   debugLsp "BindingGroupDeclaration"
+--                   NE.toList bindingGroup & allM \((sa, _), _, expr) ->
+--                     getChildExprs expr & allM \child -> handleExpr (fst sa, True, child)
+--                 decl@(P.ValueDeclaration vd) -> do
+--                   debugLsp $ "ValueDeclaration IDENT: " <> P.runIdent (P.valdeclIdent vd)
+--                   debugLsp $ "ValueDeclaration: " <> show vd
+--                   let ss = P.declSourceSpan decl
+--                       guaredExprs = P.valdeclExpression vd
+--                       children = guaredExprs >>= getChildExprs . (\(P.GuardedExpr _ e) -> e)
+--                   children & allM \expr ->
+--                     handleExpr (ss, True, expr)
+--                 decl -> do
+--                   debugLsp $ "Decl: " <> ellipsis 100 (show decl)
+--                   pure False
+-- handlePos startPos
+
+inferAtPosition :: FilePath -> Types.Position -> HandlerM (Maybe (Either P.MultipleErrors (P.SourceSpan, P.Expr, P.SourceType)))
+inferAtPosition filePath pos@(Types.Position {..}) = do
+  cacheOpenMb <- cachedRebuild filePath
+  case cacheOpenMb of
+    Nothing -> pure Nothing
+    Just OpenFile {..} -> do
+      let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
+
+      case (apTopLevelDecl everything, head $ apExprs everything) of
+        (Just decl, Just (ss, _, expr)) -> do
+          let onDecl d = pure d
+              onExpr e = do
+                when (e == expr) do
+                  (P.TypedValue' _ _ t) <- infer' e
+                  tell $ P.MultipleErrors [P.ErrorMessage [] (P.HoleInferredType hoverHoleLabel t [] Nothing)]
+                -- P.MultipleErrors  [P.ErrorMessage [] (P.HoleInferredType hoverHoleLabel inferred [] Nothing)]
+                pure e
+              onBinder b = do
+                !_ <- pure $ force $ traceShow' "onBinder" b
+                case b of
+                  P.TypedBinder _st _b' -> pure ()
+                  _ -> pure ()
+                pure b
+
+              (inferExpr, _, _) = P.everywhereOnValuesTopDownM onDecl onExpr onBinder
+
+          -- runInference :: HandlerM (Either P.MultipleErrors (P.Declaration, P.MultipleErrors))
+          -- runInference = runExceptT $ runWriterT $ evalSupplyT 0 $ evalStateT (inferExpr decl) ((P.emptyCheckState ofStartingEnv) {P.checkCurrentModule = Just ofModuleName})
+
+          inferRes <- runInference (inferExpr decl) ofModuleName ofEndEnv
+          case getHoverSourceTypeFromErrs inferRes of
+            Just t -> pure $ Just $ Right (ss, expr, t)
+            _ -> pure $ Just $ Left $ getResErrors inferRes
+        _ -> pure Nothing
+  where
+    runInference a modName env =
+      runExceptT $
+        runWriterT $
+          evalSupplyT 0 $
+            evalStateT a ((P.emptyCheckState env) {P.checkCurrentModule = Just modName})
+
+-- inferBinder :: P.SourceType -> P.Binder -> m (Map P.Ident (P.SourceSpan, P.SourceType))
+-- inferBinder _ NullBinder = return M.empty
+-- inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty
+-- inferBinder val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
+-- inferBinder val (LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty
+-- inferBinder val (LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty
+-- inferBinder val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty
+-- inferBinder val (VarBinder ss name) = return $ M.singleton name (ss, val)
+-- inferBinder val (ConstructorBinder ss ctor binders) = do
+--   env <- getEnv
+--   case M.lookup ctor (P.dataConstructors env) of
+--     Just (_, _, ty, _) -> do
+--       let (args, ret) = peelArgs ty
+--           expected = length args
+--           actual = length binders
+--       unifyTypes ret val
+--       M.unions <$> zipWithM inferBinder (reverse args) binders
+--     _ -> throwError . P.errorMessage' ss . P.UnknownName . fmap P.DctorName $ ctor
+--   where
+--     peelArgs :: P.Type a -> ([P.Type a], P.Type a)
+--     peelArgs = go []
+--       where
+--         go args (P.TypeApp _ (P.TypeApp _ fn arg) ret) | P.eqType fn P.tyFunction = go (arg : args) ret
+--         go args ret = (args, ret)
+-- inferBinder _ _ = throwError "Not implemented"
+
+getResErrors :: Either P.MultipleErrors (a, P.MultipleErrors) -> P.MultipleErrors
+getResErrors = either identity snd
+
+getHoverSourceTypeFromErrs :: Either P.MultipleErrors (P.Declaration, P.MultipleErrors) -> Maybe P.SourceType
+getHoverSourceTypeFromErrs = \case
+  Left (P.MultipleErrors errs) -> findMap getHoverHoleType errs
+  Right (_, P.MultipleErrors errs) -> findMap getHoverHoleType errs
+
+-- let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
+-- case head (apExprs everything) of
+--   Just (_, _, e) -> do
+--     inferredRes <- inferExprType filePath e
+--     case inferredRes of
+--       Right ty -> pure $ Just (e, ty)
+--       Left _ -> pure Nothing
+--   _ -> pure Nothing
+
+inferExprViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Expr, P.SourceType))
+inferExprViaTypeHole filePath pos = do
+  cacheOpenMb <- cachedRebuild filePath
+  cacheOpenMb & maybe (pure Nothing) \OpenFile {..} -> do
+    let module' = P.importPrim ofUncheckedModule
+        (moduleWithHole, exprs) = modifySmallestExprAtPos addTypeHoleAnnotation pos module'
+    case exprs of
+      Nothing -> pure Nothing
+      Just (exprBefore, _exprAfter) -> do
+        let externs = fmap edExtern ofDependencies
+        (exportEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
+        (checkRes, warnings) <-
+          runWriterT $
+            runExceptT $
+              P.desugarAndTypeCheck Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
+        debugLsp $ "Infer via type hole checkRes: " <> show (isLeft checkRes)
+        case checkRes of
+          Right _ -> pure $ (exprBefore,) <$> findHoleType warnings
+          Left errs -> do
+            debugLsp $ T.pack $ P.prettyPrintMultipleErrors P.noColorPPEOptions (warnings <> errs)
+            pure $
+              (exprBefore,) <$> findHoleType (warnings <> errs)
+  where
+    findHoleType :: P.MultipleErrors -> Maybe P.SourceType
+    findHoleType = P.runMultipleErrors >>> findMap getHoverHoleType
+
+getHoverHoleType :: P.ErrorMessage -> Maybe P.SourceType
+getHoverHoleType =
+  P.unwrapErrorMessage >>> \case
+    P.HoleInferredType label t _ _ | label == hoverHoleLabel -> Just t
+    _ -> Nothing
+
+findMap :: (a -> Maybe b) -> [a] -> Maybe b
+findMap f = listToMaybe . mapMaybe f
+
+-- addHoleAnnotation :: (Monad m) => P.Expr -> P.Declaration -> m P.Declaration
+-- addHoleAnnotation expr = onDeclExprs \e ->
+--   if e == expr
+--     then
+--       pure $
+--         P.TypedValue False e (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel)
+--     else pure e
+
+addTypeHoleAnnotation :: P.Expr -> P.Expr
+addTypeHoleAnnotation expr = P.TypedValue False expr (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel)
+
+hoverHoleLabel :: Text
+hoverHoleLabel = "?HOVER?"
+
+onDeclExprs :: (Monad m) => (P.Expr -> m P.Expr) -> P.Declaration -> m P.Declaration
+onDeclExprs fn = view _1 $ P.everywhereOnValuesTopDownM pure fn pure
+
+onChildExprs :: (Monad m) => (P.Expr -> m P.Expr) -> P.Expr -> m P.Expr
+onChildExprs fn = view _2 $ P.everywhereOnValuesTopDownM pure fn pure
 
 allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
 allM _ [] = pure True
@@ -232,12 +410,10 @@ findTypedExpr (_ : es) = findTypedExpr es
 findTypedExpr [] = Nothing
 
 dispayExprOnHover :: P.Expr -> T.Text
-dispayExprOnHover expr = ellipsis 32 $ line1Only $ T.strip $ T.pack $ render $ P.prettyPrintValue 3 expr
-  where
-    line1Only = T.takeWhile (/= '\n')
+dispayExprOnHover expr = ellipsis 32 $ T.strip $ T.pack $ render $ traceShow' "printed expr val" $ P.prettyPrintValue 2 expr
 
 dispayBinderOnHover :: P.Binder -> T.Text
-dispayBinderOnHover binder = ellipsis 32 $ line1Only $ T.strip $ P.prettyPrintBinder binder
+dispayBinderOnHover binder = line1Only $ ellipsis 32 $ T.strip $ P.prettyPrintBinder binder
   where
     line1Only = T.takeWhile (/= '\n')
 
@@ -272,7 +448,7 @@ inferExprType filePath expr = do
   case cacheOpenMb of
     Nothing -> pure $ Left FileNotCached
     Just OpenFile {..} -> do
-      inferRes <- runWriterT $ runExceptT $ evalSupplyT 0 $ evalStateT (infer' expr) (P.emptyCheckState ofStartingEnv)
+      inferRes <- runWriterT $ runExceptT $ evalSupplyT 0 $ evalStateT (infer' expr) ((P.emptyCheckState ofStartingEnv) {P.checkCurrentModule = Just ofModuleName})
       pure $ bimap CompilationError (\(P.TypedValue' _ _ t) -> t) $ fst inferRes
 
 inferExprType' :: FilePath -> P.Expr -> HandlerM P.SourceType
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index d531ec68b4..ce8fb6bce9 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -4,7 +4,7 @@
 
 -- {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
-module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, codegenTargets) where
+module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, buildExportEnvCacheAndHandleErrors, codegenTargets) where
 
 import Control.Category ((>>>))
 import Control.Concurrent.STM (TChan, TVar, writeTChan)
@@ -57,55 +57,76 @@ rebuildFile uri =
         stVar <- asks lspStateVar
         maxCache <- getMaxFilesInCache
         cachedBuild <- cachedRebuild fp
-        let makeEnv :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
-            makeEnv foreigns externs =
+        let mkMakeActions :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
+            mkMakeActions foreigns externs =
               P.buildMakeActions outputDirectory filePathMap foreigns False
                 -- & broadcastProgress chan
                 & addAllIndexing conn
-                & addRebuildCaching stVar maxCache externs
+                & addRebuildCaching stVar maxCache externs m
         case cachedBuild of
           Just open -> do
-            rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m open
+            rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m open
           Nothing -> do
-            rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
-  where
-    rebuildFromOpenFileCache outputDirectory fp pwarnings stVar makeEnv m (Language.PureScript.Lsp.Types.OpenFile moduleName _ externDeps env _) = do
-      let externs = fmap edExtern externDeps
-      foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-      (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
-      for_ externsMb (cacheDependencies moduleName)
-      res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
-        P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-          newExtern <- P.rebuildModuleWithProvidedEnv (Just $ updateCachedModule' stVar) (makeEnv foreigns externDeps) exportEnv env externs m Nothing
-          updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
-          pure newExtern
-      case fst res of
-        Left errs -> debugLsp $ "Rebuild error detected: " <> show errs
-        _ -> pure ()
-      case fst res of
-        Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
-          warnLsp "Module not found error detected, rebuilding without cache"
-          rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m
-        _ -> handleRebuildResult fp pwarnings res
-
-    rebuildWithoutCache moduleName makeEnv outputDirectory fp pwarnings m = do
-      externDeps <- logPerfStandard "Select depenencies" $ selectDependencies m
-      let externs = fmap edExtern externDeps
-      foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-      exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
-      res <- logPerfStandard "Rebuild Module" $ liftIO $ do
-        P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-          newExtern <- P.rebuildModule' (makeEnv foreigns externDeps) exportEnv externs m
-          updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
-          pure newExtern
-      handleRebuildResult fp pwarnings res
-    handleRebuildResult fp pwarnings (result, warnings) = do
-      case result of
-        Left errors ->
-          pure $ RebuildError errors
-        Right newExtern -> do
-          addExternToExportEnv newExtern
-          pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
+            rebuildWithoutCache moduleName mkMakeActions fp pwarnings m
+
+rebuildFromOpenFileCache ::
+  (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
+  FilePath ->
+  [CST.ParserWarning] ->
+  TVar LspState ->
+  (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
+  P.Module ->
+  OpenFile ->
+  m RebuildResult
+rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName _ externDeps env _ _ _) = do
+  outputDirectory <- outputPath <$> getConfig
+  let externs = fmap edExtern externDeps
+  foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+  (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
+  for_ externsMb (cacheDependencies moduleName)
+  res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
+    P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+      newExtern <- P.rebuildModuleWithProvidedEnv (Just $ updateCachedModule' stVar) (mkMakeActions foreigns externDeps) exportEnv env externs m Nothing
+      updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+      pure newExtern
+  case fst res of
+    Left errs -> debugLsp $ "Rebuild error detected: " <> show errs
+    _ -> pure ()
+  case fst res of
+    Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
+      warnLsp "Module not found error detected, rebuilding without cache"
+      rebuildWithoutCache moduleName mkMakeActions fp pwarnings m
+    _ -> handleRebuildResult fp pwarnings res
+
+rebuildWithoutCache ::
+  (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
+  P.ModuleName ->
+  (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
+  FilePath ->
+  [CST.ParserWarning] ->
+  P.Module ->
+  m RebuildResult
+rebuildWithoutCache moduleName mkMakeActions fp pwarnings m = do
+  outputDirectory <- outputPath <$> getConfig
+  externDeps <- logPerfStandard "Select depenencies" $ selectDependencies m
+  let externs = fmap edExtern externDeps
+  foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+  exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
+  res <- logPerfStandard "Rebuild Module" $ liftIO $ do
+    P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+      newExtern <- P.rebuildModule' (mkMakeActions foreigns externDeps) exportEnv externs m
+      updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+      pure newExtern
+  handleRebuildResult fp pwarnings res
+
+handleRebuildResult :: (MonadLsp ServerConfig f, MonadReader LspEnvironment f) => FilePath -> [CST.ParserWarning] -> (Either P.MultipleErrors ExternsFile, P.MultipleErrors) -> f RebuildResult
+handleRebuildResult fp pwarnings (result, warnings) = do
+  case result of
+    Left errors ->
+      pure $ RebuildError errors
+    Right newExtern -> do
+      addExternToExportEnv newExtern
+      pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
 
 couldBeFromNewImports :: P.ErrorMessage -> Bool
 couldBeFromNewImports =
@@ -194,8 +215,8 @@ broadcastProgress chan ma = do
     { P.progress = liftIO . atomically . writeTChan chan . Just
     }
 
-addRebuildCaching :: TVar Language.PureScript.Lsp.Types.LspState -> Int -> [ExternDependency] -> P.MakeActions P.Make -> P.MakeActions P.Make
-addRebuildCaching stVar maxCache deps ma =
+addRebuildCaching :: TVar LspState -> Int -> [ExternDependency] -> P.Module -> P.MakeActions P.Make -> P.MakeActions P.Make
+addRebuildCaching stVar maxCache deps unchecked ma =
   ma
-    { P.codegen = \prevEnv astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv astM) <* P.codegen ma prevEnv astM m docs ext
+    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv endEnv unchecked astM) <* P.codegen ma prevEnv endEnv astM m docs ext
     }
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index ea3ff806bd..461e040654 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -52,16 +52,16 @@ getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternDependency] -> P.Environment -> P.Module -> m ()
-cacheRebuild ef deps prevEnv module' = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.Module -> P.Module -> m ()
+cacheRebuild ef deps prevEnv endEnv unchecked module' = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
-  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv module'
+  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv endEnv unchecked module'
 
-cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [ExternDependency] -> P.Environment -> P.Module -> IO ()
-cacheRebuild' st maxFiles ef deps prevEnv module' = atomically . modifyTVar st $ \x ->
+cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.Module -> P.Module -> IO ()
+cacheRebuild' st maxFiles ef deps prevEnv endEnv unchecked module' = atomically . modifyTVar st $ \x ->
   x
-    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv module') : filter ((/= fp) . fst) (openFiles x)
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv endEnv unchecked module') : filter ((/= fp) . fst) (openFiles x)
     }
   where
     fp = P.spanName $ efSourceSpan ef
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index c43430eb22..4278852e56 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -55,6 +55,8 @@ data OpenFile = OpenFile
     ofExternsFile :: P.ExternsFile,
     ofDependencies :: [ExternDependency],
     ofStartingEnv :: P.Environment,
+    ofEndEnv :: P.Environment,
+    ofUncheckedModule :: P.Module,
     ofModule ::  P.Module
   }
   deriving (Show)
diff --git a/src/Language/PureScript/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs
index 4da8a78c96..c424d20065 100644
--- a/src/Language/PureScript/Lsp/Util.hs
+++ b/src/Language/PureScript/Lsp/Util.hs
@@ -27,7 +27,7 @@ import Protolude hiding (to)
 
 posInSpan :: Types.Position -> AST.SourceSpan -> Bool
 posInSpan (Types.Position line col) (AST.SourceSpan _ (AST.SourcePos startLine startCol) (AST.SourcePos endLine endCol)) =
-  not (startLine == 1 && startCol == 1)  -- ignore generated spans
+  not (startLine == 1 && startCol == 1) -- ignore generated spans
     && startLine <= atLine
     && endLine >= atLine
     && startCol <= atCol
@@ -185,6 +185,27 @@ declsAtLine l = go . sortBy (comparing declStartLine)
       P.TypeInstanceDeclaration {} -> True
       _ -> False
 
+
+-- Faster way to get the declarations at a line
+onDeclsAtLine :: (P.Declaration -> [a]) -> (P.Declaration -> [a]) -> Int -> [P.Declaration] -> [a]
+onDeclsAtLine atLine notAtLine l = go . sortBy (comparing declStartLine)
+  where
+    go (d : d' : ds)
+      | declStartLine d <= l && declEndLine d >= l = atLine d <> go (d' : ds)
+      | declStartLine d <= l && declStartLine d' > l && unsureEndLine d = atLine d <> go (d' : ds)
+      | otherwise = notAtLine d <> go (d' : ds)
+    go [d]
+      | declStartLine d <= l = atLine d
+      | otherwise = notAtLine d
+    go [] = []
+
+    unsureEndLine = \case
+      P.ValueDeclaration {} -> True
+      P.ExternDeclaration {} -> True
+      P.TypeClassDeclaration {} -> True
+      P.TypeInstanceDeclaration {} -> True
+      _ -> False
+
 declStartLine :: P.Declaration -> Int
 declStartLine = P.sourcePosLine . AST.spanStart . P.declSourceSpan
 
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 3438e64e2d..48025fbc98 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -2,6 +2,7 @@
 
 module Language.PureScript.Make
   ( -- * Make API
+    desugarAndTypeCheck,
     rebuildModule,
     rebuildModule',
     rebuildModuleWithProvidedEnv,
@@ -23,7 +24,7 @@ import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
 import Control.Monad.Trans.Control (MonadBaseControl (..))
 import Control.Monad.Trans.State (runStateT)
 import Control.Monad.Writer.Class (MonadWriter (..), censor)
-import Control.Monad.Writer.Strict (runWriterT, MonadTrans (lift))
+import Control.Monad.Writer.Strict (MonadTrans (lift), runWriterT)
 import Data.Foldable (fold, for_)
 import Data.Function (on)
 import Data.List (foldl', sortOn)
@@ -108,23 +109,7 @@ rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(M
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
-  ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
-    (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
-    for_ onDesugared $ lift . \f -> f desugared
-    let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-    (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
-    let usedImports' =
-          foldl'
-            ( flip $ \(fromModuleName, newtypeCtorName) ->
-                M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
-            )
-            usedImports
-            checkConstructorImportsForCoercible
-    -- Imports cannot be linted before type checking because we need to
-    -- known which newtype constructors are used to solve Coercible
-    -- constraints in order to not report them as unused.
-    censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
-    return (checked, checkEnv)
+  ((Module ss coms _ elaborated exps, env'), nextVar) <- desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env
 
   -- desugar case declarations *after* type- and exhaustiveness checking
   -- since pattern guards introduces cases which the exhaustiveness checker
@@ -134,6 +119,7 @@ rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(M
 
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
+
       corefn = CF.moduleToCoreFn env' mod'
       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
@@ -155,9 +141,36 @@ rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(M
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env mod' renamed docs exts
+  evalSupplyT nextVar'' $ codegen env env' mod' renamed docs exts
   return exts
 
+desugarAndTypeCheck ::
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m, Foldable t) =>
+  t (Module -> m b) ->
+  ModuleName ->
+  [ExternsFile] ->
+  Module ->
+  Env ->
+  Environment ->
+  m ((Module, Environment), Integer)
+desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env = runSupplyT 0 $ do
+  (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
+  for_ onDesugared $ lift . \f -> f desugared
+  let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
+  (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+  let usedImports' =
+        foldl'
+          ( flip $ \(fromModuleName, newtypeCtorName) ->
+              M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
+          )
+          usedImports
+          checkConstructorImportsForCoercible
+  -- Imports cannot be linted before type checking because we need to
+  -- known which newtype constructors are used to solve Coercible
+  -- constraints in order to not report them as unused.
+  censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
+  return (checked, checkEnv)
+
 -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
 -- but I have not done so for two reasons:
 -- 1. This should never fail; any genuine errors in the code should have been
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 418723c925..f8368f29b3 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -1,26 +1,25 @@
 module Language.PureScript.Make.Actions
-  ( MakeActions(..)
-  , RebuildPolicy(..)
-  , ProgressMessage(..)
-  , renderProgressMessage
-  , buildMakeActions
-  , checkForeignDecls
-  , cacheDbFile
-  , readCacheDb'
-  , writeCacheDb'
-  , ffiCodegen'
-  ) where
-
-import Prelude
+  ( MakeActions (..),
+    RebuildPolicy (..),
+    ProgressMessage (..),
+    renderProgressMessage,
+    buildMakeActions,
+    checkForeignDecls,
+    cacheDbFile,
+    readCacheDb',
+    writeCacheDb',
+    ffiCodegen',
+  )
+where
 
 import Control.Monad (unless, when)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Error.Class (MonadError (..))
+import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Reader (asks)
 import Control.Monad.Supply (SupplyT)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Writer.Class (MonadWriter(..))
-import Data.Aeson (Value(String), (.=), object)
+import Control.Monad.Trans.Class (MonadTrans (..))
+import Control.Monad.Writer.Class (MonadWriter (..))
+import Data.Aeson (Value (String), object, (.=))
 import Data.Bifunctor (bimap, first)
 import Data.Either (partitionEithers)
 import Data.Foldable (for_)
@@ -29,66 +28,67 @@ import Data.Map qualified as M
 import Data.Maybe (fromMaybe, maybeToList)
 import Data.Set qualified as S
 import Data.Text qualified as T
-import Data.Text.IO qualified as TIO
 import Data.Text.Encoding qualified as TE
+import Data.Text.IO qualified as TIO
 import Data.Time.Clock (UTCTime)
 import Data.Version (showVersion)
 import Language.JavaScript.Parser qualified as JS
-import Language.PureScript.AST (SourcePos(..), Module)
+import Language.PureScript.AST (Module, SourcePos (..))
 import Language.PureScript.Bundle qualified as Bundle
+import Language.PureScript.CST qualified as CST
 import Language.PureScript.CodeGen.JS qualified as J
 import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps)
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.CoreFn.ToJSON qualified as CFJ
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.CST qualified as CST
 import Language.PureScript.Docs.Prim qualified as Docs.Prim
 import Language.PureScript.Docs.Types qualified as Docs
-import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage')
+import Language.PureScript.Environment (Environment (..))
+import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), errorMessage, errorMessage')
 import Language.PureScript.Externs (ExternsFile, externsFileName)
-import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeCborFile, writeJSONFile, writeTextFile)
 import Language.PureScript.Make.Cache (CacheDb, ContentHash, normaliseForCache)
-import Language.PureScript.Names (Ident(..), ModuleName, runModuleName)
-import Language.PureScript.Options (CodegenTarget(..), Options(..))
-import Language.PureScript.Pretty.Common (SMap(..))
+import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeCborFile, writeJSONFile, writeTextFile)
+import Language.PureScript.Names (Ident (..), ModuleName, runModuleName)
+import Language.PureScript.Options (CodegenTarget (..), Options (..))
+import Language.PureScript.Pretty.Common (SMap (..))
 import Paths_purescript qualified as Paths
 import SourceMap (generate)
-import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..))
+import SourceMap.Types (Mapping (..), Pos (..), SourceMapping (..))
 import System.Directory (getCurrentDirectory)
-import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirectories)
+import System.FilePath (makeRelative, normalise, splitDirectories, splitPath, (</>))
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr)
-import Language.PureScript.Environment (Environment)
+import Prelude
 
 -- | Determines when to rebuild a module
 data RebuildPolicy
-  -- | Never rebuild this module
-  = RebuildNever
-  -- | Always rebuild this module
-  | RebuildAlways
+  = -- | Never rebuild this module
+    RebuildNever
+  | -- | Always rebuild this module
+    RebuildAlways
   deriving (Show, Eq, Ord)
 
 -- | Progress messages from the make process
 data ProgressMessage
-  = CompilingModule ModuleName (Maybe (Int, Int))
-  -- ^ Compilation started for the specified module
+  = -- | Compilation started for the specified module
+    CompilingModule ModuleName (Maybe (Int, Int))
   deriving (Show, Eq, Ord)
 
 -- | Render a progress message
 renderProgressMessage :: T.Text -> ProgressMessage -> T.Text
 renderProgressMessage infx (CompilingModule mn mi) =
   T.concat
-    [ renderProgressIndex mi
-    , infx
-    , runModuleName mn
+    [ renderProgressIndex mi,
+      infx,
+      runModuleName mn
     ]
   where
-  renderProgressIndex :: Maybe (Int, Int) -> T.Text
-  renderProgressIndex = maybe "" $ \(start, end) ->
-    let start' = T.pack (show start)
-        end' = T.pack (show end)
-        preSpace = T.replicate (T.length end' - T.length start') " "
-    in "[" <> preSpace <> start' <> " of " <> end' <> "] "
+    renderProgressIndex :: Maybe (Int, Int) -> T.Text
+    renderProgressIndex = maybe "" $ \(start, end) ->
+      let start' = T.pack (show start)
+          end' = T.pack (show end)
+          preSpace = T.replicate (T.length end' - T.length start') " "
+       in "[" <> preSpace <> start' <> " of " <> end' <> "] "
 
 -- | Actions that require implementations when running in "make" mode.
 --
@@ -98,38 +98,38 @@ renderProgressMessage infx (CompilingModule mn mi) =
 --
 -- * The details of how files are read/written etc.
 data MakeActions m = MakeActions
-  { getInputTimestampsAndHashes :: ModuleName -> m (Either RebuildPolicy (M.Map FilePath (UTCTime, m ContentHash)))
-  -- ^ Get the timestamps and content hashes for the input files for a module.
-  -- The content hash is returned as a monadic action so that the file does not
-  -- have to be read if it's not necessary.
-  , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
-  -- ^ Get the time this module was last compiled, provided that all of the
-  -- requested codegen targets were also produced then. The defaultMakeActions
-  -- implementation uses the modification time of the externs file, because the
-  -- externs file is written first and we always write one. If there is no
-  -- externs file, or if any of the requested codegen targets were not produced
-  -- the last time this module was compiled, this function must return Nothing;
-  -- this indicates that the module will have to be recompiled.
-  , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
-  -- ^ Read the externs file for a module as a string and also return the actual
-  -- path for the file.
-  , codegen :: Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
-  -- ^ Run the code generator for the module and write any required output files.
-  , ffiCodegen :: CF.Module CF.Ann -> m ()
-  -- ^ Check ffi and print it in the output directory.
-  , progress :: ProgressMessage -> m ()
-  -- ^ Respond to a progress update.
-  , readCacheDb :: m CacheDb
-  -- ^ Read the cache database (which contains timestamps and hashes for input
-  -- files) from some external source, e.g. a file on disk.
-  , writeCacheDb :: CacheDb -> m ()
-  -- ^ Write the given cache database to some external source (e.g. a file on
-  -- disk).
-  , writePackageJson :: m ()
-  -- ^ Write to the output directory the package.json file allowing Node.js to
-  -- load .js files as ES modules.
-  , outputPrimDocs :: m ()
-  -- ^ If generating docs, output the documentation for the Prim modules
+  { -- | Get the timestamps and content hashes for the input files for a module.
+    -- The content hash is returned as a monadic action so that the file does not
+    -- have to be read if it's not necessary.
+    getInputTimestampsAndHashes :: ModuleName -> m (Either RebuildPolicy (M.Map FilePath (UTCTime, m ContentHash))),
+    -- | Get the time this module was last compiled, provided that all of the
+    -- requested codegen targets were also produced then. The defaultMakeActions
+    -- implementation uses the modification time of the externs file, because the
+    -- externs file is written first and we always write one. If there is no
+    -- externs file, or if any of the requested codegen targets were not produced
+    -- the last time this module was compiled, this function must return Nothing;
+    -- this indicates that the module will have to be recompiled.
+    getOutputTimestamp :: ModuleName -> m (Maybe UTCTime),
+    -- | Read the externs file for a module as a string and also return the actual
+    -- path for the file.
+    readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile),
+    -- | Run the code generator for the module and write any required output files.
+    codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m (),
+    -- | Check ffi and print it in the output directory.
+    ffiCodegen :: CF.Module CF.Ann -> m (),
+    -- | Respond to a progress update.
+    progress :: ProgressMessage -> m (),
+    -- | Read the cache database (which contains timestamps and hashes for input
+    -- files) from some external source, e.g. a file on disk.
+    readCacheDb :: m CacheDb,
+    -- | Write the given cache database to some external source (e.g. a file on
+    -- disk).
+    writeCacheDb :: CacheDb -> m (),
+    -- | Write to the output directory the package.json file allowing Node.js to
+    -- load .js files as ES modules.
+    writePackageJson :: m (),
+    -- | If generating docs, output the documentation for the Prim modules
+    outputPrimDocs :: m ()
   }
 
 -- | Given the output directory, determines the location for the
@@ -137,194 +137,204 @@ data MakeActions m = MakeActions
 cacheDbFile :: FilePath -> FilePath
 cacheDbFile = (</> "cache-db.json")
 
-readCacheDb'
-  :: (MonadIO m, MonadError MultipleErrors m)
-  => FilePath
-  -- ^ The path to the output directory
-  -> m CacheDb
+readCacheDb' ::
+  (MonadIO m, MonadError MultipleErrors m) =>
+  -- | The path to the output directory
+  FilePath ->
+  m CacheDb
 readCacheDb' outputDir =
   fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir)
 
-writeCacheDb'
-  :: (MonadIO m, MonadError MultipleErrors m)
-  => FilePath
-  -- ^ The path to the output directory
-  -> CacheDb
-  -- ^ The CacheDb to be written
-  -> m ()
+writeCacheDb' ::
+  (MonadIO m, MonadError MultipleErrors m) =>
+  -- | The path to the output directory
+  FilePath ->
+  -- | The CacheDb to be written
+  CacheDb ->
+  m ()
 writeCacheDb' = writeJSONFile . cacheDbFile
 
-writePackageJson'
-  :: (MonadIO m, MonadError MultipleErrors m)
-  => FilePath
-  -- ^ The path to the output directory
-  -> m ()
-writePackageJson' outputDir = writeJSONFile (outputDir </> "package.json") $ object
-  [ "type" .= String "module"
-  ]
+writePackageJson' ::
+  (MonadIO m, MonadError MultipleErrors m) =>
+  -- | The path to the output directory
+  FilePath ->
+  m ()
+writePackageJson' outputDir =
+  writeJSONFile (outputDir </> "package.json") $
+    object
+      [ "type" .= String "module"
+      ]
 
 -- | A set of make actions that read and write modules from the given directory.
-buildMakeActions
-  :: FilePath
-  -- ^ the output directory
-  -> M.Map ModuleName (Either RebuildPolicy FilePath)
-  -- ^ a map between module names and paths to the file containing the PureScript module
-  -> M.Map ModuleName FilePath
-  -- ^ a map between module name and the file containing the foreign javascript for the module
-  -> Bool
-  -- ^ Generate a prefix comment?
-  -> MakeActions Make
+buildMakeActions ::
+  -- | the output directory
+  FilePath ->
+  -- | a map between module names and paths to the file containing the PureScript module
+  M.Map ModuleName (Either RebuildPolicy FilePath) ->
+  -- | a map between module name and the file containing the foreign javascript for the module
+  M.Map ModuleName FilePath ->
+  -- | Generate a prefix comment?
+  Bool ->
+  MakeActions Make
 buildMakeActions outputDir filePathMap foreigns usePrefix =
-    MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb writePackageJson outputPrimDocs
+  MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb writePackageJson outputPrimDocs
   where
-
-  getInputTimestampsAndHashes
-    :: ModuleName
-    -> Make (Either RebuildPolicy (M.Map FilePath (UTCTime, Make ContentHash)))
-  getInputTimestampsAndHashes mn = do
-    let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
-    case path of
-      Left policy ->
-        return (Left policy)
-      Right filePath -> do
-        cwd <- makeIO "Getting the current directory" getCurrentDirectory
-        let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns))
-            getInfo fp = do
-              ts <- getTimestamp fp
-              return (ts, hashFile fp)
-        pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
-        return $ Right $ M.fromList pathsWithInfo
-
-  outputFilename :: ModuleName -> String -> FilePath
-  outputFilename mn fn =
-    let filePath = T.unpack (runModuleName mn)
-    in outputDir </> filePath </> fn
-
-  targetFilename :: ModuleName -> CodegenTarget -> FilePath
-  targetFilename mn = \case
-    JS -> outputFilename mn "index.js"
-    JSSourceMap -> outputFilename mn "index.js.map"
-    CoreFn -> outputFilename mn "corefn.json"
-    Docs -> outputFilename mn "docs.json"
-
-  getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
-  getOutputTimestamp mn = do
-    codegenTargets <- asks optionsCodegenTargets
-    mExternsTimestamp <- getTimestampMaybe (outputFilename mn externsFileName)
-    case mExternsTimestamp of
-      Nothing ->
-        -- If there is no externs file, we will need to compile the module in
-        -- order to produce one.
-        pure Nothing
-      Just externsTimestamp ->
-        case NEL.nonEmpty (fmap (targetFilename mn) (S.toList codegenTargets)) of
-          Nothing ->
-            -- If the externs file exists and no other codegen targets have
-            -- been requested, then we can consider the module up-to-date
-            pure (Just externsTimestamp)
-          Just outputPaths -> do
-            -- If any of the other output paths are nonexistent or older than
-            -- the externs file, then they should be considered outdated, and
-            -- so the module will need rebuilding.
-            mmodTimes <- traverse getTimestampMaybe outputPaths
-            pure $ case sequence mmodTimes of
-              Nothing ->
-                Nothing
-              Just modTimes ->
-                if externsTimestamp <= minimum modTimes
-                  then Just externsTimestamp
-                  else Nothing
-
-  readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile)
-  readExterns mn = do
-    let path = outputDir </> T.unpack (runModuleName mn) </> externsFileName
-    (path, ) <$> readExternsFile path
-
-  outputPrimDocs :: Make ()
-  outputPrimDocs = do
-    codegenTargets <- asks optionsCodegenTargets
-    when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
-      writeJSONFile (outputFilename modName "docs.json") docsMod
-
-  codegen :: Environment ->  Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
-  codegen _prevEnv _m m docs exts = do
-    let mn = CF.moduleName m
-    lift $ writeCborFile (outputFilename mn externsFileName) exts
-    codegenTargets <- lift $ asks optionsCodegenTargets
-    when (S.member CoreFn codegenTargets) $ do
-      let coreFnFile = targetFilename mn CoreFn
-          json = CFJ.moduleToJSON Paths.version m
-      lift $ writeJSONFile coreFnFile json
-    when (S.member JS codegenTargets) $ do
-      foreignInclude <- case mn `M.lookup` foreigns of
-        Just _
-          | not $ requiresForeign m -> do
-              return Nothing
-          | otherwise -> do
-              return $ Just "./foreign.js"
-        Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
-                | otherwise -> return Nothing
-      rawJs <- J.moduleToJs m foreignInclude
-      dir <- lift $ makeIO "get the current directory" getCurrentDirectory
-      let sourceMaps = S.member JSSourceMap codegenTargets
-          (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
-          jsFile = targetFilename mn JS
-          mapFile = targetFilename mn JSSourceMap
-          prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]
-          js = T.unlines $ map ("// " <>) prefix ++ [pjs]
-          mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
-      lift $ do
-        writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef)
-        when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
-    when (S.member Docs codegenTargets) $ do
-      lift $ writeJSONFile (outputFilename mn "docs.json") docs
-
-  ffiCodegen :: CF.Module CF.Ann -> Make ()
-  ffiCodegen m = do
-    codegenTargets <- asks optionsCodegenTargets
-    ffiCodegen' foreigns codegenTargets (Just outputFilename) m
-
-  genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
-  genSourceMap dir mapFile extraLines mappings = do
-    let pathToDir = iterate (".." Posix.</>) ".." !! length (splitPath $ normalise outputDir)
-        sourceFile = case mappings of
-                      (SMap file _ _ : _) -> Just $ pathToDir Posix.</> normalizeSMPath (makeRelative dir (T.unpack file))
-                      _ -> Nothing
-    let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
-      map (\(SMap _ orig gen) -> Mapping {
-          mapOriginal = Just $ convertPos $ add 0 (-1) orig
-        , mapSourceFile = sourceFile
-        , mapGenerated = convertPos $ add (extraLines + 1) 0 gen
-        , mapName = Nothing
-        }) mappings
-    }
-    let mapping = generate rawMapping
-    writeJSONFile mapFile mapping
-    where
-    add :: Int -> Int -> SourcePos -> SourcePos
-    add n m (SourcePos n' m') = SourcePos (n + n') (m + m')
-
-    convertPos :: SourcePos -> Pos
-    convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
-      Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
-
-    normalizeSMPath :: FilePath -> FilePath
-    normalizeSMPath = Posix.joinPath . splitDirectories
-
-  requiresForeign :: CF.Module a -> Bool
-  requiresForeign = not . null . CF.moduleForeign
-
-  progress :: ProgressMessage -> Make ()
-  progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "Compiling "
-
-  readCacheDb :: Make CacheDb
-  readCacheDb = readCacheDb' outputDir
-
-  writeCacheDb :: CacheDb -> Make ()
-  writeCacheDb = writeCacheDb' outputDir
-
-  writePackageJson :: Make ()
-  writePackageJson = writePackageJson' outputDir
+    getInputTimestampsAndHashes ::
+      ModuleName ->
+      Make (Either RebuildPolicy (M.Map FilePath (UTCTime, Make ContentHash)))
+    getInputTimestampsAndHashes mn = do
+      let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
+      case path of
+        Left policy ->
+          return (Left policy)
+        Right filePath -> do
+          cwd <- makeIO "Getting the current directory" getCurrentDirectory
+          let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns))
+              getInfo fp = do
+                ts <- getTimestamp fp
+                return (ts, hashFile fp)
+          pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
+          return $ Right $ M.fromList pathsWithInfo
+
+    outputFilename :: ModuleName -> String -> FilePath
+    outputFilename mn fn =
+      let filePath = T.unpack (runModuleName mn)
+       in outputDir </> filePath </> fn
+
+    targetFilename :: ModuleName -> CodegenTarget -> FilePath
+    targetFilename mn = \case
+      JS -> outputFilename mn "index.js"
+      JSSourceMap -> outputFilename mn "index.js.map"
+      CoreFn -> outputFilename mn "corefn.json"
+      Docs -> outputFilename mn "docs.json"
+
+    getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
+    getOutputTimestamp mn = do
+      codegenTargets <- asks optionsCodegenTargets
+      mExternsTimestamp <- getTimestampMaybe (outputFilename mn externsFileName)
+      case mExternsTimestamp of
+        Nothing ->
+          -- If there is no externs file, we will need to compile the module in
+          -- order to produce one.
+          pure Nothing
+        Just externsTimestamp ->
+          case NEL.nonEmpty (fmap (targetFilename mn) (S.toList codegenTargets)) of
+            Nothing ->
+              -- If the externs file exists and no other codegen targets have
+              -- been requested, then we can consider the module up-to-date
+              pure (Just externsTimestamp)
+            Just outputPaths -> do
+              -- If any of the other output paths are nonexistent or older than
+              -- the externs file, then they should be considered outdated, and
+              -- so the module will need rebuilding.
+              mmodTimes <- traverse getTimestampMaybe outputPaths
+              pure $ case sequence mmodTimes of
+                Nothing ->
+                  Nothing
+                Just modTimes ->
+                  if externsTimestamp <= minimum modTimes
+                    then Just externsTimestamp
+                    else Nothing
+
+    readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile)
+    readExterns mn = do
+      let path = outputDir </> T.unpack (runModuleName mn) </> externsFileName
+      (path,) <$> readExternsFile path
+
+    outputPrimDocs :: Make ()
+    outputPrimDocs = do
+      codegenTargets <- asks optionsCodegenTargets
+      when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module {..} ->
+        writeJSONFile (outputFilename modName "docs.json") docsMod
+
+    codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
+    codegen _prevEnv _endEnv _m m docs exts = do
+      let mn = CF.moduleName m
+      lift $ writeCborFile (outputFilename mn externsFileName) exts
+      codegenTargets <- lift $ asks optionsCodegenTargets
+      when (S.member CoreFn codegenTargets) $ do
+        let coreFnFile = targetFilename mn CoreFn
+            json = CFJ.moduleToJSON Paths.version m
+        lift $ writeJSONFile coreFnFile json
+      when (S.member JS codegenTargets) $ do
+        foreignInclude <- case mn `M.lookup` foreigns of
+          Just _
+            | not $ requiresForeign m -> do
+                return Nothing
+            | otherwise -> do
+                return $ Just "./foreign.js"
+          Nothing
+            | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
+            | otherwise -> return Nothing
+        rawJs <- J.moduleToJs m foreignInclude
+        dir <- lift $ makeIO "get the current directory" getCurrentDirectory
+        let sourceMaps = S.member JSSourceMap codegenTargets
+            (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
+            jsFile = targetFilename mn JS
+            mapFile = targetFilename mn JSSourceMap
+            prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]
+            js = T.unlines $ map ("// " <>) prefix ++ [pjs]
+            mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
+        lift $ do
+          writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef)
+          when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
+      when (S.member Docs codegenTargets) $ do
+        lift $ writeJSONFile (outputFilename mn "docs.json") docs
+
+    ffiCodegen :: CF.Module CF.Ann -> Make ()
+    ffiCodegen m = do
+      codegenTargets <- asks optionsCodegenTargets
+      ffiCodegen' foreigns codegenTargets (Just outputFilename) m
+
+    genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
+    genSourceMap dir mapFile extraLines mappings = do
+      let pathToDir = iterate (".." Posix.</>) ".." !! length (splitPath $ normalise outputDir)
+          sourceFile = case mappings of
+            (SMap file _ _ : _) -> Just $ pathToDir Posix.</> normalizeSMPath (makeRelative dir (T.unpack file))
+            _ -> Nothing
+      let rawMapping =
+            SourceMapping
+              { smFile = "index.js",
+                smSourceRoot = Nothing,
+                smMappings =
+                  map
+                    ( \(SMap _ orig gen) ->
+                        Mapping
+                          { mapOriginal = Just $ convertPos $ add 0 (-1) orig,
+                            mapSourceFile = sourceFile,
+                            mapGenerated = convertPos $ add (extraLines + 1) 0 gen,
+                            mapName = Nothing
+                          }
+                    )
+                    mappings
+              }
+      let mapping = generate rawMapping
+      writeJSONFile mapFile mapping
+      where
+        add :: Int -> Int -> SourcePos -> SourcePos
+        add n m (SourcePos n' m') = SourcePos (n + n') (m + m')
+
+        convertPos :: SourcePos -> Pos
+        convertPos SourcePos {sourcePosLine = l, sourcePosColumn = c} =
+          Pos {posLine = fromIntegral l, posColumn = fromIntegral c}
+
+        normalizeSMPath :: FilePath -> FilePath
+        normalizeSMPath = Posix.joinPath . splitDirectories
+
+    requiresForeign :: CF.Module a -> Bool
+    requiresForeign = not . null . CF.moduleForeign
+
+    progress :: ProgressMessage -> Make ()
+    progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "Compiling "
+
+    readCacheDb :: Make CacheDb
+    readCacheDb = readCacheDb' outputDir
+
+    writeCacheDb :: CacheDb -> Make ()
+    writeCacheDb = writeCacheDb' outputDir
+
+    writePackageJson :: Make ()
+    writePackageJson = writePackageJson' outputDir
 
 data ForeignModuleType = ESModule | CJSModule deriving (Show)
 
@@ -334,24 +344,22 @@ checkForeignDecls :: CF.Module ann -> FilePath -> Make (Either MultipleErrors (F
 checkForeignDecls m path = do
   jsStr <- T.unpack <$> readTextFile path
 
-  let
-    parseResult :: Either MultipleErrors JS.JSAST
-    parseResult = first (errorParsingModule . Bundle.UnableToParseModule) $ JS.parseModule jsStr path
+  let parseResult :: Either MultipleErrors JS.JSAST
+      parseResult = first (errorParsingModule . Bundle.UnableToParseModule) $ JS.parseModule jsStr path
   traverse checkFFI parseResult
-
   where
-  mname = CF.moduleName m
-  modSS = CF.moduleSourceSpan m
+    mname = CF.moduleName m
+    modSS = CF.moduleSourceSpan m
 
-  checkFFI :: JS.JSAST -> Make (ForeignModuleType, S.Set Ident)
-  checkFFI js = do
-    (foreignModuleType, foreignIdentsStrs) <-
+    checkFFI :: JS.JSAST -> Make (ForeignModuleType, S.Set Ident)
+    checkFFI js = do
+      (foreignModuleType, foreignIdentsStrs) <-
         case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of
           Left reason -> throwError $ errorParsingModule reason
-          Right (Bundle.ForeignModuleExports{..}, Bundle.ForeignModuleImports{..})
-            | not (null cjsExports && null cjsImports)
-            , null esExports
-            , null esImports -> do
+          Right (Bundle.ForeignModuleExports {..}, Bundle.ForeignModuleImports {..})
+            | not (null cjsExports && null cjsImports),
+              null esExports,
+              null esImports -> do
                 let deprecatedFFI = filter (elem '\'') cjsExports
                 unless (null deprecatedFFI) $
                   errorDeprecatedForeignPrimes deprecatedFFI
@@ -366,73 +374,74 @@ checkForeignDecls m path = do
 
                 pure (ESModule, esExports)
 
-    foreignIdents <- either
-                      errorInvalidForeignIdentifiers
-                      (pure . S.fromList)
-                      (parseIdents foreignIdentsStrs)
-    let importedIdents = S.fromList (CF.moduleForeign m)
-
-    let unusedFFI = foreignIdents S.\\ importedIdents
-    unless (null unusedFFI) $
-      tell . errorMessage' modSS . UnusedFFIImplementations mname $
-        S.toList unusedFFI
-
-    let missingFFI = importedIdents S.\\ foreignIdents
-    unless (null missingFFI) $
-      throwError . errorMessage' modSS . MissingFFIImplementations mname $
-        S.toList missingFFI
-    pure (foreignModuleType, foreignIdents)
-
-  errorParsingModule :: Bundle.ErrorMessage -> MultipleErrors
-  errorParsingModule = errorMessage' modSS . ErrorParsingFFIModule path . Just
-
-  getForeignModuleExports :: JS.JSAST -> Either Bundle.ErrorMessage  Bundle.ForeignModuleExports
-  getForeignModuleExports = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname))
-
-  getForeignModuleImports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleImports
-  getForeignModuleImports = Bundle.getImportedModules (T.unpack (runModuleName mname))
-
-  errorInvalidForeignIdentifiers :: [String] -> Make a
-  errorInvalidForeignIdentifiers =
-    throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)
-
-  errorDeprecatedForeignPrimes :: [String] -> Make a
-  errorDeprecatedForeignPrimes =
-    throwError . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack)
-
-  errorUnsupportedFFICommonJSExports :: [String] -> Make a
-  errorUnsupportedFFICommonJSExports =
-    throwError . errorMessage' modSS . UnsupportedFFICommonJSExports mname . map T.pack
-
-  errorUnsupportedFFICommonJSImports :: [String] -> Make a
-  errorUnsupportedFFICommonJSImports =
-    throwError . errorMessage' modSS . UnsupportedFFICommonJSImports mname . map T.pack
-
-  parseIdents :: [String] -> Either [String] [Ident]
-  parseIdents strs =
-    case partitionEithers (map parseIdent strs) of
-      ([], idents) ->
-        Right idents
-      (errs, _) ->
-        Left errs
-
-  -- We ignore the error message here, just being told it's an invalid
-  -- identifier should be enough.
-  parseIdent :: String -> Either String Ident
-  parseIdent str =
-    bimap (const str) (Ident . CST.getIdent . CST.nameValue . snd)
-      . CST.runTokenParser CST.parseIdent
-      . CST.lex
-      $ T.pack str
+      foreignIdents <-
+        either
+          errorInvalidForeignIdentifiers
+          (pure . S.fromList)
+          (parseIdents foreignIdentsStrs)
+      let importedIdents = S.fromList (CF.moduleForeign m)
+
+      let unusedFFI = foreignIdents S.\\ importedIdents
+      unless (null unusedFFI) $
+        tell . errorMessage' modSS . UnusedFFIImplementations mname $
+          S.toList unusedFFI
+
+      let missingFFI = importedIdents S.\\ foreignIdents
+      unless (null missingFFI) $
+        throwError . errorMessage' modSS . MissingFFIImplementations mname $
+          S.toList missingFFI
+      pure (foreignModuleType, foreignIdents)
+
+    errorParsingModule :: Bundle.ErrorMessage -> MultipleErrors
+    errorParsingModule = errorMessage' modSS . ErrorParsingFFIModule path . Just
+
+    getForeignModuleExports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleExports
+    getForeignModuleExports = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname))
+
+    getForeignModuleImports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleImports
+    getForeignModuleImports = Bundle.getImportedModules (T.unpack (runModuleName mname))
+
+    errorInvalidForeignIdentifiers :: [String] -> Make a
+    errorInvalidForeignIdentifiers =
+      throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)
+
+    errorDeprecatedForeignPrimes :: [String] -> Make a
+    errorDeprecatedForeignPrimes =
+      throwError . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack)
+
+    errorUnsupportedFFICommonJSExports :: [String] -> Make a
+    errorUnsupportedFFICommonJSExports =
+      throwError . errorMessage' modSS . UnsupportedFFICommonJSExports mname . map T.pack
+
+    errorUnsupportedFFICommonJSImports :: [String] -> Make a
+    errorUnsupportedFFICommonJSImports =
+      throwError . errorMessage' modSS . UnsupportedFFICommonJSImports mname . map T.pack
+
+    parseIdents :: [String] -> Either [String] [Ident]
+    parseIdents strs =
+      case partitionEithers (map parseIdent strs) of
+        ([], idents) ->
+          Right idents
+        (errs, _) ->
+          Left errs
+
+    -- We ignore the error message here, just being told it's an invalid
+    -- identifier should be enough.
+    parseIdent :: String -> Either String Ident
+    parseIdent str =
+      bimap (const str) (Ident . CST.getIdent . CST.nameValue . snd)
+        . CST.runTokenParser CST.parseIdent
+        . CST.lex
+        $ T.pack str
 
 -- | FFI check and codegen action.
 -- If path maker is supplied copies foreign module to the output.
-ffiCodegen'
-  :: M.Map ModuleName FilePath
-  -> S.Set CodegenTarget
-  -> Maybe (ModuleName -> String -> FilePath)
-  -> CF.Module CF.Ann
-  -> Make ()
+ffiCodegen' ::
+  M.Map ModuleName FilePath ->
+  S.Set CodegenTarget ->
+  Maybe (ModuleName -> String -> FilePath) ->
+  CF.Module CF.Ann ->
+  Make ()
 ffiCodegen' foreigns codegenTargets makeOutputPath m = do
   when (S.member JS codegenTargets) $ do
     let mn = CF.moduleName m
@@ -447,10 +456,11 @@ ffiCodegen' foreigns codegenTargets makeOutputPath m = do
               Right (ESModule, _) -> copyForeign path mn
               Right (CJSModule, _) -> do
                 throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path
-      Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
-              | otherwise -> return ()
+      Nothing
+        | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
+        | otherwise -> return ()
   where
-  requiresForeign = not . null . CF.moduleForeign
+    requiresForeign = not . null . CF.moduleForeign
 
-  copyForeign path mn =
-    for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn "foreign.js"))
+    copyForeign path mn =
+      for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn "foreign.js"))
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 2391a2b71b..ad68b54011 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -29,7 +29,7 @@ addAllIndexing conn ma =
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \prevEnv astM m docs ext -> lift (indexAstModule conn astM ext (getExportedNames ext)) <* P.codegen ma prevEnv astM m docs ext
+    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (indexAstModule conn astM ext (getExportedNames ext)) <* P.codegen ma prevEnv endEnv astM m docs ext
     }
 
 indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> Set P.Name -> m ()
@@ -202,7 +202,7 @@ getExportedNames extern =
 addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addExternIndexing conn ma =
   ma
-    { P.codegen = \prevEnv astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma prevEnv astM m docs ext
+    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma prevEnv endEnv astM m docs ext
     }
 
 indexExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()

From 9c84b89ac5492916f653f86a494d081e2ecd1925 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 28 Oct 2024 17:46:52 +0100
Subject: [PATCH 199/297] on hover expr show inference, source type and docs

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 143 ++++++++++++------
 1 file changed, 96 insertions(+), 47 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 1bd0681188..7bddb25d61 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -59,7 +59,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 
       nullRes = res $ Right $ Types.InR Types.Null
 
-      markdownRes md range =
+      markdownRes range md =
         res $ Right $ Types.InL $ Types.Hover (Types.InL $ Types.MarkupContent Types.MarkupKind_Markdown md) range
 
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
@@ -69,27 +69,27 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       respondWithDeclInModule ss nameType modName ident = do
         declDocMb <- readDeclarationDocsWithNameType modName nameType ident
         case declDocMb of
-          Just docs -> markdownRes docs (Just $ spanToRange ss)
+          Just docs -> markdownRes (Just $ spanToRange ss) ("docs:\n" <> docs)
           _ -> do
             tipes <- getAstDeclarationTypeInModule (Just nameType) modName ident
             forLsp (head tipes) \tipe ->
-              markdownRes tipe (Just $ spanToRange ss)
+              markdownRes (Just $ spanToRange ss) ("type:\n" <> tipe)
 
-      respondWithSourceType :: P.SourceType -> HandlerM ()
-      respondWithSourceType tipe = do
-        let printedType = prettyPrintTypeSingleLine tipe
-        markdownRes (pursTypeStr "_" (Just printedType) []) (Just $ spanToRange $ fst $ P.getAnnForType tipe)
+      -- respondWithSourceType :: P.SourceType -> HandlerM ()
+      -- respondWithSourceType tipe = do
+      --   let printedType = prettyPrintTypeSingleLine tipe
+      --   markdownRes (pursTypeStr "_" (Just printedType) []) (Just $ spanToRange $ fst $ P.getAnnForType tipe)
 
-      respondWithExprDebug :: Text -> P.SourceSpan -> P.Expr -> HandlerM ()
-      respondWithExprDebug label ss expr = do
-        let printedExpr = ellipsis 2000 $ show expr
-        markdownRes (label <> ": \n" <> pursMd printedExpr) (Just $ spanToRange ss)
+      -- respondWithExprDebug :: Text -> P.SourceSpan -> P.Expr -> HandlerM ()
+      -- respondWithExprDebug label ss expr = do
+      --   let printedExpr = ellipsis 2000 $ show expr
+      --   markdownRes (label <> ": \n" <> pursMd printedExpr) (Just $ spanToRange ss)
 
-      respondWithExpr2Debug :: Text -> Text -> P.SourceSpan -> P.Expr -> P.Expr -> HandlerM ()
-      respondWithExpr2Debug label label' ss expr expr' = do
-        let printedExpr = ellipsis 2000 $ show expr
-            printedExpr' = ellipsis 2000 $ show expr'
-        markdownRes (label <> ": \n" <> pursMd printedExpr <> "\n\n" <> label' <> ": \n" <> printedExpr') (Just $ spanToRange ss)
+      -- respondWithExpr2Debug :: Text -> Text -> P.SourceSpan -> P.Expr -> P.Expr -> HandlerM ()
+      -- respondWithExpr2Debug label label' ss expr expr' = do
+      --   let printedExpr = ellipsis 2000 $ show expr
+      --       printedExpr' = ellipsis 2000 $ show expr'
+      --   markdownRes (label <> ": \n" <> pursMd printedExpr <> "\n\n" <> label' <> ": \n" <> printedExpr') (Just $ spanToRange ss)
 
       respondWithTypedExpr :: Maybe P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
       respondWithTypedExpr ss expr tipe = do
@@ -100,18 +100,18 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             printedExpr = case expr of
               P.Op _ (P.Qualified _ op) -> P.runOpName op -- pretty printing ops ends in infinite loop
               _ -> dispayExprOnHover expr
-        markdownRes (pursTypeStr printedExpr (Just printedType) []) (spanToRange <$> ss)
+        markdownRes (spanToRange <$> ss) (pursTypeStr printedExpr (Just printedType) [])
 
-      respondWithTypeBinder :: P.SourceSpan -> P.Binder -> P.SourceType -> HandlerM ()
-      respondWithTypeBinder ss binder tipe = do
-        let printedType = prettyPrintTypeSingleLine tipe
-        markdownRes (pursTypeStr (dispayBinderOnHover binder) (Just printedType) []) (Just $ spanToRange ss)
+      -- respondWithTypeBinder :: P.SourceSpan -> P.Binder -> P.SourceType -> HandlerM ()
+      -- respondWithTypeBinder ss binder tipe = do
+      --   let printedType = prettyPrintTypeSingleLine tipe
+      --   markdownRes (pursTypeStr (dispayBinderOnHover binder) (Just printedType) []) (Just $ spanToRange ss)
 
       respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
       respondWithModule ss modName = do
         docsMb <- readModuleDocs modName
         case docsMb of
-          Just docs | Just comments <- Docs.modComments docs -> markdownRes comments (Just $ spanToRange ss)
+          Just docs | Just comments <- Docs.modComments docs -> markdownRes (Just $ spanToRange ss) comments
           _ -> nullRes
 
       respondWithImport :: P.SourceSpan -> P.ModuleName -> Maybe P.DeclarationRef -> HandlerM ()
@@ -121,34 +121,76 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         respondWithDeclInModule ss nameType importedModuleName (printName name)
       respondWithImport ss importedModuleName _ = respondWithModule ss importedModuleName
 
-      handleLiteral :: P.SourceSpan -> P.Literal a -> HandlerM Bool
+      handleLiteral :: P.SourceSpan -> P.Literal a -> HandlerM ()
       handleLiteral ss = \case
         P.NumericLiteral (Left int) -> do
-          markdownRes (pursTypeStr (show int) (Just "Int") []) (Just $ spanToRange ss)
-          pure False
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show int) (Just "Prim.Int") [])
         P.NumericLiteral (Right n) -> do
-          markdownRes (pursTypeStr (show n) (Just "Number") []) (Just $ spanToRange ss)
-          pure False
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show n) (Just "Prim.Number") [])
         P.StringLiteral str -> do
-          markdownRes (pursTypeStr (ellipsis 64 $ show str) (Just "String") []) (Just $ spanToRange ss)
-          pure False
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (ellipsis 64 $ show str) (Just "Prim.String") [])
         P.CharLiteral ch -> do
-          markdownRes (pursTypeStr (show ch) (Just "Char") []) (Just $ spanToRange ss)
-          pure False
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show ch) (Just "Prim.Char") [])
         P.BooleanLiteral b -> do
-          markdownRes (pursTypeStr (show b) (Just "Boolean") []) (Just $ spanToRange ss)
-          pure False
-        _ -> pure True
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show b) (Just "Prim.Boolean") [])
+        _ -> nullRes -- should not be reachable
+      lookupExprTypes :: P.Expr -> HandlerM [Text]
+      lookupExprTypes = \case
+        P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+          getAstDeclarationTypeInModule (Just IdentNameType) modName (P.runIdent ident)
+        P.Op _ (P.Qualified (P.ByModuleName modName) op) -> do
+          getAstDeclarationTypeInModule (Just ValOpNameType) modName (P.runOpName op)
+        P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
+          getAstDeclarationTypeInModule (Just DctorNameType) modName (P.runProperName dctor)
+        P.TypedValue _ e _ | not (generatedExpr e) -> do
+          lookupExprTypes e
+        _ -> pure []
+
+      lookupExprDocs :: P.Expr -> HandlerM (Maybe Text)
+      lookupExprDocs = \case
+        P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
+          readDeclarationDocsWithNameType modName IdentNameType (P.runIdent ident)
+        P.Op _ (P.Qualified (P.ByModuleName modName) op) -> do
+          readDeclarationDocsWithNameType modName ValOpNameType (P.runOpName op)
+        P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
+          readDeclarationDocsWithNameType modName DctorNameType (P.runProperName dctor)
+        _ -> pure Nothing
 
   forLsp filePathMb \filePath -> do
-    inferredRes <- inferExprViaTypeHole filePath startPos
-    case inferredRes of
-      Just (expr, ty) -> do
-        let ss = P.exprSourceSpan expr
-        respondWithTypedExpr ss expr ty
-      Nothing -> do
-        debugLsp "Inferred via type hole failed"
-        nullRes
+    cacheOpenMb <- cachedRebuild filePath
+    forLsp cacheOpenMb \OpenFile {..} -> do
+      let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
+      case apImport everything of
+        Just (ss, importedModuleName, _, ref) -> do
+          respondWithImport ss importedModuleName ref
+        _ -> do
+          case head (apExprs everything) of
+            Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
+            Just (ss, _, foundExpr) -> do
+              inferredRes <- inferExprViaTypeHoleText filePath startPos
+              foundTypes <- lookupExprTypes foundExpr
+              docs <- lookupExprDocs foundExpr
+              markdownRes (Just $ spanToRange ss) $
+                joinMarkup
+                  [ inferredRes,
+                    ("*Source Type*\n" <>) <$> pursMd <$> head foundTypes,
+                    ("*Docs*\n" <>) <$> docs
+                  ]
+            Nothing -> nullRes
+
+-- case head $ apTypes everything of
+--   Just ty ->
+
+isLiteralNode :: Literal P.Expr -> Bool
+isLiteralNode = \case
+  NumericLiteral _ -> True
+  StringLiteral _ -> True
+  CharLiteral _ -> True
+  BooleanLiteral _ -> True
+  _ -> False
+
+joinMarkup :: [Maybe Text] -> Text
+joinMarkup = T.intercalate "\n---\n" . catMaybes
 
 -- cacheOpenMb <- cachedRebuild filePath
 
@@ -170,10 +212,10 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 --       debugLsp $ "pos: " <> show pos
 
 --       case apImport everything of
---         Just (ss, importedModuleName, _, ref) -> do
---           debugLsp $ "Import: " <> show importedModuleName
---           respondWithImport ss importedModuleName ref
---         _ -> do
+-- Just (ss, importedModuleName, _, ref) -> do
+--   debugLsp $ "Import: " <> show importedModuleName
+--   respondWithImport ss importedModuleName ref
+-- _ -> do
 --           let exprs = apExprs everything
 --               handleExpr expr = do
 --                 case expr of
@@ -311,6 +353,12 @@ getHoverSourceTypeFromErrs = \case
 --       Left _ -> pure Nothing
 --   _ -> pure Nothing
 
+inferExprViaTypeHoleText :: FilePath -> Types.Position -> HandlerM (Maybe Text)
+inferExprViaTypeHoleText filePath pos =
+  inferExprViaTypeHole filePath pos <&> fmap \(expr, t) ->
+    pursTypeStr (dispayExprOnHover expr) (Just $ prettyPrintTypeSingleLine t) []
+
+
 inferExprViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Expr, P.SourceType))
 inferExprViaTypeHole filePath pos = do
   cacheOpenMb <- cachedRebuild filePath
@@ -410,7 +458,8 @@ findTypedExpr (_ : es) = findTypedExpr es
 findTypedExpr [] = Nothing
 
 dispayExprOnHover :: P.Expr -> T.Text
-dispayExprOnHover expr = ellipsis 32 $ T.strip $ T.pack $ render $ traceShow' "printed expr val" $ P.prettyPrintValue 2 expr
+dispayExprOnHover (P.Op _ (P.Qualified _ op)) = P.showOp op -- Op's hit an infinite loop when pretty printed
+dispayExprOnHover expr = ellipsis 32 $ T.strip $ T.pack $ render $ P.prettyPrintValue 2 expr
 
 dispayBinderOnHover :: P.Binder -> T.Text
 dispayBinderOnHover binder = line1Only $ ellipsis 32 $ T.strip $ P.prettyPrintBinder binder

From 9b8a65c755ad0ba734a678d5f189d0c747d3512e Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 29 Oct 2024 06:49:38 +0100
Subject: [PATCH 200/297] remove logs

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 10 +--
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 65 ++++---------------
 2 files changed, 16 insertions(+), 59 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 40edcb19b6..35ee2e7f69 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -15,7 +15,6 @@ import Language.LSP.Server (MonadLsp)
 import Language.PureScript qualified as P
 import Language.PureScript.AST.Declarations (declSourceSpan)
 import Language.PureScript.AST.SourcePos (nullSourceSpan)
-import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.State (cachedRebuild)
@@ -207,7 +206,7 @@ getEverythingAtPos decls pos@(Types.Position {..}) =
           P.ConstructorBinder ss _ _ -> Just ss
           P.NamedBinder ss _ _ -> Just ss
           P.PositionedBinder ss _ _ -> Just ss
-          P.TypedBinder ss _ -> Just (fst $ getAnnForType ss)
+          P.TypedBinder _ b -> binderSourceSpan b
           P.OpBinder ss _ -> Just ss
           P.BinaryNoParensBinder {} -> Nothing
           P.ParensInBinder {} -> Nothing
@@ -307,7 +306,6 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
       forLsp (head declsAtPos) $ \decl -> do
         case decl of
           P.ImportDeclaration (ss, _) importedModuleName importType _ -> do
-            debugLsp $ "ImportDeclaration iomportedModuleName: " <> show importedModuleName
             case importType of
               P.Implicit -> handleModule ss importedModuleName
               P.Explicit imports -> handleImportRef ss importedModuleName imports
@@ -352,15 +350,12 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
                         _ -> nullRes
 
                 exprsAtPos = getExprsAtPos pos =<< declsAtPos
-            debugLsp $ "exprsAtPos: " <> show (length exprsAtPos)
             case smallestExpr exprsAtPos of
               Just expr -> do
                 case expr of
                   P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do
-                    debugLsp $ "Var BySourcePos : " <> show srcPos
                     handleExprInModule filePath srcPos
                   P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-                    debugLsp $ "Var ByModuleName : " <> show modName <> "." <> P.runIdent ident
                     handleDecl IdentNameType modName $ P.runIdent ident
                   P.Op _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> handleExprInModule filePath srcPos
                   P.Op _ (P.Qualified (P.ByModuleName modName) ident) -> do
@@ -369,6 +364,7 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
                   P.Constructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
                     handleDecl DctorNameType modName $ P.runProperName ident
                   _ -> respondWithTypeLocation
+
               _ -> respondWithTypeLocation
 
 smallestExpr :: [P.Expr] -> Maybe P.Expr
@@ -450,8 +446,6 @@ modifySmallestDeclExprAtPos fn pos declaration = runState (onDecl declaration) N
     handleExpr :: P.Expr -> StateT (Maybe (P.Expr, P.Expr)) Identity P.Expr
     handleExpr expr = do
       found <- get
-      !_ <- pure $ unsafePerformIO $ putErrLn $ P.exprCtr expr
-      !_ <- pure $ unsafePerformIO $ (putErrLn :: Text -> IO ()) (show $ maybe False (posInSpan pos) (P.exprSourceSpan expr))
       if isNothing found && maybe False (posInSpan pos) (P.exprSourceSpan expr)
         then do
           let expr' = fn expr
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 7bddb25d61..85b2d8130a 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -20,7 +20,6 @@ import Data.List (last)
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Text qualified as T
-import GHC.TopHandler (runIO)
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
@@ -160,6 +159,8 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
     cacheOpenMb <- cachedRebuild filePath
     forLsp cacheOpenMb \OpenFile {..} -> do
       let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
+          respondWithCounts = markdownRes Nothing $ showCounts everything
+      debugLsp $ showCounts everything
       case apImport everything of
         Just (ss, importedModuleName, _, ref) -> do
           respondWithImport ss importedModuleName ref
@@ -176,7 +177,11 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                     ("*Source Type*\n" <>) <$> pursMd <$> head foundTypes,
                     ("*Docs*\n" <>) <$> docs
                   ]
-            Nothing -> nullRes
+            Nothing -> case head $ apBinders everything of
+              Just (_ss, _, binder) -> do
+                debugLsp $ "Binder: " <> show binder
+                respondWithCounts
+              _ -> respondWithCounts
 
 -- case head $ apTypes everything of
 --   Just ty ->
@@ -269,47 +274,6 @@ joinMarkup = T.intercalate "\n---\n" . catMaybes
 --                   pure False
 -- handlePos startPos
 
-inferAtPosition :: FilePath -> Types.Position -> HandlerM (Maybe (Either P.MultipleErrors (P.SourceSpan, P.Expr, P.SourceType)))
-inferAtPosition filePath pos@(Types.Position {..}) = do
-  cacheOpenMb <- cachedRebuild filePath
-  case cacheOpenMb of
-    Nothing -> pure Nothing
-    Just OpenFile {..} -> do
-      let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
-
-      case (apTopLevelDecl everything, head $ apExprs everything) of
-        (Just decl, Just (ss, _, expr)) -> do
-          let onDecl d = pure d
-              onExpr e = do
-                when (e == expr) do
-                  (P.TypedValue' _ _ t) <- infer' e
-                  tell $ P.MultipleErrors [P.ErrorMessage [] (P.HoleInferredType hoverHoleLabel t [] Nothing)]
-                -- P.MultipleErrors  [P.ErrorMessage [] (P.HoleInferredType hoverHoleLabel inferred [] Nothing)]
-                pure e
-              onBinder b = do
-                !_ <- pure $ force $ traceShow' "onBinder" b
-                case b of
-                  P.TypedBinder _st _b' -> pure ()
-                  _ -> pure ()
-                pure b
-
-              (inferExpr, _, _) = P.everywhereOnValuesTopDownM onDecl onExpr onBinder
-
-          -- runInference :: HandlerM (Either P.MultipleErrors (P.Declaration, P.MultipleErrors))
-          -- runInference = runExceptT $ runWriterT $ evalSupplyT 0 $ evalStateT (inferExpr decl) ((P.emptyCheckState ofStartingEnv) {P.checkCurrentModule = Just ofModuleName})
-
-          inferRes <- runInference (inferExpr decl) ofModuleName ofEndEnv
-          case getHoverSourceTypeFromErrs inferRes of
-            Just t -> pure $ Just $ Right (ss, expr, t)
-            _ -> pure $ Just $ Left $ getResErrors inferRes
-        _ -> pure Nothing
-  where
-    runInference a modName env =
-      runExceptT $
-        runWriterT $
-          evalSupplyT 0 $
-            evalStateT a ((P.emptyCheckState env) {P.checkCurrentModule = Just modName})
-
 -- inferBinder :: P.SourceType -> P.Binder -> m (Map P.Ident (P.SourceSpan, P.SourceType))
 -- inferBinder _ NullBinder = return M.empty
 -- inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty
@@ -358,7 +322,6 @@ inferExprViaTypeHoleText filePath pos =
   inferExprViaTypeHole filePath pos <&> fmap \(expr, t) ->
     pursTypeStr (dispayExprOnHover expr) (Just $ prettyPrintTypeSingleLine t) []
 
-
 inferExprViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Expr, P.SourceType))
 inferExprViaTypeHole filePath pos = do
   cacheOpenMb <- cachedRebuild filePath
@@ -374,11 +337,9 @@ inferExprViaTypeHole filePath pos = do
           runWriterT $
             runExceptT $
               P.desugarAndTypeCheck Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
-        debugLsp $ "Infer via type hole checkRes: " <> show (isLeft checkRes)
         case checkRes of
           Right _ -> pure $ (exprBefore,) <$> findHoleType warnings
           Left errs -> do
-            debugLsp $ T.pack $ P.prettyPrintMultipleErrors P.noColorPPEOptions (warnings <> errs)
             pure $
               (exprBefore,) <$> findHoleType (warnings <> errs)
   where
@@ -458,13 +419,15 @@ findTypedExpr (_ : es) = findTypedExpr es
 findTypedExpr [] = Nothing
 
 dispayExprOnHover :: P.Expr -> T.Text
-dispayExprOnHover (P.Op _ (P.Qualified _ op)) = P.showOp op -- Op's hit an infinite loop when pretty printed
-dispayExprOnHover expr = ellipsis 32 $ T.strip $ T.pack $ render $ P.prettyPrintValue 2 expr
+dispayExprOnHover (P.Op _ (P.Qualified _ op)) = P.runOpName op -- Op's hit an infinite loop when pretty printed by themselves
+dispayExprOnHover (P.Case _ _) = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
+dispayExprOnHover expr = ellipsis 32 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 2 expr
 
 dispayBinderOnHover :: P.Binder -> T.Text
-dispayBinderOnHover binder = line1Only $ ellipsis 32 $ T.strip $ P.prettyPrintBinder binder
-  where
-    line1Only = T.takeWhile (/= '\n')
+dispayBinderOnHover binder = ellipsis 32 $ on1Line $ T.strip $ P.prettyPrintBinder binder
+
+on1Line :: T.Text -> T.Text
+on1Line = T.intercalate " " . T.lines
 
 ellipsis :: Int -> Text -> Text
 ellipsis l t = if T.length t > l then T.take l t <> "..." else t

From db4e8778c9d6cd2b3d4be53d949a3df25b9d2e59 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 29 Oct 2024 12:17:58 +0100
Subject: [PATCH 201/297] adds binder on hover

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 85 ++++++++++++----
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 96 ++++++++++++-------
 2 files changed, 128 insertions(+), 53 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 35ee2e7f69..2aafec82ab 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.Lsp.AtPosition where
@@ -7,6 +8,7 @@ module Language.PureScript.Lsp.AtPosition where
 import Control.Lens (At, Field1 (_1), Field2 (_2), Field3 (_3), un, view)
 -- import Language.PureScript.Lsp.Monad (m)
 
+import Control.Monad.State.Strict (StateT, execState, get, modify, runState)
 import Data.List qualified as List
 import Data.Text qualified as T
 import GHC.IO (unsafePerformIO)
@@ -22,7 +24,7 @@ import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
 import Language.PureScript.Lsp.Util (declsAtLine, getDeclarationAtPos, onDeclsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Traversals (defS)
 import Language.PureScript.Types (getAnnForType)
-import Protolude
+import Protolude hiding (StateT, execState, runState)
 
 data AtPos
   = APExpr P.SourceSpan Bool P.Expr
@@ -155,6 +157,14 @@ getEverythingAtPos decls pos@(Types.Position {..}) =
         onDecl :: P.SourceSpan -> P.Declaration -> StateT EverythingAtPos Identity (P.SourceSpan, P.Declaration)
         onDecl _ decl = do
           let ss = declSourceSpan decl
+          --     !_ = force $ traceWith "decls" (T.take 128 . debugExpr) decl
+
+          -- !_ <- force <$> case decl of
+          --   P.ValueDecl _sa ident _nk binders _gexprs -> do
+          --     let a :: Text = show $ force $ traceShow' "" (ident, binders)
+          --     pure a
+          --   _ -> pure ""
+
           when (posInSpan pos ss) do
             modify $ addDecl decl
           addTypesSt $ declTypes decl
@@ -163,6 +173,14 @@ getEverythingAtPos decls pos@(Types.Position {..}) =
         onExpr ss expr = do
           let ssMb = P.exprSourceSpan expr
               ss' = fromMaybe ss ssMb
+          --     !_ = force $ traceWith "expr" (T.take 256 . debugExpr) expr
+          -- !_ <-
+          --   force <$> case expr of
+          --     P.Abs binder _e -> do
+          --       let a :: Text = show $ force $ traceShow' "binder" binder
+          --       pure a
+          --     _ -> pure ""
+
           when (posInSpan pos ss' && not (isPlaceholder expr)) do
             modify $ addExpr ss' (isJust ssMb) expr
           addTypesSt $ exprTypes expr
@@ -198,19 +216,6 @@ getEverythingAtPos decls pos@(Types.Position {..}) =
             modify (addGuard ss guard')
           pure (ss, guard')
 
-        binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
-        binderSourceSpan = \case
-          P.NullBinder -> Nothing
-          P.LiteralBinder ss _ -> Just ss
-          P.VarBinder ss _ -> Just ss
-          P.ConstructorBinder ss _ _ -> Just ss
-          P.NamedBinder ss _ _ -> Just ss
-          P.PositionedBinder ss _ _ -> Just ss
-          P.TypedBinder _ b -> binderSourceSpan b
-          P.OpBinder ss _ -> Just ss
-          P.BinaryNoParensBinder {} -> Nothing
-          P.ParensInBinder {} -> Nothing
-
         doNotationElementSpan :: P.DoNotationElement -> Maybe P.SourceSpan
         doNotationElementSpan = \case
           P.PositionedDoNotationElement ss _ _ -> Just ss
@@ -225,6 +230,15 @@ getEverythingAtPos decls pos@(Types.Position {..}) =
           P.DerivedInstancePlaceholder {} -> True
           _ -> False
 
+traceToErr :: Text -> b -> b
+traceToErr a b = trace a b
+
+traceWith :: Text -> (b -> Text) -> b -> b
+traceWith label f a = traceToErr (label <> ": " <> f a) a
+
+traceShow' :: (Show b) => Text -> b -> b
+traceShow' l = traceWith l show
+
 addDecl :: P.Declaration -> EverythingAtPos -> EverythingAtPos
 addDecl decl atPos = atPos {apDecls = decl : apDecls atPos}
 
@@ -250,9 +264,10 @@ addTypes tys atPos = atPos {apTypes = tys <> apTypes atPos}
 addTypesSt :: (MonadState EverythingAtPos m) => [P.SourceType] -> m ()
 addTypesSt tys = modify (addTypes tys)
 
-debugExpr :: P.Expr -> Text
+debugExpr :: (Show a) => a -> Text
 debugExpr =
-  T.replace ", sourcePosColumn = " ":"
+  T.replace "ValueDeclaration (ValueDeclarationData {valdeclSourceAnn = (SourceSpan" "ValDecl"
+    . T.replace ", sourcePosColumn = " ":"
     . T.replace "SourcePos {sourcePosLine = " ""
     . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
     . T.replace "SourceSpan {spanStart = SourcePos {sourcePosLine =  " "start = "
@@ -364,7 +379,6 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
                   P.Constructor _ (P.Qualified (P.ByModuleName modName) ident) -> do
                     handleDecl DctorNameType modName $ P.runProperName ident
                   _ -> respondWithTypeLocation
-
               _ -> respondWithTypeLocation
 
 smallestExpr :: [P.Expr] -> Maybe P.Expr
@@ -432,6 +446,7 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
         modify (expr :)
       pure expr
 
+
 modifySmallestExprAtPos :: (P.Expr -> P.Expr) -> Types.Position -> P.Module -> (P.Module, Maybe (P.Expr, P.Expr))
 modifySmallestExprAtPos fn pos@(Types.Position {..}) (P.Module ss c mName decls refs) =
   (P.Module ss c mName (fmap fst declsAndExpr) refs, asum $ snd <$> declsAndExpr)
@@ -453,6 +468,42 @@ modifySmallestDeclExprAtPos fn pos declaration = runState (onDecl declaration) N
           pure expr'
         else pure expr
 
+
+modifySmallestBinderAtPos :: (P.Binder -> P.Binder) -> Types.Position -> P.Module -> (P.Module, Maybe (P.Binder, P.Binder))
+modifySmallestBinderAtPos fn pos@(Types.Position {..}) (P.Module ss c mName decls refs) =
+  (P.Module ss c mName (fmap fst declsAndBinder) refs, asum $ snd <$> declsAndBinder)
+  where
+    declsAndBinder = onDeclsAtLine (pure . modifySmallestDeclBinderAtPos fn pos) (\d -> [(d, Nothing)]) (fromIntegral _line + 1) decls
+
+
+modifySmallestDeclBinderAtPos :: (P.Binder -> P.Binder) -> Types.Position -> P.Declaration -> (P.Declaration, Maybe (P.Binder, P.Binder))
+modifySmallestDeclBinderAtPos fn pos declaration = runState (onDecl declaration) Nothing
+  where
+    (onDecl, _, _) = P.everywhereOnValuesM pure pure handleBinder
+
+    handleBinder :: P.Binder -> StateT (Maybe (P.Binder, P.Binder)) Identity P.Binder
+    handleBinder binder = do
+      found <- get
+      if isNothing found && maybe False (posInSpan pos) (binderSourceSpan binder)
+        then do
+          let binder' = fn binder
+          modify (const $ Just (binder, binder'))
+          pure binder'
+        else pure binder
+
+binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
+binderSourceSpan = \case
+  P.NullBinder -> Nothing
+  P.LiteralBinder ss _ -> Just ss
+  P.VarBinder ss _ -> Just ss
+  P.ConstructorBinder ss _ _ -> Just ss
+  P.NamedBinder ss _ _ -> Just ss
+  P.PositionedBinder ss _ _ -> Just ss
+  P.TypedBinder _ b -> binderSourceSpan b
+  P.OpBinder ss _ -> Just ss
+  P.BinaryNoParensBinder {} -> Nothing
+  P.ParensInBinder {} -> Nothing
+
 getChildExprs :: P.Expr -> [P.Expr]
 getChildExprs parentExpr = execState (goExpr parentExpr) []
   where
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 85b2d8130a..1b3a8c6f9c 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -32,7 +32,7 @@ import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (tyBoolean, tyChar, tyInt, tyNumber, tyString)
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, modifySmallestExprAtPos, showCounts, spanSize, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, spanSize, spanToRange)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
@@ -123,24 +123,24 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       handleLiteral :: P.SourceSpan -> P.Literal a -> HandlerM ()
       handleLiteral ss = \case
         P.NumericLiteral (Left int) -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show int) (Just "Prim.Int") [])
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show int) (Just "Int") [])
         P.NumericLiteral (Right n) -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show n) (Just "Prim.Number") [])
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show n) (Just "Number") [])
         P.StringLiteral str -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (ellipsis 64 $ show str) (Just "Prim.String") [])
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (ellipsis 64 $ show str) (Just "String") [])
         P.CharLiteral ch -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show ch) (Just "Prim.Char") [])
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show ch) (Just "Char") [])
         P.BooleanLiteral b -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show b) (Just "Prim.Boolean") [])
+          markdownRes (Just $ spanToRange ss) (pursTypeStr (show b) (Just "Boolean") [])
         _ -> nullRes -- should not be reachable
       lookupExprTypes :: P.Expr -> HandlerM [Text]
       lookupExprTypes = \case
         P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-          getAstDeclarationTypeInModule (Just IdentNameType) modName (P.runIdent ident)
+          fmap (displayType modName (P.runIdent ident)) <$> getAstDeclarationTypeInModule (Just IdentNameType) modName (P.runIdent ident)
         P.Op _ (P.Qualified (P.ByModuleName modName) op) -> do
-          getAstDeclarationTypeInModule (Just ValOpNameType) modName (P.runOpName op)
+          fmap (displayType modName (P.runOpName op)) <$> getAstDeclarationTypeInModule (Just ValOpNameType) modName (P.runOpName op)
         P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
-          getAstDeclarationTypeInModule (Just DctorNameType) modName (P.runProperName dctor)
+          fmap (displayType modName (P.runProperName dctor)) <$> getAstDeclarationTypeInModule (Just DctorNameType) modName (P.runProperName dctor)
         P.TypedValue _ e _ | not (generatedExpr e) -> do
           lookupExprTypes e
         _ -> pure []
@@ -174,14 +174,20 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               markdownRes (Just $ spanToRange ss) $
                 joinMarkup
                   [ inferredRes,
-                    ("*Source Type*\n" <>) <$> pursMd <$> head foundTypes,
-                    ("*Docs*\n" <>) <$> docs
+                    head foundTypes,
+                    ("_Docs_\n" <>) <$> docs
                   ]
-            Nothing -> case head $ apBinders everything of
-              Just (_ss, _, binder) -> do
-                debugLsp $ "Binder: " <> show binder
-                respondWithCounts
-              _ -> respondWithCounts
+            Nothing -> do
+              binderInferredRes <- inferBinderViaTypeHole filePath startPos
+              case binderInferredRes of
+                Just (binder, ty) ->
+                  markdownRes
+                    (spanToRange <$> binderSourceSpan binder)
+                    (pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine ty) [])
+                Nothing -> respondWithCounts
+
+displayType :: P.ModuleName -> Text -> Text -> Text
+displayType mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
 
 -- case head $ apTypes everything of
 --   Just ty ->
@@ -195,7 +201,7 @@ isLiteralNode = \case
   _ -> False
 
 joinMarkup :: [Maybe Text] -> Text
-joinMarkup = T.intercalate "\n---\n" . catMaybes
+joinMarkup = T.intercalate "\n---\n\n" . catMaybes
 
 -- cacheOpenMb <- cachedRebuild filePath
 
@@ -323,28 +329,51 @@ inferExprViaTypeHoleText filePath pos =
     pursTypeStr (dispayExprOnHover expr) (Just $ prettyPrintTypeSingleLine t) []
 
 inferExprViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Expr, P.SourceType))
-inferExprViaTypeHole filePath pos = do
+inferExprViaTypeHole = inferViaTypeHole (modifySmallestExprAtPos addExprTypeHoleAnnotation)
+
+inferBinderViaTypeHoleText :: FilePath -> Types.Position -> HandlerM (Maybe Text)
+inferBinderViaTypeHoleText filePath pos =
+  inferBinderViaTypeHole filePath pos <&> fmap \(binder, t) ->
+    pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine t) []
+
+inferBinderViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Binder, P.SourceType))
+inferBinderViaTypeHole = inferViaTypeHole (modifySmallestBinderAtPos addBinderTypeHoleAnnotation)
+
+inferViaTypeHole ::
+  (Show a) =>
+  ( Types.Position ->
+    P.Module ->
+    (P.Module, Maybe (a, a))
+  ) ->
+  FilePath ->
+  Types.Position ->
+  HandlerM (Maybe (a, P.SourceType))
+inferViaTypeHole addHole filePath pos = do
   cacheOpenMb <- cachedRebuild filePath
   cacheOpenMb & maybe (pure Nothing) \OpenFile {..} -> do
     let module' = P.importPrim ofUncheckedModule
-        (moduleWithHole, exprs) = modifySmallestExprAtPos addTypeHoleAnnotation pos module'
-    case exprs of
+        (moduleWithHole, values) = addHole pos module'
+    case values of
       Nothing -> pure Nothing
-      Just (exprBefore, _exprAfter) -> do
+      Just (valueBefore, _valueAfter) -> do
+        debugLsp $ "valueBefore: " <> show valueBefore
+        debugLsp $ "_valueAfter: " <> show _valueAfter
         let externs = fmap edExtern ofDependencies
         (exportEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
         (checkRes, warnings) <-
           runWriterT $
             runExceptT $
               P.desugarAndTypeCheck Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
+        debugLsp $ "warnings: " <> show warnings
         case checkRes of
-          Right _ -> pure $ (exprBefore,) <$> findHoleType warnings
+          Right _ -> pure $ (valueBefore,) <$> findHoleType warnings
           Left errs -> do
+            debugLsp $ "errs: " <> show errs
             pure $
-              (exprBefore,) <$> findHoleType (warnings <> errs)
-  where
-    findHoleType :: P.MultipleErrors -> Maybe P.SourceType
-    findHoleType = P.runMultipleErrors >>> findMap getHoverHoleType
+              (valueBefore,) <$> findHoleType (warnings <> errs)
+
+findHoleType :: P.MultipleErrors -> Maybe P.SourceType
+findHoleType = P.runMultipleErrors >>> findMap getHoverHoleType
 
 getHoverHoleType :: P.ErrorMessage -> Maybe P.SourceType
 getHoverHoleType =
@@ -355,19 +384,14 @@ getHoverHoleType =
 findMap :: (a -> Maybe b) -> [a] -> Maybe b
 findMap f = listToMaybe . mapMaybe f
 
--- addHoleAnnotation :: (Monad m) => P.Expr -> P.Declaration -> m P.Declaration
--- addHoleAnnotation expr = onDeclExprs \e ->
---   if e == expr
---     then
---       pure $
---         P.TypedValue False e (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel)
---     else pure e
+addExprTypeHoleAnnotation :: P.Expr -> P.Expr
+addExprTypeHoleAnnotation expr = P.TypedValue False expr (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel)
 
-addTypeHoleAnnotation :: P.Expr -> P.Expr
-addTypeHoleAnnotation expr = P.TypedValue False expr (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel)
+addBinderTypeHoleAnnotation :: P.Binder -> P.Binder
+addBinderTypeHoleAnnotation b = P.ParensInBinder (P.TypedBinder (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel) b) -- parens seems to be needed. For some desugaring reason?
 
 hoverHoleLabel :: Text
-hoverHoleLabel = "?HOVER?"
+hoverHoleLabel = "HOVER"
 
 onDeclExprs :: (Monad m) => (P.Expr -> m P.Expr) -> P.Declaration -> m P.Declaration
 onDeclExprs fn = view _1 $ P.everywhereOnValuesTopDownM pure fn pure

From 68deae6eed08b2c27bcea3cc3226d8a63a6da207 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 29 Oct 2024 12:18:32 +0100
Subject: [PATCH 202/297] use lazy state

---
 src/Language/PureScript/Lsp/AtPosition.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 2aafec82ab..7c3e23f023 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -8,7 +8,6 @@ module Language.PureScript.Lsp.AtPosition where
 import Control.Lens (At, Field1 (_1), Field2 (_2), Field3 (_3), un, view)
 -- import Language.PureScript.Lsp.Monad (m)
 
-import Control.Monad.State.Strict (StateT, execState, get, modify, runState)
 import Data.List qualified as List
 import Data.Text qualified as T
 import GHC.IO (unsafePerformIO)
@@ -24,8 +23,7 @@ import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
 import Language.PureScript.Lsp.Util (declsAtLine, getDeclarationAtPos, onDeclsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Traversals (defS)
 import Language.PureScript.Types (getAnnForType)
-import Protolude hiding (StateT, execState, runState)
-
+import Protolude 
 data AtPos
   = APExpr P.SourceSpan Bool P.Expr
   | APBinder P.SourceSpan Bool P.Binder

From b3a5086e5921fa0bf2ecdddcdba73af81b69107d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 29 Oct 2024 12:22:20 +0100
Subject: [PATCH 203/297] remove logs

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 199 +-----------------
 1 file changed, 1 insertion(+), 198 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 1b3a8c6f9c..e0d6c5bc08 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -228,7 +228,7 @@ joinMarkup = T.intercalate "\n---\n\n" . catMaybes
 --   respondWithImport ss importedModuleName ref
 -- _ -> do
 --           let exprs = apExprs everything
---               handleExpr expr = do
+--               handleExpr exprT = do
 --                 case expr of
 --                   (ss, _, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
 --                     debugLsp $ "Var: " <> show ident
@@ -340,7 +340,6 @@ inferBinderViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Binde
 inferBinderViaTypeHole = inferViaTypeHole (modifySmallestBinderAtPos addBinderTypeHoleAnnotation)
 
 inferViaTypeHole ::
-  (Show a) =>
   ( Types.Position ->
     P.Module ->
     (P.Module, Maybe (a, a))
@@ -356,19 +355,15 @@ inferViaTypeHole addHole filePath pos = do
     case values of
       Nothing -> pure Nothing
       Just (valueBefore, _valueAfter) -> do
-        debugLsp $ "valueBefore: " <> show valueBefore
-        debugLsp $ "_valueAfter: " <> show _valueAfter
         let externs = fmap edExtern ofDependencies
         (exportEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
         (checkRes, warnings) <-
           runWriterT $
             runExceptT $
               P.desugarAndTypeCheck Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
-        debugLsp $ "warnings: " <> show warnings
         case checkRes of
           Right _ -> pure $ (valueBefore,) <$> findHoleType warnings
           Left errs -> do
-            debugLsp $ "errs: " <> show errs
             pure $
               (valueBefore,) <$> findHoleType (warnings <> errs)
 
@@ -492,195 +487,3 @@ inferExprType' fp =
   inferExprType fp >=> \case
     Right t -> pure t
     Left e -> throwIO e
-
--- asdf =
--- ValueDeclaration
---   : ValueDeclarationData
---     { valdeclSourceAnn =
---         ( SourceSpan
---             { spanStart =
---                 SourcePos {sourcePosLine = 27, sourcePosColumn = 3},
---               spanEnd =
---                 SourcePos {sourcePosLine = 27, sourcePosColumn = 18}
---             },
---           []
---         ),
---       valdeclIdent = Ident "asdfa",
---       valdeclName = Public,
---       valdeclBinders = [],
---       valdeclExpression =
---         [ GuardedExpr
---             []
---             ( PositionedValue
---                 ( SourceSpan
---                     {         spanStart =
---                         SourcePos {sourcePosLine = 27, sourcePosColumn = 11},
---                       spanEnd =
---                         SourcePos {sourcePosLine = 27, sourcePosColumn = 18}
---                     }
---                 )
---                 []
---                 ( App
---                     ( App
---                         ( TypedValue
---                             True
---                             ( PositionedValue
---                                 ( SourceSpan
---                                     {                         spanStart =
---                                         SourcePos {sourcePosLine = 27, sourcePosColumn = 11},
---                                       spanEnd =
---                                         SourcePos {sourcePosLine = 27, sourcePosColumn = 15}
---                                     }
---                                 )
---                                 []
---                                 ( Var
---                                     ( SourceSpan
---                                         {                             spanStart =
---                                             SourcePos {sourcePosLine = 27, sourcePosColumn = 11},
---                                           spanEnd =
---                                             SourcePos {sourcePosLine = 27, sourcePosColumn = 15}
---                                         }
---                                     )
---                                     (Qualified (ByModuleName (ModuleName "Data.Show")) (Ident "show"))
---                                 )
---                             )
---                             ( ForAll
---                                 ( SourceSpan
---                                     { spanName = "",
---                                       spanStart =
---                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
---                                       spanEnd =
---                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
---                                     },
---                                   []
---                                 )
---                                 TypeVarVisible
---                                 "a"
---                                 ( Just
---                                     ( TypeConstructor
---                                         ( SourceSpan
---                                             { spanName = "",
---                                               spanStart =
---                                                 SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
---                                               spanEnd =
---                                                 SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
---                                             },
---                                           []
---                                         )
---                                         (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Type"}))
---                                     )
---                                 )
---                                 ( ConstrainedType
---                                     ( SourceSpan
---                                         { spanName = "",
---                                           spanStart =
---                                             SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
---                                           spanEnd =
---                                             SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
---                                         },
---                                       []
---                                     )
---                                     ( Constraint
---                                         { constraintAnn =
---                                             ( SourceSpan
---                                                 { spanName = "",
---                                                   spanStart =
---                                                     SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
---                                                   spanEnd =
---                                                     SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
---                                                 },
---                                               []
---                                             ),
---                                           constraintClass = Qualified (ByModuleName (ModuleName "Data.Show")) (ProperName {runProperName = "Show"}),
---                                           constraintKindArgs = [],
---                                           constraintArgs =
---                                             [ TypeVar
---                                                 ( SourceSpan
---                                                     { spanName = "",
---                                                       spanStart =
---                                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
---                                                       spanEnd =
---                                                         SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
---                                                     },
---                                                   []
---                                                 )
---                                                 "a"
---                                             ],
---                                           constraintData = Nothing
---                                         }
---                                     )
---                                     ( TypeApp
---                                         ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 11}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 22}},
---                                           []
---                                         )
---                                         ( TypeApp
---                                             ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 11}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 22}},
---                                               []
---                                             )
---                                             ( TypeConstructor
---                                                 ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 13}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 15}},
---                                                   []
---                                                 )
---                                                 (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))
---                                             )
---                                             ( TypeVar
---                                                 ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 11}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 12}},
---                                                   []
---                                                 )
---                                                 "a"
---                                             )
---                                         )
---                                         ( TypeConstructor
---                                             ( SourceSpan {spanName = ".spago/p/prelude-6.0.1/src/Data/Show.purs", spanStart = SourcePos {sourcePosLine = 24, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 24, sourcePosColumn = 22}},
---                                               []
---                                             )
---                                             (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "String"}))
---                                         )
---                                     )
---                                 )
---                                 (Just (SkolemScope {runSkolemScope = 24}))
---                             )
---                         )
---                         ( Var
---                             ( SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}
---                             )
---                             (Qualified (ByModuleName (ModuleName "Data.Show")) (Ident "showInt"))
---                         )
---                     )
---                     ( TypedValue
---                         True
---                         ( TypedValue
---                             True
---                             ( PositionedValue
---                                 ( SourceSpan { spanStart = SourcePos {sourcePosLine = 27, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 27, sourcePosColumn = 18}}
---                                 )
---                                 []
---                                 ( Literal
---                                     ( SourceSpan { spanStart = SourcePos {sourcePosLine = 27, sourcePosColumn = 16}, spanEnd = SourcePos {sourcePosLine = 27, sourcePosColumn = 18}}
---                                     )
---                                     (NumericLiteral (Left 11))
---                                 )
---                             )
---                             ( TypeConstructor
---                                 ( SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}},
---                                   []
---                                 )
---                                 (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))
---                             )
---                         )
---                         ( TypeConstructor
---                             ( SourceSpan
---                                 { spanName = "",
---                                   spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0},
---                                   spanEnd =
---                                     SourcePos {sourcePosLine = 0, sourcePosColumn = 0}
---                                 },
---                               []
---                             )
---                             (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))
---                         )
---                     )
---                 )
---             )
---         ]
---     }
\ No newline at end of file

From e130e018c9f13a833b9bb7d8d9353c8939a06d72 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 29 Oct 2024 15:37:49 +0100
Subject: [PATCH 204/297] adds option to not infer

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 61 ++++++++-----------
 src/Language/PureScript/Lsp/ServerConfig.hs   | 12 +++-
 2 files changed, 35 insertions(+), 38 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index e0d6c5bc08..28f183c6a3 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -41,6 +41,7 @@ import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.Rebuild (buildExportEnvCacheAndHandleErrors)
+import Language.PureScript.Lsp.ServerConfig (getInferExpressions)
 import Language.PureScript.Lsp.State (cachedRebuild, getExportEnv)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), OpenFile (..))
 import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
@@ -74,22 +75,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             forLsp (head tipes) \tipe ->
               markdownRes (Just $ spanToRange ss) ("type:\n" <> tipe)
 
-      -- respondWithSourceType :: P.SourceType -> HandlerM ()
-      -- respondWithSourceType tipe = do
-      --   let printedType = prettyPrintTypeSingleLine tipe
-      --   markdownRes (pursTypeStr "_" (Just printedType) []) (Just $ spanToRange $ fst $ P.getAnnForType tipe)
-
-      -- respondWithExprDebug :: Text -> P.SourceSpan -> P.Expr -> HandlerM ()
-      -- respondWithExprDebug label ss expr = do
-      --   let printedExpr = ellipsis 2000 $ show expr
-      --   markdownRes (label <> ": \n" <> pursMd printedExpr) (Just $ spanToRange ss)
-
-      -- respondWithExpr2Debug :: Text -> Text -> P.SourceSpan -> P.Expr -> P.Expr -> HandlerM ()
-      -- respondWithExpr2Debug label label' ss expr expr' = do
-      --   let printedExpr = ellipsis 2000 $ show expr
-      --       printedExpr' = ellipsis 2000 $ show expr'
-      --   markdownRes (label <> ": \n" <> pursMd printedExpr <> "\n\n" <> label' <> ": \n" <> printedExpr') (Just $ spanToRange ss)
-
       respondWithTypedExpr :: Maybe P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
       respondWithTypedExpr ss expr tipe = do
         void $
@@ -132,7 +117,9 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           markdownRes (Just $ spanToRange ss) (pursTypeStr (show ch) (Just "Char") [])
         P.BooleanLiteral b -> do
           markdownRes (Just $ spanToRange ss) (pursTypeStr (show b) (Just "Boolean") [])
-        _ -> nullRes -- should not be reachable
+        -- should not be reachable
+        _ -> nullRes
+
       lookupExprTypes :: P.Expr -> HandlerM [Text]
       lookupExprTypes = \case
         P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
@@ -348,24 +335,28 @@ inferViaTypeHole ::
   Types.Position ->
   HandlerM (Maybe (a, P.SourceType))
 inferViaTypeHole addHole filePath pos = do
-  cacheOpenMb <- cachedRebuild filePath
-  cacheOpenMb & maybe (pure Nothing) \OpenFile {..} -> do
-    let module' = P.importPrim ofUncheckedModule
-        (moduleWithHole, values) = addHole pos module'
-    case values of
-      Nothing -> pure Nothing
-      Just (valueBefore, _valueAfter) -> do
-        let externs = fmap edExtern ofDependencies
-        (exportEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
-        (checkRes, warnings) <-
-          runWriterT $
-            runExceptT $
-              P.desugarAndTypeCheck Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
-        case checkRes of
-          Right _ -> pure $ (valueBefore,) <$> findHoleType warnings
-          Left errs -> do
-            pure $
-              (valueBefore,) <$> findHoleType (warnings <> errs)
+  shouldInfer <- getInferExpressions
+  if not shouldInfer
+    then pure Nothing
+    else do
+      cacheOpenMb <- cachedRebuild filePath
+      cacheOpenMb & maybe (pure Nothing) \OpenFile {..} -> do
+        let module' = P.importPrim ofUncheckedModule
+            (moduleWithHole, values) = addHole pos module'
+        case values of
+          Nothing -> pure Nothing
+          Just (valueBefore, _valueAfter) -> do
+            let externs = fmap edExtern ofDependencies
+            (exportEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
+            (checkRes, warnings) <-
+              runWriterT $
+                runExceptT $
+                  P.desugarAndTypeCheck Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
+            case checkRes of
+              Right _ -> pure $ (valueBefore,) <$> findHoleType warnings
+              Left errs -> do
+                pure $
+                  (valueBefore,) <$> findHoleType (warnings <> errs)
 
 findHoleType :: P.MultipleErrors -> Maybe P.SourceType
 findHoleType = P.runMultipleErrors >>> findMap getHoverHoleType
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index 1bdad9c2fb..f977f3b166 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -16,7 +16,8 @@ data ServerConfig = ServerConfig
     traceValue :: Maybe TraceValue,
     maxTypeLength :: Maybe Int,
     maxCompletions :: Maybe Int, 
-    maxFilesInCache :: Maybe Int
+    maxFilesInCache :: Maybe Int, 
+    inferExpressions :: Bool
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
@@ -30,7 +31,8 @@ defaultConfig outputPath =
       traceValue = Nothing,
       maxTypeLength = Just defaultMaxTypeLength,
       maxCompletions = Just defaultMaxCompletions, 
-      maxFilesInCache = Just defaultMaxFilesInCache
+      maxFilesInCache = Just defaultMaxFilesInCache,
+      inferExpressions = True
     }
 
 setTraceValue :: (MonadLsp ServerConfig m) => TraceValue -> m ()
@@ -57,4 +59,8 @@ getMaxCompletions =
 
 getMaxFilesInCache :: (MonadLsp ServerConfig m) => m Int
 getMaxFilesInCache =
-  fromMaybe defaultMaxFilesInCache . maxFilesInCache <$> getConfig
\ No newline at end of file
+  fromMaybe defaultMaxFilesInCache . maxFilesInCache <$> getConfig
+
+
+getInferExpressions :: (MonadLsp ServerConfig m) => m Bool
+getInferExpressions = inferExpressions <$> getConfig  
\ No newline at end of file

From 613a7268fcc17c24ab402d21363aa39eef41c2cf Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 29 Oct 2024 15:40:30 +0100
Subject: [PATCH 205/297] bold docs

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 28f183c6a3..e3f2381084 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -162,7 +162,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                 joinMarkup
                   [ inferredRes,
                     head foundTypes,
-                    ("_Docs_\n" <>) <$> docs
+                    ("**Docs**\n" <>) <$> docs
                   ]
             Nothing -> do
               binderInferredRes <- inferBinderViaTypeHole filePath startPos
@@ -188,7 +188,7 @@ isLiteralNode = \case
   _ -> False
 
 joinMarkup :: [Maybe Text] -> Text
-joinMarkup = T.intercalate "\n---\n\n" . catMaybes
+joinMarkup = T.intercalate "\n---\n" . catMaybes
 
 -- cacheOpenMb <- cachedRebuild filePath
 

From a8adee51414fbb293387e1c43a88c382b7dcddbb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 29 Oct 2024 17:45:04 +0100
Subject: [PATCH 206/297] type kinds on hover fixed

---
 .../PureScript/Lsp/Handlers/Completion.hs     |  4 +-
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 51 ++++++++++++-------
 src/Language/PureScript/Lsp/Imports.hs        |  2 +
 src/Language/PureScript/Lsp/NameType.hs       | 15 ++++++
 src/Language/PureScript/Lsp/Print.hs          | 13 ++---
 src/Language/PureScript/Make/Index.hs         | 10 ++--
 6 files changed, 61 insertions(+), 34 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index e23821e4b7..1abaab8931 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -89,7 +89,9 @@ completionAndResolveHandlers =
                                       TyClassNameType -> Types.CompletionItemKind_Interface
                                       ValOpNameType -> Types.CompletionItemKind_Operator
                                       TyOpNameType -> Types.CompletionItemKind_TypeParameter
-                                      ModNameType -> Types.CompletionItemKind_Module,
+                                      ModNameType -> Types.CompletionItemKind_Module
+                                      KindNameType -> Types.CompletionItemKind_Struct
+                                      RoleNameType -> Types.CompletionItemKind_Struct,
                                   _tags = Nothing,
                                   _detail = Nothing,
                                   _documentation = Nothing,
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index e3f2381084..0dd4f4def7 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -32,7 +32,7 @@ import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (tyBoolean, tyChar, tyInt, tyNumber, tyString)
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, spanSize, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, getTypeLinesAndColumns, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, spanSize, spanToRange)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
@@ -50,6 +50,8 @@ import Language.PureScript.TypeChecker (getEnv)
 import Language.PureScript.TypeChecker.Types (infer')
 import Language.PureScript.TypeChecker.Unify (unifyTypes)
 import Protolude hiding (handle, to)
+import Safe qualified
+import Text.Blaze.Html5 (mark)
 import Text.PrettyPrint.Boxes (render)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -67,13 +69,15 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 
       respondWithDeclInModule :: P.SourceSpan -> LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInModule ss nameType modName ident = do
-        declDocMb <- readDeclarationDocsWithNameType modName nameType ident
-        case declDocMb of
-          Just docs -> markdownRes (Just $ spanToRange ss) ("docs:\n" <> docs)
-          _ -> do
-            tipes <- getAstDeclarationTypeInModule (Just nameType) modName ident
-            forLsp (head tipes) \tipe ->
-              markdownRes (Just $ spanToRange ss) ("type:\n" <> tipe)
+        docs <- readDeclarationDocsWithNameType modName nameType ident
+        foundTypes <- getAstDeclarationTypeInModule (Just nameType) modName ident
+        debugLsp $ "Found types: " <> show (isJust $ head foundTypes)
+        debugLsp $ "Found docs: " <> show (isJust docs)
+        markdownRes (Just $ spanToRange ss) $
+          joinMarkup
+            [ displayType modName ident <$> head foundTypes,
+              ("**Docs**\n" <>) <$> docs
+            ]
 
       respondWithTypedExpr :: Maybe P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
       respondWithTypedExpr ss expr tipe = do
@@ -86,11 +90,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               _ -> dispayExprOnHover expr
         markdownRes (spanToRange <$> ss) (pursTypeStr printedExpr (Just printedType) [])
 
-      -- respondWithTypeBinder :: P.SourceSpan -> P.Binder -> P.SourceType -> HandlerM ()
-      -- respondWithTypeBinder ss binder tipe = do
-      --   let printedType = prettyPrintTypeSingleLine tipe
-      --   markdownRes (pursTypeStr (dispayBinderOnHover binder) (Just printedType) []) (Just $ spanToRange ss)
-
       respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
       respondWithModule ss modName = do
         docsMb <- readModuleDocs modName
@@ -152,9 +151,10 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         Just (ss, importedModuleName, _, ref) -> do
           respondWithImport ss importedModuleName ref
         _ -> do
-          case head (apExprs everything) of
+          case head $ filter (not . generatedExpr . view _3) $ apExprs everything of
             Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
             Just (ss, _, foundExpr) -> do
+              debugLsp $ "Found expr: " <> show foundExpr
               inferredRes <- inferExprViaTypeHoleText filePath startPos
               foundTypes <- lookupExprTypes foundExpr
               docs <- lookupExprDocs foundExpr
@@ -166,19 +166,32 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                   ]
             Nothing -> do
               binderInferredRes <- inferBinderViaTypeHole filePath startPos
+
               case binderInferredRes of
-                Just (binder, ty) ->
+                Just (binder, ty) -> do
+                  debugLsp $ "Found binder: " <> show binder
                   markdownRes
                     (spanToRange <$> binderSourceSpan binder)
                     (pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine ty) [])
-                Nothing -> respondWithCounts
+                Nothing -> do
+                  debugLsp $ "smallest type: " <> show (Safe.minimumByMay (comparing getTypeLinesAndColumns) (apTypes everything))
+                  case Safe.minimumByMay (comparing getTypeLinesAndColumns) (apTypes everything) of
+                    Just (P.ConstrainedType ann (P.Constraint _ (P.Qualified (P.ByModuleName modName) ident) _ _ _) _) ->
+                      respondWithDeclInModule (fst ann) TyClassNameType modName $ P.runProperName ident
+                    Just (P.TypeConstructor ann (P.Qualified (P.ByModuleName mName) name)) -> do
+                      debugLsp $ "TypeConstructor: " <> P.runProperName name
+                      respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
+                    Just (P.TypeOp ann (P.Qualified (P.ByModuleName mName) name)) ->
+                      respondWithDeclInModule (fst ann) TyOpNameType mName (P.runOpName name)
+                    Just ty ->
+                      markdownRes
+                        (Just $ spanToRange $ fst $ P.getAnnForType ty)
+                        (pursTypeStr "" (Just $ prettyPrintTypeSingleLine ty) [])
+                    _ -> respondWithCounts
 
 displayType :: P.ModuleName -> Text -> Text -> Text
 displayType mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
 
--- case head $ apTypes everything of
---   Just ty ->
-
 isLiteralNode :: Literal P.Expr -> Bool
 isLiteralNode = \case
   NumericLiteral _ -> True
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 16325ce653..891f4b1b5a 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -138,6 +138,8 @@ addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName
         DctorNameType -> P.TypeRef nullSourceSpan (P.ProperName $ fromMaybe "Ctr type not found" ctrType) (Just [P.ProperName declName])
         TyClassNameType -> P.TypeClassRef nullSourceSpan (P.ProperName declName)
         ModNameType -> P.ModuleRef nullSourceSpan (P.ModuleName declName)
+        RoleNameType -> P.TypeRef nullSourceSpan (P.ProperName declName) Nothing
+        KindNameType -> P.TypeRef nullSourceSpan (P.ProperName declName) Nothing
 
     alreadyImportedModuleMb =
       find (\(Import mn' _ _) -> mn' == importedModuleName) imports
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index b805f5afb9..a1935ae1f1 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -8,6 +8,7 @@ import Database.SQLite.Simple.ToField (ToField (toField))
 import Language.PureScript.Externs (ExternsDeclaration (..))
 import Language.PureScript.Names
 import Protolude
+import Language.PureScript.AST.Declarations qualified as P
 
 data LspNameType
   = IdentNameType
@@ -17,6 +18,8 @@ data LspNameType
   | DctorNameType
   | TyClassNameType
   | ModNameType
+  | RoleNameType
+  | KindNameType
   deriving (Show, Read, Eq, Generic, A.ToJSON, A.FromJSON)
 
 readableType :: LspNameType -> Text
@@ -28,6 +31,8 @@ readableType = \case
   DctorNameType -> "Constructor"
   TyClassNameType -> "Type Class"
   ModNameType -> "Module"
+  RoleNameType -> "Role"
+  KindNameType -> "Kind"
 
 readableTypeIn :: LspNameType -> Text
 readableTypeIn = \case
@@ -50,6 +55,16 @@ lspNameType = \case
   TyClassName _ -> TyClassNameType
   ModName _ -> ModNameType
 
+declNameType :: P.Declaration -> Maybe LspNameType
+declNameType = \case
+  P.DataDeclaration{} ->  Just TyNameType
+  P.TypeSynonymDeclaration{} ->  Just TyNameType
+  P.TypeClassDeclaration{} ->  Just TyClassNameType
+  P.TypeInstanceDeclaration{} ->  Just IdentNameType
+  P.KindDeclaration{} ->  Just KindNameType
+  P.RoleDeclaration{} ->  Just RoleNameType
+  _ -> Nothing
+
 externDeclNameType :: ExternsDeclaration -> LspNameType
 externDeclNameType = \case
   EDType _ _ _ -> TyNameType
diff --git a/src/Language/PureScript/Lsp/Print.hs b/src/Language/PureScript/Lsp/Print.hs
index aa9eb18303..e7f0f6c09f 100644
--- a/src/Language/PureScript/Lsp/Print.hs
+++ b/src/Language/PureScript/Lsp/Print.hs
@@ -39,16 +39,11 @@ getCtrType pos tyName ctr = foldr addCtrField (P.TypeConstructor () $ P.Qualifie
 addCtrField :: (P.Ident, P.SourceType) -> P.Type () -> P.Type ()
 addCtrField (_ident, ty) acc = ty `arrow` acc
 
-printDataDeclType :: P.ProperName 'P.TypeName -> [(Text, Maybe P.SourceType)] -> Text
-printDataDeclType tyName = printType . getDataDeclType tyName
+printDataDeclKind :: [(Text, Maybe P.SourceType)] -> Text
+printDataDeclKind = printType . getDataDeclKind
 
-getDataDeclType :: P.ProperName 'P.TypeName -> [(Text, Maybe P.SourceType)] -> P.Type ()
-getDataDeclType tyName args = P.KindedType () tipe kind
-  where
-    tipe :: P.Type ()
-    tipe = foldr addDataDeclArgType (P.TypeVar () $ P.runProperName tyName) args
-
-    kind = foldr addDataDeclArgKind (P.TypeVar () "Type") args
+getDataDeclKind :: [(Text, Maybe P.SourceType)] -> P.Type ()
+getDataDeclKind args = foldr addDataDeclArgKind (P.TypeVar () "Type") args
 
 addDataDeclArgType :: (Text, Maybe P.SourceType) -> P.Type () -> P.Type ()
 addDataDeclArgType (ident, _) acc = P.TypeApp () acc (P.TypeVar () ident)
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index ad68b54011..72d9efb288 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -13,8 +13,8 @@ import Language.LSP.Server (MonadLsp)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Externs qualified as P
-import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), externDeclNameType, lspNameType)
-import Language.PureScript.Lsp.Print (printCtrType, printDataDeclType, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType)
+import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), declNameType, externDeclNameType, lspNameType)
+import Language.PureScript.Lsp.Print (printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Make qualified as P
@@ -51,12 +51,12 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
         printedType = case getOperatorValueName decl >>= disqualifyIfInModule >>= getDeclFromName of
           Just decl' -> printDeclarationType decl'
           Nothing -> case decl of
-            P.TypeDeclaration declData -> printType $ P.tydeclType declData
-            P.DataDeclaration _ _ tyName args _ -> printDataDeclType tyName args
+            P.TypeDeclaration declData -> printType (P.tydeclType declData)
+            P.DataDeclaration _ _ _ args _ -> printDataDeclKind args
             _ -> printDeclarationType decl
     for_ nameMb \name -> do
       let exported = Set.member name exportedNames
-          nameType = lspNameType name
+          nameType = fromMaybe (lspNameType name) $ declNameType decl
           printedName = printName name
 
       SQL.executeNamed

From faea44a04d79efd852c44c7267728f1003d80e59 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 30 Oct 2024 09:37:51 +0100
Subject: [PATCH 207/297] fix type syn signatures

---
 src/Language/PureScript/AST/Declarations.hs   |  18 ++
 src/Language/PureScript/Lsp/AtPosition.hs     | 234 ++++++++----------
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  91 ++++---
 src/Language/PureScript/Make/Index.hs         |  63 +++--
 src/Language/PureScript/Pretty/Values.hs      |   1 +
 src/Language/PureScript/TypeChecker/Kinds.hs  |   1 +
 6 files changed, 226 insertions(+), 182 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index e25c305ae8..617612d567 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -449,6 +449,24 @@ data Declaration
   | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody
   deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
+declCtr :: Declaration -> Text 
+declCtr DataDeclaration{} = "DataDeclaration"
+declCtr DataBindingGroupDeclaration{} = "DataBindingGroupDeclaration"
+declCtr TypeSynonymDeclaration{} = "TypeSynonymDeclaration"
+declCtr KindDeclaration{} = "KindDeclaration"
+declCtr RoleDeclaration{} = "RoleDeclaration"
+declCtr TypeDeclaration{} = "TypeDeclaration"
+declCtr ValueDeclaration{} = "ValueDeclaration"
+declCtr BoundValueDeclaration{} = "BoundValueDeclaration"
+declCtr BindingGroupDeclaration{} = "BindingGroupDeclaration"
+declCtr ExternDeclaration{} = "ExternDeclaration"
+declCtr ExternDataDeclaration{} = "ExternDataDeclaration"
+declCtr FixityDeclaration{} = "FixityDeclaration"
+declCtr ImportDeclaration{} = "ImportDeclaration"
+declCtr TypeClassDeclaration{} = "TypeClassDeclaration"
+declCtr TypeInstanceDeclaration{} = "TypeInstanceDeclaration"
+
+
 instance A.ToJSON Declaration where
   toJSON = A.toJSON . show . S.serialise
 
diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 7c3e23f023..86dc434c5c 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -23,7 +23,9 @@ import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
 import Language.PureScript.Lsp.Util (declsAtLine, getDeclarationAtPos, onDeclsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Traversals (defS)
 import Language.PureScript.Types (getAnnForType)
-import Protolude 
+import Protolude
+import Safe qualified
+
 data AtPos
   = APExpr P.SourceSpan Bool P.Expr
   | APBinder P.SourceSpan Bool P.Binder
@@ -34,44 +36,11 @@ data AtPos
   | APImport P.SourceSpan P.ModuleName P.ImportDeclarationType (Maybe P.DeclarationRef)
   | APDecl P.Declaration
 
-getSmallestAtPos :: EverythingAtPos -> Maybe AtPos
-getSmallestAtPos = \case
-  EverythingAtPos {apImport = Just import'} ->
-    Just $ uncurry4 APImport import'
-  EverythingAtPos {apTypes = types}
-    | not . null $ types ->
-        Just $ APType $ minimumBy (comparing getTypeLinesAndColumns) types
-  EverythingAtPos {apBinders = binders}
-    | not . null $ binders ->
-        Just $ uncurry3 APBinder $ minimumBy (comparing (spanSize . view _1)) binders
-  EverythingAtPos {apExprs = exprs}
-    | not . null $ exprs ->
-        Just $ uncurry3 APExpr $ minimumBy (comparing (spanSize . view _1)) exprs
-  EverythingAtPos {apCaseAlternatives = caseAlts}
-    | not . null $ caseAlts ->
-        Just $ uncurry APCaseAlternative $ minimumBy (comparing (spanSize . view _1)) caseAlts
-  EverythingAtPos {apDoNotationElements = doNotElems}
-    | not . null $ doNotElems ->
-        Just $ uncurry3 APDoNotationElement $ minimumBy (comparing (spanSize . view _1)) doNotElems
-  EverythingAtPos {apGuards = guards}
-    | not . null $ guards ->
-        Just $ uncurry APGuard $ minimumBy (comparing (spanSize . view _1)) guards
-  EverythingAtPos {apDecls = decls}
-    | not . null $ decls ->
-        Just $ APDecl $ minimumBy (comparing (spanSize . declSourceSpan)) decls
-  _ -> Nothing
-
-uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
-uncurry3 f (a, b, c) = f a b c
-
-uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
-uncurry4 f (a, b, c, d) = f a b c d
-
 spanSize :: P.SourceSpan -> (Int, Int)
 spanSize (P.SourceSpan _ start end) = (P.sourcePosLine end - P.sourcePosLine start, P.sourcePosColumn end - P.sourcePosColumn start)
 
 data EverythingAtPos = EverythingAtPos
-  { apTopLevelDecl :: Maybe P.Declaration,
+  { apTopLevelDecl :: [P.Declaration],
     apDecls :: [P.Declaration],
     apExprs :: [(P.SourceSpan, Bool, P.Expr)],
     apBinders :: [(P.SourceSpan, Bool, P.Binder)],
@@ -79,10 +48,17 @@ data EverythingAtPos = EverythingAtPos
     apDoNotationElements :: [(P.SourceSpan, Bool, P.DoNotationElement)],
     apGuards :: [(P.SourceSpan, P.Guard)],
     apTypes :: [P.SourceType],
-    apImport :: Maybe (P.SourceSpan, P.ModuleName, P.ImportDeclarationType, Maybe P.DeclarationRef)
+    apImport :: [(P.SourceSpan, P.ModuleName, P.ImportDeclarationType, Maybe P.DeclarationRef)]
   }
   deriving (Show)
 
+instance Semigroup EverythingAtPos where
+  EverythingAtPos a1 b1 c1 d1 e1 f1 g1 h1 i1 <> EverythingAtPos a2 b2 c2 d2 e2 f2 g2 h2 i2 =
+    EverythingAtPos (a1 <> a2) (b1 <> b2) (c1 <> c2) (d1 <> d2) (e1 <> e2) (f1 <> f2) (g1 <> g2) (h1 <> h2) (i1 <> i2)
+
+instance Monoid EverythingAtPos where
+  mempty = nullEverythingAtPos
+  
 showCounts :: EverythingAtPos -> Text
 showCounts EverythingAtPos {..} =
   "decls: "
@@ -100,13 +76,13 @@ showCounts EverythingAtPos {..} =
     <> ",\ntypes: "
     <> show (length apTypes)
     <> ",\nimport: "
-    <> show (isJust apImport)
+    <> show (length apImport)
 
 nullEverythingAtPos :: EverythingAtPos
-nullEverythingAtPos = EverythingAtPos Nothing [] [] [] [] [] [] [] Nothing
+nullEverythingAtPos = EverythingAtPos [] [] [] [] [] [] [] [] []
 
 topLevelDecl :: P.Declaration -> EverythingAtPos
-topLevelDecl decl = nullEverythingAtPos {apTopLevelDecl = Just decl}
+topLevelDecl decl = nullEverythingAtPos {apTopLevelDecl = pure decl}
 
 withSpansOnly :: EverythingAtPos -> EverythingAtPos
 withSpansOnly EverythingAtPos {..} =
@@ -138,95 +114,91 @@ withTypedValuesOnly EverythingAtPos {..} =
       P.accumTypes (const $ Just ())
 
 getEverythingAtPos :: [P.Declaration] -> Types.Position -> EverythingAtPos
-getEverythingAtPos decls pos@(Types.Position {..}) =
-  case head $ declsAtLine (fromIntegral _line + 1) $ filter (not . isPrimImport) decls of
-    Nothing -> nullEverythingAtPos
-    Just decl@(P.ImportDeclaration (ss, _) importedModuleName importType _) ->
-      (topLevelDecl decl) {apImport = Just (maybe ss P.declRefSourceSpan ref, importedModuleName, importType, ref)}
-      where
-        ref = findDeclRefAtPos pos case importType of
-          P.Implicit -> []
-          P.Explicit refs -> refs
-          P.Hiding refs -> refs
-    Just topDecl -> execState (handleDecl topDecl) (topLevelDecl topDecl) {apDecls = [topDecl]}
-      where
-        (handleDecl, _, _, _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan topDecl) onDecl onExpr onBinder onCaseAlternative onDoNotationElement onGuard
-
-        onDecl :: P.SourceSpan -> P.Declaration -> StateT EverythingAtPos Identity (P.SourceSpan, P.Declaration)
-        onDecl _ decl = do
-          let ss = declSourceSpan decl
-          --     !_ = force $ traceWith "decls" (T.take 128 . debugExpr) decl
-
-          -- !_ <- force <$> case decl of
-          --   P.ValueDecl _sa ident _nk binders _gexprs -> do
-          --     let a :: Text = show $ force $ traceShow' "" (ident, binders)
-          --     pure a
-          --   _ -> pure ""
-
-          when (posInSpan pos ss) do
-            modify $ addDecl decl
-          addTypesSt $ declTypes decl
-          pure (ss, decl)
-
-        onExpr ss expr = do
-          let ssMb = P.exprSourceSpan expr
-              ss' = fromMaybe ss ssMb
-          --     !_ = force $ traceWith "expr" (T.take 256 . debugExpr) expr
-          -- !_ <-
-          --   force <$> case expr of
-          --     P.Abs binder _e -> do
-          --       let a :: Text = show $ force $ traceShow' "binder" binder
-          --       pure a
-          --     _ -> pure ""
-
-          when (posInSpan pos ss' && not (isPlaceholder expr)) do
-            modify $ addExpr ss' (isJust ssMb) expr
-          addTypesSt $ exprTypes expr
-          pure (ss', expr)
-
-        onBinder ss binder = do
-          let ssMb = binderSourceSpan binder
-              ss' = fromMaybe ss ssMb
-          when (posInSpan pos ss') do
-            modify $ addBinder ss' (isJust ssMb) binder
-          addTypesSt $ binderTypes binder
-          pure (ss', binder)
-
-        onCaseAlternative :: P.SourceSpan -> P.CaseAlternative -> StateT EverythingAtPos Identity (P.SourceSpan, P.CaseAlternative)
-        onCaseAlternative ss caseAlt = do
-          when (posInSpan pos ss) do
-            modify $ addCaseAlternative ss caseAlt
-          addTypesSt $ caseAltTypes caseAlt
-          pure (ss, caseAlt)
-
-        onDoNotationElement :: P.SourceSpan -> P.DoNotationElement -> StateT EverythingAtPos Identity (P.SourceSpan, P.DoNotationElement)
-        onDoNotationElement ss doNotationElement = do
-          let ssMb = doNotationElementSpan doNotationElement
-              ss' = fromMaybe ss ssMb
-          when (posInSpan pos ss') do
-            modify $ addDoNotationElement ss' (isJust ssMb) doNotationElement
-          addTypesSt $ doNotTypes doNotationElement
-          pure (ss', doNotationElement)
-
-        onGuard :: P.SourceSpan -> P.Guard -> StateT EverythingAtPos Identity (P.SourceSpan, P.Guard)
-        onGuard ss guard' = do
-          when (posInSpan pos ss) do
-            modify (addGuard ss guard')
-          pure (ss, guard')
-
-        doNotationElementSpan :: P.DoNotationElement -> Maybe P.SourceSpan
-        doNotationElementSpan = \case
-          P.PositionedDoNotationElement ss _ _ -> Just ss
-          _ -> Nothing
-
-        (declTypes, exprTypes, binderTypes, caseAltTypes, doNotTypes) = P.accumTypes (getTypesAtPos pos)
-
-        isPlaceholder :: P.Expr -> Bool
-        isPlaceholder = \case
-          P.TypeClassDictionary {} -> True
-          P.DeferredDictionary {} -> True
-          P.DerivedInstancePlaceholder {} -> True
-          _ -> False
+getEverythingAtPos decls pos@(Types.Position {..}) = foldMap (addDeclValuesAtPos pos) declsAtPos
+  where
+    declsAtPos = declsAtLine (fromIntegral _line + 1) $ filter (not . isPrimImport) decls
+
+addDeclValuesAtPos :: Types.Position -> P.Declaration -> EverythingAtPos
+addDeclValuesAtPos pos = \case
+  decl@(P.ImportDeclaration (ss, _) importedModuleName importType _) ->
+    (topLevelDecl decl) {apImport = pure (maybe ss P.declRefSourceSpan ref, importedModuleName, importType, ref)}
+    where
+      ref = findDeclRefAtPos pos case importType of
+        P.Implicit -> []
+        P.Explicit refs -> refs
+        P.Hiding refs -> refs
+  topDecl -> execState (handleDecl topDecl) (topLevelDecl topDecl)
+    where
+      (handleDecl, _, _, _, _, _) = P.everywhereWithContextOnValuesM (declSourceSpan topDecl) onDecl onExpr onBinder onCaseAlternative onDoNotationElement onGuard
+
+      onDecl :: P.SourceSpan -> P.Declaration -> StateT EverythingAtPos Identity (P.SourceSpan, P.Declaration)
+      onDecl _ decl = do
+        let ss = declSourceSpan decl
+
+        when (posInSpan pos ss) do
+          modify $ addDecl decl
+        addTypesSt $ declTypes decl
+        pure (ss, decl)
+
+      onExpr ss expr = do
+        let ssMb = P.exprSourceSpan expr
+            ss' = fromMaybe ss ssMb
+        --     !_ = force $ traceWith "expr" (T.take 256 . debugExpr) expr
+        -- !_ <-
+        --   force <$> case expr of
+        --     P.Abs binder _e -> do
+        --       let a :: Text = show $ force $ traceShow' "binder" binder
+        --       pure a
+        --     _ -> pure ""
+
+        when (posInSpan pos ss' && not (isPlaceholder expr)) do
+          modify $ addExpr ss' (isJust ssMb) expr
+        addTypesSt $ exprTypes expr
+        pure (ss', expr)
+
+      onBinder ss binder = do
+        let ssMb = binderSourceSpan binder
+            ss' = fromMaybe ss ssMb
+        when (posInSpan pos ss') do
+          modify $ addBinder ss' (isJust ssMb) binder
+        addTypesSt $ binderTypes binder
+        pure (ss', binder)
+
+      onCaseAlternative :: P.SourceSpan -> P.CaseAlternative -> StateT EverythingAtPos Identity (P.SourceSpan, P.CaseAlternative)
+      onCaseAlternative ss caseAlt = do
+        when (posInSpan pos ss) do
+          modify $ addCaseAlternative ss caseAlt
+        addTypesSt $ caseAltTypes caseAlt
+        pure (ss, caseAlt)
+
+      onDoNotationElement :: P.SourceSpan -> P.DoNotationElement -> StateT EverythingAtPos Identity (P.SourceSpan, P.DoNotationElement)
+      onDoNotationElement ss doNotationElement = do
+        let ssMb = doNotationElementSpan doNotationElement
+            ss' = fromMaybe ss ssMb
+        when (posInSpan pos ss') do
+          modify $ addDoNotationElement ss' (isJust ssMb) doNotationElement
+        addTypesSt $ doNotTypes doNotationElement
+        pure (ss', doNotationElement)
+
+      onGuard :: P.SourceSpan -> P.Guard -> StateT EverythingAtPos Identity (P.SourceSpan, P.Guard)
+      onGuard ss guard' = do
+        when (posInSpan pos ss) do
+          modify (addGuard ss guard')
+        pure (ss, guard')
+
+      doNotationElementSpan :: P.DoNotationElement -> Maybe P.SourceSpan
+      doNotationElementSpan = \case
+        P.PositionedDoNotationElement ss _ _ -> Just ss
+        _ -> Nothing
+
+      (declTypes, exprTypes, binderTypes, caseAltTypes, doNotTypes) = P.accumTypes (getTypesAtPos pos)
+
+      isPlaceholder :: P.Expr -> Bool
+      isPlaceholder = \case
+        P.TypeClassDictionary {} -> True
+        P.DeferredDictionary {} -> True
+        P.DerivedInstancePlaceholder {} -> True
+        _ -> False
 
 traceToErr :: Text -> b -> b
 traceToErr a b = trace a b
@@ -398,6 +370,9 @@ isNullSourceTypeSpan st = getAnnForType st == (nullSourceSpan, [])
 isSingleLine :: P.SourceType -> Bool
 isSingleLine st = P.sourcePosLine (P.spanStart (fst (getAnnForType st))) == P.sourcePosLine (P.spanEnd (fst (getAnnForType st)))
 
+smallestType :: [P.SourceType] -> Maybe P.SourceType
+smallestType = Safe.minimumByMay (comparing getTypeLinesAndColumns)
+
 getTypeLinesAndColumns :: P.SourceType -> (Int, Int)
 getTypeLinesAndColumns st = (getTypeLines st, getTypeColumns st)
 
@@ -444,7 +419,6 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
         modify (expr :)
       pure expr
 
-
 modifySmallestExprAtPos :: (P.Expr -> P.Expr) -> Types.Position -> P.Module -> (P.Module, Maybe (P.Expr, P.Expr))
 modifySmallestExprAtPos fn pos@(Types.Position {..}) (P.Module ss c mName decls refs) =
   (P.Module ss c mName (fmap fst declsAndExpr) refs, asum $ snd <$> declsAndExpr)
@@ -466,14 +440,12 @@ modifySmallestDeclExprAtPos fn pos declaration = runState (onDecl declaration) N
           pure expr'
         else pure expr
 
-
 modifySmallestBinderAtPos :: (P.Binder -> P.Binder) -> Types.Position -> P.Module -> (P.Module, Maybe (P.Binder, P.Binder))
 modifySmallestBinderAtPos fn pos@(Types.Position {..}) (P.Module ss c mName decls refs) =
   (P.Module ss c mName (fmap fst declsAndBinder) refs, asum $ snd <$> declsAndBinder)
   where
     declsAndBinder = onDeclsAtLine (pure . modifySmallestDeclBinderAtPos fn pos) (\d -> [(d, Nothing)]) (fromIntegral _line + 1) decls
 
-
 modifySmallestDeclBinderAtPos :: (P.Binder -> P.Binder) -> Types.Position -> P.Declaration -> (P.Declaration, Maybe (P.Binder, P.Binder))
 modifySmallestDeclBinderAtPos fn pos declaration = runState (onDecl declaration) Nothing
   where
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 0dd4f4def7..b90584a148 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -32,10 +32,10 @@ import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (tyBoolean, tyChar, tyInt, tyNumber, tyString)
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, getTypeLinesAndColumns, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, spanSize, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, getTypeLinesAndColumns, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestType, spanSize, spanToRange)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
@@ -71,12 +71,26 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       respondWithDeclInModule ss nameType modName ident = do
         docs <- readDeclarationDocsWithNameType modName nameType ident
         foundTypes <- getAstDeclarationTypeInModule (Just nameType) modName ident
-        debugLsp $ "Found types: " <> show (isJust $ head foundTypes)
+        debugLsp $ "respondWithDeclInModule " <> show (modName, ident)
+        debugLsp $ "Found types: " <> show foundTypes
         debugLsp $ "Found docs: " <> show (isJust docs)
         markdownRes (Just $ spanToRange ss) $
           joinMarkup
-            [ displayType modName ident <$> head foundTypes,
-              ("**Docs**\n" <>) <$> docs
+            [ showTypeSection modName ident <$> head foundTypes,
+              showDocs <$> docs
+            ]
+
+      respondWithDeclInModuleWithUnkownNameType :: P.SourceSpan -> P.ModuleName -> Text -> HandlerM ()
+      respondWithDeclInModuleWithUnkownNameType ss modName ident = do
+        docs <- readDeclarationDocsAsMarkdown modName ident
+        foundTypes <- getAstDeclarationTypeInModule Nothing modName ident
+        debugLsp $ "respondWithDeclInModuleWithUnkownNameType " <> show (modName, ident)
+        debugLsp $ "Found types: " <> show foundTypes
+        debugLsp $ "Found docs: " <> show (isJust docs)
+        markdownRes (Just $ spanToRange ss) $
+          joinMarkup
+            [ showTypeSection modName ident <$> head foundTypes,
+              showDocs <$> docs
             ]
 
       respondWithTypedExpr :: Maybe P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
@@ -122,11 +136,11 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       lookupExprTypes :: P.Expr -> HandlerM [Text]
       lookupExprTypes = \case
         P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-          fmap (displayType modName (P.runIdent ident)) <$> getAstDeclarationTypeInModule (Just IdentNameType) modName (P.runIdent ident)
+          fmap (showTypeSection modName (P.runIdent ident)) <$> getAstDeclarationTypeInModule (Just IdentNameType) modName (P.runIdent ident)
         P.Op _ (P.Qualified (P.ByModuleName modName) op) -> do
-          fmap (displayType modName (P.runOpName op)) <$> getAstDeclarationTypeInModule (Just ValOpNameType) modName (P.runOpName op)
+          fmap (showTypeSection modName (P.runOpName op)) <$> getAstDeclarationTypeInModule (Just ValOpNameType) modName (P.runOpName op)
         P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
-          fmap (displayType modName (P.runProperName dctor)) <$> getAstDeclarationTypeInModule (Just DctorNameType) modName (P.runProperName dctor)
+          fmap (showTypeSection modName (P.runProperName dctor)) <$> getAstDeclarationTypeInModule (Just DctorNameType) modName (P.runProperName dctor)
         P.TypedValue _ e _ | not (generatedExpr e) -> do
           lookupExprTypes e
         _ -> pure []
@@ -147,7 +161,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
           respondWithCounts = markdownRes Nothing $ showCounts everything
       debugLsp $ showCounts everything
-      case apImport everything of
+      case head $ apImport everything of
         Just (ss, importedModuleName, _, ref) -> do
           respondWithImport ss importedModuleName ref
         _ -> do
@@ -162,7 +176,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                 joinMarkup
                   [ inferredRes,
                     head foundTypes,
-                    ("**Docs**\n" <>) <$> docs
+                    showDocs <$> docs
                   ]
             Nothing -> do
               binderInferredRes <- inferBinderViaTypeHole filePath startPos
@@ -174,23 +188,41 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                     (spanToRange <$> binderSourceSpan binder)
                     (pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine ty) [])
                 Nothing -> do
-                  debugLsp $ "smallest type: " <> show (Safe.minimumByMay (comparing getTypeLinesAndColumns) (apTypes everything))
-                  case Safe.minimumByMay (comparing getTypeLinesAndColumns) (apTypes everything) of
-                    Just (P.ConstrainedType ann (P.Constraint _ (P.Qualified (P.ByModuleName modName) ident) _ _ _) _) ->
-                      respondWithDeclInModule (fst ann) TyClassNameType modName $ P.runProperName ident
-                    Just (P.TypeConstructor ann (P.Qualified (P.ByModuleName mName) name)) -> do
-                      debugLsp $ "TypeConstructor: " <> P.runProperName name
+                  case smallestType $ apTypes everything of
+                    Just (P.ConstrainedType ann (P.Constraint _ (P.Qualified (P.ByModuleName mName) ident) _ _ _) _) -> do
+                      debugLsp $ "Found constrained type: " <> show ident
+                      respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
+                    Just (P.TypeConstructor ann (P.Qualified (P.ByModuleName mName) name)) | P.runProperName name /= "Type" -> do
+                      debugLsp $ "Found type constructor: " <> show name
                       respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
-                    Just (P.TypeOp ann (P.Qualified (P.ByModuleName mName) name)) ->
+                    Just (P.TypeOp ann (P.Qualified (P.ByModuleName mName) name)) -> do
+                      debugLsp $ "Found type op: " <> show name
                       respondWithDeclInModule (fst ann) TyOpNameType mName (P.runOpName name)
-                    Just ty ->
-                      markdownRes
-                        (Just $ spanToRange $ fst $ P.getAnnForType ty)
-                        (pursTypeStr "" (Just $ prettyPrintTypeSingleLine ty) [])
-                    _ -> respondWithCounts
-
-displayType :: P.ModuleName -> Text -> Text -> Text
-displayType mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
+                    _ -> do
+                      debugLsp "Looking for unsugared types"
+                      let typesBeforeSugaring = apTypes $ getEverythingAtPos (P.getModuleDeclarations ofUncheckedModule) startPos
+                      case smallestType typesBeforeSugaring of
+                        Just ty -> do
+                          case ty of
+                            P.TypeConstructor ann (P.Qualified _ name) | P.runProperName name /= "Type" -> do
+                              debugLsp $ "Found type constructor: " <> show name
+                              respondWithDeclInModule (fst ann) TyNameType ofModuleName (P.runProperName name)
+                            P.ConstrainedType ann (P.Constraint _ (P.Qualified _ ident) _ _ _) _ -> do
+                              debugLsp $ "Found constrained type: " <> show ident
+                              respondWithDeclInModule (fst ann) TyClassNameType ofModuleName $ P.runProperName ident
+                            _ -> do
+                              debugLsp $ "Found type: " <> show ty
+                              markdownRes
+                                (Just $ spanToRange $ fst $ P.getAnnForType ty)
+                                (pursTypeStr (prettyPrintTypeSingleLine ty) Nothing [])
+                        Nothing -> do
+                          respondWithCounts
+
+showTypeSection :: P.ModuleName -> Text -> Text -> Text
+showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
+
+showDocs :: Text -> Text
+showDocs d = "**Docs**\n" <> d
 
 isLiteralNode :: Literal P.Expr -> Bool
 isLiteralNode = \case
@@ -314,15 +346,6 @@ getHoverSourceTypeFromErrs = \case
   Left (P.MultipleErrors errs) -> findMap getHoverHoleType errs
   Right (_, P.MultipleErrors errs) -> findMap getHoverHoleType errs
 
--- let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
--- case head (apExprs everything) of
---   Just (_, _, e) -> do
---     inferredRes <- inferExprType filePath e
---     case inferredRes of
---       Right ty -> pure $ Just (e, ty)
---       Left _ -> pure Nothing
---   _ -> pure Nothing
-
 inferExprViaTypeHoleText :: FilePath -> Types.Position -> HandlerM (Maybe Text)
 inferExprViaTypeHoleText filePath pos =
   inferExprViaTypeHole filePath pos <&> fmap \(expr, t) ->
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 72d9efb288..7b90064522 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -4,21 +4,21 @@
 module Language.PureScript.Make.Index where
 
 import Codec.Serialise (serialise)
+import Data.List (partition)
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple (Connection, NamedParam ((:=)))
 import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
 import Language.LSP.Server (MonadLsp)
-import Language.PureScript.AST qualified as P
+import Language.PureScript qualified as P
+import Language.PureScript.Environment (Environment)
 import Language.PureScript.Externs (ExternsFile (efModuleName))
-import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), declNameType, externDeclNameType, lspNameType)
-import Language.PureScript.Lsp.Print (printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType)
+import Language.PureScript.Lsp.Print (addDataDeclArgKind, printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
-import Language.PureScript.Make qualified as P
-import Language.PureScript.Names qualified as P
+import Language.PureScript.TypeChecker.Monad (emptyCheckState)
 import Protolude hiding (moduleName)
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
@@ -29,11 +29,11 @@ addAllIndexing conn ma =
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (indexAstModule conn astM ext (getExportedNames ext)) <* P.codegen ma prevEnv endEnv astM m docs ext
+    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (indexAstModule conn endEnv astM ext (getExportedNames ext)) <* P.codegen ma prevEnv endEnv astM m docs ext
     }
 
-indexAstModule :: (MonadIO m) => Connection -> P.Module -> ExternsFile -> Set P.Name -> m ()
-indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) extern exportedNames = liftIO do
+indexAstModule :: (MonadIO m) => Connection -> Environment -> P.Module -> ExternsFile -> Set P.Name -> m ()
+indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs) extern exportedNames = liftIO do
   path <- makeAbsolute externPath
   SQL.executeNamed
     conn
@@ -43,17 +43,42 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
     ]
   SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName moduleName')
 
-  forM_ decls \decl -> do
+  let declsSorted :: [P.Declaration]
+      declsSorted = partition (not . isTypeDecl) decls & uncurry (<>)
+
+      isTypeDecl = \case
+        P.TypeDeclaration _ -> True
+        _ -> False
+
+  forM_ declsSorted \decl -> do
     let (ss, _) = P.declSourceAnn decl
         start = P.spanStart ss
         end = P.spanEnd ss
         nameMb = P.declName decl
-        printedType = case getOperatorValueName decl >>= disqualifyIfInModule >>= getDeclFromName of
+        getMatchingKind sigFor tyName = findMap (\case P.KindDeclaration _ sigFor' name kind  | sigFor == sigFor' && name == tyName -> Just kind; _ -> Nothing) decls
+        getPrintedType d = case getOperatorValueName d >>= disqualifyIfInModule >>= getDeclFromName of
           Just decl' -> printDeclarationType decl'
-          Nothing -> case decl of
-            P.TypeDeclaration declData -> printType (P.tydeclType declData)
-            P.DataDeclaration _ _ _ args _ -> printDataDeclKind args
-            _ -> printDeclarationType decl
+          Nothing -> case d of
+            P.DataDeclaration _ _ tyName args _ -> case getMatchingKind P.DataSig tyName of 
+                Just kind -> printType kind 
+                _ ->  printDataDeclKind args
+            P.TypeSynonymDeclaration ann name args ty ->  case getMatchingKind P.TypeSynonymSig name of 
+                Just kind -> printType kind 
+                _ ->
+                  let addForall ty' = foldl' (\acc v -> P.ForAll P.nullSourceAnn P.TypeVarInvisible v Nothing acc Nothing) ty' vars
+                        where
+                          vars = P.usedTypeVariables ty'
+
+                      inferSynRes =
+                        runExcept $ evalStateT (P.inferKind . addForall =<< P.inferTypeSynonym moduleName' (ann, name, args, ty)) (emptyCheckState endEnv) {P.checkCurrentModule = Just moduleName'}
+                  in case inferSynRes of
+                        Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
+                        Right (_, tyKind) ->
+                          printType $ foldr addDataDeclArgKind (void tyKind) args
+            _ -> printDeclarationType d
+
+    let printedType = getPrintedType decl
+
     for_ nameMb \name -> do
       let exported = Set.member name exportedNames
           nameType = fromMaybe (lspNameType name) $ declNameType decl
@@ -63,13 +88,14 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
         conn
         ( SQL.Query
             "INSERT INTO ast_declarations \
-            \         (module_name, name, printed_type, name_type, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
-            \ VALUES (:module_name, :name, :printed_type, :name_type, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
+            \         (module_name, name, printed_type, name_type, decl_ctr, start_line, end_line, start_col, end_col, lines, cols, exported, generated) \
+            \ VALUES (:module_name, :name, :printed_type, :name_type, :decl_ctr, :start_line, :end_line, :start_col, :end_col, :lines, :cols, :exported, :generated)"
         )
         [ ":module_name" := P.runModuleName moduleName',
           ":name" := printedName,
           ":printed_type" := printedType,
           ":name_type" := nameType,
+          ":decl_ctr" := P.declCtr decl,
           ":start_line" := P.sourcePosLine start,
           ":end_line" := P.sourcePosLine end,
           ":start_col" := P.sourcePosColumn start,
@@ -119,6 +145,9 @@ indexAstModule conn (P.Module _ss _comments moduleName' decls _exportRefs) exter
     disqualifyIfInModule (P.Qualified (P.BySourcePos _) name) = Just name
     disqualifyIfInModule _ = Nothing
 
+findMap :: (a -> Maybe b) -> [a] -> Maybe b
+findMap f = listToMaybe . mapMaybe f
+
 declCtrs :: P.Declaration -> Maybe (P.SourceAnn, P.ProperName 'P.TypeName, [P.DataConstructorDeclaration])
 declCtrs = \case
   P.DataDeclaration sa _ n _ ctors -> Just (sa, n, ctors)
@@ -245,7 +274,7 @@ initDb conn = do
   SQL.execute_
     conn
     "CREATE TABLE IF NOT EXISTS ast_declarations \
-    \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, ctr_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, generated BOOLEAN, \
+    \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, decl_ctr TEXT, ctr_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, generated BOOLEAN, \
     \UNIQUE(module_name, name_type, name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 6c5b6fe775..ba430cc93e 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Pretty.Values
   ( prettyPrintValue
   , prettyPrintBinder
   , prettyPrintBinderAtom
+  , prettyPrintDeclaration
   , prettyPrintLiteralValue
   ) where
 
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 5be87c0057..b6c886846c 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -23,6 +23,7 @@ module Language.PureScript.TypeChecker.Kinds
   , unknownsWithKinds
   , freshKind
   , freshKindWithKind
+  , inferTypeSynonym
   ) where
 
 import Prelude

From be4b70153160ef05f51a3be19257946a79577ec7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 30 Oct 2024 09:50:44 +0100
Subject: [PATCH 208/297] type class signatures showing

---
 src/Language/PureScript/Lsp/Print.hs  |  6 +++++
 src/Language/PureScript/Make/Index.hs | 37 +++++++++++++++------------
 2 files changed, 26 insertions(+), 17 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Print.hs b/src/Language/PureScript/Lsp/Print.hs
index e7f0f6c09f..6b24924eb2 100644
--- a/src/Language/PureScript/Lsp/Print.hs
+++ b/src/Language/PureScript/Lsp/Print.hs
@@ -45,6 +45,12 @@ printDataDeclKind = printType . getDataDeclKind
 getDataDeclKind :: [(Text, Maybe P.SourceType)] -> P.Type ()
 getDataDeclKind args = foldr addDataDeclArgKind (P.TypeVar () "Type") args
 
+printTypeClassKind :: [(Text, Maybe P.SourceType)] -> Text
+printTypeClassKind = printType . getTypeClassKind
+
+getTypeClassKind :: [(Text, Maybe P.SourceType)] -> P.Type ()
+getTypeClassKind args = foldr addDataDeclArgKind (P.TypeVar () "Constraint") args
+
 addDataDeclArgType :: (Text, Maybe P.SourceType) -> P.Type () -> P.Type ()
 addDataDeclArgType (ident, _) acc = P.TypeApp () acc (P.TypeVar () ident)
 
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 7b90064522..6c836aedff 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -15,7 +15,7 @@ import Language.PureScript qualified as P
 import Language.PureScript.Environment (Environment)
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), declNameType, externDeclNameType, lspNameType)
-import Language.PureScript.Lsp.Print (addDataDeclArgKind, printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType)
+import Language.PureScript.Lsp.Print (addDataDeclArgKind, printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType, printTypeClassKind)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.TypeChecker.Monad (emptyCheckState)
@@ -55,26 +55,29 @@ indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs
         start = P.spanStart ss
         end = P.spanEnd ss
         nameMb = P.declName decl
-        getMatchingKind sigFor tyName = findMap (\case P.KindDeclaration _ sigFor' name kind  | sigFor == sigFor' && name == tyName -> Just kind; _ -> Nothing) decls
+        getMatchingKind sigFor tyName = findMap (\case P.KindDeclaration _ sigFor' name kind | sigFor == sigFor' && name == tyName -> Just kind; _ -> Nothing) decls
         getPrintedType d = case getOperatorValueName d >>= disqualifyIfInModule >>= getDeclFromName of
           Just decl' -> printDeclarationType decl'
           Nothing -> case d of
-            P.DataDeclaration _ _ tyName args _ -> case getMatchingKind P.DataSig tyName of 
-                Just kind -> printType kind 
-                _ ->  printDataDeclKind args
-            P.TypeSynonymDeclaration ann name args ty ->  case getMatchingKind P.TypeSynonymSig name of 
-                Just kind -> printType kind 
-                _ ->
-                  let addForall ty' = foldl' (\acc v -> P.ForAll P.nullSourceAnn P.TypeVarInvisible v Nothing acc Nothing) ty' vars
-                        where
-                          vars = P.usedTypeVariables ty'
+            P.DataDeclaration _ _ tyName args _ -> case getMatchingKind P.DataSig tyName of
+              Just kind -> printType kind
+              _ -> printDataDeclKind args
+            P.TypeSynonymDeclaration ann name args ty -> case getMatchingKind P.TypeSynonymSig name of
+              Just kind -> printType kind
+              _ ->
+                let addForall ty' = foldl' (\acc v -> P.ForAll P.nullSourceAnn P.TypeVarInvisible v Nothing acc Nothing) ty' vars
+                      where
+                        vars = P.usedTypeVariables ty'
 
-                      inferSynRes =
-                        runExcept $ evalStateT (P.inferKind . addForall =<< P.inferTypeSynonym moduleName' (ann, name, args, ty)) (emptyCheckState endEnv) {P.checkCurrentModule = Just moduleName'}
-                  in case inferSynRes of
-                        Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
-                        Right (_, tyKind) ->
-                          printType $ foldr addDataDeclArgKind (void tyKind) args
+                    inferSynRes =
+                      runExcept $ evalStateT (P.inferKind . addForall =<< P.inferTypeSynonym moduleName' (ann, name, args, ty)) (emptyCheckState endEnv) {P.checkCurrentModule = Just moduleName'}
+                 in case inferSynRes of
+                      Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
+                      Right (_, tyKind) ->
+                        printType $ foldr addDataDeclArgKind (void tyKind) args
+            P.TypeClassDeclaration _ name args _ _ _ -> case getMatchingKind P.ClassSig (P.coerceProperName name) of
+              Just kind -> printType kind
+              _ -> printTypeClassKind args
             _ -> printDeclarationType d
 
     let printedType = getPrintedType decl

From 2231c465c6c6a1000668db10b6e678daee05191e Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 30 Oct 2024 10:59:19 +0100
Subject: [PATCH 209/297] get smallest expr

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 11 +++++++----
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 12 +++++++-----
 2 files changed, 14 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 86dc434c5c..50a7eeac1f 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -241,7 +241,7 @@ debugExpr =
     . T.replace "SourcePos {sourcePosLine = " ""
     . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
     . T.replace "SourceSpan {spanStart = SourcePos {sourcePosLine =  " "start = "
-    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/simple-purs/src/B.purs\", " ""
+    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/oa/application/purs-projects/lib/oa-common/src/general/AwsLambda.purs\", " ""
     . show
 
 debugSrcSpan :: P.SourceSpan -> Text
@@ -250,7 +250,7 @@ debugSrcSpan =
     . T.replace "SourcePos {sourcePosLine = " ""
     . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
     . T.replace "SourceSpan {spanStart = SourcePos {sourcePosLine =  " "start = "
-    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/simple-purs/src/B.purs\", " ""
+    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/oa/application/purs-projects/lib/oa-common/src/general/AwsLambda.purs\", " ""
     . show
 
 -- getDeclTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
@@ -352,8 +352,11 @@ atPosition nullRes handleDecl handleImportRef handleModule handleExprInModule fi
               _ -> respondWithTypeLocation
 
 smallestExpr :: [P.Expr] -> Maybe P.Expr
-smallestExpr [] = Nothing
-smallestExpr es = Just $ minimumBy (comparing (fromMaybe (maxInt, maxInt) . getExprLinesAndColumns)) es
+smallestExpr = smallestExpr' identity
+
+smallestExpr' :: (a -> P.Expr) -> [a] -> Maybe a
+smallestExpr' f = Safe.minimumByMay (comparing (fromMaybe (maxInt, maxInt) . (getExprLinesAndColumns . f))) 
+
 
 getExprLinesAndColumns :: P.Expr -> Maybe (Int, Int)
 getExprLinesAndColumns expr =
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index b90584a148..4c754ba307 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -32,7 +32,7 @@ import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (tyBoolean, tyChar, tyInt, tyNumber, tyString)
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, getTypeLinesAndColumns, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestType, spanSize, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, getTypeLinesAndColumns, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestType, spanSize, spanToRange, smallestExpr, smallestExpr')
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readDeclarationDocsWithNameType, readModuleDocs)
@@ -143,6 +143,8 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           fmap (showTypeSection modName (P.runProperName dctor)) <$> getAstDeclarationTypeInModule (Just DctorNameType) modName (P.runProperName dctor)
         P.TypedValue _ e _ | not (generatedExpr e) -> do
           lookupExprTypes e
+        P.PositionedValue _ _ e | not (generatedExpr e) -> do
+          lookupExprTypes e
         _ -> pure []
 
       lookupExprDocs :: P.Expr -> HandlerM (Maybe Text)
@@ -165,10 +167,11 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         Just (ss, importedModuleName, _, ref) -> do
           respondWithImport ss importedModuleName ref
         _ -> do
-          case head $ filter (not . generatedExpr . view _3) $ apExprs everything of
+          case smallestExpr' (view _3) $ filter (not . generatedExpr . view _3) $ apExprs everything of
             Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
             Just (ss, _, foundExpr) -> do
-              debugLsp $ "Found expr: " <> show foundExpr
+              debugLsp $ "Found expr: " <> ellipsis 512 (debugExpr foundExpr)
+              debugLsp $ "Show expr: " <> dispayExprOnHover foundExpr
               inferredRes <- inferExprViaTypeHoleText filePath startPos
               foundTypes <- lookupExprTypes foundExpr
               docs <- lookupExprDocs foundExpr
@@ -180,7 +183,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                   ]
             Nothing -> do
               binderInferredRes <- inferBinderViaTypeHole filePath startPos
-
               case binderInferredRes of
                 Just (binder, ty) -> do
                   debugLsp $ "Found binder: " <> show binder
@@ -211,7 +213,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                               debugLsp $ "Found constrained type: " <> show ident
                               respondWithDeclInModule (fst ann) TyClassNameType ofModuleName $ P.runProperName ident
                             _ -> do
-                              debugLsp $ "Found type: " <> show ty
                               markdownRes
                                 (Just $ spanToRange $ fst $ P.getAnnForType ty)
                                 (pursTypeStr (prettyPrintTypeSingleLine ty) Nothing [])
@@ -434,6 +435,7 @@ generatedExpr = \case
   P.App e e' -> generatedExpr e || generatedExpr e'
   P.TypedValue _ e _ -> generatedExpr e
   P.PositionedValue _ _ e -> generatedExpr e
+  P.Case es _ -> any generatedExpr es
   _ -> False
 
 sortDeclsBySize :: [P.Declaration] -> [P.Declaration]

From c9732842ec62c8d7c3ad143bb30dd5d5a751ba23 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 30 Oct 2024 12:35:28 +0100
Subject: [PATCH 210/297] fixes type alias hovering

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 27 ++++++++++++++-----
 1 file changed, 20 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 4c754ba307..775e4415a8 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -53,6 +53,7 @@ import Protolude hiding (handle, to)
 import Safe qualified
 import Text.Blaze.Html5 (mark)
 import Text.PrettyPrint.Boxes (render)
+import Language.PureScript.Sugar.Names.Env qualified as P
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
@@ -167,7 +168,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         Just (ss, importedModuleName, _, ref) -> do
           respondWithImport ss importedModuleName ref
         _ -> do
-          case smallestExpr' (view _3) $ filter (not . generatedExpr . view _3) $ apExprs everything of
+          case smallestExpr' (view _3) $ filter (not . (isAbs <||> generatedExpr) . view _3) $ apExprs everything of
             Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
             Just (ss, _, foundExpr) -> do
               debugLsp $ "Found expr: " <> ellipsis 512 (debugExpr foundExpr)
@@ -201,17 +202,23 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                       debugLsp $ "Found type op: " <> show name
                       respondWithDeclInModule (fst ann) TyOpNameType mName (P.runOpName name)
                     _ -> do
+                      debugLsp $ "Smallest type printed: " <> show (fmap prettyPrintTypeSingleLine $ smallestType $ apTypes everything) 
                       debugLsp "Looking for unsugared types"
                       let typesBeforeSugaring = apTypes $ getEverythingAtPos (P.getModuleDeclarations ofUncheckedModule) startPos
                       case smallestType typesBeforeSugaring of
                         Just ty -> do
+                          exportEnv <- getExportEnv
+                          let 
+                            imports = maybe P.nullImports (view _2) $ M.lookup ofModuleName exportEnv 
+
                           case ty of
-                            P.TypeConstructor ann (P.Qualified _ name) | P.runProperName name /= "Type" -> do
-                              debugLsp $ "Found type constructor: " <> show name
-                              respondWithDeclInModule (fst ann) TyNameType ofModuleName (P.runProperName name)
-                            P.ConstrainedType ann (P.Constraint _ (P.Qualified _ ident) _ _ _) _ -> do
-                              debugLsp $ "Found constrained type: " <> show ident
-                              respondWithDeclInModule (fst ann) TyClassNameType ofModuleName $ P.runProperName ident
+                            P.TypeConstructor ann q@(P.Qualified _ name) | P.runProperName name /= "Type" -> do
+                              debugLsp $ "Found type constructor: " <> show (q, name)
+                              let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypes imports)
+                              respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
+                            P.ConstrainedType ann (P.Constraint _ q@(P.Qualified _ ident) _ _ _) _ -> do
+                              let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypeClasses imports)
+                              respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
                             _ -> do
                               markdownRes
                                 (Just $ spanToRange $ fst $ P.getAnnForType ty)
@@ -428,6 +435,12 @@ allM f (x : xs) = do
   b <- f x
   if b then allM f xs else pure False
 
+isAbs :: P.Expr -> Bool
+isAbs = \case
+  P.Abs _ _ -> True
+  P.TypedValue _ e _ -> isAbs e
+  _ -> False
+
 generatedExpr :: P.Expr -> Bool
 generatedExpr = \case
   P.Var _ ident -> generatedIdent $ P.disqualify ident

From a2432afd6427176c487e138f8700ecc374b0e6af Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 30 Oct 2024 12:36:55 +0100
Subject: [PATCH 211/297] remove logs

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 775e4415a8..817d66a0df 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -171,14 +171,12 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           case smallestExpr' (view _3) $ filter (not . (isAbs <||> generatedExpr) . view _3) $ apExprs everything of
             Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
             Just (ss, _, foundExpr) -> do
-              debugLsp $ "Found expr: " <> ellipsis 512 (debugExpr foundExpr)
-              debugLsp $ "Show expr: " <> dispayExprOnHover foundExpr
               inferredRes <- inferExprViaTypeHoleText filePath startPos
               foundTypes <- lookupExprTypes foundExpr
               docs <- lookupExprDocs foundExpr
               markdownRes (Just $ spanToRange ss) $
                 joinMarkup
-                  [ inferredRes,
+                  [ inferredRes <|> Just (dispayExprOnHover foundExpr),
                     head foundTypes,
                     showDocs <$> docs
                   ]

From d30b8f93336b4e9f8e37723bc5bb48c2f0594ccd Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 30 Oct 2024 13:53:25 +0100
Subject: [PATCH 212/297] clean up

---
 src/Language/PureScript/Lsp/AtPosition.hs     |  21 +-
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 229 ++----------------
 2 files changed, 22 insertions(+), 228 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 50a7eeac1f..107e7e364e 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -1,16 +1,8 @@
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# OPTIONS_GHC -Wno-deprecations #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-
 module Language.PureScript.Lsp.AtPosition where
 
-import Control.Lens (At, Field1 (_1), Field2 (_2), Field3 (_3), un, view)
--- import Language.PureScript.Lsp.Monad (m)
-
-import Data.List qualified as List
+import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view)
 import Data.Text qualified as T
-import GHC.IO (unsafePerformIO)
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server (MonadLsp)
 import Language.PureScript qualified as P
@@ -20,8 +12,7 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (LspEnvironment, OpenFile (..))
-import Language.PureScript.Lsp.Util (declsAtLine, getDeclarationAtPos, onDeclsAtLine, posInSpan, sourcePosToPosition)
-import Language.PureScript.Traversals (defS)
+import Language.PureScript.Lsp.Util (declsAtLine, onDeclsAtLine, posInSpan, sourcePosToPosition)
 import Language.PureScript.Types (getAnnForType)
 import Protolude
 import Safe qualified
@@ -200,14 +191,6 @@ addDeclValuesAtPos pos = \case
         P.DerivedInstancePlaceholder {} -> True
         _ -> False
 
-traceToErr :: Text -> b -> b
-traceToErr a b = trace a b
-
-traceWith :: Text -> (b -> Text) -> b -> b
-traceWith label f a = traceToErr (label <> ": " <> f a) a
-
-traceShow' :: (Show b) => Text -> b -> b
-traceShow' l = traceWith l show
 
 addDecl :: P.Declaration -> EverythingAtPos -> EverythingAtPos
 addDecl decl atPos = atPos {apDecls = decl : apDecls atPos}
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 817d66a0df..e61ea2c9e6 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -2,40 +2,28 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-deprecations #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-local-binds #-}
-{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 
-module Language.PureScript.Lsp.Handlers.Hover where
+module Language.PureScript.Lsp.Handlers.Hover (hoverHandler) where
 
 import Control.Arrow ((>>>))
-import Control.Exception.Lifted (catch, handle)
-import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), (^.))
+import Control.Lens (Field2 (_2), Field3 (_3), (^.))
 import Control.Lens.Combinators (view)
-import Control.Monad.Supply (runSupplyT)
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
-import Control.Monad.Writer (MonadWriter (..), censor)
-import Data.List (last)
-import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
-import Language.PureScript (evalSupplyT)
 import Language.PureScript qualified as P
-import Language.PureScript.AST.Binders (Binder (..))
 import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
-import Language.PureScript.Environment (tyBoolean, tyChar, tyInt, tyNumber, tyString)
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, debugExpr, getChildExprs, getEverythingAtPos, getImportRefNameType, getTypeLinesAndColumns, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestType, spanSize, spanToRange, smallestExpr, smallestExpr')
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestType, spanToRange, smallestExpr')
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsAsMarkdown, readDeclarationDocsWithNameType, readModuleDocs)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
@@ -44,14 +32,7 @@ import Language.PureScript.Lsp.Rebuild (buildExportEnvCacheAndHandleErrors)
 import Language.PureScript.Lsp.ServerConfig (getInferExpressions)
 import Language.PureScript.Lsp.State (cachedRebuild, getExportEnv)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), OpenFile (..))
-import Language.PureScript.Lsp.Util (declsAtLine, posInSpan, sourcePosToPosition)
-import Language.PureScript.Names (disqualify)
-import Language.PureScript.TypeChecker (getEnv)
-import Language.PureScript.TypeChecker.Types (infer')
-import Language.PureScript.TypeChecker.Unify (unifyTypes)
 import Protolude hiding (handle, to)
-import Safe qualified
-import Text.Blaze.Html5 (mark)
 import Text.PrettyPrint.Boxes (render)
 import Language.PureScript.Sugar.Names.Env qualified as P
 
@@ -81,30 +62,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               showDocs <$> docs
             ]
 
-      respondWithDeclInModuleWithUnkownNameType :: P.SourceSpan -> P.ModuleName -> Text -> HandlerM ()
-      respondWithDeclInModuleWithUnkownNameType ss modName ident = do
-        docs <- readDeclarationDocsAsMarkdown modName ident
-        foundTypes <- getAstDeclarationTypeInModule Nothing modName ident
-        debugLsp $ "respondWithDeclInModuleWithUnkownNameType " <> show (modName, ident)
-        debugLsp $ "Found types: " <> show foundTypes
-        debugLsp $ "Found docs: " <> show (isJust docs)
-        markdownRes (Just $ spanToRange ss) $
-          joinMarkup
-            [ showTypeSection modName ident <$> head foundTypes,
-              showDocs <$> docs
-            ]
-
-      respondWithTypedExpr :: Maybe P.SourceSpan -> P.Expr -> P.SourceType -> HandlerM ()
-      respondWithTypedExpr ss expr tipe = do
-        void $
-          expr & onChildExprs \e -> do
-            pure e
-        let printedType = prettyPrintTypeSingleLine tipe
-            printedExpr = case expr of
-              P.Op _ (P.Qualified _ op) -> P.runOpName op -- pretty printing ops ends in infinite loop
-              _ -> dispayExprOnHover expr
-        markdownRes (spanToRange <$> ss) (pursTypeStr printedExpr (Just printedType) [])
-
       respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
       respondWithModule ss modName = do
         docsMb <- readModuleDocs modName
@@ -200,7 +157,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                       debugLsp $ "Found type op: " <> show name
                       respondWithDeclInModule (fst ann) TyOpNameType mName (P.runOpName name)
                     _ -> do
-                      debugLsp $ "Smallest type printed: " <> show (fmap prettyPrintTypeSingleLine $ smallestType $ apTypes everything) 
                       debugLsp "Looking for unsugared types"
                       let typesBeforeSugaring = apTypes $ getEverythingAtPos (P.getModuleDeclarations ofUncheckedModule) startPos
                       case smallestType typesBeforeSugaring of
@@ -211,7 +167,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 
                           case ty of
                             P.TypeConstructor ann q@(P.Qualified _ name) | P.runProperName name /= "Type" -> do
-                              debugLsp $ "Found type constructor: " <> show (q, name)
                               let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypes imports)
                               respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
                             P.ConstrainedType ann (P.Constraint _ q@(P.Qualified _ ident) _ _ _) _ -> do
@@ -241,117 +196,6 @@ isLiteralNode = \case
 joinMarkup :: [Maybe Text] -> Text
 joinMarkup = T.intercalate "\n---\n" . catMaybes
 
--- cacheOpenMb <- cachedRebuild filePath
-
--- forLsp cacheOpenMb \OpenFile {..} -> do
---   let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
---   case head (apExprs everything) of
---     Just (ss, _, e) -> do
---       inferredRes <-  filePath e
---       case inferredRes of
---         Right ty -> respondWithTypedExpr ss e ty
---         Left err -> do
---           debugLsp $ "Error: " <> show err
---           nullRes
---     _ -> nullRes
-
--- let handlePos :: Types.Position -> HandlerM ()
---     handlePos pos = do
---       let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) pos
---       debugLsp $ "pos: " <> show pos
-
---       case apImport everything of
--- Just (ss, importedModuleName, _, ref) -> do
---   debugLsp $ "Import: " <> show importedModuleName
---   respondWithImport ss importedModuleName ref
--- _ -> do
---           let exprs = apExprs everything
---               handleExpr exprT = do
---                 case expr of
---                   (ss, _, P.Var _ (P.Qualified (P.ByModuleName modName) ident)) -> do
---                     debugLsp $ "Var: " <> show ident
---                     respondWithDeclInModule ss IdentNameType modName (P.runIdent ident)
---                     pure False
---                   (ss, _, P.Op _ (P.Qualified (P.ByModuleName modName) ident)) -> do
---                     debugLsp $ "Op: " <> show ident
---                     respondWithDeclInModule ss ValOpNameType modName (P.runOpName ident)
---                     pure False
---                   (ss, _, P.Constructor _ (P.Qualified (P.ByModuleName modName) ident)) -> do
---                     debugLsp $ "Dctor: " <> show ident
---                     respondWithDeclInModule ss DctorNameType modName (P.runProperName ident)
---                     pure False
---                   (ss, _, P.TypedValue _ tExpr ty) | not (generatedExpr tExpr) -> do
---                     respondWithTypedExpr ss tExpr ty
---                     pure False
---                   (ss, _, P.Literal _ lit) -> do
---                     handleLiteral ss lit
---                   _ -> pure True
-
---           debugLsp $ "exprs found: " <> show (length exprs)
---           noExprFound <- allM handleExpr exprs
-
---           debugLsp $ "No expr found: " <> show noExprFound
---           when noExprFound do
---             debugLsp $ showCounts everything
---             let decls = apDecls everything & sortDeclsBySize
---             void $
---               apDecls everything & allM \case
---                 P.BoundValueDeclaration sa _binder expr -> do
---                   debugLsp "BoundValueDeclaration"
---                   let ss = fst sa
---                       children = getChildExprs expr
---                   children & allM \e -> handleExpr (ss, True, e)
---                 P.BindingGroupDeclaration bindingGroup -> do
---                   debugLsp "BindingGroupDeclaration"
---                   NE.toList bindingGroup & allM \((sa, _), _, expr) ->
---                     getChildExprs expr & allM \child -> handleExpr (fst sa, True, child)
---                 decl@(P.ValueDeclaration vd) -> do
---                   debugLsp $ "ValueDeclaration IDENT: " <> P.runIdent (P.valdeclIdent vd)
---                   debugLsp $ "ValueDeclaration: " <> show vd
---                   let ss = P.declSourceSpan decl
---                       guaredExprs = P.valdeclExpression vd
---                       children = guaredExprs >>= getChildExprs . (\(P.GuardedExpr _ e) -> e)
---                   children & allM \expr ->
---                     handleExpr (ss, True, expr)
---                 decl -> do
---                   debugLsp $ "Decl: " <> ellipsis 100 (show decl)
---                   pure False
--- handlePos startPos
-
--- inferBinder :: P.SourceType -> P.Binder -> m (Map P.Ident (P.SourceSpan, P.SourceType))
--- inferBinder _ NullBinder = return M.empty
--- inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty
--- inferBinder val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
--- inferBinder val (LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty
--- inferBinder val (LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty
--- inferBinder val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty
--- inferBinder val (VarBinder ss name) = return $ M.singleton name (ss, val)
--- inferBinder val (ConstructorBinder ss ctor binders) = do
---   env <- getEnv
---   case M.lookup ctor (P.dataConstructors env) of
---     Just (_, _, ty, _) -> do
---       let (args, ret) = peelArgs ty
---           expected = length args
---           actual = length binders
---       unifyTypes ret val
---       M.unions <$> zipWithM inferBinder (reverse args) binders
---     _ -> throwError . P.errorMessage' ss . P.UnknownName . fmap P.DctorName $ ctor
---   where
---     peelArgs :: P.Type a -> ([P.Type a], P.Type a)
---     peelArgs = go []
---       where
---         go args (P.TypeApp _ (P.TypeApp _ fn arg) ret) | P.eqType fn P.tyFunction = go (arg : args) ret
---         go args ret = (args, ret)
--- inferBinder _ _ = throwError "Not implemented"
-
-getResErrors :: Either P.MultipleErrors (a, P.MultipleErrors) -> P.MultipleErrors
-getResErrors = either identity snd
-
-getHoverSourceTypeFromErrs :: Either P.MultipleErrors (P.Declaration, P.MultipleErrors) -> Maybe P.SourceType
-getHoverSourceTypeFromErrs = \case
-  Left (P.MultipleErrors errs) -> findMap getHoverHoleType errs
-  Right (_, P.MultipleErrors errs) -> findMap getHoverHoleType errs
-
 inferExprViaTypeHoleText :: FilePath -> Types.Position -> HandlerM (Maybe Text)
 inferExprViaTypeHoleText filePath pos =
   inferExprViaTypeHole filePath pos <&> fmap \(expr, t) ->
@@ -360,10 +204,6 @@ inferExprViaTypeHoleText filePath pos =
 inferExprViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Expr, P.SourceType))
 inferExprViaTypeHole = inferViaTypeHole (modifySmallestExprAtPos addExprTypeHoleAnnotation)
 
-inferBinderViaTypeHoleText :: FilePath -> Types.Position -> HandlerM (Maybe Text)
-inferBinderViaTypeHoleText filePath pos =
-  inferBinderViaTypeHole filePath pos <&> fmap \(binder, t) ->
-    pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine t) []
 
 inferBinderViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Binder, P.SourceType))
 inferBinderViaTypeHole = inferViaTypeHole (modifySmallestBinderAtPos addBinderTypeHoleAnnotation)
@@ -377,8 +217,8 @@ inferViaTypeHole ::
   Types.Position ->
   HandlerM (Maybe (a, P.SourceType))
 inferViaTypeHole addHole filePath pos = do
-  shouldInfer <- getInferExpressions
-  if not shouldInfer
+  shouldInferUsingTypeHole <- getInferExpressions
+  if not shouldInferUsingTypeHole
     then pure Nothing
     else do
       cacheOpenMb <- cachedRebuild filePath
@@ -421,18 +261,6 @@ addBinderTypeHoleAnnotation b = P.ParensInBinder (P.TypedBinder (P.TypeWildcard
 hoverHoleLabel :: Text
 hoverHoleLabel = "HOVER"
 
-onDeclExprs :: (Monad m) => (P.Expr -> m P.Expr) -> P.Declaration -> m P.Declaration
-onDeclExprs fn = view _1 $ P.everywhereOnValuesTopDownM pure fn pure
-
-onChildExprs :: (Monad m) => (P.Expr -> m P.Expr) -> P.Expr -> m P.Expr
-onChildExprs fn = view _2 $ P.everywhereOnValuesTopDownM pure fn pure
-
-allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
-allM _ [] = pure True
-allM f (x : xs) = do
-  b <- f x
-  if b then allM f xs else pure False
-
 isAbs :: P.Expr -> Bool
 isAbs = \case
   P.Abs _ _ -> True
@@ -449,18 +277,6 @@ generatedExpr = \case
   P.Case es _ -> any generatedExpr es
   _ -> False
 
-sortDeclsBySize :: [P.Declaration] -> [P.Declaration]
-sortDeclsBySize = sortBy (compare `on` (spanSize . P.declSourceSpan))
-
-traceToErr :: Text -> b -> b
-traceToErr a b = trace a b
-
-traceWith :: Text -> (b -> Text) -> b -> b
-traceWith label f a = traceToErr (label <> ": " <> f a) a
-
-traceShow' :: (Show b) => Text -> b -> b
-traceShow' l = traceWith l show
-
 generatedBinder :: P.Binder -> Bool
 generatedBinder = \case
   P.VarBinder ss ident -> (ss == P.nullSourceSpan) || generatedIdent ident
@@ -472,11 +288,6 @@ generatedIdent = \case
   P.GenIdent {} -> True
   _ -> False
 
-findTypedExpr :: [(P.SourceSpan, Bool, P.Expr)] -> Maybe (P.SourceSpan, P.Expr, P.SourceType)
-findTypedExpr ((ss, _, P.TypedValue _ e t) : _) = Just (ss, e, t)
-findTypedExpr (_ : es) = findTypedExpr es
-findTypedExpr [] = Nothing
-
 dispayExprOnHover :: P.Expr -> T.Text
 dispayExprOnHover (P.Op _ (P.Qualified _ op)) = P.runOpName op -- Op's hit an infinite loop when pretty printed by themselves
 dispayExprOnHover (P.Case _ _) = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
@@ -513,17 +324,17 @@ data InferError
   | InferException Text
   deriving (Show, Exception)
 
-inferExprType :: FilePath -> P.Expr -> HandlerM (Either InferError P.SourceType)
-inferExprType filePath expr = do
-  cacheOpenMb <- cachedRebuild filePath
-  case cacheOpenMb of
-    Nothing -> pure $ Left FileNotCached
-    Just OpenFile {..} -> do
-      inferRes <- runWriterT $ runExceptT $ evalSupplyT 0 $ evalStateT (infer' expr) ((P.emptyCheckState ofStartingEnv) {P.checkCurrentModule = Just ofModuleName})
-      pure $ bimap CompilationError (\(P.TypedValue' _ _ t) -> t) $ fst inferRes
-
-inferExprType' :: FilePath -> P.Expr -> HandlerM P.SourceType
-inferExprType' fp =
-  inferExprType fp >=> \case
-    Right t -> pure t
-    Left e -> throwIO e
+-- inferExprType :: FilePath -> P.Expr -> HandlerM (Either InferError P.SourceType)
+-- inferExprType filePath expr = do
+--   cacheOpenMb <- cachedRebuild filePath
+--   case cacheOpenMb of
+--     Nothing -> pure $ Left FileNotCached
+--     Just OpenFile {..} -> do
+--       inferRes <- runWriterT $ runExceptT $ evalSupplyT 0 $ evalStateT (infer' expr) ((P.emptyCheckState ofStartingEnv) {P.checkCurrentModule = Just ofModuleName})
+--       pure $ bimap CompilationError (\(P.TypedValue' _ _ t) -> t) $ fst inferRes
+
+-- inferExprType' :: FilePath -> P.Expr -> HandlerM P.SourceType
+-- inferExprType' fp =
+--   inferExprType fp >=> \case
+--     Right t -> pure t
+--     Left e -> throwIO e

From 0d2d49de6c78446533860fe9b9fc505715a0b98c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 31 Oct 2024 09:51:20 +0100
Subject: [PATCH 213/297] go back to type hole inference

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 19 +++--
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 73 ++++++++++++++++++-
 2 files changed, 82 insertions(+), 10 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index 107e7e364e..abb4524fae 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+
 module Language.PureScript.Lsp.AtPosition where
 
 import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view)
@@ -49,7 +50,7 @@ instance Semigroup EverythingAtPos where
 
 instance Monoid EverythingAtPos where
   mempty = nullEverythingAtPos
-  
+
 showCounts :: EverythingAtPos -> Text
 showCounts EverythingAtPos {..} =
   "decls: "
@@ -191,7 +192,6 @@ addDeclValuesAtPos pos = \case
         P.DerivedInstancePlaceholder {} -> True
         _ -> False
 
-
 addDecl :: P.Declaration -> EverythingAtPos -> EverythingAtPos
 addDecl decl atPos = atPos {apDecls = decl : apDecls atPos}
 
@@ -338,8 +338,7 @@ smallestExpr :: [P.Expr] -> Maybe P.Expr
 smallestExpr = smallestExpr' identity
 
 smallestExpr' :: (a -> P.Expr) -> [a] -> Maybe a
-smallestExpr' f = Safe.minimumByMay (comparing (fromMaybe (maxInt, maxInt) . (getExprLinesAndColumns . f))) 
-
+smallestExpr' f = Safe.minimumByMay (comparing (fromMaybe (maxInt, maxInt) . (getExprLinesAndColumns . f)))
 
 getExprLinesAndColumns :: P.Expr -> Maybe (Int, Int)
 getExprLinesAndColumns expr =
@@ -406,10 +405,18 @@ getExprsAtPos pos declaration = execState (goDecl declaration) []
       pure expr
 
 modifySmallestExprAtPos :: (P.Expr -> P.Expr) -> Types.Position -> P.Module -> (P.Module, Maybe (P.Expr, P.Expr))
-modifySmallestExprAtPos fn pos@(Types.Position {..}) (P.Module ss c mName decls refs) =
+modifySmallestExprAtPos fn pos m@(P.Module ss c mName _ refs) =
   (P.Module ss c mName (fmap fst declsAndExpr) refs, asum $ snd <$> declsAndExpr)
   where
-    declsAndExpr = onDeclsAtLine (pure . modifySmallestDeclExprAtPos fn pos) (\d -> [(d, Nothing)]) (fromIntegral _line + 1) decls
+    declsAndExpr = modifySmallestExprAtPosWithDecl fn pos m
+
+modifySmallestExprAtPosWithDecl :: (P.Expr -> P.Expr) -> Types.Position -> P.Module -> [(P.Declaration, Maybe (P.Expr, P.Expr))]
+modifySmallestExprAtPosWithDecl fn pos@(Types.Position {..}) (P.Module _ _ _ decls _) =
+  onDeclsAtLine (pure . modifySmallestDeclExprAtPos fn pos) (\d -> [(d, Nothing)]) (fromIntegral _line + 1) decls
+
+modifySmallestExprDropOthers :: (P.Expr -> P.Expr) -> Types.Position -> P.Module -> Maybe (P.Declaration, Maybe (P.Expr, P.Expr))
+modifySmallestExprDropOthers fn pos@(Types.Position {..}) (P.Module _ _ _ decls _) =
+  find (isJust . snd) $ onDeclsAtLine (pure . modifySmallestDeclExprAtPos fn pos) (const []) (fromIntegral _line + 1) decls
 
 modifySmallestDeclExprAtPos :: (P.Expr -> P.Expr) -> Types.Position -> P.Declaration -> (P.Declaration, Maybe (P.Expr, P.Expr))
 modifySmallestDeclExprAtPos fn pos declaration = runState (onDecl declaration) Nothing
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index e61ea2c9e6..2e119b0d0c 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -20,7 +20,7 @@ import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestType, spanToRange, smallestExpr')
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, showCounts, smallestExpr', smallestType, spanToRange, modifySmallestExprAtPos)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
@@ -32,9 +32,9 @@ import Language.PureScript.Lsp.Rebuild (buildExportEnvCacheAndHandleErrors)
 import Language.PureScript.Lsp.ServerConfig (getInferExpressions)
 import Language.PureScript.Lsp.State (cachedRebuild, getExportEnv)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), OpenFile (..))
+import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (handle, to)
 import Text.PrettyPrint.Boxes (render)
-import Language.PureScript.Sugar.Names.Env qualified as P
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
@@ -162,8 +162,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                       case smallestType typesBeforeSugaring of
                         Just ty -> do
                           exportEnv <- getExportEnv
-                          let 
-                            imports = maybe P.nullImports (view _2) $ M.lookup ofModuleName exportEnv 
+                          let imports = maybe P.nullImports (view _2) $ M.lookup ofModuleName exportEnv
 
                           case ty of
                             P.TypeConstructor ann q@(P.Qualified _ name) | P.runProperName name /= "Type" -> do
@@ -240,6 +239,72 @@ inferViaTypeHole addHole filePath pos = do
                 pure $
                   (valueBefore,) <$> findHoleType (warnings <> errs)
 
+-- inferOnDeclViaTypeHole ::
+--   ( Types.Position ->
+--     P.Module ->
+--     Maybe (P.Declaration, Maybe (a, a))
+--   ) ->
+--   FilePath ->
+--   Types.Position ->
+--   HandlerM (Maybe (a, P.SourceType))
+-- inferOnDeclViaTypeHole addHole filePath pos = do
+--   shouldInferUsingTypeHole <- getInferExpressions
+--   if not shouldInferUsingTypeHole
+--     then pure Nothing
+--     else do
+--       cacheOpenMb <- cachedRebuild filePath
+--       cacheOpenMb & maybe (pure Nothing) \OpenFile {..} -> do
+--         let module' = P.importPrim ofUncheckedModule
+--             withHole = addHole pos module'
+--         case withHole of
+--           Just (declWithHole, Just (valueBefore, _valueAfter)) -> do
+--             let externs = fmap edExtern ofDependencies
+--             (exEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
+--             (checkRes, warnings) <-
+--               runWriterT $
+--                 runExceptT $
+--                   evalSupplyT 0 $
+--                     evalStateT
+--                       (typeCheckDecl (view _3 <$> exEnv) ofModuleName (P.getModuleDeclarations module') declWithHole)
+--                       ((P.emptyCheckState $ removeDeclFromEnv ofModuleName declWithHole ofEndEnv) {P.checkCurrentModule = Just ofModuleName})
+
+--             case checkRes of
+--               Right _ -> do
+--                 debugLsp "Decl hole error not found"
+--                 pure $ (valueBefore,) <$> findHoleType warnings
+--               Left errs -> do
+--                 debugLsp $ "Errors: \n" <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions errs)
+--                 pure $
+--                   (valueBefore,) <$> findHoleType (warnings <> errs)
+--           _ -> do
+--             warnLsp "Decl with hole not found"
+--             pure Nothing
+--   where
+--     typeCheckDecl modulesExports mn decls decl = do
+--       let (_, imports) = partitionEithers $ fromImportDecl modulesExports <$> decls
+--       modify (\s -> s {P.checkCurrentModule = Just mn, P.checkCurrentModuleImports = imports})
+--       P.typeCheckAll mn [ignoreWildcardsUnderCompleteTypeSignatures decl]
+
+--     fromImportDecl ::
+--       M.Map P.ModuleName P.Exports ->
+--       P.Declaration ->
+--       Either
+--         P.Declaration
+--         ( P.SourceAnn,
+--           P.ModuleName,
+--           P.ImportDeclarationType,
+--           Maybe P.ModuleName,
+--           M.Map (P.ProperName 'P.TypeName) ([P.ProperName 'P.ConstructorName], P.ExportSource)
+--         )
+--     fromImportDecl modulesExports (P.ImportDeclaration sa moduleName' importDeclarationType asModuleName) =
+--       Right (sa, moduleName', importDeclarationType, asModuleName, foldMap P.exportedTypes $ M.lookup moduleName' modulesExports)
+--     fromImportDecl _ decl = Left decl
+
+-- removeDeclFromEnv :: P.ModuleName -> P.Declaration -> P.Environment -> P.Environment
+-- removeDeclFromEnv mName decl env = case decl of
+--   P.ValueDecl _ ident _ _ _ -> env {E.names = M.delete (P.Qualified (P.ByModuleName mName) ident) (E.names env)}
+--   _ -> env
+
 findHoleType :: P.MultipleErrors -> Maybe P.SourceType
 findHoleType = P.runMultipleErrors >>> findMap getHoverHoleType
 

From 9c07400a5c035f01b224980e71f457301044a664 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 31 Oct 2024 11:16:13 +0100
Subject: [PATCH 214/297] adds check state to cache

---
 src/Language/PureScript/Lsp/Rebuild.hs  |  5 +++--
 src/Language/PureScript/Lsp/State.hs    | 13 +++++++------
 src/Language/PureScript/Lsp/Types.hs    |  3 ++-
 src/Language/PureScript/Make.hs         | 12 +++++++-----
 src/Language/PureScript/Make/Actions.hs |  5 +++--
 src/Language/PureScript/Make/Index.hs   |  3 +--
 6 files changed, 23 insertions(+), 18 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index ce8fb6bce9..b5b4ad462b 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -30,6 +30,7 @@ import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Language.PureScript.Sugar.Names qualified as P
 import Protolude hiding (moduleName, race, race_, threadDelay)
+import Language.PureScript.TypeChecker qualified as P
 
 rebuildFile ::
   forall m.
@@ -78,7 +79,7 @@ rebuildFromOpenFileCache ::
   P.Module ->
   OpenFile ->
   m RebuildResult
-rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName _ externDeps env _ _ _) = do
+rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName _ externDeps env _ _ _ _) = do
   outputDirectory <- outputPath <$> getConfig
   let externs = fmap edExtern externDeps
   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
@@ -218,5 +219,5 @@ broadcastProgress chan ma = do
 addRebuildCaching :: TVar LspState -> Int -> [ExternDependency] -> P.Module -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache deps unchecked ma =
   ma
-    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv endEnv unchecked astM) <* P.codegen ma prevEnv endEnv astM m docs ext
+    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv (P.checkEnv checkSt) checkSt unchecked astM) <* P.codegen ma prevEnv checkSt astM m docs ext
     }
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 461e040654..ebc05546ed 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -47,21 +47,22 @@ import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
+import Language.PureScript.TypeChecker qualified as P
 
 getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.Module -> P.Module -> m ()
-cacheRebuild ef deps prevEnv endEnv unchecked module' = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.CheckState -> P.Module -> P.Module -> m ()
+cacheRebuild ef deps prevEnv endEnv checkSt unchecked module' = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
-  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv endEnv unchecked module'
+  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv endEnv checkSt unchecked module'
 
-cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.Module -> P.Module -> IO ()
-cacheRebuild' st maxFiles ef deps prevEnv endEnv unchecked module' = atomically . modifyTVar st $ \x ->
+cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.CheckState -> P.Module -> P.Module -> IO ()
+cacheRebuild' st maxFiles ef deps prevEnv endEnv checkSt unchecked module' = atomically . modifyTVar st $ \x ->
   x
-    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv endEnv unchecked module') : filter ((/= fp) . fst) (openFiles x)
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv endEnv checkSt unchecked module') : filter ((/= fp) . fst) (openFiles x)
     }
   where
     fp = P.spanName $ efSourceSpan ef
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 4278852e56..bd1c9ff048 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -19,6 +19,7 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Lsp.LogLevel (LspLogLevel)
 import Codec.Serialise (deserialise, serialise)
 import Language.PureScript.Lsp.NameType (LspNameType)
+import Language.PureScript.TypeChecker qualified as P
 
 data LspEnvironment = LspEnvironment
   { lspDbConnectionVar :: TVar (FilePath, Connection),
@@ -56,10 +57,10 @@ data OpenFile = OpenFile
     ofDependencies :: [ExternDependency],
     ofStartingEnv :: P.Environment,
     ofEndEnv :: P.Environment,
+    ofEndCheckState :: P.CheckState,
     ofUncheckedModule :: P.Module,
     ofModule ::  P.Module
   }
-  deriving (Show)
 
   
 data ExternDependency = ExternDependency
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 48025fbc98..f4e12082ef 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -56,6 +56,7 @@ import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCh
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 import Prelude
+import Language.PureScript.TypeChecker qualified as P
 
 -- | Rebuild a single module.
 --
@@ -109,7 +110,8 @@ rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(M
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
-  ((Module ss coms _ elaborated exps, env'), nextVar) <- desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env
+  ((Module ss coms _ elaborated exps, checkSt), nextVar) <- desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env
+  let env' = P.checkEnv checkSt
 
   -- desugar case declarations *after* type- and exhaustiveness checking
   -- since pattern guards introduces cases which the exhaustiveness checker
@@ -141,7 +143,7 @@ rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(M
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env env' mod' renamed docs exts
+  evalSupplyT nextVar'' $ codegen env checkSt mod' renamed docs exts
   return exts
 
 desugarAndTypeCheck ::
@@ -152,12 +154,12 @@ desugarAndTypeCheck ::
   Module ->
   Env ->
   Environment ->
-  m ((Module, Environment), Integer)
+  m ((Module, CheckState), Integer)
 desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env = runSupplyT 0 $ do
   (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
   for_ onDesugared $ lift . \f -> f desugared
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-  (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+  (checked, checkSt@(CheckState {..})) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
   let usedImports' =
         foldl'
           ( flip $ \(fromModuleName, newtypeCtorName) ->
@@ -169,7 +171,7 @@ desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env = runSuppl
   -- known which newtype constructors are used to solve Coercible
   -- constraints in order to not report them as unused.
   censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
-  return (checked, checkEnv)
+  return (checked, checkSt)
 
 -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
 -- but I have not done so for two reasons:
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index f8368f29b3..c2914d21fa 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -59,6 +59,7 @@ import System.FilePath (makeRelative, normalise, splitDirectories, splitPath, (<
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr)
 import Prelude
+import Language.PureScript.TypeChecker (CheckState)
 
 -- | Determines when to rebuild a module
 data RebuildPolicy
@@ -114,7 +115,7 @@ data MakeActions m = MakeActions
     -- path for the file.
     readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile),
     -- | Run the code generator for the module and write any required output files.
-    codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m (),
+    codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m (),
     -- | Check ffi and print it in the output directory.
     ffiCodegen :: CF.Module CF.Ann -> m (),
     -- | Respond to a progress update.
@@ -247,7 +248,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
       when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module {..} ->
         writeJSONFile (outputFilename modName "docs.json") docsMod
 
-    codegen :: Environment -> Environment -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
+    codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
     codegen _prevEnv _endEnv _m m docs exts = do
       let mn = CF.moduleName m
       lift $ writeCborFile (outputFilename mn externsFileName) exts
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 6c836aedff..b3c508a49f 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE PackageImports #-}
 
 module Language.PureScript.Make.Index where
 
@@ -29,7 +28,7 @@ addAllIndexing conn ma =
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (indexAstModule conn endEnv astM ext (getExportedNames ext)) <* P.codegen ma prevEnv endEnv astM m docs ext
+    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (indexAstModule conn (P.checkEnv checkSt) astM ext (getExportedNames ext)) <* P.codegen ma prevEnv checkSt astM m docs ext
     }
 
 indexAstModule :: (MonadIO m) => Connection -> Environment -> P.Module -> ExternsFile -> Set P.Name -> m ()

From 355c0f9a11ee2562f4165bb4799201cd59e7d4e9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 1 Nov 2024 18:33:51 +0100
Subject: [PATCH 215/297] adds IdeArtifacts

---
 purescript.cabal                              |   1 +
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 163 +++++++++++------
 src/Language/PureScript/Lsp/Rebuild.hs        |  19 +-
 src/Language/PureScript/Make.hs               |  81 +-------
 src/Language/PureScript/TypeChecker.hs        |  14 +-
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 173 ++++++++++++++++++
 src/Language/PureScript/TypeChecker/Kinds.hs  |  23 ++-
 src/Language/PureScript/TypeChecker/Monad.hs  |  42 ++++-
 src/Language/PureScript/TypeChecker/Types.hs  |  92 +++++++---
 9 files changed, 438 insertions(+), 170 deletions(-)
 create mode 100644 src/Language/PureScript/TypeChecker/IdeArtifacts.hs

diff --git a/purescript.cabal b/purescript.cabal
index 638ec41e1a..3a1433612e 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -416,6 +416,7 @@ library
     Language.PureScript.TypeChecker.Entailment
     Language.PureScript.TypeChecker.Entailment.Coercible
     Language.PureScript.TypeChecker.Entailment.IntCompare
+    Language.PureScript.TypeChecker.IdeArtifacts
     Language.PureScript.TypeChecker.Kinds
     Language.PureScript.TypeChecker.Monad
     Language.PureScript.TypeChecker.Roles
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 2e119b0d0c..759b7566ed 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -20,7 +20,7 @@ import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, showCounts, smallestExpr', smallestType, spanToRange, modifySmallestExprAtPos)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestExpr', smallestType, spanToRange)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
@@ -32,7 +32,9 @@ import Language.PureScript.Lsp.Rebuild (buildExportEnvCacheAndHandleErrors)
 import Language.PureScript.Lsp.ServerConfig (getInferExpressions)
 import Language.PureScript.Lsp.State (cachedRebuild, getExportEnv)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), OpenFile (..))
+import Language.PureScript.Lsp.Util (positionToSourcePos)
 import Language.PureScript.Sugar.Names.Env qualified as P
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
 import Protolude hiding (handle, to)
 import Text.PrettyPrint.Boxes (render)
 
@@ -120,63 +122,113 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
     forLsp cacheOpenMb \OpenFile {..} -> do
       let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
           respondWithCounts = markdownRes Nothing $ showCounts everything
-      debugLsp $ showCounts everything
-      case head $ apImport everything of
-        Just (ss, importedModuleName, _, ref) -> do
-          respondWithImport ss importedModuleName ref
-        _ -> do
-          case smallestExpr' (view _3) $ filter (not . (isAbs <||> generatedExpr) . view _3) $ apExprs everything of
-            Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
-            Just (ss, _, foundExpr) -> do
-              inferredRes <- inferExprViaTypeHoleText filePath startPos
-              foundTypes <- lookupExprTypes foundExpr
-              docs <- lookupExprDocs foundExpr
-              markdownRes (Just $ spanToRange ss) $
+          atPos = getArtifactsAtPosition (positionToSourcePos startPos) (P.checkIdeArtifacts ofEndCheckState)
+      -- debugLsp $ showCounts everything
+      debugLsp $ "at pos len: " <> show (length atPos)
+      debugLsp $ "smallest: " <> (ellipsis 512 . show) (iaValue <$> smallestArtifact atPos)
+      case smallestArtifact atPos of
+        Just (IdeArtifact {..}) ->
+          case iaValue of
+            IaExpr expr -> do
+              let inferredRes = pursTypeStr (dispayExprOnHover expr) (Just $ prettyPrintTypeSingleLine iaType) []
+              foundTypes <- lookupExprTypes expr
+              docs <- lookupExprDocs expr
+              markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
-                  [ inferredRes <|> Just (dispayExprOnHover foundExpr),
+                  [ Just inferredRes,
                     head foundTypes,
                     showDocs <$> docs
                   ]
-            Nothing -> do
-              binderInferredRes <- inferBinderViaTypeHole filePath startPos
-              case binderInferredRes of
-                Just (binder, ty) -> do
-                  debugLsp $ "Found binder: " <> show binder
-                  markdownRes
-                    (spanToRange <$> binderSourceSpan binder)
-                    (pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine ty) [])
+            IaTypeName name -> do
+              let name' = P.runProperName name
+                  inferredRes = pursTypeStr name' (Just $ prettyPrintTypeSingleLine iaType) []
+                  modName = fromMaybe ofModuleName iaDefinitionModule
+              docs <- readDeclarationDocsWithNameType modName TyNameType name'
+              foundTypes <- getAstDeclarationTypeInModule (Just TyNameType) modName name'
+              markdownRes (Just $ spanToRange iaSpan) $
+                joinMarkup
+                  [ Just inferredRes,
+                    showTypeSection modName (P.runProperName name) <$> head foundTypes,
+                    showDocs <$> docs
+                  ]
+            IaClassName name -> do
+              let name' = P.runProperName name
+                  inferredRes = pursTypeStr name' (Just $ prettyPrintTypeSingleLine iaType) []
+                  modName = fromMaybe ofModuleName iaDefinitionModule
+              docs <- readDeclarationDocsWithNameType modName TyClassNameType name'
+              foundTypes <- getAstDeclarationTypeInModule (Just TyClassNameType) modName name'
+              markdownRes (Just $ spanToRange iaSpan) $
+                joinMarkup
+                  [ Just inferredRes,
+                    showTypeSection modName (P.runProperName name) <$> head foundTypes,
+                    showDocs <$> docs
+                  ]
+            IaIdent ident -> do
+              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr ident (Just $ prettyPrintTypeSingleLine iaType) []
+            IaBinder binder -> do
+              let inferredRes = pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine iaType) []
+              markdownRes (spanToRange <$> binderSourceSpan binder) inferredRes
+            IaDecl decl -> do
+              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (maybe "_" printName $ P.declName decl) (Just $ prettyPrintTypeSingleLine iaType) []
+            IaType ty -> do
+              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (prettyPrintTypeSingleLine ty) (Just $ prettyPrintTypeSingleLine iaType) []
+        _ ->
+          case head $ apImport everything of
+            Just (ss, importedModuleName, _, ref) -> do
+              respondWithImport ss importedModuleName ref
+            _ -> do
+              case smallestExpr' (view _3) $ filter (not . (isAbs <||> generatedExpr) . view _3) $ apExprs everything of
+                Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
+                Just (ss, _, foundExpr) -> do
+                  inferredRes <- inferExprViaTypeHoleText filePath startPos
+                  foundTypes <- lookupExprTypes foundExpr
+                  docs <- lookupExprDocs foundExpr
+                  markdownRes (Just $ spanToRange ss) $
+                    joinMarkup
+                      [ inferredRes <|> Just (dispayExprOnHover foundExpr),
+                        head foundTypes,
+                        showDocs <$> docs
+                      ]
                 Nothing -> do
-                  case smallestType $ apTypes everything of
-                    Just (P.ConstrainedType ann (P.Constraint _ (P.Qualified (P.ByModuleName mName) ident) _ _ _) _) -> do
-                      debugLsp $ "Found constrained type: " <> show ident
-                      respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
-                    Just (P.TypeConstructor ann (P.Qualified (P.ByModuleName mName) name)) | P.runProperName name /= "Type" -> do
-                      debugLsp $ "Found type constructor: " <> show name
-                      respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
-                    Just (P.TypeOp ann (P.Qualified (P.ByModuleName mName) name)) -> do
-                      debugLsp $ "Found type op: " <> show name
-                      respondWithDeclInModule (fst ann) TyOpNameType mName (P.runOpName name)
-                    _ -> do
-                      debugLsp "Looking for unsugared types"
-                      let typesBeforeSugaring = apTypes $ getEverythingAtPos (P.getModuleDeclarations ofUncheckedModule) startPos
-                      case smallestType typesBeforeSugaring of
-                        Just ty -> do
-                          exportEnv <- getExportEnv
-                          let imports = maybe P.nullImports (view _2) $ M.lookup ofModuleName exportEnv
-
-                          case ty of
-                            P.TypeConstructor ann q@(P.Qualified _ name) | P.runProperName name /= "Type" -> do
-                              let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypes imports)
-                              respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
-                            P.ConstrainedType ann (P.Constraint _ q@(P.Qualified _ ident) _ _ _) _ -> do
-                              let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypeClasses imports)
-                              respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
-                            _ -> do
-                              markdownRes
-                                (Just $ spanToRange $ fst $ P.getAnnForType ty)
-                                (pursTypeStr (prettyPrintTypeSingleLine ty) Nothing [])
-                        Nothing -> do
-                          respondWithCounts
+                  binderInferredRes <- inferBinderViaTypeHole filePath startPos
+                  case binderInferredRes of
+                    Just (binder, ty) -> do
+                      debugLsp $ "Found binder: " <> show binder
+                      markdownRes
+                        (spanToRange <$> binderSourceSpan binder)
+                        (pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine ty) [])
+                    Nothing -> do
+                      case smallestType $ apTypes everything of
+                        Just (P.ConstrainedType ann (P.Constraint _ (P.Qualified (P.ByModuleName mName) ident) _ _ _) _) -> do
+                          debugLsp $ "Found constrained type: " <> show ident
+                          respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
+                        Just (P.TypeConstructor ann (P.Qualified (P.ByModuleName mName) name)) | P.runProperName name /= "Type" -> do
+                          debugLsp $ "Found type constructor: " <> show name
+                          respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
+                        Just (P.TypeOp ann (P.Qualified (P.ByModuleName mName) name)) -> do
+                          debugLsp $ "Found type op: " <> show name
+                          respondWithDeclInModule (fst ann) TyOpNameType mName (P.runOpName name)
+                        _ -> do
+                          debugLsp "Looking for unsugared types"
+                          let typesBeforeSugaring = apTypes $ getEverythingAtPos (P.getModuleDeclarations ofUncheckedModule) startPos
+                          case smallestType typesBeforeSugaring of
+                            Just ty -> do
+                              exportEnv <- getExportEnv
+                              let imports = maybe P.nullImports (view _2) $ M.lookup ofModuleName exportEnv
+
+                              case ty of
+                                P.TypeConstructor ann q@(P.Qualified _ name) | P.runProperName name /= "Type" -> do
+                                  let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypes imports)
+                                  respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
+                                P.ConstrainedType ann (P.Constraint _ q@(P.Qualified _ ident) _ _ _) _ -> do
+                                  let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypeClasses imports)
+                                  respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
+                                _ -> do
+                                  markdownRes
+                                    (Just $ spanToRange $ fst $ P.getAnnForType ty)
+                                    (pursTypeStr (prettyPrintTypeSingleLine ty) Nothing [])
+                            Nothing -> do
+                              respondWithCounts
 
 showTypeSection :: P.ModuleName -> Text -> Text -> Text
 showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
@@ -203,7 +255,6 @@ inferExprViaTypeHoleText filePath pos =
 inferExprViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Expr, P.SourceType))
 inferExprViaTypeHole = inferViaTypeHole (modifySmallestExprAtPos addExprTypeHoleAnnotation)
 
-
 inferBinderViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Binder, P.SourceType))
 inferBinderViaTypeHole = inferViaTypeHole (modifySmallestBinderAtPos addBinderTypeHoleAnnotation)
 
@@ -232,7 +283,7 @@ inferViaTypeHole addHole filePath pos = do
             (checkRes, warnings) <-
               runWriterT $
                 runExceptT $
-                  P.desugarAndTypeCheck Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
+                  P.desugarAndTypeCheck P.emptyCheckState Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
             case checkRes of
               Right _ -> pure $ (valueBefore,) <$> findHoleType warnings
               Left errs -> do
@@ -356,7 +407,7 @@ generatedIdent = \case
 dispayExprOnHover :: P.Expr -> T.Text
 dispayExprOnHover (P.Op _ (P.Qualified _ op)) = P.runOpName op -- Op's hit an infinite loop when pretty printed by themselves
 dispayExprOnHover (P.Case _ _) = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
-dispayExprOnHover expr = ellipsis 32 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 2 expr
+dispayExprOnHover expr = ellipsis 64 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 4 expr
 
 dispayBinderOnHover :: P.Binder -> T.Text
 dispayBinderOnHover binder = ellipsis 32 $ on1Line $ T.strip $ P.prettyPrintBinder binder
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index b5b4ad462b..6655a799ff 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -31,6 +31,8 @@ import Language.PureScript.Options qualified as P
 import Language.PureScript.Sugar.Names qualified as P
 import Protolude hiding (moduleName, race, race_, threadDelay)
 import Language.PureScript.TypeChecker qualified as P
+import Language.PureScript.Environment qualified as P
+import Language.PureScript.Externs qualified as P
 
 rebuildFile ::
   forall m.
@@ -87,7 +89,7 @@ rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName
   for_ externsMb (cacheDependencies moduleName)
   res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-      newExtern <- P.rebuildModuleWithProvidedEnv (Just $ updateCachedModule' stVar) (mkMakeActions foreigns externDeps) exportEnv env externs m Nothing
+      newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState (Just $ updateCachedModule' stVar) (mkMakeActions foreigns externDeps) exportEnv env externs m Nothing
       updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
       pure newExtern
   case fst res of
@@ -99,6 +101,12 @@ rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName
       rebuildWithoutCache moduleName mkMakeActions fp pwarnings m
     _ -> handleRebuildResult fp pwarnings res
 
+ideCheckState :: P.Environment -> P.CheckState
+ideCheckState env =
+  (P.emptyCheckState env)
+    { P.checkAddIdeArtifacts = True
+    }
+
 rebuildWithoutCache ::
   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
   P.ModuleName ->
@@ -115,10 +123,17 @@ rebuildWithoutCache moduleName mkMakeActions fp pwarnings m = do
   exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
   res <- logPerfStandard "Rebuild Module" $ liftIO $ do
     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-      newExtern <- P.rebuildModule' (mkMakeActions foreigns externDeps) exportEnv externs m
+      newExtern <- rebuildModule' (mkMakeActions foreigns externDeps) exportEnv externs m
       updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
       pure newExtern
   handleRebuildResult fp pwarnings res
+  where 
+    rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
+
+    rebuildModuleWithIndex act exEnv externs m' moduleIndex = do
+      let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
+      P.rebuildModuleWithProvidedEnv ideCheckState Nothing act exEnv env externs m' moduleIndex
+
 
 handleRebuildResult :: (MonadLsp ServerConfig f, MonadReader LspEnvironment f) => FilePath -> [CST.ParserWarning] -> (Either P.MultipleErrors ExternsFile, P.MultipleErrors) -> f RebuildResult
 handleRebuildResult fp pwarnings (result, warnings) = do
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index f4e12082ef..5e47f18a84 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -53,10 +53,10 @@ import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName
 import Language.PureScript.Renamer (renameInModule)
 import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
+import Language.PureScript.TypeChecker qualified as P
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 import Prelude
-import Language.PureScript.TypeChecker qualified as P
 
 -- | Rebuild a single module.
 --
@@ -93,11 +93,12 @@ rebuildModuleWithIndex ::
   m ExternsFile
 rebuildModuleWithIndex act exEnv externs m moduleIndex = do
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
-  rebuildModuleWithProvidedEnv Nothing act exEnv env externs m moduleIndex
+  rebuildModuleWithProvidedEnv emptyCheckState Nothing act exEnv env externs m moduleIndex
 
 rebuildModuleWithProvidedEnv ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  (Environment -> CheckState) ->
   Maybe (Module -> m ()) ->
   MakeActions m ->
   Env ->
@@ -106,11 +107,11 @@ rebuildModuleWithProvidedEnv ::
   Module ->
   Maybe (Int, Int) ->
   m ExternsFile
-rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do
+rebuildModuleWithProvidedEnv initialCheckState onDesugared MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
-  ((Module ss coms _ elaborated exps, checkSt), nextVar) <- desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env
+  ((Module ss coms _ elaborated exps, checkSt), nextVar) <- desugarAndTypeCheck initialCheckState onDesugared moduleName externs withPrim exEnv env
   let env' = P.checkEnv checkSt
 
   -- desugar case declarations *after* type- and exhaustiveness checking
@@ -148,6 +149,7 @@ rebuildModuleWithProvidedEnv onDesugared MakeActions {..} exEnv env externs m@(M
 
 desugarAndTypeCheck ::
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m, Foldable t) =>
+  (Environment -> CheckState) ->
   t (Module -> m b) ->
   ModuleName ->
   [ExternsFile] ->
@@ -155,11 +157,11 @@ desugarAndTypeCheck ::
   Env ->
   Environment ->
   m ((Module, CheckState), Integer)
-desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env = runSupplyT 0 $ do
+desugarAndTypeCheck initialCheckState onDesugared moduleName externs withPrim exEnv env = runSupplyT 0 $ do
   (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
   for_ onDesugared $ lift . \f -> f desugared
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-  (checked, checkSt@(CheckState {..})) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+  (checked, checkSt@(CheckState {..})) <- runStateT (typeCheckModule modulesExports desugared) $ initialCheckState env
   let usedImports' =
         foldl'
           ( flip $ \(fromModuleName, newtypeCtorName) ->
@@ -173,73 +175,6 @@ desugarAndTypeCheck onDesugared moduleName externs withPrim exEnv env = runSuppl
   censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
   return (checked, checkSt)
 
--- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
--- but I have not done so for two reasons:
--- 1. This should never fail; any genuine errors in the code should have been
--- caught earlier in this function. Therefore if we
-
--- rebuildModuleUsingDbEnv ::
---   forall m.
---   (MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
---   MakeActions m ->
---   Module ->
---   m ExternsFile
--- rebuildModuleUsingDbEnv MakeActions {..} m@(Module _ _ moduleName _ _) = do
---   let withPrim = importPrim m
---   lint withPrim
---   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
-
---     desugared <- desugarLsp withPrim
---     -- (desugared, (exEnv', usedImports)) <- runStateT (desugarLsp externs withPrim) (exEnv, mempty)
-
---     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
---     (checked, CheckState {..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
---     let usedImports' =
---           foldl'
---             ( flip $ \(fromModuleName, newtypeCtorName) ->
---                 M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
---             )
---             usedImports
---             checkConstructorImportsForCoercible
---     -- Imports cannot be linted before type checking because we need to
---     -- known which newtype constructors are used to solve Coercible
---     -- constraints in order to not report them as unused.
---     censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
---     return (checked, checkEnv)
-
---   -- desugar case declarations *after* type- and exhaustiveness checking
---   -- since pattern guards introduces cases which the exhaustiveness checker
---   -- reports as not-exhaustive.
---   (deguarded, nextVar') <- runSupplyT nextVar $ do
---     desugarCaseGuards elaborated
-
---   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
---   let mod' = Module ss coms moduleName regrouped exps
---       corefn = CF.moduleToCoreFn env' mod'
---       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
---       (renamedIdents, renamed) = renameInModule optimized
---       exts = moduleToExternsFile mod' env' renamedIdents
---   ffiCodegen renamed
---   -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
---   -- but I have not done so for two reasons:
---   -- 1. This should never fail; any genuine errors in the code should have been
---   -- caught earlier in this function. Therefore if we do fail here it indicates
---   -- a bug in the compiler, which should be reported as such.
---   -- 2. We do not want to perform any extra work generating docs unless the
---   -- user has asked for docs to be generated.
---   let docs = undefined
---     -- case Docs.convertModule externs exEnv env' withPrim of
---     --     Left errs ->
---     --       internalError $
---     --         "Failed to produce docs for "
---     --           ++ T.unpack (runModuleName moduleName)
---     --           ++ "; details:\n"
---     --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
---     --     Right d -> d
-
---   evalSupplyT nextVar'' $ codegen env' mod' renamed docs exts
---   return exts
-
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
 --
 -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 479a01f012..a8e649c5ea 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -257,7 +257,7 @@ typeCheckAll
 typeCheckAll moduleName = traverse go
   where
   go :: Declaration -> m Declaration
-  go (DataDeclaration sa@(ss, _) dtype name args dctors) = do
+  go d@(DataDeclaration sa@(ss, _) dtype name args dctors) = do
     warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do
       when (dtype == Newtype) $ void $ checkNewtype name dctors
       checkDuplicateTypeArguments $ map fst args
@@ -267,6 +267,7 @@ typeCheckAll moduleName = traverse go
       dctors' <- traverse (replaceTypeSynonymsInDataConstructor . fst) dataCtors
       let args'' = args' `withRoles` inferRoles env moduleName name args' dctors'
       addDataType moduleName dtype name args'' dataCtors ctorKind
+      addIdeDecl d ctorKind
     return $ DataDeclaration sa dtype name args dctors
   go d@(DataBindingGroupDeclaration tys) = do
     let tysList = NEL.toList tys
@@ -283,6 +284,7 @@ typeCheckAll moduleName = traverse go
         checkDuplicateTypeArguments $ map fst args
         let args' = args `withKinds` kind
         addTypeSynonym moduleName name args' elabTy kind
+        addIdeType elabTy kind
       let dataDeclsWithKinds = zipWith (\(dtype, (_, name, args, _)) (dataCtors, ctorKind) ->
             (dtype, name, args `withKinds` ctorKind, dataCtors, ctorKind)) dataDecls data_ks
       inferRoles' <- fmap (inferDataBindingGroupRoles env moduleName roleDecls) .
@@ -293,6 +295,7 @@ typeCheckAll moduleName = traverse go
         checkDuplicateTypeArguments $ map fst args'
         let args'' = args' `withRoles` inferRoles' name args'
         addDataType moduleName dtype name args'' dataCtors ctorKind
+        -- addIdeTypeName (Just moduleName) _ name ctorKind
       for_ roleDecls $ checkRoleDeclaration moduleName
       for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do
         let qualifiedClassName = Qualified (ByModuleName moduleName) pn
@@ -309,12 +312,13 @@ typeCheckAll moduleName = traverse go
     toRoleDecl _ = Nothing
     toClassDecl (TypeClassDeclaration sa nm args implies deps decls) = Just (deps, (sa, nm, args, implies, decls))
     toClassDecl _ = Nothing
-  go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do
+  go d@(TypeSynonymDeclaration sa@(ss, _) name args ty) = do
     warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (positionedError ss) ) $ do
       checkDuplicateTypeArguments $ map fst args
       (elabTy, kind) <- kindOfTypeSynonym moduleName (sa, name, args, ty)
       let args' = args `withKinds` kind
       addTypeSynonym moduleName name args' elabTy kind
+      addIdeDecl d kind
     return $ TypeSynonymDeclaration sa name args ty
   go (KindDeclaration sa@(ss, _) kindFor name ty) = do
     warnAndRethrow (addHint (ErrorInKindDeclaration name) . addHint (positionedError ss)) $ do
@@ -327,7 +331,7 @@ typeCheckAll moduleName = traverse go
     return d
   go TypeDeclaration{} =
     internalError "Type declarations should have been removed before typeCheckAlld"
-  go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do
+  go d@(ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do
     env <- getEnv
     let declHint = if isPlainIdent name then addHint (ErrorInValueDeclaration name) else id
     warnAndRethrow (declHint . addHint (positionedError ss)) $ do
@@ -336,6 +340,7 @@ typeCheckAll moduleName = traverse go
       typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case
         [(_, (val'', ty))] -> do
           addValue moduleName name ty nameKind
+          addIdeDecl d ty
           return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
         _ -> internalError "typesOf did not return a singleton"
   go ValueDeclaration{} = internalError "Binders were not desugared"
@@ -351,8 +356,9 @@ typeCheckAll moduleName = traverse go
                      | (sai@(_, name), nameKind, _) <- vals'
                      , ((_, name'), (val, ty)) <- tys
                      , name == name'
-                     ] $ \(sai@(_, name), val, nameKind, ty) -> do
+                     ] $ \(sai@((ss, _), name), val, nameKind, ty) -> do
         addValue moduleName name ty nameKind
+        addIdeIdent ss name ty
         return (sai, nameKind, val)
       return . BindingGroupDeclaration $ NEL.fromList vals''
   go d@(ExternDataDeclaration (ss, _) name kind) = do
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
new file mode 100644
index 0000000000..5f046d9b35
--- /dev/null
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -0,0 +1,173 @@
+-- | Stores information about the source code that is useful for the IDE
+-- | This includes value types and source spans
+module Language.PureScript.TypeChecker.IdeArtifacts
+  ( IdeArtifacts,
+    IdeArtifact (..),
+    IdeArtifactValue (..),
+    getArtifactsAtPosition,
+    emptyIdeArtifacts,
+    insertIaExpr,
+    insertIaBinder,
+    insertIaDecl,
+    insertIaType,
+    insertIaIdent,
+    smallestArtifact,
+    debugIdeArtifacts,
+    insertIaTypeName,
+    insertIaClassName,
+    moduleNameFromQual,
+  )
+where
+
+-- import Language.PureScript qualified as P
+
+import Data.Map qualified as Map
+import Data.Text qualified as T
+import Language.PureScript.AST.Binders qualified as P
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.AST.SourcePos qualified as P
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Types qualified as P
+import Protolude
+import Safe (minimumByMay)
+
+data IdeArtifacts = IdeArtifacts (Map Line [IdeArtifact]) deriving (Show)
+
+type Line = Int
+
+emptyIdeArtifacts :: IdeArtifacts
+emptyIdeArtifacts = IdeArtifacts Map.empty
+
+debugIdeArtifacts :: IdeArtifacts -> Text
+debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts
+  where
+    showCount :: (Int, Int) -> Text
+    showCount (line, count) = show line <> ": " <> show count
+    lineCounts :: IdeArtifacts -> [(Int, Int)]
+    lineCounts (IdeArtifacts m) = Map.toList m <&> fmap length
+
+data IdeArtifact = IdeArtifact
+  { iaSpan :: P.SourceSpan,
+    iaValue :: IdeArtifactValue,
+    iaType :: P.SourceType,
+    iaDefinitionModule :: Maybe P.ModuleName,
+    iaDefinitionPos :: Maybe (Either P.SourcePos P.SourceSpan)
+  }
+  deriving (Show)
+
+data IdeArtifactValue
+  = IaExpr P.Expr
+  | IaDecl P.Declaration
+  | IaBinder P.Binder
+  | IaIdent Text
+  | IaType P.SourceType
+  | IaTypeName (P.ProperName 'P.TypeName)
+  | IaClassName (P.ProperName 'P.ClassName)
+  deriving (Show)
+
+-- valueCtr :: IdeArtifactValue -> Text
+-- valueCtr = \case
+--   IaExpr {} -> "Expr"
+--   IaDecl {} -> "Decl"
+--   IaBinder {} -> "Binder"
+--   IaIdent {} -> "BinderIdent"
+--   IaType {} -> "Type"
+
+smallestArtifact :: [IdeArtifact] -> Maybe IdeArtifact
+smallestArtifact = minimumByMay (compare `on` (\a -> (artifactSize a, negate $ artifactInterest a)))
+
+artifactSize :: IdeArtifact -> (Int, Int)
+artifactSize (IdeArtifact {..}) =
+  ( P.sourcePosLine (P.spanEnd iaSpan) - P.sourcePosLine (P.spanStart iaSpan),
+    P.sourcePosColumn (P.spanEnd iaSpan) - P.sourcePosColumn (P.spanStart iaSpan)
+  )
+
+
+-- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
+artifactInterest :: IdeArtifact -> Int
+artifactInterest (IdeArtifact {..}) = case iaValue of
+  IaBinder {} -> 1
+  IaTypeName {} -> 1
+  IaClassName {} -> 1
+  _ -> 0
+
+getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
+getArtifactsAtPosition pos (IdeArtifacts m) =
+  Map.lookup (P.sourcePosLine pos) m
+    & fromMaybe []
+    & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
+  where
+    posCol = P.sourcePosColumn pos
+
+insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaExpr expr ty = case ss of
+  Just span -> insertAtLines span (IaExpr expr) ty mName defSpan
+  Nothing -> identity
+  where
+    ss = P.exprSourceSpan expr
+    defSpan =
+      Left <$> case expr of
+        P.Var _ q -> posFromQual q
+        P.Constructor _ q -> posFromQual q
+        P.Op _ q -> posFromQual q
+        _ -> Nothing
+
+    mName = case expr of
+      P.Var _ q -> moduleNameFromQual q
+      P.Constructor _ q -> moduleNameFromQual q
+      P.Op _ q -> moduleNameFromQual q
+      _ -> Nothing
+
+insertIaIdent :: P.SourceSpan -> P.Ident -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaIdent ss ident ty = case ident of
+  P.Ident ident' -> insertAtLines ss (IaIdent ident') ty Nothing (Just $ Right ss)
+  _ -> identity
+
+insertIaBinder :: P.Binder -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaBinder binder ty = case binderSourceSpan binder of
+  Just ss -> insertAtLines ss (IaBinder binder) ty Nothing (Just $ Right ss)
+  Nothing -> identity
+
+insertIaDecl :: P.Declaration -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaDecl decl ty = insertAtLines (P.declSourceSpan decl) (IaDecl decl) ty Nothing Nothing
+
+insertIaType :: P.SourceType -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaType ty kind = insertAtLines (fst $ P.getAnnForType ty) (IaType ty) kind Nothing Nothing
+
+insertIaTypeName :: P.SourceSpan -> P.ProperName 'P.TypeName -> Maybe P.ModuleName -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaTypeName ss name mName kind = insertAtLines ss (IaTypeName name) kind mName (Just $ Right $ fst $ P.getAnnForType kind)
+
+insertIaClassName :: P.SourceSpan -> P.ProperName 'P.ClassName -> Maybe P.ModuleName -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaClassName ss name mName kind = insertAtLines ss (IaClassName name) kind mName (Just $ Right $ fst $ P.getAnnForType kind)
+
+binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
+binderSourceSpan = \case
+  P.NullBinder -> Nothing
+  P.LiteralBinder ss _ -> Just ss
+  P.VarBinder ss _ -> Just ss
+  P.ConstructorBinder ss _ _ -> Just ss
+  P.NamedBinder ss _ _ -> Just ss
+  P.PositionedBinder ss _ _ -> Just ss
+  P.TypedBinder _ b -> binderSourceSpan b
+  P.OpBinder ss _ -> Just ss
+  P.BinaryNoParensBinder {} -> Nothing
+  P.ParensInBinder {} -> Nothing
+
+posFromQual :: P.Qualified a -> Maybe P.SourcePos
+posFromQual (P.Qualified (P.BySourcePos pos) _) = Just pos
+posFromQual _ = Nothing
+
+moduleNameFromQual :: P.Qualified a -> Maybe P.ModuleName
+moduleNameFromQual (P.Qualified (P.ByModuleName mn) _) = Just mn
+moduleNameFromQual _ = Nothing
+
+insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
+insertAtLines span value ty mName defSpan (IdeArtifacts m) = IdeArtifacts $ foldr insert m (linesFromSpan span)
+  where
+    insert line = Map.insertWith (<>) line [IdeArtifact span value ty mName defSpan]
+
+linesFromSpan :: P.SourceSpan -> [Line]
+linesFromSpan ss = [P.sourcePosLine $ P.spanStart ss .. P.sourcePosLine $ P.spanEnd ss]
+
+-- insertIaExpr :: P.SourceSpan -> P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+-- insertIaExpr ann expr ty (IdeArtifacts m) = IdeArtifacts $ Map.insert line (ann, IaExpr expr, ty) m
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index b6c886846c..6c6ae9e91d 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -52,7 +52,7 @@ import Language.PureScript.Crash (HasCallStack, internalError)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Errors
 import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified)
-import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, addIdeType, addIdeTypeNameQual, addIdeClassNameQual)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.Types
@@ -161,8 +161,12 @@ inferKind
 inferKind = \tyToInfer ->
   withErrorMessageHint (ErrorInferringKind tyToInfer)
     . rethrowWithPosition (fst $ getAnnForType tyToInfer)
-    $ go tyToInfer
+    $ addTypeKindToIde
+    =<< go tyToInfer
   where
+  addTypeKindToIde (ty, kind)  = do 
+    addIdeType ty kind 
+    pure (ty, kind)
   go = \case
     ty@(TypeConstructor ann v) -> do
       env <- getEnv
@@ -171,8 +175,10 @@ inferKind = \tyToInfer ->
           throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
         Just (kind, E.LocalTypeVariable) -> do
           kind' <- apply kind
+          addIdeTypeNameQual (fst ann) v kind'
           pure (ty, kind' $> ann)
         Just (kind, _) -> do
+          addIdeTypeNameQual (fst ann) v kind
           pure (ty, kind $> ann)
     ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do
       env <- getEnv
@@ -183,7 +189,9 @@ inferKind = \tyToInfer ->
           checkConstraint con
       ty' <- checkIsSaturatedType ty
       con'' <- applyConstraint con'
-      pure (ConstrainedType ann' con'' ty', E.kindType $> ann')
+      let kind = E.kindType $> ann'
+      addIdeClassNameQual (fst ann) v kind
+      pure (ConstrainedType ann' con'' ty', kind)
     ty@(TypeLevelString ann _) ->
       pure (ty, E.kindSymbol $> ann)
     ty@(TypeLevelInt ann _) ->
@@ -614,6 +622,7 @@ kindOfWithScopedVars ty = do
   let binders = fst . fromJust $ completeBinderList ty'
   pure ((snd <$> binders, ty'), kind)
 
+
 type DataDeclarationArgs =
   ( SourceAnn
   , ProperName 'TypeName
@@ -860,8 +869,11 @@ applyConstraint
   => SourceConstraint
   -> m SourceConstraint
 applyConstraint (Constraint ann clsName kinds args dat) = do
-  let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args
-  (_, kinds', args') <- unapplyTypes <$> apply ty
+  let 
+     ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args
+  applied <- apply ty
+  addIdeClassNameQual (fst ann) clsName applied
+  let (_, kinds', args') = unapplyTypes applied
   pure $ Constraint ann clsName kinds' args' dat
 
 type InstanceDeclarationArgs =
@@ -897,6 +909,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do
     let allWithVars = replaceUnknownsWithVars unknownVars allTy
     let (allConstraints, (_, allKinds, allArgs)) = unapplyTypes <$> unapplyConstraints allWithVars
     varKinds <- traverse (traverse (fmap (replaceUnknownsWithVars unknownVars) . apply)) $ (snd <$> unknownVars) <> (first runProperName <$> freeVarsDict)
+    addIdeClassNameQual (fst ann) clsName allWithVars
     pure (allConstraints, allKinds, allArgs, varKinds)
 
 checkKindDeclaration
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index b6382e6707..d6cf89e0f6 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
 
 -- |
 -- Monads for type checking and type inference and associated data types
@@ -28,6 +29,10 @@ import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual)
+import Protolude (whenM)
+import Language.PureScript.AST.Binders (Binder)
+import Language.PureScript.AST.Declarations (Declaration)
 
 newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown)
   deriving (Eq, Show)
@@ -105,11 +110,15 @@ data CheckState = CheckState
   , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
   -- ^ Newtype constructors imports required to solve Coercible constraints.
   -- We have to keep track of them so that we don't emit unused import warnings.
+  , checkAddIdeArtifacts :: Bool
+  -- ^ Whether to add IDE artifacts to the environment
+  , checkIdeArtifacts :: IdeArtifacts
+  -- ^ The IDE artifacts
   }
 
 -- | Create an empty @CheckState@
 emptyCheckState :: Environment -> CheckState
-emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty
+emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty False emptyIdeArtifacts
 
 -- | Unification variables
 type Unknown = Int
@@ -374,6 +383,37 @@ unsafeCheckCurrentModule = gets checkCurrentModule >>= \case
   Nothing -> internalError "No module name set in scope"
   Just name -> pure name
 
+addIdeDecl :: MonadState CheckState m => Declaration -> SourceType -> m ()
+addIdeDecl declaration ty = onIdeArtifacts $ insertIaDecl declaration ty
+
+addIdeBinder :: MonadState CheckState m => Binder -> SourceType -> m ()
+addIdeBinder binder ty = onIdeArtifacts $ insertIaBinder binder ty
+
+addIdeIdent :: MonadState CheckState m => SourceSpan -> Ident -> SourceType -> m ()
+addIdeIdent ss ident ty  = onIdeArtifacts $ insertIaIdent ss ident ty 
+
+addIdeExpr ::  MonadState CheckState m => Expr -> SourceType -> m ()
+addIdeExpr expr ty = onIdeArtifacts $ insertIaExpr expr ty
+
+addIdeType ::  MonadState CheckState m => SourceType -> SourceType -> m ()
+addIdeType expr ty = onIdeArtifacts $ insertIaType expr ty
+
+addIdeTypeName :: MonadState CheckState m => Maybe ModuleName -> SourceSpan -> ProperName 'TypeName -> SourceType -> m ()
+addIdeTypeName mName ss name ty = onIdeArtifacts $ insertIaTypeName ss name mName ty
+
+addIdeTypeNameQual :: MonadState CheckState m => SourceSpan -> Qualified (ProperName 'TypeName) -> SourceType -> m ()
+addIdeTypeNameQual ss name ty = onIdeArtifacts $ insertIaTypeName ss (disqualify name) (moduleNameFromQual name) ty
+
+addIdeClassName :: MonadState CheckState m => Maybe ModuleName -> SourceSpan -> ProperName 'ClassName -> SourceType -> m ()
+addIdeClassName mName ss name ty = onIdeArtifacts $ insertIaClassName ss name mName ty
+
+addIdeClassNameQual :: MonadState CheckState m => SourceSpan -> Qualified ( ProperName 'ClassName) -> SourceType -> m ()
+addIdeClassNameQual ss name ty = onIdeArtifacts $ insertIaClassName ss (disqualify name) (moduleNameFromQual name) ty
+
+onIdeArtifacts :: MonadState CheckState m => (IdeArtifacts -> IdeArtifacts) -> m ()
+onIdeArtifacts f = whenM (gets checkAddIdeArtifacts)  
+  $ modify $ \env -> env { checkIdeArtifacts = f (checkIdeArtifacts env) }
+
 debugEnv :: Environment -> [String]
 debugEnv env = join
   [ debugTypes env
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 15e09939c9..6a5faced95 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 -- |
 -- This module implements the type checker
 --
@@ -6,7 +7,6 @@ module Language.PureScript.TypeChecker.Types
   , TypedValue'(..)
   , typesOf
   , checkTypeKind
-  , infer'
   ) where
 
 {-
@@ -14,7 +14,7 @@ module Language.PureScript.TypeChecker.Types
 
     infer
       Synthesize a type for a value
-
+f
     check
       Check a value has a given type
 
@@ -26,7 +26,7 @@ module Language.PureScript.TypeChecker.Types
 -}
 
 import Prelude
-import Protolude (ordNub, fold, atMay)
+import Protolude (ordNub, fold, atMay, (>=>))
 
 import Control.Arrow (first, second, (***))
 import Control.Monad (forM, forM_, guard, replicateM, unless, when, zipWithM, (<=<))
@@ -189,8 +189,15 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     raisePreviousWarnings False wInfer
     forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) ->
       raisePreviousWarnings shouldGeneralize w
+      
+
+    let typedExprs = map fst inferred 
 
-    return (map fst inferred)
+    forM_ typedExprs \((ann, ident), (expr, ty) ) ->  do
+      addIdeExpr expr ty
+      addIdeIdent (fst ann) ident ty
+
+    return typedExprs
   where
     replaceTypes
       :: Substitution
@@ -361,11 +368,23 @@ insertUnkName' (TUnknown _ i) n = insertUnkName i n
 insertUnkName' _ _ = internalCompilerError "type is not TUnknown"
 
 -- | Infer a type for a value, rethrowing any error to provide a more useful error message
+-- | and add the inferred type to the IDE artifacts if necessary.
 infer
   :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => Expr
   -> m TypedValue'
-infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val
+infer val = withErrorMessageHint (ErrorInferringType val) $ inferAndAddToIde val
+
+
+inferAndAddToIde  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  => Expr
+  -> m TypedValue'
+inferAndAddToIde = infer' >=> addTypedValueToIde
+
+addTypedValueToIde :: MonadState CheckState m => TypedValue' -> m TypedValue'
+addTypedValueToIde tv@(TypedValue' _ expr ty)  = do 
+  addIdeExpr expr ty 
+  pure tv
 
 -- | Infer a type for a value
 infer'
@@ -453,7 +472,7 @@ infer' (Abs binder ret)
   | VarBinder ss arg <- binder = do
       ty <- freshTypeWithKind kindType
       withBindingGroupVisible $ bindLocalVariables [(ss, arg, ty, Defined)] $ do
-        body@(TypedValue' _ _ bodyTy) <- infer' ret
+        body@(TypedValue' _ _ bodyTy) <- inferAndAddToIde ret
         (body', bodyTy') <- instantiatePolyTypeWithUnknowns (tvToExpr body) bodyTy
         return $ TypedValue' True (Abs (VarBinder ss arg) body') (function ty bodyTy')
   | otherwise = internalError "Binder was not desugared"
@@ -532,7 +551,7 @@ infer' (Hole name) = do
   tell . errorMessage $ HoleInferredType name ty ctx . Just $ TSBefore env
   return $ TypedValue' True (Hole name) ty
 infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
-  TypedValue' t v ty <- infer' val
+  TypedValue' t v ty <- inferAndAddToIde val
   return $ TypedValue' t (PositionedValue pos c v) ty
 infer' v = internalError $ "Invalid argument to infer: " ++ show v
 
@@ -593,6 +612,7 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed
     if checkType
       then withScopedTypeVars moduleName args (bindNames dict (check val ty'))
       else return (TypedValue' checkType val elabTy)
+  addIdeIdent ss ident ty''
   bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined))
     $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j
 inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do
@@ -601,6 +621,7 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] :
     let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined)
     bindNames dict $ infer val
   warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy'
+  addIdeIdent ss ident valTy'
   bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined))
     $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j
 inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
@@ -614,21 +635,34 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
     inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
 inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
 
+inferBinder 
+  :: forall m
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  => SourceType
+  -> Binder
+  -> m (M.Map Ident (SourceSpan, SourceType))
+inferBinder val binder = do 
+  addIdeBinder binder val
+  m <- inferBinder' val binder
+  forM_ (M.toList m) $ \(ident, (ss, ty)) -> do
+    addIdeIdent ss ident ty
+  pure m
+
 -- | Infer the types of variables brought into scope by a binder
-inferBinder
+inferBinder'
   :: forall m
    . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => SourceType
   -> Binder
   -> m (M.Map Ident (SourceSpan, SourceType))
-inferBinder _ NullBinder = return M.empty
-inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty
-inferBinder val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
-inferBinder val (LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty
-inferBinder val (LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty
-inferBinder val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty
-inferBinder val (VarBinder ss name) = return $ M.singleton name (ss, val)
-inferBinder val (ConstructorBinder ss ctor binders) = do
+inferBinder' _ NullBinder = return M.empty
+inferBinder' val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty
+inferBinder' val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty
+inferBinder' val (LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty
+inferBinder' val (LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty
+inferBinder' val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty
+inferBinder' val (VarBinder ss name) = return $ M.singleton name (ss, val)
+inferBinder' val (ConstructorBinder ss ctor binders) = do
   env <- getEnv
   case M.lookup ctor (dataConstructors env) of
     Just (_, _, ty, _) -> do
@@ -647,7 +681,7 @@ inferBinder val (ConstructorBinder ss ctor binders) = do
     where
     go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret
     go args ret = (args, ret)
-inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do
+inferBinder' val (LiteralBinder _ (ObjectLiteral props)) = do
   row <- freshTypeWithKind (kindRow kindType)
   rest <- freshTypeWithKind (kindRow kindType)
   m1 <- inferRowProperties row rest props
@@ -661,29 +695,29 @@ inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do
     m1 <- inferBinder propTy binder
     m2 <- inferRowProperties nrow (srcRCons (Label name) propTy row) binders
     return $ m1 `M.union` m2
-inferBinder val (LiteralBinder _ (ArrayLiteral binders)) = do
+inferBinder' val (LiteralBinder _ (ArrayLiteral binders)) = do
   el <- freshTypeWithKind kindType
   m1 <- M.unions <$> traverse (inferBinder el) binders
   unifyTypes val (srcTypeApp tyArray el)
   return m1
-inferBinder val (NamedBinder ss name binder) =
+inferBinder' val (NamedBinder ss name binder) =
   warnAndRethrowWithPositionTC ss $ do
-    m <- inferBinder val binder
+    m <- inferBinder' val binder
     return $ M.insert name (ss, val) m
-inferBinder val (PositionedBinder pos _ binder) =
+inferBinder' val (PositionedBinder pos _ binder) =
   warnAndRethrowWithPositionTC pos $ inferBinder val binder
-inferBinder val (TypedBinder ty binder) = do
+inferBinder' val (TypedBinder ty binder) = do
   (elabTy, kind) <- kindOf ty
   checkTypeKind ty kind
   ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy
   unifyTypes val ty1
-  inferBinder ty1 binder
-inferBinder _ OpBinder{} =
-  internalError "OpBinder should have been desugared before inferBinder"
-inferBinder _ BinaryNoParensBinder{} =
-  internalError "BinaryNoParensBinder should have been desugared before inferBinder"
-inferBinder _ ParensInBinder{} =
-  internalError "ParensInBinder should have been desugared before inferBinder"
+  inferBinder' ty1 binder
+inferBinder' _ OpBinder{} =
+  internalError "OpBinder should have been desugared before inferBinder'"
+inferBinder' _ BinaryNoParensBinder{} =
+  internalError "BinaryNoParensBinder should have been desugared before inferBinder'"
+inferBinder' _ ParensInBinder{} =
+  internalError "ParensInBinder should have been desugared before inferBinder'"
 
 -- | Returns true if a binder requires its argument type to be a monotype.
 -- | If this is the case, we need to instantiate any polymorphic types before checking binders.

From ae6065c831ce6f918e4a8c9ab5d8c4bce2c9eca9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 1 Nov 2024 19:12:43 +0100
Subject: [PATCH 216/297] dont track generated expressions

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  5 +-
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 61 +++++++++++++++++--
 src/Language/PureScript/TypeChecker/Types.hs  | 24 ++++----
 3 files changed, 71 insertions(+), 19 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 759b7566ed..a3eeaa4990 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -34,7 +34,7 @@ import Language.PureScript.Lsp.State (cachedRebuild, getExportEnv)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
 import Language.PureScript.Sugar.Names.Env qualified as P
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, debugIdeArtifact)
 import Protolude hiding (handle, to)
 import Text.PrettyPrint.Boxes (render)
 
@@ -126,6 +126,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       -- debugLsp $ showCounts everything
       debugLsp $ "at pos len: " <> show (length atPos)
       debugLsp $ "smallest: " <> (ellipsis 512 . show) (iaValue <$> smallestArtifact atPos)
+      for_ atPos \a -> debugLsp $ debugIdeArtifact a
       case smallestArtifact atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
@@ -407,7 +408,7 @@ generatedIdent = \case
 dispayExprOnHover :: P.Expr -> T.Text
 dispayExprOnHover (P.Op _ (P.Qualified _ op)) = P.runOpName op -- Op's hit an infinite loop when pretty printed by themselves
 dispayExprOnHover (P.Case _ _) = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
-dispayExprOnHover expr = ellipsis 64 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 4 expr
+dispayExprOnHover expr = ellipsis 128 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 8 expr
 
 dispayBinderOnHover :: P.Binder -> T.Text
 dispayBinderOnHover binder = ellipsis 32 $ on1Line $ T.strip $ P.prettyPrintBinder binder
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 5f046d9b35..7c491ac01b 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -16,6 +16,7 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     insertIaTypeName,
     insertIaClassName,
     moduleNameFromQual,
+    debugIdeArtifact,
   )
 where
 
@@ -26,10 +27,14 @@ import Data.Text qualified as T
 import Language.PureScript.AST.Binders qualified as P
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.SourcePos qualified as P
+import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Names qualified as P
+import Language.PureScript.Pretty.Types qualified as P
+import Language.PureScript.Pretty.Values qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude
 import Safe (minimumByMay)
+import Text.PrettyPrint.Boxes (render)
 
 data IdeArtifacts = IdeArtifacts (Map Line [IdeArtifact]) deriving (Show)
 
@@ -82,7 +87,6 @@ artifactSize (IdeArtifact {..}) =
     P.sourcePosColumn (P.spanEnd iaSpan) - P.sourcePosColumn (P.spanStart iaSpan)
   )
 
-
 -- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
 artifactInterest :: IdeArtifact -> Int
 artifactInterest (IdeArtifact {..}) = case iaValue of
@@ -101,8 +105,8 @@ getArtifactsAtPosition pos (IdeArtifacts m) =
 
 insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaExpr expr ty = case ss of
-  Just span -> insertAtLines span (IaExpr expr) ty mName defSpan
-  Nothing -> identity
+  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr expr) ty mName defSpan
+  _ -> identity
   where
     ss = P.exprSourceSpan expr
     defSpan =
@@ -169,5 +173,52 @@ insertAtLines span value ty mName defSpan (IdeArtifacts m) = IdeArtifacts $ fold
 linesFromSpan :: P.SourceSpan -> [Line]
 linesFromSpan ss = [P.sourcePosLine $ P.spanStart ss .. P.sourcePosLine $ P.spanEnd ss]
 
--- insertIaExpr :: P.SourceSpan -> P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
--- insertIaExpr ann expr ty (IdeArtifacts m) = IdeArtifacts $ Map.insert line (ann, IaExpr expr, ty) m
\ No newline at end of file
+generatedExpr :: P.Expr -> Bool
+generatedExpr = \case
+  P.Var _ ident -> generatedIdent $ P.disqualify ident
+  P.Abs b e -> generatedBinder b || generatedExpr e
+  P.App e e' -> generatedExpr e || generatedExpr e'
+  P.TypedValue _ e _ -> generatedExpr e
+  P.PositionedValue _ _ e -> generatedExpr e
+  P.Case es _ -> any generatedExpr es
+  _ -> False
+
+generatedBinder :: P.Binder -> Bool
+generatedBinder = \case
+  P.VarBinder ss ident -> (ss == P.nullSourceSpan) || generatedIdent ident
+  P.NamedBinder ss ident _ -> (ss == P.nullSourceSpan) || generatedIdent ident
+  _ -> False
+
+generatedIdent :: P.Ident -> Bool
+generatedIdent = \case
+  P.GenIdent {} -> True
+  _ -> False
+
+debugIdeArtifact :: IdeArtifact -> Text
+debugIdeArtifact (IdeArtifact {..}) =
+  show (P.sourcePosLine $ P.spanStart iaSpan)
+    <> ":"
+    <> show (P.sourcePosColumn $ P.spanStart iaSpan)
+    <> "-"
+    <> show (P.sourcePosLine $ P.spanEnd iaSpan)
+    <> ":"
+    <> show (P.sourcePosColumn $ P.spanEnd iaSpan)
+    <> "\n"
+    <> "Value: "
+    <> debugIdeArtifactValue iaValue
+    <> "\n"
+    <> "Type: "
+    <> debugType iaType
+
+debugIdeArtifactValue :: IdeArtifactValue -> Text
+debugIdeArtifactValue = \case
+  IaExpr expr -> "Expr: " <> T.pack (take 32 $ render $ P.prettyPrintValue 5 expr) <> ")"
+  IaDecl d -> "Decl: " <> maybe "_" printName (P.declName d)
+  IaBinder binder -> "Binder: " <> show binder
+  IaIdent ident -> "Ident: " <> ident
+  IaType t -> "Type " <> debugType t <> ")"
+  IaTypeName name -> "TypeName: " <> P.runProperName name
+  IaClassName name -> "ClassName: " <> P.runProperName name
+
+debugType :: P.Type a -> Text
+debugType = T.pack . take 64 . P.prettyPrintType 5
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 6a5faced95..263dec7cdf 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -177,6 +177,8 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
 
       -- Check skolem variables did not escape their scope
       skolemEscapeCheck val'
+      addIdeIdent ss ident generalized
+      addIdeExpr val' generalized
       return ((sai, (foldr (Abs . VarBinder nullSourceSpan . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved)
 
     -- Show warnings here, since types in wildcards might have been solved during
@@ -190,14 +192,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) ->
       raisePreviousWarnings shouldGeneralize w
       
-
-    let typedExprs = map fst inferred 
-
-    forM_ typedExprs \((ann, ident), (expr, ty) ) ->  do
-      addIdeExpr expr ty
-      addIdeIdent (fst ann) ident ty
-
-    return typedExprs
+    return $  map fst inferred 
   where
     replaceTypes
       :: Substitution
@@ -792,8 +787,13 @@ check
   => Expr
   -> SourceType
   -> m TypedValue'
-check val ty = withErrorMessageHint' val (ErrorCheckingType val ty) $ check' val ty
+check val ty = withErrorMessageHint' val (ErrorCheckingType val ty) $ checkAndAddToIde val ty
 
+checkAndAddToIde :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) 
+  => Expr -> SourceType -> m TypedValue'
+checkAndAddToIde val ty = do
+  tv <- check' val ty
+  addTypedValueToIde tv
 -- |
 -- Check the type of a value
 --
@@ -908,7 +908,7 @@ check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp _ obj row) | obj == tyRecord
   return $ TypedValue' True (Literal ss (ObjectLiteral ps')) t
 check' (DerivedInstancePlaceholder name strategy) t = do
   d <- deriveInstance t name strategy
-  d' <- tvToExpr <$> check' d t
+  d' <- tvToExpr <$> checkAndAddToIde d t
   return $ TypedValue' True d' t
 check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do
   ensureNoDuplicateProperties ps
@@ -938,10 +938,10 @@ check' (Let w ds val) ty = do
   return $ TypedValue' True (Let w ds' (tvToExpr val')) ty
 check' val kt@(KindedType _ ty kind) = do
   checkTypeKind ty kind
-  val' <- tvToExpr <$> check' val ty
+  val' <- tvToExpr <$> checkAndAddToIde val ty
   return $ TypedValue' True val' kt
 check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do
-  TypedValue' t v ty' <- check' val ty
+  TypedValue' t v ty' <- checkAndAddToIde val ty
   return $ TypedValue' t (PositionedValue pos c v) ty'
 check' val ty = do
   TypedValue' _ val' ty' <- infer val

From 027528582c35369027c3f038a60cd9526524d817 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 1 Nov 2024 20:04:47 +0100
Subject: [PATCH 217/297] countUnkownsAndVars

---
 .../PureScript/TypeChecker/IdeArtifacts.hs     | 18 ++++++++++++++++--
 1 file changed, 16 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 7c491ac01b..bf9de82b4b 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -93,8 +93,18 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   IaBinder {} -> 1
   IaTypeName {} -> 1
   IaClassName {} -> 1
+  IaExpr _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
   _ -> 0
 
+
+countUnkownsAndVars :: P.Type a -> Int
+countUnkownsAndVars = P.everythingOnTypes (+) go where
+  go :: P.Type a -> Int
+  go (P.TUnknown _ _) = 1
+  go (P.TypeVar _ _) = 1
+  go _ = 0
+
+
 getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
 getArtifactsAtPosition pos (IdeArtifacts m) =
   Map.lookup (P.sourcePosLine pos) m
@@ -176,6 +186,7 @@ linesFromSpan ss = [P.sourcePosLine $ P.spanStart ss .. P.sourcePosLine $ P.span
 generatedExpr :: P.Expr -> Bool
 generatedExpr = \case
   P.Var _ ident -> generatedIdent $ P.disqualify ident
+  P.Constructor _ q -> generatedName $ P.disqualify q
   P.Abs b e -> generatedBinder b || generatedExpr e
   P.App e e' -> generatedExpr e || generatedExpr e'
   P.TypedValue _ e _ -> generatedExpr e
@@ -183,6 +194,9 @@ generatedExpr = \case
   P.Case es _ -> any generatedExpr es
   _ -> False
 
+generatedName :: P.ProperName a -> Bool
+generatedName = T.isSuffixOf "$Dict" . P.runProperName
+
 generatedBinder :: P.Binder -> Bool
 generatedBinder = \case
   P.VarBinder ss ident -> (ss == P.nullSourceSpan) || generatedIdent ident
@@ -212,11 +226,11 @@ debugIdeArtifact (IdeArtifact {..}) =
 
 debugIdeArtifactValue :: IdeArtifactValue -> Text
 debugIdeArtifactValue = \case
-  IaExpr expr -> "Expr: " <> T.pack (take 32 $ render $ P.prettyPrintValue 5 expr) <> ")"
+  IaExpr expr -> "Expr: " <> T.pack (take 64 $ render $ P.prettyPrintValue 5 expr) 
   IaDecl d -> "Decl: " <> maybe "_" printName (P.declName d)
   IaBinder binder -> "Binder: " <> show binder
   IaIdent ident -> "Ident: " <> ident
-  IaType t -> "Type " <> debugType t <> ")"
+  IaType t -> "Type " <> debugType t 
   IaTypeName name -> "TypeName: " <> P.runProperName name
   IaClassName name -> "ClassName: " <> P.runProperName name
 

From f5596da706bd1b62f18723f4e80d93bdde1b0c6d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 1 Nov 2024 20:15:47 +0100
Subject: [PATCH 218/297] use inferBinder instead of inferBinder'

---
 src/Language/PureScript/TypeChecker/Monad.hs | 6 ++++--
 src/Language/PureScript/TypeChecker/Types.hs | 4 ++--
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index d6cf89e0f6..9b3e4f569b 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -27,7 +27,7 @@ import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperN
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
-import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
+import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar, replaceAllTypeVars)
 import Text.PrettyPrint.Boxes (render)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual)
 import Protolude (whenM)
@@ -393,7 +393,9 @@ addIdeIdent :: MonadState CheckState m => SourceSpan -> Ident -> SourceType -> m
 addIdeIdent ss ident ty  = onIdeArtifacts $ insertIaIdent ss ident ty 
 
 addIdeExpr ::  MonadState CheckState m => Expr -> SourceType -> m ()
-addIdeExpr expr ty = onIdeArtifacts $ insertIaExpr expr ty
+addIdeExpr expr ty = do 
+  vars <- gets $ substUnsolved . checkSubstitution
+  onIdeArtifacts $ insertIaExpr expr (replaceAllTypeVars vars ty)
 
 addIdeType ::  MonadState CheckState m => SourceType -> SourceType -> m ()
 addIdeType expr ty = onIdeArtifacts $ insertIaType expr ty
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 263dec7cdf..f321e74b77 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -697,7 +697,7 @@ inferBinder' val (LiteralBinder _ (ArrayLiteral binders)) = do
   return m1
 inferBinder' val (NamedBinder ss name binder) =
   warnAndRethrowWithPositionTC ss $ do
-    m <- inferBinder' val binder
+    m <- inferBinder val binder
     return $ M.insert name (ss, val) m
 inferBinder' val (PositionedBinder pos _ binder) =
   warnAndRethrowWithPositionTC pos $ inferBinder val binder
@@ -706,7 +706,7 @@ inferBinder' val (TypedBinder ty binder) = do
   checkTypeKind ty kind
   ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy
   unifyTypes val ty1
-  inferBinder' ty1 binder
+  inferBinder ty1 binder
 inferBinder' _ OpBinder{} =
   internalError "OpBinder should have been desugared before inferBinder'"
 inferBinder' _ BinaryNoParensBinder{} =

From 62c2557395fdcfde8776a2ce53f1022a1a47993a Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 1 Nov 2024 20:17:08 +0100
Subject: [PATCH 219/297] revert addIdeExpr

---
 src/Language/PureScript/TypeChecker/Monad.hs | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 9b3e4f569b..d6cf89e0f6 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -27,7 +27,7 @@ import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperN
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
-import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar, replaceAllTypeVars)
+import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual)
 import Protolude (whenM)
@@ -393,9 +393,7 @@ addIdeIdent :: MonadState CheckState m => SourceSpan -> Ident -> SourceType -> m
 addIdeIdent ss ident ty  = onIdeArtifacts $ insertIaIdent ss ident ty 
 
 addIdeExpr ::  MonadState CheckState m => Expr -> SourceType -> m ()
-addIdeExpr expr ty = do 
-  vars <- gets $ substUnsolved . checkSubstitution
-  onIdeArtifacts $ insertIaExpr expr (replaceAllTypeVars vars ty)
+addIdeExpr expr ty = onIdeArtifacts $ insertIaExpr expr ty
 
 addIdeType ::  MonadState CheckState m => SourceType -> SourceType -> m ()
 addIdeType expr ty = onIdeArtifacts $ insertIaType expr ty

From 3a7a19d9dfe10cd03aca0882554a80a412816393 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sat, 2 Nov 2024 07:19:06 +0100
Subject: [PATCH 220/297] adds applied types for constructors on hover

---
 src/Language/PureScript/Lsp/AtPosition.hs     |  4 +--
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 12 ++++++---
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 12 ++++-----
 src/Language/PureScript/TypeChecker/Kinds.hs  |  4 +--
 src/Language/PureScript/TypeChecker/Monad.hs  |  4 +--
 src/Language/PureScript/TypeChecker/Types.hs  | 27 +++++++++++++++----
 6 files changed, 42 insertions(+), 21 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index abb4524fae..ae5696b046 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -224,7 +224,7 @@ debugExpr =
     . T.replace "SourcePos {sourcePosLine = " ""
     . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
     . T.replace "SourceSpan {spanStart = SourcePos {sourcePosLine =  " "start = "
-    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/oa/application/purs-projects/lib/oa-common/src/general/AwsLambda.purs\", " ""
+    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/simple-purs/src/B.purs\", " ""
     . show
 
 debugSrcSpan :: P.SourceSpan -> Text
@@ -233,7 +233,7 @@ debugSrcSpan =
     . T.replace "SourcePos {sourcePosLine = " ""
     . T.replace "SourceSpan {spanEnd = SourcePos {sourcePosLine =  " "end = "
     . T.replace "SourceSpan {spanStart = SourcePos {sourcePosLine =  " "start = "
-    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/oa/application/purs-projects/lib/oa-common/src/general/AwsLambda.purs\", " ""
+    . T.replace "spanName = \"/Users/rorycampbell/Documents/projects/simple-purs/src/B.purs\", " ""
     . show
 
 -- getDeclTypesAtPos :: Types.Position -> P.Declaration -> [P.SourceType]
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index a3eeaa4990..32020ba46d 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -20,7 +20,7 @@ import Language.PureScript.Docs.Convert.Single (convertComments)
 import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestExpr', smallestType, spanToRange)
+import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestExpr', smallestType, spanToRange, debugExpr)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
@@ -125,12 +125,16 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           atPos = getArtifactsAtPosition (positionToSourcePos startPos) (P.checkIdeArtifacts ofEndCheckState)
       -- debugLsp $ showCounts everything
       debugLsp $ "at pos len: " <> show (length atPos)
-      debugLsp $ "smallest: " <> (ellipsis 512 . show) (iaValue <$> smallestArtifact atPos)
-      for_ atPos \a -> debugLsp $ debugIdeArtifact a
+      debugLsp $ "smallest: " <> (ellipsis 512 . show) (debugExpr . iaValue <$> smallestArtifact atPos)
+      for_ atPos \a -> do 
+        debugLsp $ debugIdeArtifact a
+        case iaValue a of 
+          IaExpr label e -> debugLsp $ "Expr: " <> label <> "\n" <> debugExpr e
+          _ -> pure ()
       case smallestArtifact atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
-            IaExpr expr -> do
+            IaExpr _ expr -> do
               let inferredRes = pursTypeStr (dispayExprOnHover expr) (Just $ prettyPrintTypeSingleLine iaType) []
               foundTypes <- lookupExprTypes expr
               docs <- lookupExprDocs expr
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index bf9de82b4b..740198b4dd 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -61,7 +61,7 @@ data IdeArtifact = IdeArtifact
   deriving (Show)
 
 data IdeArtifactValue
-  = IaExpr P.Expr
+  = IaExpr Text P.Expr
   | IaDecl P.Declaration
   | IaBinder P.Binder
   | IaIdent Text
@@ -93,7 +93,7 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   IaBinder {} -> 1
   IaTypeName {} -> 1
   IaClassName {} -> 1
-  IaExpr _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
+  IaExpr _ _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
   _ -> 0
 
 
@@ -113,9 +113,9 @@ getArtifactsAtPosition pos (IdeArtifacts m) =
   where
     posCol = P.sourcePosColumn pos
 
-insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
-insertIaExpr expr ty = case ss of
-  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr expr) ty mName defSpan
+insertIaExpr :: Text -> P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaExpr label expr ty = case ss of
+  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr label expr) ty mName defSpan
   _ -> identity
   where
     ss = P.exprSourceSpan expr
@@ -226,7 +226,7 @@ debugIdeArtifact (IdeArtifact {..}) =
 
 debugIdeArtifactValue :: IdeArtifactValue -> Text
 debugIdeArtifactValue = \case
-  IaExpr expr -> "Expr: " <> T.pack (take 64 $ render $ P.prettyPrintValue 5 expr) 
+  IaExpr label expr -> "Expr: " <> label <> "\n" <> T.pack (take 64 $ render $ P.prettyPrintValue 5 expr) 
   IaDecl d -> "Decl: " <> maybe "_" printName (P.declName d)
   IaBinder binder -> "Binder: " <> show binder
   IaIdent ident -> "Ident: " <> ident
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 6c6ae9e91d..7f22695e1a 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -175,10 +175,10 @@ inferKind = \tyToInfer ->
           throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
         Just (kind, E.LocalTypeVariable) -> do
           kind' <- apply kind
-          addIdeTypeNameQual (fst ann) v kind'
+          addIdeTypeNameQual (fst ann) v (kind' $> ann)
           pure (ty, kind' $> ann)
         Just (kind, _) -> do
-          addIdeTypeNameQual (fst ann) v kind
+          addIdeTypeNameQual (fst ann) v (kind $> ann)
           pure (ty, kind $> ann)
     ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do
       env <- getEnv
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index d6cf89e0f6..1773d42ad5 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -392,8 +392,8 @@ addIdeBinder binder ty = onIdeArtifacts $ insertIaBinder binder ty
 addIdeIdent :: MonadState CheckState m => SourceSpan -> Ident -> SourceType -> m ()
 addIdeIdent ss ident ty  = onIdeArtifacts $ insertIaIdent ss ident ty 
 
-addIdeExpr ::  MonadState CheckState m => Expr -> SourceType -> m ()
-addIdeExpr expr ty = onIdeArtifacts $ insertIaExpr expr ty
+addIdeExpr ::  MonadState CheckState m => Text -> Expr -> SourceType -> m ()
+addIdeExpr t expr ty = onIdeArtifacts $ insertIaExpr t expr ty
 
 addIdeType ::  MonadState CheckState m => SourceType -> SourceType -> m ()
 addIdeType expr ty = onIdeArtifacts $ insertIaType expr ty
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index f321e74b77..1301df3f63 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -26,7 +26,7 @@ f
 -}
 
 import Prelude
-import Protolude (ordNub, fold, atMay, (>=>))
+import Protolude (ordNub, fold, atMay, (>=>), whenM)
 
 import Control.Arrow (first, second, (***))
 import Control.Monad (forM, forM_, guard, replicateM, unless, when, zipWithM, (<=<))
@@ -64,6 +64,7 @@ import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, replaceTypeWild
 import Language.PureScript.Types
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.PSString (PSString)
+import Data.Text qualified as T
 
 data BindingGroupType
   = RecursiveBindingGroup
@@ -178,7 +179,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
       -- Check skolem variables did not escape their scope
       skolemEscapeCheck val'
       addIdeIdent ss ident generalized
-      addIdeExpr val' generalized
+      addIdeExpr "181" val' generalized
       return ((sai, (foldr (Abs . VarBinder nullSourceSpan . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved)
 
     -- Show warnings here, since types in wildcards might have been solved during
@@ -378,7 +379,7 @@ inferAndAddToIde = infer' >=> addTypedValueToIde
 
 addTypedValueToIde :: MonadState CheckState m => TypedValue' -> m TypedValue'
 addTypedValueToIde tv@(TypedValue' _ expr ty)  = do 
-  addIdeExpr expr ty 
+  addIdeExpr "standard" expr ty 
   pure tv
 
 -- | Infer a type for a value
@@ -932,6 +933,7 @@ check' v@(Constructor _ c) ty = do
       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
       ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
       elaborate <- subsumes repl ty'
+      addIdeExpr "935" v repl
       return $ TypedValue' True (elaborate v) ty'
 check' (Let w ds val) ty = do
   (ds', val') <- inferLetBinding [] ds val (`check` ty)
@@ -1021,9 +1023,17 @@ checkFunctionApplication'
   -> SourceType
   -> Expr
   -> m (SourceType, Expr)
-checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg = do
+checkFunctionApplication' fn (TypeApp ann (TypeApp ann' tyFunction' argTy) retTy) arg = do
   unifyTypes tyFunction' tyFunction
-  arg' <- tvToExpr <$> check arg argTy
+  tv@(TypedValue' _ _ argTy') <- check arg argTy
+  let arg' = tvToExpr tv
+  whenM (gets checkAddIdeArtifacts) do
+    let 
+        retTy' = case argTy of
+          TypeVar _ v -> replaceTypeVars v argTy' retTy
+          TUnknown _ u -> replaceUnknown u argTy' retTy
+          _ -> retTy
+    addIdeExpr ("1028: " <> T.pack (show argTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
   return (retTy, App fn arg')
 checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do
   u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK
@@ -1045,8 +1055,15 @@ checkFunctionApplication' fn u arg = do
     return $ TypedValue' True arg'' t'
   ret <- freshTypeWithKind kindType
   unifyTypes u (function ty ret)
+  addIdeExpr "1050" fn (function ty ret)
   return (ret, App fn (tvToExpr tv))
 
+replaceUnknown :: Int -> SourceType -> Type SourceAnn -> Type SourceAnn
+replaceUnknown i replacement  = everywhereOnTypes go
+  where
+  go (TUnknown _ j) | i == j = replacement
+  go other = other
+
 -- |
 -- Ensure a set of property names and value does not contain duplicate labels
 --

From 8e893562f482e4f4e4c0f9628d4bd001a4c52815 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sat, 2 Nov 2024 07:39:26 +0100
Subject: [PATCH 221/297] adds applied types to functions with contrained types

---
 src/Language/PureScript/TypeChecker/Types.hs | 21 ++++++++++++++++----
 1 file changed, 17 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 1301df3f63..1f977a7bf6 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1031,7 +1031,7 @@ checkFunctionApplication' fn (TypeApp ann (TypeApp ann' tyFunction' argTy) retTy
     let 
         retTy' = case argTy of
           TypeVar _ v -> replaceTypeVars v argTy' retTy
-          TUnknown _ u -> replaceUnknown u argTy' retTy
+          TUnknown _ u -> replaceUnknowns u argTy' retTy
           _ -> retTy
     addIdeExpr ("1028: " <> T.pack (show argTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
   return (retTy, App fn arg')
@@ -1045,6 +1045,18 @@ checkFunctionApplication' fn (KindedType _ ty _) arg =
 checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
+  whenM (gets checkAddIdeArtifacts) do
+    case fnTy of 
+      TypeApp ann (TypeApp ann' tyFunction' argTy) retTy -> do
+        (TypedValue' _ _ argTy') <- check arg argTy
+        let 
+          retTy' = case argTy' of
+            TypeVar _ v -> replaceTypeVars v argTy' retTy
+            TUnknown _ u -> replaceUnknowns u argTy' retTy
+            _ -> retTy
+        addIdeExpr ("1056: " <> T.pack (show argTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
+      _ -> pure ()
+    -- addIdeExpr "1049" fn (ConstrainedType con fnTy)
   checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg
 checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
   return (fnTy, App fn dict)
@@ -1055,11 +1067,12 @@ checkFunctionApplication' fn u arg = do
     return $ TypedValue' True arg'' t'
   ret <- freshTypeWithKind kindType
   unifyTypes u (function ty ret)
-  addIdeExpr "1050" fn (function ty ret)
+  addIdeExpr "69" fn (function ty ret)
   return (ret, App fn (tvToExpr tv))
 
-replaceUnknown :: Int -> SourceType -> Type SourceAnn -> Type SourceAnn
-replaceUnknown i replacement  = everywhereOnTypes go
+
+replaceUnknowns :: Int -> SourceType -> Type SourceAnn -> Type SourceAnn
+replaceUnknowns i replacement  = everywhereOnTypes go
   where
   go (TUnknown _ j) | i == j = replacement
   go other = other

From 2a5aa80a70fb4cee3c134658ddb14a07a8e30d69 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 4 Nov 2024 04:39:18 +0100
Subject: [PATCH 222/297] show substituted types on exprs

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  5 +-
 src/Language/PureScript/TypeChecker.hs        |  1 +
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 70 +++++++++++++------
 src/Language/PureScript/TypeChecker/Monad.hs  |  8 ++-
 src/Language/PureScript/TypeChecker/Types.hs  | 52 +++++++++-----
 5 files changed, 92 insertions(+), 44 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 32020ba46d..848d8017a9 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -116,9 +116,10 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
           readDeclarationDocsWithNameType modName DctorNameType (P.runProperName dctor)
         _ -> pure Nothing
-
+  debugLsp $ "Hover request for: " <> show filePathMb
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
+    debugLsp $ "Cache found: " <> show (isJust cacheOpenMb)
     forLsp cacheOpenMb \OpenFile {..} -> do
       let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
           respondWithCounts = markdownRes Nothing $ showCounts everything
@@ -129,7 +130,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       for_ atPos \a -> do 
         debugLsp $ debugIdeArtifact a
         case iaValue a of 
-          IaExpr label e -> debugLsp $ "Expr: " <> label <> "\n" <> debugExpr e
+          IaExpr label e -> debugLsp $ "Expr: " <> label <> "\n" <>  (ellipsis 256 $ debugExpr e)
           _ -> pure ()
       case smallestArtifact atPos of
         Just (IdeArtifact {..}) ->
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index a8e649c5ea..dfd511b881 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -341,6 +341,7 @@ typeCheckAll moduleName = traverse go
         [(_, (val'', ty))] -> do
           addValue moduleName name ty nameKind
           addIdeDecl d ty
+          addIdeIdent ss name ty
           return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
         _ -> internalError "typesOf did not return a singleton"
   go ValueDeclaration{} = internalError "Binders were not desugared"
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 740198b4dd..6b1396c41f 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -4,6 +4,7 @@ module Language.PureScript.TypeChecker.IdeArtifacts
   ( IdeArtifacts,
     IdeArtifact (..),
     IdeArtifactValue (..),
+    UnResolvedExpr (..),
     getArtifactsAtPosition,
     emptyIdeArtifacts,
     insertIaExpr,
@@ -17,6 +18,8 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     insertIaClassName,
     moduleNameFromQual,
     debugIdeArtifact,
+    onUnresolvedExprs,
+    resolveExprs,
   )
 where
 
@@ -36,12 +39,16 @@ import Protolude
 import Safe (minimumByMay)
 import Text.PrettyPrint.Boxes (render)
 
-data IdeArtifacts = IdeArtifacts (Map Line [IdeArtifact]) deriving (Show)
+data IdeArtifacts
+  = IdeArtifacts
+      (Map Line [IdeArtifact]) -- with substitutions
+      (Map Line [UnResolvedExpr]) -- without substitutions
+  deriving (Show)
 
 type Line = Int
 
 emptyIdeArtifacts :: IdeArtifacts
-emptyIdeArtifacts = IdeArtifacts Map.empty
+emptyIdeArtifacts = IdeArtifacts Map.empty Map.empty
 
 debugIdeArtifacts :: IdeArtifacts -> Text
 debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts
@@ -49,7 +56,7 @@ debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts
     showCount :: (Int, Int) -> Text
     showCount (line, count) = show line <> ": " <> show count
     lineCounts :: IdeArtifacts -> [(Int, Int)]
-    lineCounts (IdeArtifacts m) = Map.toList m <&> fmap length
+    lineCounts (IdeArtifacts m _) = Map.toList m <&> fmap length
 
 data IdeArtifact = IdeArtifact
   { iaSpan :: P.SourceSpan,
@@ -70,13 +77,30 @@ data IdeArtifactValue
   | IaClassName (P.ProperName 'P.ClassName)
   deriving (Show)
 
--- valueCtr :: IdeArtifactValue -> Text
--- valueCtr = \case
---   IaExpr {} -> "Expr"
---   IaDecl {} -> "Decl"
---   IaBinder {} -> "Binder"
---   IaIdent {} -> "BinderIdent"
---   IaType {} -> "Type"
+data UnResolvedExpr = UnResolvedExpr
+  { urSpan :: P.SourceSpan,
+    urLabel :: Text,
+    urExpr :: P.Expr,
+    urType :: P.SourceType,
+    urDefinitionModule :: Maybe P.ModuleName,
+    urDefinitionPos :: Maybe (Either P.SourcePos P.SourceSpan)
+  }
+  deriving (Show)
+
+onUnresolvedExprs :: (UnResolvedExpr -> UnResolvedExpr) -> IdeArtifacts -> IdeArtifacts
+onUnresolvedExprs f (IdeArtifacts m u) = IdeArtifacts m (Map.map (fmap f) u)
+
+resolveExprs :: IdeArtifacts -> IdeArtifacts
+resolveExprs (IdeArtifacts m u) = IdeArtifacts (Map.unionWith (<>) m exprArtifacts) Map.empty
+  where
+    exprArtifacts :: Map Line [IdeArtifact]
+    exprArtifacts = Map.foldrWithKey resolve Map.empty u
+
+    resolve line exprs = Map.insertWith (<>) line newArtifacts
+      where
+        newArtifacts = fmap newArtifact exprs
+        newArtifact  (UnResolvedExpr {..}) = IdeArtifact urSpan (IaExpr urLabel urExpr) urType urDefinitionModule urDefinitionPos
+
 
 smallestArtifact :: [IdeArtifact] -> Maybe IdeArtifact
 smallestArtifact = minimumByMay (compare `on` (\a -> (artifactSize a, negate $ artifactInterest a)))
@@ -96,17 +120,16 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   IaExpr _ _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
   _ -> 0
 
-
 countUnkownsAndVars :: P.Type a -> Int
-countUnkownsAndVars = P.everythingOnTypes (+) go where
-  go :: P.Type a -> Int
-  go (P.TUnknown _ _) = 1
-  go (P.TypeVar _ _) = 1
-  go _ = 0
-
+countUnkownsAndVars = P.everythingOnTypes (+) go
+  where
+    go :: P.Type a -> Int
+    go (P.TUnknown _ _) = 1
+    go (P.TypeVar _ _) = 1
+    go _ = 0
 
 getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
-getArtifactsAtPosition pos (IdeArtifacts m) =
+getArtifactsAtPosition pos (IdeArtifacts m _) =
   Map.lookup (P.sourcePosLine pos) m
     & fromMaybe []
     & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
@@ -115,7 +138,7 @@ getArtifactsAtPosition pos (IdeArtifacts m) =
 
 insertIaExpr :: Text -> P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaExpr label expr ty = case ss of
-  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr label expr) ty mName defSpan
+  Just span | not (generatedExpr expr) -> insertUnresolvedExprAtLines (UnResolvedExpr span label expr ty mName defSpan)
   _ -> identity
   where
     ss = P.exprSourceSpan expr
@@ -176,10 +199,13 @@ moduleNameFromQual (P.Qualified (P.ByModuleName mn) _) = Just mn
 moduleNameFromQual _ = Nothing
 
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
-insertAtLines span value ty mName defSpan (IdeArtifacts m) = IdeArtifacts $ foldr insert m (linesFromSpan span)
+insertAtLines span value ty mName defSpan (IdeArtifacts m u) = IdeArtifacts (foldr insert m (linesFromSpan span)) u
   where
     insert line = Map.insertWith (<>) line [IdeArtifact span value ty mName defSpan]
 
+insertUnresolvedExprAtLines :: UnResolvedExpr -> IdeArtifacts -> IdeArtifacts
+insertUnresolvedExprAtLines expr (IdeArtifacts m u) = IdeArtifacts m (Map.insertWith (<>) (P.sourcePosLine $ P.spanStart $ urSpan expr) [expr] u)
+
 linesFromSpan :: P.SourceSpan -> [Line]
 linesFromSpan ss = [P.sourcePosLine $ P.spanStart ss .. P.sourcePosLine $ P.spanEnd ss]
 
@@ -226,11 +252,11 @@ debugIdeArtifact (IdeArtifact {..}) =
 
 debugIdeArtifactValue :: IdeArtifactValue -> Text
 debugIdeArtifactValue = \case
-  IaExpr label expr -> "Expr: " <> label <> "\n" <> T.pack (take 64 $ render $ P.prettyPrintValue 5 expr) 
+  IaExpr label expr -> "Expr: " <> label <> "\n" <> T.pack (take 64 $ render $ P.prettyPrintValue 5 expr)
   IaDecl d -> "Decl: " <> maybe "_" printName (P.declName d)
   IaBinder binder -> "Binder: " <> show binder
   IaIdent ident -> "Ident: " <> ident
-  IaType t -> "Type " <> debugType t 
+  IaType t -> "Type " <> debugType t
   IaTypeName name -> "TypeName: " <> P.runProperName name
   IaClassName name -> "ClassName: " <> P.runProperName name
 
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 1773d42ad5..5b8be24f75 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -29,7 +29,7 @@ import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, onUnresolvedExprs, UnResolvedExpr, resolveExprs)
 import Protolude (whenM)
 import Language.PureScript.AST.Binders (Binder)
 import Language.PureScript.AST.Declarations (Declaration)
@@ -414,6 +414,12 @@ onIdeArtifacts :: MonadState CheckState m => (IdeArtifacts -> IdeArtifacts) -> m
 onIdeArtifacts f = whenM (gets checkAddIdeArtifacts)  
   $ modify $ \env -> env { checkIdeArtifacts = f (checkIdeArtifacts env) }
 
+onUnresolvedIdeExprs :: MonadState CheckState m => (UnResolvedExpr -> UnResolvedExpr) -> m ()
+onUnresolvedIdeExprs = onIdeArtifacts . onUnresolvedExprs
+
+resolveIdeExprs :: MonadState CheckState m => m ()
+resolveIdeExprs = onIdeArtifacts resolveExprs
+
 debugEnv :: Environment -> [String]
 debugEnv env = join
   [ debugTypes env
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 1f977a7bf6..55b4a9ea88 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -65,6 +65,7 @@ import Language.PureScript.Types
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.PSString (PSString)
 import Data.Text qualified as T
+import Language.PureScript.TypeChecker.IdeArtifacts (UnResolvedExpr(urType))
 
 data BindingGroupType
   = RecursiveBindingGroup
@@ -106,6 +107,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
       currentSubst <- gets checkSubstitution
       let ty' = substituteType currentSubst ty
           ty'' = constrain unsolved ty'
+      addIdeExpr "constrained" val ty
       unsolvedTypeVarsWithKinds <- unknownsWithKinds . IS.toList . unknowns $ constrain unsolved ty''
       let unsolvedTypeVars = IS.toList $ unknowns ty'
 
@@ -172,7 +174,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
         unsolvedVarNames <- traverse lookupUnkName' (S.toList unsolvedVars)
         unless (S.null unsolvedVars) .
           throwError
-            . onErrorMessages (replaceTypes currentSubst)
+            . onErrorMessages (replaceErrorTypes currentSubst)
             . errorMessage' ss
             $ AmbiguousTypeVariables generalized unsolvedVarNames
 
@@ -185,21 +187,31 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     -- Show warnings here, since types in wildcards might have been solved during
     -- instance resolution (by functional dependencies).
     finalState <- get
-    let replaceTypes' = replaceTypes (checkSubstitution finalState)
+    let replaceErrorTypes' = replaceErrorTypes (checkSubstitution finalState)
         runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState
-        raisePreviousWarnings gen = escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')
+        raisePreviousWarnings gen = escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceErrorTypes')
+
+        -- replaceIdeTypes = 
 
     raisePreviousWarnings False wInfer
-    forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) ->
+    forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
       raisePreviousWarnings shouldGeneralize w
-      
+      onUnresolvedIdeExprs $ replaceIdeExprTypes (checkSubstitution finalState)
+    
+    resolveIdeExprs
     return $  map fst inferred 
   where
-    replaceTypes
+    replaceIdeExprTypes
+      :: Substitution
+      -> UnResolvedExpr
+      -> UnResolvedExpr
+    replaceIdeExprTypes subst e = e { urType = substituteType subst (urType e) }
+
+    replaceErrorTypes
       :: Substitution
       -> ErrorMessage
       -> ErrorMessage
-    replaceTypes subst = onTypesInErrorMessage (substituteType subst)
+    replaceErrorTypes subst = onTypesInErrorMessage (substituteType subst)
 
     -- Run type search to complete any typed hole error messages
     runTypeSearch
@@ -1045,18 +1057,20 @@ checkFunctionApplication' fn (KindedType _ ty _) arg =
 checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
-  whenM (gets checkAddIdeArtifacts) do
-    case fnTy of 
-      TypeApp ann (TypeApp ann' tyFunction' argTy) retTy -> do
-        (TypedValue' _ _ argTy') <- check arg argTy
-        let 
-          retTy' = case argTy' of
-            TypeVar _ v -> replaceTypeVars v argTy' retTy
-            TUnknown _ u -> replaceUnknowns u argTy' retTy
-            _ -> retTy
-        addIdeExpr ("1056: " <> T.pack (show argTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
-      _ -> pure ()
-    -- addIdeExpr "1049" fn (ConstrainedType con fnTy)
+  let addAppliedType ty argE =
+        whenM (gets checkAddIdeArtifacts) do
+          case ty of
+            TypeApp ann (TypeApp ann' tyFunction' argTy) retTy -> do
+              (TypedValue' _ _ argTy') <- check argE argTy
+              let retTy' = case argTy of
+                    TypeVar _ v -> replaceTypeVars v argTy' retTy
+                    TUnknown _ u -> replaceUnknowns u argTy' retTy
+                    _ -> retTy
+              addIdeExpr ("1056: \n" <> T.pack (show argTy) <> "\n\n" <> T.pack (show retTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
+              
+            _ -> pure ()
+
+  addAppliedType fnTy arg
   checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg
 checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
   return (fnTy, App fn dict)

From 202f58993c1014541a0bf9847580536677f85d67 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 4 Nov 2024 06:49:50 +0100
Subject: [PATCH 223/297] hover showing substituted  types

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 297 ++----------------
 src/Language/PureScript/TypeChecker.hs        |   2 +
 .../PureScript/TypeChecker/IdeArtifacts.hs    |  65 +---
 src/Language/PureScript/TypeChecker/Monad.hs  |  10 +-
 src/Language/PureScript/TypeChecker/Types.hs  |  26 +-
 5 files changed, 57 insertions(+), 343 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 848d8017a9..485754d276 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -5,11 +5,7 @@
 
 module Language.PureScript.Lsp.Handlers.Hover (hoverHandler) where
 
-import Control.Arrow ((>>>))
-import Control.Lens (Field2 (_2), Field3 (_3), (^.))
-import Control.Lens.Combinators (view)
-import Control.Monad.Trans.Writer (WriterT (runWriterT))
-import Data.Map qualified as M
+import Control.Lens ((^.))
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
@@ -17,24 +13,18 @@ import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.PureScript qualified as P
 import Language.PureScript.Docs.Convert.Single (convertComments)
-import Language.PureScript.Docs.Types qualified as Docs
-import Language.PureScript.Errors (Literal (..))
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (EverythingAtPos (..), binderSourceSpan, getEverythingAtPos, getImportRefNameType, modifySmallestBinderAtPos, modifySmallestExprAtPos, showCounts, smallestExpr', smallestType, spanToRange, debugExpr)
-import Language.PureScript.Lsp.Cache (selectDependencies)
+import Language.PureScript.Lsp.AtPosition (binderSourceSpan, spanToRange)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.Rebuild (buildExportEnvCacheAndHandleErrors)
-import Language.PureScript.Lsp.ServerConfig (getInferExpressions)
-import Language.PureScript.Lsp.State (cachedRebuild, getExportEnv)
-import Language.PureScript.Lsp.Types (ExternDependency (edExtern), OpenFile (..))
+import Language.PureScript.Lsp.State (cachedRebuild)
+import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
-import Language.PureScript.Sugar.Names.Env qualified as P
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, debugIdeArtifact)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
 import Protolude hiding (handle, to)
 import Text.PrettyPrint.Boxes (render)
 
@@ -51,48 +41,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
-      respondWithDeclInModule :: P.SourceSpan -> LspNameType -> P.ModuleName -> Text -> HandlerM ()
-      respondWithDeclInModule ss nameType modName ident = do
-        docs <- readDeclarationDocsWithNameType modName nameType ident
-        foundTypes <- getAstDeclarationTypeInModule (Just nameType) modName ident
-        debugLsp $ "respondWithDeclInModule " <> show (modName, ident)
-        debugLsp $ "Found types: " <> show foundTypes
-        debugLsp $ "Found docs: " <> show (isJust docs)
-        markdownRes (Just $ spanToRange ss) $
-          joinMarkup
-            [ showTypeSection modName ident <$> head foundTypes,
-              showDocs <$> docs
-            ]
-
-      respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
-      respondWithModule ss modName = do
-        docsMb <- readModuleDocs modName
-        case docsMb of
-          Just docs | Just comments <- Docs.modComments docs -> markdownRes (Just $ spanToRange ss) comments
-          _ -> nullRes
-
-      respondWithImport :: P.SourceSpan -> P.ModuleName -> Maybe P.DeclarationRef -> HandlerM ()
-      respondWithImport ss importedModuleName (Just ref) = do
-        let name = P.declRefName ref
-            nameType = getImportRefNameType ref
-        respondWithDeclInModule ss nameType importedModuleName (printName name)
-      respondWithImport ss importedModuleName _ = respondWithModule ss importedModuleName
-
-      handleLiteral :: P.SourceSpan -> P.Literal a -> HandlerM ()
-      handleLiteral ss = \case
-        P.NumericLiteral (Left int) -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show int) (Just "Int") [])
-        P.NumericLiteral (Right n) -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show n) (Just "Number") [])
-        P.StringLiteral str -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (ellipsis 64 $ show str) (Just "String") [])
-        P.CharLiteral ch -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show ch) (Just "Char") [])
-        P.BooleanLiteral b -> do
-          markdownRes (Just $ spanToRange ss) (pursTypeStr (show b) (Just "Boolean") [])
-        -- should not be reachable
-        _ -> nullRes
-
       lookupExprTypes :: P.Expr -> HandlerM [Text]
       lookupExprTypes = \case
         P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
@@ -116,23 +64,13 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
         P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
           readDeclarationDocsWithNameType modName DctorNameType (P.runProperName dctor)
         _ -> pure Nothing
-  debugLsp $ "Hover request for: " <> show filePathMb
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     debugLsp $ "Cache found: " <> show (isJust cacheOpenMb)
     forLsp cacheOpenMb \OpenFile {..} -> do
-      let everything = getEverythingAtPos (P.getModuleDeclarations ofModule) startPos
-          respondWithCounts = markdownRes Nothing $ showCounts everything
-          atPos = getArtifactsAtPosition (positionToSourcePos startPos) (P.checkIdeArtifacts ofEndCheckState)
-      -- debugLsp $ showCounts everything
-      debugLsp $ "at pos len: " <> show (length atPos)
-      debugLsp $ "smallest: " <> (ellipsis 512 . show) (debugExpr . iaValue <$> smallestArtifact atPos)
-      for_ atPos \a -> do 
-        debugLsp $ debugIdeArtifact a
-        case iaValue a of 
-          IaExpr label e -> debugLsp $ "Expr: " <> label <> "\n" <>  (ellipsis 256 $ debugExpr e)
-          _ -> pure ()
-      case smallestArtifact atPos of
+      let atPos = getArtifactsAtPosition (positionToSourcePos startPos) (P.checkIdeArtifacts ofEndCheckState)
+      debugLsp $ "hover artiacts length: " <> show (length atPos)
+      case smallestArtifact (negate . artifactInterest) atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
             IaExpr _ expr -> do
@@ -178,63 +116,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (maybe "_" printName $ P.declName decl) (Just $ prettyPrintTypeSingleLine iaType) []
             IaType ty -> do
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (prettyPrintTypeSingleLine ty) (Just $ prettyPrintTypeSingleLine iaType) []
-        _ ->
-          case head $ apImport everything of
-            Just (ss, importedModuleName, _, ref) -> do
-              respondWithImport ss importedModuleName ref
-            _ -> do
-              case smallestExpr' (view _3) $ filter (not . (isAbs <||> generatedExpr) . view _3) $ apExprs everything of
-                Just (_, _, P.Literal ss literal) | isLiteralNode literal -> handleLiteral ss literal
-                Just (ss, _, foundExpr) -> do
-                  inferredRes <- inferExprViaTypeHoleText filePath startPos
-                  foundTypes <- lookupExprTypes foundExpr
-                  docs <- lookupExprDocs foundExpr
-                  markdownRes (Just $ spanToRange ss) $
-                    joinMarkup
-                      [ inferredRes <|> Just (dispayExprOnHover foundExpr),
-                        head foundTypes,
-                        showDocs <$> docs
-                      ]
-                Nothing -> do
-                  binderInferredRes <- inferBinderViaTypeHole filePath startPos
-                  case binderInferredRes of
-                    Just (binder, ty) -> do
-                      debugLsp $ "Found binder: " <> show binder
-                      markdownRes
-                        (spanToRange <$> binderSourceSpan binder)
-                        (pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine ty) [])
-                    Nothing -> do
-                      case smallestType $ apTypes everything of
-                        Just (P.ConstrainedType ann (P.Constraint _ (P.Qualified (P.ByModuleName mName) ident) _ _ _) _) -> do
-                          debugLsp $ "Found constrained type: " <> show ident
-                          respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
-                        Just (P.TypeConstructor ann (P.Qualified (P.ByModuleName mName) name)) | P.runProperName name /= "Type" -> do
-                          debugLsp $ "Found type constructor: " <> show name
-                          respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
-                        Just (P.TypeOp ann (P.Qualified (P.ByModuleName mName) name)) -> do
-                          debugLsp $ "Found type op: " <> show name
-                          respondWithDeclInModule (fst ann) TyOpNameType mName (P.runOpName name)
-                        _ -> do
-                          debugLsp "Looking for unsugared types"
-                          let typesBeforeSugaring = apTypes $ getEverythingAtPos (P.getModuleDeclarations ofUncheckedModule) startPos
-                          case smallestType typesBeforeSugaring of
-                            Just ty -> do
-                              exportEnv <- getExportEnv
-                              let imports = maybe P.nullImports (view _2) $ M.lookup ofModuleName exportEnv
-
-                              case ty of
-                                P.TypeConstructor ann q@(P.Qualified _ name) | P.runProperName name /= "Type" -> do
-                                  let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypes imports)
-                                  respondWithDeclInModule (fst ann) TyNameType mName (P.runProperName name)
-                                P.ConstrainedType ann (P.Constraint _ q@(P.Qualified _ ident) _ _ _) _ -> do
-                                  let mName = fromMaybe ofModuleName $ fmap P.importSourceModule . head =<< M.lookup q (P.importedTypeClasses imports)
-                                  respondWithDeclInModule (fst ann) TyClassNameType mName $ P.runProperName ident
-                                _ -> do
-                                  markdownRes
-                                    (Just $ spanToRange $ fst $ P.getAnnForType ty)
-                                    (pursTypeStr (prettyPrintTypeSingleLine ty) Nothing [])
-                            Nothing -> do
-                              respondWithCounts
+        _ -> nullRes
 
 showTypeSection :: P.ModuleName -> Text -> Text -> Text
 showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
@@ -242,152 +124,25 @@ showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd
 showDocs :: Text -> Text
 showDocs d = "**Docs**\n" <> d
 
-isLiteralNode :: Literal P.Expr -> Bool
-isLiteralNode = \case
-  NumericLiteral _ -> True
-  StringLiteral _ -> True
-  CharLiteral _ -> True
-  BooleanLiteral _ -> True
-  _ -> False
-
 joinMarkup :: [Maybe Text] -> Text
 joinMarkup = T.intercalate "\n---\n" . catMaybes
 
-inferExprViaTypeHoleText :: FilePath -> Types.Position -> HandlerM (Maybe Text)
-inferExprViaTypeHoleText filePath pos =
-  inferExprViaTypeHole filePath pos <&> fmap \(expr, t) ->
-    pursTypeStr (dispayExprOnHover expr) (Just $ prettyPrintTypeSingleLine t) []
-
-inferExprViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Expr, P.SourceType))
-inferExprViaTypeHole = inferViaTypeHole (modifySmallestExprAtPos addExprTypeHoleAnnotation)
-
-inferBinderViaTypeHole :: FilePath -> Types.Position -> HandlerM (Maybe (P.Binder, P.SourceType))
-inferBinderViaTypeHole = inferViaTypeHole (modifySmallestBinderAtPos addBinderTypeHoleAnnotation)
-
-inferViaTypeHole ::
-  ( Types.Position ->
-    P.Module ->
-    (P.Module, Maybe (a, a))
-  ) ->
-  FilePath ->
-  Types.Position ->
-  HandlerM (Maybe (a, P.SourceType))
-inferViaTypeHole addHole filePath pos = do
-  shouldInferUsingTypeHole <- getInferExpressions
-  if not shouldInferUsingTypeHole
-    then pure Nothing
-    else do
-      cacheOpenMb <- cachedRebuild filePath
-      cacheOpenMb & maybe (pure Nothing) \OpenFile {..} -> do
-        let module' = P.importPrim ofUncheckedModule
-            (moduleWithHole, values) = addHole pos module'
-        case values of
-          Nothing -> pure Nothing
-          Just (valueBefore, _valueAfter) -> do
-            let externs = fmap edExtern ofDependencies
-            (exportEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
-            (checkRes, warnings) <-
-              runWriterT $
-                runExceptT $
-                  P.desugarAndTypeCheck P.emptyCheckState Nothing ofModuleName externs moduleWithHole exportEnv ofStartingEnv
-            case checkRes of
-              Right _ -> pure $ (valueBefore,) <$> findHoleType warnings
-              Left errs -> do
-                pure $
-                  (valueBefore,) <$> findHoleType (warnings <> errs)
-
--- inferOnDeclViaTypeHole ::
---   ( Types.Position ->
---     P.Module ->
---     Maybe (P.Declaration, Maybe (a, a))
---   ) ->
---   FilePath ->
---   Types.Position ->
---   HandlerM (Maybe (a, P.SourceType))
--- inferOnDeclViaTypeHole addHole filePath pos = do
---   shouldInferUsingTypeHole <- getInferExpressions
---   if not shouldInferUsingTypeHole
---     then pure Nothing
---     else do
---       cacheOpenMb <- cachedRebuild filePath
---       cacheOpenMb & maybe (pure Nothing) \OpenFile {..} -> do
---         let module' = P.importPrim ofUncheckedModule
---             withHole = addHole pos module'
---         case withHole of
---           Just (declWithHole, Just (valueBefore, _valueAfter)) -> do
---             let externs = fmap edExtern ofDependencies
---             (exEnv, _) <- buildExportEnvCacheAndHandleErrors (selectDependencies module') module' externs
---             (checkRes, warnings) <-
---               runWriterT $
---                 runExceptT $
---                   evalSupplyT 0 $
---                     evalStateT
---                       (typeCheckDecl (view _3 <$> exEnv) ofModuleName (P.getModuleDeclarations module') declWithHole)
---                       ((P.emptyCheckState $ removeDeclFromEnv ofModuleName declWithHole ofEndEnv) {P.checkCurrentModule = Just ofModuleName})
-
---             case checkRes of
---               Right _ -> do
---                 debugLsp "Decl hole error not found"
---                 pure $ (valueBefore,) <$> findHoleType warnings
---               Left errs -> do
---                 debugLsp $ "Errors: \n" <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions errs)
---                 pure $
---                   (valueBefore,) <$> findHoleType (warnings <> errs)
---           _ -> do
---             warnLsp "Decl with hole not found"
---             pure Nothing
---   where
---     typeCheckDecl modulesExports mn decls decl = do
---       let (_, imports) = partitionEithers $ fromImportDecl modulesExports <$> decls
---       modify (\s -> s {P.checkCurrentModule = Just mn, P.checkCurrentModuleImports = imports})
---       P.typeCheckAll mn [ignoreWildcardsUnderCompleteTypeSignatures decl]
-
---     fromImportDecl ::
---       M.Map P.ModuleName P.Exports ->
---       P.Declaration ->
---       Either
---         P.Declaration
---         ( P.SourceAnn,
---           P.ModuleName,
---           P.ImportDeclarationType,
---           Maybe P.ModuleName,
---           M.Map (P.ProperName 'P.TypeName) ([P.ProperName 'P.ConstructorName], P.ExportSource)
---         )
---     fromImportDecl modulesExports (P.ImportDeclaration sa moduleName' importDeclarationType asModuleName) =
---       Right (sa, moduleName', importDeclarationType, asModuleName, foldMap P.exportedTypes $ M.lookup moduleName' modulesExports)
---     fromImportDecl _ decl = Left decl
-
--- removeDeclFromEnv :: P.ModuleName -> P.Declaration -> P.Environment -> P.Environment
--- removeDeclFromEnv mName decl env = case decl of
---   P.ValueDecl _ ident _ _ _ -> env {E.names = M.delete (P.Qualified (P.ByModuleName mName) ident) (E.names env)}
---   _ -> env
-
-findHoleType :: P.MultipleErrors -> Maybe P.SourceType
-findHoleType = P.runMultipleErrors >>> findMap getHoverHoleType
-
-getHoverHoleType :: P.ErrorMessage -> Maybe P.SourceType
-getHoverHoleType =
-  P.unwrapErrorMessage >>> \case
-    P.HoleInferredType label t _ _ | label == hoverHoleLabel -> Just t
-    _ -> Nothing
-
-findMap :: (a -> Maybe b) -> [a] -> Maybe b
-findMap f = listToMaybe . mapMaybe f
-
-addExprTypeHoleAnnotation :: P.Expr -> P.Expr
-addExprTypeHoleAnnotation expr = P.TypedValue False expr (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel)
-
-addBinderTypeHoleAnnotation :: P.Binder -> P.Binder
-addBinderTypeHoleAnnotation b = P.ParensInBinder (P.TypedBinder (P.TypeWildcard P.nullSourceAnn $ P.HoleWildcard hoverHoleLabel) b) -- parens seems to be needed. For some desugaring reason?
-
-hoverHoleLabel :: Text
-hoverHoleLabel = "HOVER"
-
-isAbs :: P.Expr -> Bool
-isAbs = \case
-  P.Abs _ _ -> True
-  P.TypedValue _ e _ -> isAbs e
-  _ -> False
+-- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
+artifactInterest :: IdeArtifact -> Int
+artifactInterest (IdeArtifact {..}) = case iaValue of
+  IaBinder {} -> 1
+  IaTypeName {} -> 1
+  IaClassName {} -> 1
+  IaExpr _ _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
+  _ -> 0
+
+countUnkownsAndVars :: P.Type a -> Int
+countUnkownsAndVars = P.everythingOnTypes (+) go
+  where
+    go :: P.Type a -> Int
+    go (P.TUnknown _ _) = 1
+    go (P.TypeVar _ _) = 1
+    go _ = 0
 
 generatedExpr :: P.Expr -> Bool
 generatedExpr = \case
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index dfd511b881..c01e10b382 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -342,6 +342,7 @@ typeCheckAll moduleName = traverse go
           addValue moduleName name ty nameKind
           addIdeDecl d ty
           addIdeIdent ss name ty
+          endIdeSubstitutions
           return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
         _ -> internalError "typesOf did not return a singleton"
   go ValueDeclaration{} = internalError "Binders were not desugared"
@@ -361,6 +362,7 @@ typeCheckAll moduleName = traverse go
         addValue moduleName name ty nameKind
         addIdeIdent ss name ty
         return (sai, nameKind, val)
+      endIdeSubstitutions
       return . BindingGroupDeclaration $ NEL.fromList vals''
   go d@(ExternDataDeclaration (ss, _) name kind) = do
     warnAndRethrow (addHint (ErrorInForeignImportData name) . addHint (positionedError ss)) $ do
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 6b1396c41f..56a290a92a 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -4,7 +4,6 @@ module Language.PureScript.TypeChecker.IdeArtifacts
   ( IdeArtifacts,
     IdeArtifact (..),
     IdeArtifactValue (..),
-    UnResolvedExpr (..),
     getArtifactsAtPosition,
     emptyIdeArtifacts,
     insertIaExpr,
@@ -18,8 +17,8 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     insertIaClassName,
     moduleNameFromQual,
     debugIdeArtifact,
-    onUnresolvedExprs,
-    resolveExprs,
+    substituteArtifactTypes,
+    endSubstitutions,
   )
 where
 
@@ -42,7 +41,7 @@ import Text.PrettyPrint.Boxes (render)
 data IdeArtifacts
   = IdeArtifacts
       (Map Line [IdeArtifact]) -- with substitutions
-      (Map Line [UnResolvedExpr]) -- without substitutions
+      (Map Line [IdeArtifact]) -- without substitutions
   deriving (Show)
 
 type Line = Int
@@ -77,33 +76,17 @@ data IdeArtifactValue
   | IaClassName (P.ProperName 'P.ClassName)
   deriving (Show)
 
-data UnResolvedExpr = UnResolvedExpr
-  { urSpan :: P.SourceSpan,
-    urLabel :: Text,
-    urExpr :: P.Expr,
-    urType :: P.SourceType,
-    urDefinitionModule :: Maybe P.ModuleName,
-    urDefinitionPos :: Maybe (Either P.SourcePos P.SourceSpan)
-  }
-  deriving (Show)
-
-onUnresolvedExprs :: (UnResolvedExpr -> UnResolvedExpr) -> IdeArtifacts -> IdeArtifacts
-onUnresolvedExprs f (IdeArtifacts m u) = IdeArtifacts m (Map.map (fmap f) u)
-
-resolveExprs :: IdeArtifacts -> IdeArtifacts
-resolveExprs (IdeArtifacts m u) = IdeArtifacts (Map.unionWith (<>) m exprArtifacts) Map.empty
-  where
-    exprArtifacts :: Map Line [IdeArtifact]
-    exprArtifacts = Map.foldrWithKey resolve Map.empty u
+substituteArtifactTypes :: (P.SourceType -> P.SourceType) -> IdeArtifacts -> IdeArtifacts
+substituteArtifactTypes f (IdeArtifacts m u) = IdeArtifacts m (Map.map (fmap (onArtifactType f)) u)
 
-    resolve line exprs = Map.insertWith (<>) line newArtifacts
-      where
-        newArtifacts = fmap newArtifact exprs
-        newArtifact  (UnResolvedExpr {..}) = IdeArtifact urSpan (IaExpr urLabel urExpr) urType urDefinitionModule urDefinitionPos
+onArtifactType :: (P.SourceType -> P.SourceType) -> IdeArtifact -> IdeArtifact
+onArtifactType f (IdeArtifact {..}) = IdeArtifact iaSpan iaValue (f iaType) iaDefinitionModule iaDefinitionPos
 
+endSubstitutions :: IdeArtifacts -> IdeArtifacts
+endSubstitutions (IdeArtifacts m u) = IdeArtifacts (Map.unionWith (<>) m u) Map.empty
 
-smallestArtifact :: [IdeArtifact] -> Maybe IdeArtifact
-smallestArtifact = minimumByMay (compare `on` (\a -> (artifactSize a, negate $ artifactInterest a)))
+smallestArtifact :: Ord a => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
+smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
 artifactSize :: IdeArtifact -> (Int, Int)
 artifactSize (IdeArtifact {..}) =
@@ -111,22 +94,7 @@ artifactSize (IdeArtifact {..}) =
     P.sourcePosColumn (P.spanEnd iaSpan) - P.sourcePosColumn (P.spanStart iaSpan)
   )
 
--- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
-artifactInterest :: IdeArtifact -> Int
-artifactInterest (IdeArtifact {..}) = case iaValue of
-  IaBinder {} -> 1
-  IaTypeName {} -> 1
-  IaClassName {} -> 1
-  IaExpr _ _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
-  _ -> 0
-
-countUnkownsAndVars :: P.Type a -> Int
-countUnkownsAndVars = P.everythingOnTypes (+) go
-  where
-    go :: P.Type a -> Int
-    go (P.TUnknown _ _) = 1
-    go (P.TypeVar _ _) = 1
-    go _ = 0
+
 
 getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
 getArtifactsAtPosition pos (IdeArtifacts m _) =
@@ -138,7 +106,7 @@ getArtifactsAtPosition pos (IdeArtifacts m _) =
 
 insertIaExpr :: Text -> P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaExpr label expr ty = case ss of
-  Just span | not (generatedExpr expr) -> insertUnresolvedExprAtLines (UnResolvedExpr span label expr ty mName defSpan)
+  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr label expr) ty mName defSpan
   _ -> identity
   where
     ss = P.exprSourceSpan expr
@@ -199,13 +167,10 @@ moduleNameFromQual (P.Qualified (P.ByModuleName mn) _) = Just mn
 moduleNameFromQual _ = Nothing
 
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
-insertAtLines span value ty mName defSpan (IdeArtifacts m u) = IdeArtifacts (foldr insert m (linesFromSpan span)) u
+insertAtLines span value ty mName defSpan (IdeArtifacts m u) = IdeArtifacts m (foldr insert u (linesFromSpan span))
   where
     insert line = Map.insertWith (<>) line [IdeArtifact span value ty mName defSpan]
-
-insertUnresolvedExprAtLines :: UnResolvedExpr -> IdeArtifacts -> IdeArtifacts
-insertUnresolvedExprAtLines expr (IdeArtifacts m u) = IdeArtifacts m (Map.insertWith (<>) (P.sourcePosLine $ P.spanStart $ urSpan expr) [expr] u)
-
+    
 linesFromSpan :: P.SourceSpan -> [Line]
 linesFromSpan ss = [P.sourcePosLine $ P.spanStart ss .. P.sourcePosLine $ P.spanEnd ss]
 
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 5b8be24f75..52b180c122 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -29,7 +29,7 @@ import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, onUnresolvedExprs, UnResolvedExpr, resolveExprs)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, endSubstitutions)
 import Protolude (whenM)
 import Language.PureScript.AST.Binders (Binder)
 import Language.PureScript.AST.Declarations (Declaration)
@@ -414,11 +414,11 @@ onIdeArtifacts :: MonadState CheckState m => (IdeArtifacts -> IdeArtifacts) -> m
 onIdeArtifacts f = whenM (gets checkAddIdeArtifacts)  
   $ modify $ \env -> env { checkIdeArtifacts = f (checkIdeArtifacts env) }
 
-onUnresolvedIdeExprs :: MonadState CheckState m => (UnResolvedExpr -> UnResolvedExpr) -> m ()
-onUnresolvedIdeExprs = onIdeArtifacts . onUnresolvedExprs
+substituteIdeTypes :: MonadState CheckState m => (SourceType -> SourceType) -> m ()
+substituteIdeTypes = onIdeArtifacts . substituteArtifactTypes
 
-resolveIdeExprs :: MonadState CheckState m => m ()
-resolveIdeExprs = onIdeArtifacts resolveExprs
+endIdeSubstitutions :: MonadState CheckState m => m ()
+endIdeSubstitutions = onIdeArtifacts endSubstitutions
 
 debugEnv :: Environment -> [String]
 debugEnv env = join
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 55b4a9ea88..4b68e49816 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 -- |
 -- This module implements the type checker
 --
@@ -65,7 +66,6 @@ import Language.PureScript.Types
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.PSString (PSString)
 import Data.Text qualified as T
-import Language.PureScript.TypeChecker.IdeArtifacts (UnResolvedExpr(urType))
 
 data BindingGroupType
   = RecursiveBindingGroup
@@ -196,17 +196,10 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     raisePreviousWarnings False wInfer
     forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
       raisePreviousWarnings shouldGeneralize w
-      onUnresolvedIdeExprs $ replaceIdeExprTypes (checkSubstitution finalState)
+      substituteIdeTypes $ substituteType (checkSubstitution finalState)
     
-    resolveIdeExprs
     return $  map fst inferred 
   where
-    replaceIdeExprTypes
-      :: Substitution
-      -> UnResolvedExpr
-      -> UnResolvedExpr
-    replaceIdeExprTypes subst e = e { urType = substituteType subst (urType e) }
-
     replaceErrorTypes
       :: Substitution
       -> ErrorMessage
@@ -1039,13 +1032,13 @@ checkFunctionApplication' fn (TypeApp ann (TypeApp ann' tyFunction' argTy) retTy
   unifyTypes tyFunction' tyFunction
   tv@(TypedValue' _ _ argTy') <- check arg argTy
   let arg' = tvToExpr tv
-  whenM (gets checkAddIdeArtifacts) do
-    let 
-        retTy' = case argTy of
-          TypeVar _ v -> replaceTypeVars v argTy' retTy
-          TUnknown _ u -> replaceUnknowns u argTy' retTy
-          _ -> retTy
-    addIdeExpr ("1028: " <> T.pack (show argTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
+  -- whenM (gets checkAddIdeArtifacts) do
+  --   let 
+  --       retTy' = case argTy of
+  --         TypeVar _ v -> replaceTypeVars v argTy' retTy
+  --         TUnknown _ u -> replaceUnknowns u argTy' retTy
+  --         _ -> retTy
+  --   addIdeExpr ("1028: " <> T.pack (show argTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
   return (retTy, App fn arg')
 checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do
   u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK
@@ -1081,7 +1074,6 @@ checkFunctionApplication' fn u arg = do
     return $ TypedValue' True arg'' t'
   ret <- freshTypeWithKind kindType
   unifyTypes u (function ty ret)
-  addIdeExpr "69" fn (function ty ret)
   return (ret, App fn (tvToExpr tv))
 
 

From 6bc73833b68e5092323acb66f43828ff3a7a1406 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 4 Nov 2024 08:06:26 +0100
Subject: [PATCH 224/297] on purs projects hover is running fast but without
 type substituion

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 75 ++++-----------
 src/Language/PureScript/Lsp/Rebuild.hs        | 35 ++++---
 src/Language/PureScript/TypeChecker.hs        |  1 -
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 91 +++++++++++++------
 src/Language/PureScript/TypeChecker/Monad.hs  |  4 +-
 src/Language/PureScript/TypeChecker/Types.hs  | 35 ++++---
 6 files changed, 122 insertions(+), 119 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 485754d276..4e2db35fec 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -20,13 +20,11 @@ import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
-import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
 import Protolude hiding (handle, to)
-import Text.PrettyPrint.Boxes (render)
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
@@ -41,29 +39,16 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
-      lookupExprTypes :: P.Expr -> HandlerM [Text]
-      lookupExprTypes = \case
-        P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-          fmap (showTypeSection modName (P.runIdent ident)) <$> getAstDeclarationTypeInModule (Just IdentNameType) modName (P.runIdent ident)
-        P.Op _ (P.Qualified (P.ByModuleName modName) op) -> do
-          fmap (showTypeSection modName (P.runOpName op)) <$> getAstDeclarationTypeInModule (Just ValOpNameType) modName (P.runOpName op)
-        P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
-          fmap (showTypeSection modName (P.runProperName dctor)) <$> getAstDeclarationTypeInModule (Just DctorNameType) modName (P.runProperName dctor)
-        P.TypedValue _ e _ | not (generatedExpr e) -> do
-          lookupExprTypes e
-        P.PositionedValue _ _ e | not (generatedExpr e) -> do
-          lookupExprTypes e
-        _ -> pure []
-
-      lookupExprDocs :: P.Expr -> HandlerM (Maybe Text)
-      lookupExprDocs = \case
-        P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do
-          readDeclarationDocsWithNameType modName IdentNameType (P.runIdent ident)
-        P.Op _ (P.Qualified (P.ByModuleName modName) op) -> do
-          readDeclarationDocsWithNameType modName ValOpNameType (P.runOpName op)
-        P.Constructor _ (P.Qualified (P.ByModuleName modName) dctor) -> do
-          readDeclarationDocsWithNameType modName DctorNameType (P.runProperName dctor)
-        _ -> pure Nothing
+      lookupExprTypes :: Maybe Text -> Maybe P.ModuleName -> Maybe LspNameType -> HandlerM [Text]
+      lookupExprTypes (Just ident) (Just modName) nameType = 
+          fmap (showTypeSection modName  ident) <$> getAstDeclarationTypeInModule nameType modName ident
+      lookupExprTypes _ _ _ = pure []
+
+      lookupExprDocs :: Maybe Text -> Maybe P.ModuleName -> Maybe LspNameType -> HandlerM (Maybe Text)
+      lookupExprDocs (Just ident) (Just modName) (Just nameType) = 
+          readDeclarationDocsWithNameType modName nameType ident
+      lookupExprDocs _ _ _ = pure Nothing
+
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     debugLsp $ "Cache found: " <> show (isJust cacheOpenMb)
@@ -73,10 +58,10 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       case smallestArtifact (negate . artifactInterest) atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
-            IaExpr _ expr -> do
-              let inferredRes = pursTypeStr (dispayExprOnHover expr) (Just $ prettyPrintTypeSingleLine iaType) []
-              foundTypes <- lookupExprTypes expr
-              docs <- lookupExprDocs expr
+            IaExpr exprTxt ident nameType -> do
+              let inferredRes = pursTypeStr exprTxt (Just $ prettyPrintTypeSingleLine iaType) []
+              foundTypes <- lookupExprTypes ident iaDefinitionModule nameType
+              docs <- lookupExprDocs ident iaDefinitionModule nameType
               markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
                   [ Just inferredRes,
@@ -112,8 +97,8 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             IaBinder binder -> do
               let inferredRes = pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine iaType) []
               markdownRes (spanToRange <$> binderSourceSpan binder) inferredRes
-            IaDecl decl -> do
-              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (maybe "_" printName $ P.declName decl) (Just $ prettyPrintTypeSingleLine iaType) []
+            IaDecl decl _ -> do
+              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (fromMaybe "_" decl) (Just $ prettyPrintTypeSingleLine iaType) []
             IaType ty -> do
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (prettyPrintTypeSingleLine ty) (Just $ prettyPrintTypeSingleLine iaType) []
         _ -> nullRes
@@ -133,7 +118,7 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   IaBinder {} -> 1
   IaTypeName {} -> 1
   IaClassName {} -> 1
-  IaExpr _ _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
+  IaExpr _ _ _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
   _ -> 0
 
 countUnkownsAndVars :: P.Type a -> Int
@@ -144,32 +129,6 @@ countUnkownsAndVars = P.everythingOnTypes (+) go
     go (P.TypeVar _ _) = 1
     go _ = 0
 
-generatedExpr :: P.Expr -> Bool
-generatedExpr = \case
-  P.Var _ ident -> generatedIdent $ P.disqualify ident
-  P.Abs b e -> generatedBinder b || generatedExpr e
-  P.App e e' -> generatedExpr e || generatedExpr e'
-  P.TypedValue _ e _ -> generatedExpr e
-  P.PositionedValue _ _ e -> generatedExpr e
-  P.Case es _ -> any generatedExpr es
-  _ -> False
-
-generatedBinder :: P.Binder -> Bool
-generatedBinder = \case
-  P.VarBinder ss ident -> (ss == P.nullSourceSpan) || generatedIdent ident
-  P.NamedBinder ss ident _ -> (ss == P.nullSourceSpan) || generatedIdent ident
-  _ -> False
-
-generatedIdent :: P.Ident -> Bool
-generatedIdent = \case
-  P.GenIdent {} -> True
-  _ -> False
-
-dispayExprOnHover :: P.Expr -> T.Text
-dispayExprOnHover (P.Op _ (P.Qualified _ op)) = P.runOpName op -- Op's hit an infinite loop when pretty printed by themselves
-dispayExprOnHover (P.Case _ _) = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
-dispayExprOnHover expr = ellipsis 128 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 8 expr
-
 dispayBinderOnHover :: P.Binder -> T.Text
 dispayBinderOnHover binder = ellipsis 32 $ on1Line $ T.strip $ P.prettyPrintBinder binder
 
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 6655a799ff..ee0fbc33dc 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -16,12 +16,14 @@ import Language.LSP.Server (MonadLsp, getConfig)
 import Language.PureScript (ExternsFile (efModuleName), primEnv)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
+import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors qualified as P
+import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies)
 import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getMaxFilesInCache)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
 import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheDependencies, cacheRebuild', cachedRebuild, getDbConn, mergeExportEnvCache, updateCachedModule, updateCachedModule')
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern, edLevel), LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile, ofDependencies))
 import Language.PureScript.Make qualified as P
@@ -29,10 +31,8 @@ import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Options qualified as P
 import Language.PureScript.Sugar.Names qualified as P
-import Protolude hiding (moduleName, race, race_, threadDelay)
 import Language.PureScript.TypeChecker qualified as P
-import Language.PureScript.Environment qualified as P
-import Language.PureScript.Externs qualified as P
+import Protolude hiding (moduleName, race, race_, threadDelay)
 
 rebuildFile ::
   forall m.
@@ -87,6 +87,7 @@ rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName
   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
   (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
   for_ externsMb (cacheDependencies moduleName)
+  ideCheckState <- getIdeCheckState
   res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
       newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState (Just $ updateCachedModule' stVar) (mkMakeActions foreigns externDeps) exportEnv env externs m Nothing
@@ -101,11 +102,17 @@ rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName
       rebuildWithoutCache moduleName mkMakeActions fp pwarnings m
     _ -> handleRebuildResult fp pwarnings res
 
-ideCheckState :: P.Environment -> P.CheckState
-ideCheckState env =
-  (P.emptyCheckState env)
-    { P.checkAddIdeArtifacts = True
-    }
+getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment  -> P.CheckState)
+getIdeCheckState = 
+  ideCheckState <$> getInferExpressions
+
+  where 
+
+    ideCheckState :: Bool -> P.Environment -> P.CheckState
+    ideCheckState infer env =
+      (P.emptyCheckState env)
+        { P.checkAddIdeArtifacts = infer
+        }
 
 rebuildWithoutCache ::
   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
@@ -121,20 +128,20 @@ rebuildWithoutCache moduleName mkMakeActions fp pwarnings m = do
   let externs = fmap edExtern externDeps
   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
   exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
+  ideCheckState <- getIdeCheckState
   res <- logPerfStandard "Rebuild Module" $ liftIO $ do
     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-      newExtern <- rebuildModule' (mkMakeActions foreigns externDeps) exportEnv externs m
+      newExtern <- rebuildModule' ideCheckState (mkMakeActions foreigns externDeps) exportEnv externs m
       updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
       pure newExtern
   handleRebuildResult fp pwarnings res
-  where 
-    rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing
+  where
+    rebuildModule' ideCheckState act env ext mdl = rebuildModuleWithIndex ideCheckState act env ext mdl Nothing
 
-    rebuildModuleWithIndex act exEnv externs m' moduleIndex = do
+    rebuildModuleWithIndex ideCheckState act exEnv externs m' moduleIndex = do
       let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
       P.rebuildModuleWithProvidedEnv ideCheckState Nothing act exEnv env externs m' moduleIndex
 
-
 handleRebuildResult :: (MonadLsp ServerConfig f, MonadReader LspEnvironment f) => FilePath -> [CST.ParserWarning] -> (Either P.MultipleErrors ExternsFile, P.MultipleErrors) -> f RebuildResult
 handleRebuildResult fp pwarnings (result, warnings) = do
   case result of
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index c01e10b382..a3cf489407 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -295,7 +295,6 @@ typeCheckAll moduleName = traverse go
         checkDuplicateTypeArguments $ map fst args'
         let args'' = args' `withRoles` inferRoles' name args'
         addDataType moduleName dtype name args'' dataCtors ctorKind
-        -- addIdeTypeName (Just moduleName) _ name ctorKind
       for_ roleDecls $ checkRoleDeclaration moduleName
       for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do
         let qualifiedClassName = Qualified (ByModuleName moduleName) pn
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 56a290a92a..53da1ae317 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 -- | Stores information about the source code that is useful for the IDE
 -- | This includes value types and source spans
 module Language.PureScript.TypeChecker.IdeArtifacts
@@ -29,6 +30,7 @@ import Data.Text qualified as T
 import Language.PureScript.AST.Binders qualified as P
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.SourcePos qualified as P
+import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Pretty.Types qualified as P
@@ -67,8 +69,8 @@ data IdeArtifact = IdeArtifact
   deriving (Show)
 
 data IdeArtifactValue
-  = IaExpr Text P.Expr
-  | IaDecl P.Declaration
+  = IaExpr Text (Maybe Text) (Maybe LspNameType)
+  | IaDecl (Maybe Text) (Maybe LspNameType)
   | IaBinder P.Binder
   | IaIdent Text
   | IaType P.SourceType
@@ -85,7 +87,7 @@ onArtifactType f (IdeArtifact {..}) = IdeArtifact iaSpan iaValue (f iaType) iaDe
 endSubstitutions :: IdeArtifacts -> IdeArtifacts
 endSubstitutions (IdeArtifacts m u) = IdeArtifacts (Map.unionWith (<>) m u) Map.empty
 
-smallestArtifact :: Ord a => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
+smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
 smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
 artifactSize :: IdeArtifact -> (Int, Int)
@@ -94,8 +96,6 @@ artifactSize (IdeArtifact {..}) =
     P.sourcePosColumn (P.spanEnd iaSpan) - P.sourcePosColumn (P.spanStart iaSpan)
   )
 
-
-
 getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
 getArtifactsAtPosition pos (IdeArtifacts m _) =
   Map.lookup (P.sourcePosLine pos) m
@@ -104,24 +104,50 @@ getArtifactsAtPosition pos (IdeArtifacts m _) =
   where
     posCol = P.sourcePosColumn pos
 
-insertIaExpr :: Text -> P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
-insertIaExpr label expr ty = case ss of
-  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr label expr) ty mName defSpan
+insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertIaExpr expr ty =  case ss of
+  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr "_" exprIdent exprNameType) ty mName defSpan
+    where
+      defSpan =
+        Left <$> case expr of
+          P.Var _ q -> posFromQual q
+          P.Constructor _ q -> posFromQual q
+          P.Op _ q -> posFromQual q
+          _ -> Nothing
+
+      mName = case expr of
+        P.Var _ q -> moduleNameFromQual q
+        P.Constructor _ q -> moduleNameFromQual q
+        P.Op _ q -> moduleNameFromQual q
+        _ -> Nothing
+
+      exprIdent :: Maybe Text
+      exprIdent = case expr of
+        P.Var _ ident -> Just $ P.runIdent $ P.disqualify ident
+        P.Constructor _ q -> Just $ P.runProperName $ P.disqualify q
+        P.Op _ q -> Just $ P.runOpName $ P.disqualify q
+        _ -> Nothing
+
+      exprNameType :: Maybe LspNameType
+      exprNameType = case expr of
+        P.Var _ _ -> Just IdentNameType
+        P.Constructor _ _ -> Just DctorNameType
+        P.Op _ _ -> Just ValOpNameType
+        _ -> Nothing
   _ -> identity
   where
     ss = P.exprSourceSpan expr
-    defSpan =
-      Left <$> case expr of
-        P.Var _ q -> posFromQual q
-        P.Constructor _ q -> posFromQual q
-        P.Op _ q -> posFromQual q
-        _ -> Nothing
 
-    mName = case expr of
-      P.Var _ q -> moduleNameFromQual q
-      P.Constructor _ q -> moduleNameFromQual q
-      P.Op _ q -> moduleNameFromQual q
-      _ -> Nothing
+printExpr :: P.Expr -> T.Text
+printExpr (P.Op _ (P.Qualified _ op)) = P.runOpName op -- `Op`s hit an infinite loop when pretty printed by themselves
+printExpr (P.Case _ _) = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
+printExpr expr = ellipsis 128 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 4 expr
+
+ellipsis :: Int -> Text -> Text
+ellipsis n t = if T.length t > n then T.take (n - 3) t <> "..." else t
+
+on1Line :: T.Text -> T.Text
+on1Line = T.intercalate " " . T.lines
 
 insertIaIdent :: P.SourceSpan -> P.Ident -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaIdent ss ident ty = case ident of
@@ -134,7 +160,20 @@ insertIaBinder binder ty = case binderSourceSpan binder of
   Nothing -> identity
 
 insertIaDecl :: P.Declaration -> P.SourceType -> IdeArtifacts -> IdeArtifacts
-insertIaDecl decl ty = insertAtLines (P.declSourceSpan decl) (IaDecl decl) ty Nothing Nothing
+insertIaDecl decl ty = insertAtLines (P.declSourceSpan decl) (IaDecl (printDecl decl) (declNameType decl)) ty Nothing Nothing
+
+printDecl :: P.Declaration -> Maybe Text
+printDecl = fmap printName . P.declName
+
+declNameType :: P.Declaration -> Maybe LspNameType
+declNameType = \case
+  P.DataDeclaration {} -> Just TyNameType
+  P.TypeSynonymDeclaration {} -> Just TyNameType
+  P.TypeClassDeclaration {} -> Just TyClassNameType
+  P.TypeInstanceDeclaration {} -> Just IdentNameType
+  P.KindDeclaration {} -> Just KindNameType
+  P.ValueDeclaration {} -> Just IdentNameType
+  _ -> Nothing
 
 insertIaType :: P.SourceType -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaType ty kind = insertAtLines (fst $ P.getAnnForType ty) (IaType ty) kind Nothing Nothing
@@ -170,7 +209,7 @@ insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.Mod
 insertAtLines span value ty mName defSpan (IdeArtifacts m u) = IdeArtifacts m (foldr insert u (linesFromSpan span))
   where
     insert line = Map.insertWith (<>) line [IdeArtifact span value ty mName defSpan]
-    
+
 linesFromSpan :: P.SourceSpan -> [Line]
 linesFromSpan ss = [P.sourcePosLine $ P.spanStart ss .. P.sourcePosLine $ P.spanEnd ss]
 
@@ -178,11 +217,11 @@ generatedExpr :: P.Expr -> Bool
 generatedExpr = \case
   P.Var _ ident -> generatedIdent $ P.disqualify ident
   P.Constructor _ q -> generatedName $ P.disqualify q
-  P.Abs b e -> generatedBinder b || generatedExpr e
-  P.App e e' -> generatedExpr e || generatedExpr e'
+  P.Abs b _e -> generatedBinder b 
+  -- P.App e e' -> generatedExpr e || generatedExpr e'
   P.TypedValue _ e _ -> generatedExpr e
   P.PositionedValue _ _ e -> generatedExpr e
-  P.Case es _ -> any generatedExpr es
+  -- P.Case es _ -> any generatedExpr es
   _ -> False
 
 generatedName :: P.ProperName a -> Bool
@@ -217,8 +256,8 @@ debugIdeArtifact (IdeArtifact {..}) =
 
 debugIdeArtifactValue :: IdeArtifactValue -> Text
 debugIdeArtifactValue = \case
-  IaExpr label expr -> "Expr: " <> label <> "\n" <> T.pack (take 64 $ render $ P.prettyPrintValue 5 expr)
-  IaDecl d -> "Decl: " <> maybe "_" printName (P.declName d)
+  IaExpr t _ _ -> "Expr: " <> t
+  IaDecl d _ -> "Decl: " <> fromMaybe "_" d
   IaBinder binder -> "Binder: " <> show binder
   IaIdent ident -> "Ident: " <> ident
   IaType t -> "Type " <> debugType t
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 52b180c122..0e7f87d7c6 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -392,8 +392,8 @@ addIdeBinder binder ty = onIdeArtifacts $ insertIaBinder binder ty
 addIdeIdent :: MonadState CheckState m => SourceSpan -> Ident -> SourceType -> m ()
 addIdeIdent ss ident ty  = onIdeArtifacts $ insertIaIdent ss ident ty 
 
-addIdeExpr ::  MonadState CheckState m => Text -> Expr -> SourceType -> m ()
-addIdeExpr t expr ty = onIdeArtifacts $ insertIaExpr t expr ty
+addIdeExpr ::  MonadState CheckState m => Expr -> SourceType -> m ()
+addIdeExpr expr ty = onIdeArtifacts $ insertIaExpr expr ty
 
 addIdeType ::  MonadState CheckState m => SourceType -> SourceType -> m ()
 addIdeType expr ty = onIdeArtifacts $ insertIaType expr ty
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 4b68e49816..0e213986c8 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 -- |
 -- This module implements the type checker
 --
@@ -65,7 +67,6 @@ import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, replaceTypeWild
 import Language.PureScript.Types
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.PSString (PSString)
-import Data.Text qualified as T
 
 data BindingGroupType
   = RecursiveBindingGroup
@@ -107,7 +108,6 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
       currentSubst <- gets checkSubstitution
       let ty' = substituteType currentSubst ty
           ty'' = constrain unsolved ty'
-      addIdeExpr "constrained" val ty
       unsolvedTypeVarsWithKinds <- unknownsWithKinds . IS.toList . unknowns $ constrain unsolved ty''
       let unsolvedTypeVars = IS.toList $ unknowns ty'
 
@@ -181,7 +181,6 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
       -- Check skolem variables did not escape their scope
       skolemEscapeCheck val'
       addIdeIdent ss ident generalized
-      addIdeExpr "181" val' generalized
       return ((sai, (foldr (Abs . VarBinder nullSourceSpan . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved)
 
     -- Show warnings here, since types in wildcards might have been solved during
@@ -196,7 +195,8 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     raisePreviousWarnings False wInfer
     forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
       raisePreviousWarnings shouldGeneralize w
-      substituteIdeTypes $ substituteType (checkSubstitution finalState)
+      -- when shouldGeneralize do 
+      --   substituteIdeTypes $ substituteType (checkSubstitution finalState)
     
     return $  map fst inferred 
   where
@@ -384,7 +384,7 @@ inferAndAddToIde = infer' >=> addTypedValueToIde
 
 addTypedValueToIde :: MonadState CheckState m => TypedValue' -> m TypedValue'
 addTypedValueToIde tv@(TypedValue' _ expr ty)  = do 
-  addIdeExpr "standard" expr ty 
+  addIdeExpr expr ty 
   pure tv
 
 -- | Infer a type for a value
@@ -938,7 +938,6 @@ check' v@(Constructor _ c) ty = do
       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
       ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
       elaborate <- subsumes repl ty'
-      addIdeExpr "935" v repl
       return $ TypedValue' True (elaborate v) ty'
 check' (Let w ds val) ty = do
   (ds', val') <- inferLetBinding [] ds val (`check` ty)
@@ -1050,20 +1049,20 @@ checkFunctionApplication' fn (KindedType _ ty _) arg =
 checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
-  let addAppliedType ty argE =
-        whenM (gets checkAddIdeArtifacts) do
-          case ty of
-            TypeApp ann (TypeApp ann' tyFunction' argTy) retTy -> do
-              (TypedValue' _ _ argTy') <- check argE argTy
-              let retTy' = case argTy of
-                    TypeVar _ v -> replaceTypeVars v argTy' retTy
-                    TUnknown _ u -> replaceUnknowns u argTy' retTy
-                    _ -> retTy
-              addIdeExpr ("1056: \n" <> T.pack (show argTy) <> "\n\n" <> T.pack (show retTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
+  -- let addAppliedType ty argE =
+  --       whenM (gets checkAddIdeArtifacts) do
+  --         case ty of
+  --           TypeApp ann (TypeApp ann' tyFunction' argTy) retTy -> do
+  --             (TypedValue' _ _ argTy') <- check argE argTy
+  --             let retTy' = case argTy of
+  --                   TypeVar _ v -> replaceTypeVars v argTy' retTy
+  --                   TUnknown _ u -> replaceUnknowns u argTy' retTy
+  --                   _ -> retTy
+  --             addIdeExpr fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
               
-            _ -> pure ()
+  --           _ -> pure ()
 
-  addAppliedType fnTy arg
+  -- addAppliedType fnTy arg
   checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg
 checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
   return (fnTy, App fn dict)

From 6a93d35f9c8edf6559daf0a0d65bce5616c74fd9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 4 Nov 2024 08:09:20 +0100
Subject: [PATCH 225/297] on purs projects hover is running fast but with
 limited type substitution

---
 src/Language/PureScript/TypeChecker/Types.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 0e213986c8..a10381c087 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -195,8 +195,8 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     raisePreviousWarnings False wInfer
     forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
       raisePreviousWarnings shouldGeneralize w
-      -- when shouldGeneralize do 
-      --   substituteIdeTypes $ substituteType (checkSubstitution finalState)
+      when shouldGeneralize do 
+        substituteIdeTypes $ substituteType (checkSubstitution finalState)
     
     return $  map fst inferred 
   where

From 4c19995eee9cb47117e78eec97141a15e262d272 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 5 Nov 2024 06:42:51 +0100
Subject: [PATCH 226/297] decent hover without inferring all expressions

---
 src/Language/PureScript/AST/Declarations.hs   |   4 +-
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  46 +++++--
 src/Language/PureScript/Lsp/Rebuild.hs        |  12 +-
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 125 ++++++++++++------
 src/Language/PureScript/TypeChecker/Monad.hs  |  35 ++++-
 .../PureScript/TypeChecker/Synonyms.hs        |   2 +
 src/Language/PureScript/TypeChecker/Types.hs  |  57 ++++----
 7 files changed, 187 insertions(+), 94 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 617612d567..ac122369f9 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -813,7 +813,7 @@ exprCtr (Op _ _) = "Op"
 exprCtr (IfThenElse _ _ _) = "IfThenElse"
 exprCtr (Constructor _ _) = "Constructor"
 exprCtr (Case _ _) = "Case"
-exprCtr (TypedValue _ _ _) = "TypedValue"
+exprCtr (TypedValue _ e _) = "TypedValue " <> exprCtr e
 exprCtr (Let _ _ _) = "Let"
 exprCtr (Do _ _) = "Do"
 exprCtr (Ado _ _ _) = "Ado"
@@ -822,7 +822,7 @@ exprCtr (DeferredDictionary _ _) = "DeferredDictionary"
 exprCtr (DerivedInstancePlaceholder _ _) = "DerivedInstancePlaceholder"
 exprCtr AnonymousArgument = "AnonymousArgument"
 exprCtr (Hole _) = "Hole"
-exprCtr (PositionedValue _ _ _) = "PositionedValue"
+exprCtr (PositionedValue _ _ e) = "PositionedValue " <> exprCtr e
 
 
 exprSourceSpan :: Expr -> Maybe SourceSpan
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 4e2db35fec..017b238fb9 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -23,7 +23,7 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.State (cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, artifactsAtSpan)
 import Protolude hiding (handle, to)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -40,31 +40,36 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       forLsp val f = maybe nullRes f val
 
       lookupExprTypes :: Maybe Text -> Maybe P.ModuleName -> Maybe LspNameType -> HandlerM [Text]
-      lookupExprTypes (Just ident) (Just modName) nameType = 
-          fmap (showTypeSection modName  ident) <$> getAstDeclarationTypeInModule nameType modName ident
+      lookupExprTypes (Just ident) (Just modName) nameType =
+        fmap (showTypeSection modName ident) <$> getAstDeclarationTypeInModule nameType modName ident
       lookupExprTypes _ _ _ = pure []
 
       lookupExprDocs :: Maybe Text -> Maybe P.ModuleName -> Maybe LspNameType -> HandlerM (Maybe Text)
-      lookupExprDocs (Just ident) (Just modName) (Just nameType) = 
-          readDeclarationDocsWithNameType modName nameType ident
+      lookupExprDocs (Just ident) (Just modName) (Just nameType) =
+        readDeclarationDocsWithNameType modName nameType ident
       lookupExprDocs _ _ _ = pure Nothing
 
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     debugLsp $ "Cache found: " <> show (isJust cacheOpenMb)
     forLsp cacheOpenMb \OpenFile {..} -> do
-      let atPos = getArtifactsAtPosition (positionToSourcePos startPos) (P.checkIdeArtifacts ofEndCheckState)
+      let allArtifacts = P.checkIdeArtifacts ofEndCheckState
+          atPos = getArtifactsAtPosition (positionToSourcePos startPos) allArtifacts
       debugLsp $ "hover artiacts length: " <> show (length atPos)
-      case smallestArtifact (negate . artifactInterest) atPos of
+      case smallestArtifact (bimap negate negate . artifactInterest) atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
             IaExpr exprTxt ident nameType -> do
               let inferredRes = pursTypeStr exprTxt (Just $ prettyPrintTypeSingleLine iaType) []
+                  otherArtifacts = artifactsAtSpan iaSpan allArtifacts
+                  otherInferrences = joinMarkup $ otherArtifacts <&> (Just . printOtherInference)
+
               foundTypes <- lookupExprTypes ident iaDefinitionModule nameType
               docs <- lookupExprDocs ident iaDefinitionModule nameType
               markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
                   [ Just inferredRes,
+                    Just otherInferrences,
                     head foundTypes,
                     showDocs <$> docs
                   ]
@@ -103,6 +108,18 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (prettyPrintTypeSingleLine ty) (Just $ prettyPrintTypeSingleLine iaType) []
         _ -> nullRes
 
+printOtherInference :: IdeArtifact ->  Text
+printOtherInference IdeArtifact{..} = pursTypeStr label (Just $ prettyPrintTypeSingleLine iaType) []
+  where 
+    label = case iaValue of 
+       IaExpr t _ _ -> t 
+       IaDecl t _ -> "BINDER " <> fromMaybe "__" t 
+       IaIdent t -> "IDENT " <> t 
+       IaBinder b -> "BINDER " <> dispayBinderOnHover b
+       _ -> "___"
+
+
+
 showTypeSection :: P.ModuleName -> Text -> Text -> Text
 showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
 
@@ -113,13 +130,16 @@ joinMarkup :: [Maybe Text] -> Text
 joinMarkup = T.intercalate "\n---\n" . catMaybes
 
 -- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
-artifactInterest :: IdeArtifact -> Int
+artifactInterest :: IdeArtifact -> (Int, Int)
 artifactInterest (IdeArtifact {..}) = case iaValue of
-  IaBinder {} -> 1
-  IaTypeName {} -> 1
-  IaClassName {} -> 1
-  IaExpr _ _ _ -> negate (countUnkownsAndVars iaType) -- Prefer expressions with fewer unknowns and type vars
-  _ -> 0
+  IaBinder {} -> (2, 0)
+  IaTypeName {} -> (3, 0)
+  IaClassName {} -> (3, 0)
+  IaExpr _ ident nt ->
+    ( length $ catMaybes [void ident, void nt],
+      negate (countUnkownsAndVars iaType) 
+    )
+  _ -> (1, 0)
 
 countUnkownsAndVars :: P.Type a -> Int
 countUnkownsAndVars = P.everythingOnTypes (+) go
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index ee0fbc33dc..738ff3c1dc 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -102,16 +102,14 @@ rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName
       rebuildWithoutCache moduleName mkMakeActions fp pwarnings m
     _ -> handleRebuildResult fp pwarnings res
 
-getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment  -> P.CheckState)
-getIdeCheckState = 
+getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
+getIdeCheckState =
   ideCheckState <$> getInferExpressions
-
-  where 
-
+  where
     ideCheckState :: Bool -> P.Environment -> P.CheckState
     ideCheckState infer env =
       (P.emptyCheckState env)
-        { P.checkAddIdeArtifacts = infer
+        { P.checkAddIdeArtifacts = Just if infer then P.AllIdeExprs else P.IdentIdeExprs
         }
 
 rebuildWithoutCache ::
@@ -157,7 +155,7 @@ couldBeFromNewImports =
     P.ModuleNotFound {} -> True
     P.UnknownImport {} -> True
     P.UnknownImportDataConstructor {} -> True
-    P.UnknownName qName | (P.ModName _) <- P.disqualify qName -> True
+    P.NameIsUndefined _ -> True
     _ -> False
 
 cachedImportsAreInActual ::
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 53da1ae317..4209c8c6cd 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -1,10 +1,12 @@
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 -- | Stores information about the source code that is useful for the IDE
 -- | This includes value types and source spans
 module Language.PureScript.TypeChecker.IdeArtifacts
   ( IdeArtifacts,
     IdeArtifact (..),
     IdeArtifactValue (..),
+    artifactsAtSpan,
     getArtifactsAtPosition,
     emptyIdeArtifacts,
     insertIaExpr,
@@ -12,6 +14,7 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     insertIaDecl,
     insertIaType,
     insertIaIdent,
+    insertTypeSynonym,
     smallestArtifact,
     debugIdeArtifacts,
     insertIaTypeName,
@@ -34,22 +37,21 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Pretty.Types qualified as P
-import Language.PureScript.Pretty.Values qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude
 import Safe (minimumByMay)
-import Text.PrettyPrint.Boxes (render)
 
 data IdeArtifacts
   = IdeArtifacts
-      (Map Line [IdeArtifact]) -- with substitutions
-      (Map Line [IdeArtifact]) -- without substitutions
+      (Map Line [IdeArtifact]) -- with type var substitutions
+      (Map Line [IdeArtifact]) -- without var substitutions
+      (Map P.SourceType [P.SourceType]) -- type synonym substitutions
   deriving (Show)
 
 type Line = Int
 
 emptyIdeArtifacts :: IdeArtifacts
-emptyIdeArtifacts = IdeArtifacts Map.empty Map.empty
+emptyIdeArtifacts = IdeArtifacts Map.empty Map.empty Map.empty
 
 debugIdeArtifacts :: IdeArtifacts -> Text
 debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts
@@ -57,7 +59,7 @@ debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts
     showCount :: (Int, Int) -> Text
     showCount (line, count) = show line <> ": " <> show count
     lineCounts :: IdeArtifacts -> [(Int, Int)]
-    lineCounts (IdeArtifacts m _) = Map.toList m <&> fmap length
+    lineCounts (IdeArtifacts m _ _) = Map.toList m <&> fmap length
 
 data IdeArtifact = IdeArtifact
   { iaSpan :: P.SourceSpan,
@@ -79,17 +81,22 @@ data IdeArtifactValue
   deriving (Show)
 
 substituteArtifactTypes :: (P.SourceType -> P.SourceType) -> IdeArtifacts -> IdeArtifacts
-substituteArtifactTypes f (IdeArtifacts m u) = IdeArtifacts m (Map.map (fmap (onArtifactType f)) u)
+substituteArtifactTypes f (IdeArtifacts m u s) = IdeArtifacts m (Map.map (fmap (onArtifactType f)) u) s
 
 onArtifactType :: (P.SourceType -> P.SourceType) -> IdeArtifact -> IdeArtifact
 onArtifactType f (IdeArtifact {..}) = IdeArtifact iaSpan iaValue (f iaType) iaDefinitionModule iaDefinitionPos
 
 endSubstitutions :: IdeArtifacts -> IdeArtifacts
-endSubstitutions (IdeArtifacts m u) = IdeArtifacts (Map.unionWith (<>) m u) Map.empty
+endSubstitutions (IdeArtifacts m u s) = IdeArtifacts (Map.unionWith (<>) m u) Map.empty s
 
 smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
 smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
+artifactsAtSpan :: P.SourceSpan -> IdeArtifacts -> [IdeArtifact]
+artifactsAtSpan span (IdeArtifacts m _ _) =
+  Map.lookup (P.sourcePosLine $ P.spanStart span) m
+    & maybe [] (filter ((==) span . iaSpan))
+
 artifactSize :: IdeArtifact -> (Int, Int)
 artifactSize (IdeArtifact {..}) =
   ( P.sourcePosLine (P.spanEnd iaSpan) - P.sourcePosLine (P.spanStart iaSpan),
@@ -97,7 +104,7 @@ artifactSize (IdeArtifact {..}) =
   )
 
 getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
-getArtifactsAtPosition pos (IdeArtifacts m _) =
+getArtifactsAtPosition pos (IdeArtifacts m _ _) =
   Map.lookup (P.sourcePosLine pos) m
     & fromMaybe []
     & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
@@ -105,8 +112,8 @@ getArtifactsAtPosition pos (IdeArtifacts m _) =
     posCol = P.sourcePosColumn pos
 
 insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
-insertIaExpr expr ty =  case ss of
-  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr "_" exprIdent exprNameType) ty mName defSpan
+insertIaExpr expr ty = case ss of
+  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr (exprCtr expr <> ": " <> fromMaybe "_" exprIdent) exprIdent exprNameType) ty mName defSpan
     where
       defSpan =
         Left <$> case expr of
@@ -115,18 +122,21 @@ insertIaExpr expr ty =  case ss of
           P.Op _ q -> posFromQual q
           _ -> Nothing
 
-      mName = case expr of
-        P.Var _ q -> moduleNameFromQual q
-        P.Constructor _ q -> moduleNameFromQual q
-        P.Op _ q -> moduleNameFromQual q
-        _ -> Nothing
+      mName = exprIdentQual expr >>= moduleNameFromQual
 
       exprIdent :: Maybe Text
-      exprIdent = case expr of
-        P.Var _ ident -> Just $ P.runIdent $ P.disqualify ident
-        P.Constructor _ q -> Just $ P.runProperName $ P.disqualify q
-        P.Op _ q -> Just $ P.runOpName $ P.disqualify q
+      exprIdent = P.disqualify <$> exprIdentQual expr
+
+      exprIdentQual :: P.Expr -> Maybe (P.Qualified Text)
+      exprIdentQual = \case 
+        P.Var _ ident -> Just $ P.runIdent <$> ident 
+        P.Constructor _ q -> Just $ P.runProperName <$> q
+        P.Op _ q -> Just $ P.runOpName <$> q
+        P.PositionedValue _ _ e -> exprIdentQual e
+        P.TypedValue _ e _ -> exprIdentQual e
+        P.App e (P.TypeClassDictionary{}) -> exprIdentQual e
         _ -> Nothing
+        
 
       exprNameType :: Maybe LspNameType
       exprNameType = case expr of
@@ -140,8 +150,12 @@ insertIaExpr expr ty =  case ss of
 
 printExpr :: P.Expr -> T.Text
 printExpr (P.Op _ (P.Qualified _ op)) = P.runOpName op -- `Op`s hit an infinite loop when pretty printed by themselves
-printExpr (P.Case _ _) = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
-printExpr expr = ellipsis 128 $ on1Line $ T.strip $ T.pack $ render $ P.prettyPrintValue 4 expr
+printExpr (P.Constructor _ n) = P.runProperName $ P.disqualify n
+printExpr (P.Var _ n) = P.runIdent $  P.disqualify n
+-- printExpr 
+printExpr P.Case{} = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
+printExpr P.IfThenElse{} = "<if expr>"
+printExpr _ = "_"
 
 ellipsis :: Int -> Text -> Text
 ellipsis n t = if T.length t > n then T.take (n - 3) t <> "..." else t
@@ -159,6 +173,19 @@ insertIaBinder binder ty = case binderSourceSpan binder of
   Just ss -> insertAtLines ss (IaBinder binder) ty Nothing (Just $ Right ss)
   Nothing -> identity
 
+binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
+binderSourceSpan = \case
+  P.NullBinder -> Nothing
+  P.LiteralBinder ss _ -> Just ss
+  P.VarBinder ss _ -> Just ss
+  P.ConstructorBinder ss _ _ -> Just ss
+  P.NamedBinder ss _ _ -> Just ss
+  P.PositionedBinder ss _ _ -> Just ss
+  P.TypedBinder _ b -> binderSourceSpan b
+  P.OpBinder ss _ -> Just ss
+  P.BinaryNoParensBinder {} -> Nothing
+  P.ParensInBinder {} -> Nothing
+
 insertIaDecl :: P.Declaration -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaDecl decl ty = insertAtLines (P.declSourceSpan decl) (IaDecl (printDecl decl) (declNameType decl)) ty Nothing Nothing
 
@@ -184,18 +211,8 @@ insertIaTypeName ss name mName kind = insertAtLines ss (IaTypeName name) kind mN
 insertIaClassName :: P.SourceSpan -> P.ProperName 'P.ClassName -> Maybe P.ModuleName -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaClassName ss name mName kind = insertAtLines ss (IaClassName name) kind mName (Just $ Right $ fst $ P.getAnnForType kind)
 
-binderSourceSpan :: P.Binder -> Maybe P.SourceSpan
-binderSourceSpan = \case
-  P.NullBinder -> Nothing
-  P.LiteralBinder ss _ -> Just ss
-  P.VarBinder ss _ -> Just ss
-  P.ConstructorBinder ss _ _ -> Just ss
-  P.NamedBinder ss _ _ -> Just ss
-  P.PositionedBinder ss _ _ -> Just ss
-  P.TypedBinder _ b -> binderSourceSpan b
-  P.OpBinder ss _ -> Just ss
-  P.BinaryNoParensBinder {} -> Nothing
-  P.ParensInBinder {} -> Nothing
+insertTypeSynonym :: P.SourceType -> P.SourceType -> IdeArtifacts -> IdeArtifacts
+insertTypeSynonym syn ty (IdeArtifacts m u s) = IdeArtifacts m u (Map.insertWith (<>) syn [ty] s)
 
 posFromQual :: P.Qualified a -> Maybe P.SourcePos
 posFromQual (P.Qualified (P.BySourcePos pos) _) = Just pos
@@ -206,7 +223,7 @@ moduleNameFromQual (P.Qualified (P.ByModuleName mn) _) = Just mn
 moduleNameFromQual _ = Nothing
 
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
-insertAtLines span value ty mName defSpan (IdeArtifacts m u) = IdeArtifacts m (foldr insert u (linesFromSpan span))
+insertAtLines span value ty mName defSpan (IdeArtifacts m u s) = IdeArtifacts m (foldr insert u (linesFromSpan span)) s
   where
     insert line = Map.insertWith (<>) line [IdeArtifact span value ty mName defSpan]
 
@@ -217,11 +234,13 @@ generatedExpr :: P.Expr -> Bool
 generatedExpr = \case
   P.Var _ ident -> generatedIdent $ P.disqualify ident
   P.Constructor _ q -> generatedName $ P.disqualify q
-  P.Abs b _e -> generatedBinder b 
-  -- P.App e e' -> generatedExpr e || generatedExpr e'
+  P.Abs b _e -> generatedBinder b
   P.TypedValue _ e _ -> generatedExpr e
   P.PositionedValue _ _ e -> generatedExpr e
-  -- P.Case es _ -> any generatedExpr es
+  P.Unused {} -> True
+  P.DeferredDictionary {} -> True
+  P.TypeClassDictionary {} -> True
+  P.DerivedInstancePlaceholder {} -> True
   _ -> False
 
 generatedName :: P.ProperName a -> Bool
@@ -265,4 +284,32 @@ debugIdeArtifactValue = \case
   IaClassName name -> "ClassName: " <> P.runProperName name
 
 debugType :: P.Type a -> Text
-debugType = T.pack . take 64 . P.prettyPrintType 5
\ No newline at end of file
+debugType = T.pack . take 64 . P.prettyPrintType 5
+
+exprCtr :: P.Expr -> Text
+exprCtr (P.Literal _ _) = "Literal"
+exprCtr (P.UnaryMinus _ _) = "UnaryMinus"
+exprCtr (P.BinaryNoParens _ _ _) = "BinaryNoParens"
+exprCtr (P.Parens _) = "Parens"
+exprCtr (P.Accessor _ _) = "Accessor"
+exprCtr (P.ObjectUpdate _ _) = "ObjectUpdate"
+exprCtr (P.ObjectUpdateNested _ _) = "ObjectUpdateNested"
+exprCtr (P.Abs _ _) = "Abs"
+exprCtr (P.App e e') = "App (" <> exprCtr e <> ") (" <> exprCtr e' <> ")"
+exprCtr (P.VisibleTypeApp _ _) = "VisibleTypeApp"
+exprCtr (P.Unused e) = "Unused " <> exprCtr e
+exprCtr (P.Var _ _) = "Var"
+exprCtr (P.Op _ _) = "Op"
+exprCtr (P.IfThenElse _ _ _) = "IfThenElse"
+exprCtr (P.Constructor _ _) = "Constructor"
+exprCtr (P.Case _ _) = "Case"
+exprCtr (P.TypedValue _ e _) = "TypedValue " <> exprCtr e
+exprCtr (P.Let _ _ _) = "Let"
+exprCtr (P.Do _ _) = "Do"
+exprCtr (P.Ado _ _ _) = "Ado"
+exprCtr (P.TypeClassDictionary _ _ _) = "TypeClassDictionary"
+exprCtr (P.DeferredDictionary _ _) = "DeferredDictionary"
+exprCtr (P.DerivedInstancePlaceholder _ _) = "DerivedInstancePlaceholder"
+exprCtr P.AnonymousArgument = "AnonymousArgument"
+exprCtr (P.Hole _) = "Hole"
+exprCtr (P.PositionedValue _ _ e) = "PositionedValue " <> exprCtr e
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 0e7f87d7c6..980fd7ef15 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -30,9 +30,9 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, endSubstitutions)
-import Protolude (whenM)
+import Protolude (whenM, isJust)
 import Language.PureScript.AST.Binders (Binder)
-import Language.PureScript.AST.Declarations (Declaration)
+import Language.PureScript.AST.Declarations (Declaration, Expr (..))
 
 newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown)
   deriving (Eq, Show)
@@ -110,15 +110,18 @@ data CheckState = CheckState
   , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
   -- ^ Newtype constructors imports required to solve Coercible constraints.
   -- We have to keep track of them so that we don't emit unused import warnings.
-  , checkAddIdeArtifacts :: Bool
+  , checkAddIdeArtifacts :: Maybe AddIdeArtifacts
   -- ^ Whether to add IDE artifacts to the environment
   , checkIdeArtifacts :: IdeArtifacts
   -- ^ The IDE artifacts
   }
 
+data AddIdeArtifacts = AllIdeExprs | IdentIdeExprs
+  deriving (Eq)
+
 -- | Create an empty @CheckState@
 emptyCheckState :: Environment -> CheckState
-emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty False emptyIdeArtifacts
+emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty Nothing emptyIdeArtifacts
 
 -- | Unification variables
 type Unknown = Int
@@ -393,7 +396,21 @@ addIdeIdent :: MonadState CheckState m => SourceSpan -> Ident -> SourceType -> m
 addIdeIdent ss ident ty  = onIdeArtifacts $ insertIaIdent ss ident ty 
 
 addIdeExpr ::  MonadState CheckState m => Expr -> SourceType -> m ()
-addIdeExpr expr ty = onIdeArtifacts $ insertIaExpr expr ty
+addIdeExpr expr ty = do 
+  addAllExprs <- shouldAddAllIdeExprs 
+  when (addAllExprs || allowedExpr expr) 
+   $ onIdeArtifacts $ insertIaExpr expr ty
+  where 
+    allowedExpr = \case 
+      Literal{} -> True
+      Abs{} -> True
+      Var{} -> True 
+      Op{} -> True 
+      Constructor{} -> True
+      TypedValue _ e _ -> allowedExpr e
+      PositionedValue _ _ e -> allowedExpr e
+      App e TypeClassDictionary{} -> allowedExpr e
+      _ -> False 
 
 addIdeType ::  MonadState CheckState m => SourceType -> SourceType -> m ()
 addIdeType expr ty = onIdeArtifacts $ insertIaType expr ty
@@ -411,7 +428,7 @@ addIdeClassNameQual :: MonadState CheckState m => SourceSpan -> Qualified ( Prop
 addIdeClassNameQual ss name ty = onIdeArtifacts $ insertIaClassName ss (disqualify name) (moduleNameFromQual name) ty
 
 onIdeArtifacts :: MonadState CheckState m => (IdeArtifacts -> IdeArtifacts) -> m ()
-onIdeArtifacts f = whenM (gets checkAddIdeArtifacts)  
+onIdeArtifacts f = whenAddingIdeArtifacts  
   $ modify $ \env -> env { checkIdeArtifacts = f (checkIdeArtifacts env) }
 
 substituteIdeTypes :: MonadState CheckState m => (SourceType -> SourceType) -> m ()
@@ -420,6 +437,12 @@ substituteIdeTypes = onIdeArtifacts . substituteArtifactTypes
 endIdeSubstitutions :: MonadState CheckState m => m ()
 endIdeSubstitutions = onIdeArtifacts endSubstitutions
 
+whenAddingIdeArtifacts :: MonadState CheckState m => m () -> m ()
+whenAddingIdeArtifacts = whenM (gets (isJust . checkAddIdeArtifacts)) 
+
+shouldAddAllIdeExprs ::  MonadState CheckState m => m  Bool
+shouldAddAllIdeExprs =  gets ((==) (Just AllIdeExprs) . checkAddIdeArtifacts)
+
 debugEnv :: Environment -> [String]
 debugEnv env = join
   [ debugTypes env
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 567ae415ef..e119282885 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -60,3 +60,5 @@ replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadErr
 replaceAllTypeSynonyms d = do
   env <- getEnv
   either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d
+
+-- todo track synonymns
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index a10381c087..2a317ab104 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -195,8 +195,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     raisePreviousWarnings False wInfer
     forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do
       raisePreviousWarnings shouldGeneralize w
-      when shouldGeneralize do 
-        substituteIdeTypes $ substituteType (checkSubstitution finalState)
+      substituteIdeTypes $ removeRedundantConstraints . substituteType (checkSubstitution finalState)
     
     return $  map fst inferred 
   where
@@ -234,6 +233,20 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
     isHoleError (ErrorMessage _ HoleInferredType{}) = True
     isHoleError _ = False
 
+removeRedundantConstraints :: SourceType -> SourceType
+removeRedundantConstraints = \case 
+  ConstrainedType _ con ty | isRedundant con  -> ty
+  ty -> ty
+  where 
+    isRedundant :: SourceConstraint -> Bool
+    isRedundant (Constraint _ _ _ tys _) = all isTyCtr tys
+
+    isTyCtr :: SourceType -> Bool
+    isTyCtr = \case 
+      TypeConstructor _ _ -> True
+      _ -> False
+
+
 -- | A binding group contains multiple value definitions, some of which are typed
 -- and some which are not.
 --
@@ -501,9 +514,11 @@ infer' (VisibleTypeApp valFn tyArg) = do
       pure $ TypedValue' True valFn''' resTy'
     _ ->
       throwError $ errorMessage $ CannotApplyExpressionOfTypeOnType valTy tyArg
-infer' (Var ss var) = do
+infer' e@(Var ss var) = do
   checkVisibility var
-  ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var
+  tyWithSyns <- replaceTypeWildcards <=< lookupVariable $ var
+  addIdeExpr e tyWithSyns
+  ty <- introduceSkolemScope <=< replaceAllTypeSynonyms $ tyWithSyns
   case ty of
     ConstrainedType _ con ty' -> do
       dicts <- getTypeClassDictionaries
@@ -1018,7 +1033,9 @@ checkFunctionApplication
   -- ^ The result type, and the elaborated term
 checkFunctionApplication fn fnTy arg = withErrorMessageHint' fn (ErrorInApplication fn fnTy arg) $ do
   subst <- gets checkSubstitution
-  checkFunctionApplication' fn (substituteType subst fnTy) arg
+  res <- checkFunctionApplication' fn (substituteType subst fnTy) arg
+  addIdeExpr fn (substituteType subst fnTy)
+  pure res
 
 -- | Check the type of a function application
 checkFunctionApplication'
@@ -1031,13 +1048,10 @@ checkFunctionApplication' fn (TypeApp ann (TypeApp ann' tyFunction' argTy) retTy
   unifyTypes tyFunction' tyFunction
   tv@(TypedValue' _ _ argTy') <- check arg argTy
   let arg' = tvToExpr tv
-  -- whenM (gets checkAddIdeArtifacts) do
-  --   let 
-  --       retTy' = case argTy of
-  --         TypeVar _ v -> replaceTypeVars v argTy' retTy
-  --         TUnknown _ u -> replaceUnknowns u argTy' retTy
-  --         _ -> retTy
-  --   addIdeExpr ("1028: " <> T.pack (show argTy)) fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
+  -- whenAddingIdeArtifacts do
+  --   subst <- gets checkSubstitution
+  --   addIdeExpr fn (substituteType subst $ TypeApp ann (TypeApp ann' tyFunction' argTy') retTy)
+  -- substituteIdeTypes (substituteType _)
   return (retTy, App fn arg')
 checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do
   u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK
@@ -1046,23 +1060,12 @@ checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do
   checkFunctionApplication fn replaced arg
 checkFunctionApplication' fn (KindedType _ ty _) arg =
   checkFunctionApplication fn ty arg
-checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do
+checkFunctionApplication' fn (ConstrainedType ann con fnTy) arg = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
-  -- let addAppliedType ty argE =
-  --       whenM (gets checkAddIdeArtifacts) do
-  --         case ty of
-  --           TypeApp ann (TypeApp ann' tyFunction' argTy) retTy -> do
-  --             (TypedValue' _ _ argTy') <- check argE argTy
-  --             let retTy' = case argTy of
-  --                   TypeVar _ v -> replaceTypeVars v argTy' retTy
-  --                   TUnknown _ u -> replaceUnknowns u argTy' retTy
-  --                   _ -> retTy
-  --             addIdeExpr fn (TypeApp ann (TypeApp ann' tyFunction' argTy') retTy')
-              
-  --           _ -> pure ()
-
-  -- addAppliedType fnTy arg
+  whenAddingIdeArtifacts do
+    subst <- gets checkSubstitution
+    addIdeExpr fn (substituteType subst $ ConstrainedType ann con fnTy)
   checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg
 checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
   return (fnTy, App fn dict)

From 560c68a73d4829f90ad899cbcce8d6d40e142ad9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 5 Nov 2024 06:47:05 +0100
Subject: [PATCH 227/297] remove unneeded ide adding

---
 src/Language/PureScript/TypeChecker/Types.hs | 13 ++-----------
 1 file changed, 2 insertions(+), 11 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 2a317ab104..4b27a45d29 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -396,7 +396,7 @@ inferAndAddToIde  :: (MonadSupply m, MonadState CheckState m, MonadError Multipl
 inferAndAddToIde = infer' >=> addTypedValueToIde
 
 addTypedValueToIde :: MonadState CheckState m => TypedValue' -> m TypedValue'
-addTypedValueToIde tv@(TypedValue' _ expr ty)  = do 
+addTypedValueToIde tv@(TypedValue' _ expr ty) = do 
   addIdeExpr expr ty 
   pure tv
 
@@ -516,9 +516,7 @@ infer' (VisibleTypeApp valFn tyArg) = do
       throwError $ errorMessage $ CannotApplyExpressionOfTypeOnType valTy tyArg
 infer' e@(Var ss var) = do
   checkVisibility var
-  tyWithSyns <- replaceTypeWildcards <=< lookupVariable $ var
-  addIdeExpr e tyWithSyns
-  ty <- introduceSkolemScope <=< replaceAllTypeSynonyms $ tyWithSyns
+  ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var
   case ty of
     ConstrainedType _ con ty' -> do
       dicts <- getTypeClassDictionaries
@@ -1048,10 +1046,6 @@ checkFunctionApplication' fn (TypeApp ann (TypeApp ann' tyFunction' argTy) retTy
   unifyTypes tyFunction' tyFunction
   tv@(TypedValue' _ _ argTy') <- check arg argTy
   let arg' = tvToExpr tv
-  -- whenAddingIdeArtifacts do
-  --   subst <- gets checkSubstitution
-  --   addIdeExpr fn (substituteType subst $ TypeApp ann (TypeApp ann' tyFunction' argTy') retTy)
-  -- substituteIdeTypes (substituteType _)
   return (retTy, App fn arg')
 checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do
   u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK
@@ -1063,9 +1057,6 @@ checkFunctionApplication' fn (KindedType _ ty _) arg =
 checkFunctionApplication' fn (ConstrainedType ann con fnTy) arg = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
-  whenAddingIdeArtifacts do
-    subst <- gets checkSubstitution
-    addIdeExpr fn (substituteType subst $ ConstrainedType ann con fnTy)
   checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg
 checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
   return (fnTy, App fn dict)

From 668261043613ed972997a2e835eae6fe21aea1a5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 5 Nov 2024 15:13:20 +0100
Subject: [PATCH 228/297] adds handling for type synonyms

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 77 +++++++------------
 src/Language/PureScript/Lsp/State.hs          | 10 +++
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 37 ++++++---
 src/Language/PureScript/TypeChecker/Monad.hs  |  5 +-
 .../PureScript/TypeChecker/Synonyms.hs        | 36 ++++++---
 5 files changed, 92 insertions(+), 73 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 017b238fb9..610a8a24ef 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -20,10 +20,10 @@ import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
-import Language.PureScript.Lsp.State (cachedRebuild)
+import Language.PureScript.Lsp.State (cachedRebuild, cachedFilePaths)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, artifactsAtSpan)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns)
 import Protolude hiding (handle, to)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -52,26 +52,32 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     debugLsp $ "Cache found: " <> show (isJust cacheOpenMb)
+    when (isNothing cacheOpenMb) do 
+      debugLsp $ "file path not cached: " <> T.pack filePath
+      debugLsp . show =<< cachedFilePaths
     forLsp cacheOpenMb \OpenFile {..} -> do
       let allArtifacts = P.checkIdeArtifacts ofEndCheckState
           atPos = getArtifactsAtPosition (positionToSourcePos startPos) allArtifacts
       debugLsp $ "hover artiacts length: " <> show (length atPos)
-      case smallestArtifact (bimap negate negate . artifactInterest) atPos of
+      case smallestArtifact (\a -> (artifactInterest a, negate $ countUnkownsAndVars $ iaType a)) atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
             IaExpr exprTxt ident nameType -> do
-              let inferredRes = pursTypeStr exprTxt (Just $ prettyPrintTypeSingleLine iaType) []
-                  otherArtifacts = artifactsAtSpan iaSpan allArtifacts
-                  otherInferrences = joinMarkup $ otherArtifacts <&> (Just . printOtherInference)
-
+              let inferredRes =
+                    pursTypeStr
+                      exprTxt
+                      ( Just $
+                          prettyPrintTypeSingleLine $
+                            useSynonymns allArtifacts iaType
+                      )
+                      []
               foundTypes <- lookupExprTypes ident iaDefinitionModule nameType
               docs <- lookupExprDocs ident iaDefinitionModule nameType
               markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
                   [ Just inferredRes,
-                    Just otherInferrences,
-                    head foundTypes,
-                    showDocs <$> docs
+                    showDocs <$> docs,
+                    head foundTypes
                   ]
             IaTypeName name -> do
               let name' = P.runProperName name
@@ -82,8 +88,8 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
                   [ Just inferredRes,
-                    showTypeSection modName (P.runProperName name) <$> head foundTypes,
-                    showDocs <$> docs
+                    showDocs <$> docs,
+                    showTypeSection modName (P.runProperName name) <$> head foundTypes
                   ]
             IaClassName name -> do
               let name' = P.runProperName name
@@ -98,27 +104,16 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                     showDocs <$> docs
                   ]
             IaIdent ident -> do
-              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr ident (Just $ prettyPrintTypeSingleLine iaType) []
+              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr ident (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
             IaBinder binder -> do
-              let inferredRes = pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine iaType) []
+              let inferredRes = pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
               markdownRes (spanToRange <$> binderSourceSpan binder) inferredRes
             IaDecl decl _ -> do
-              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (fromMaybe "_" decl) (Just $ prettyPrintTypeSingleLine iaType) []
+              markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (fromMaybe "_" decl) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
             IaType ty -> do
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (prettyPrintTypeSingleLine ty) (Just $ prettyPrintTypeSingleLine iaType) []
         _ -> nullRes
 
-printOtherInference :: IdeArtifact ->  Text
-printOtherInference IdeArtifact{..} = pursTypeStr label (Just $ prettyPrintTypeSingleLine iaType) []
-  where 
-    label = case iaValue of 
-       IaExpr t _ _ -> t 
-       IaDecl t _ -> "BINDER " <> fromMaybe "__" t 
-       IaIdent t -> "IDENT " <> t 
-       IaBinder b -> "BINDER " <> dispayBinderOnHover b
-       _ -> "___"
-
-
 
 showTypeSection :: P.ModuleName -> Text -> Text -> Text
 showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
@@ -130,16 +125,13 @@ joinMarkup :: [Maybe Text] -> Text
 joinMarkup = T.intercalate "\n---\n" . catMaybes
 
 -- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
-artifactInterest :: IdeArtifact -> (Int, Int)
+artifactInterest :: IdeArtifact -> Int
 artifactInterest (IdeArtifact {..}) = case iaValue of
-  IaBinder {} -> (2, 0)
-  IaTypeName {} -> (3, 0)
-  IaClassName {} -> (3, 0)
-  IaExpr _ ident nt ->
-    ( length $ catMaybes [void ident, void nt],
-      negate (countUnkownsAndVars iaType) 
-    )
-  _ -> (1, 0)
+  IaBinder {} -> 2
+  IaTypeName {} -> 3
+  IaClassName {} -> 3
+  IaExpr _ _ _ -> negate (countUnkownsAndVars iaType)
+  _ -> 1
 
 countUnkownsAndVars :: P.Type a -> Int
 countUnkownsAndVars = P.everythingOnTypes (+) go
@@ -179,18 +171,3 @@ data InferError
   | CompilationError P.MultipleErrors
   | InferException Text
   deriving (Show, Exception)
-
--- inferExprType :: FilePath -> P.Expr -> HandlerM (Either InferError P.SourceType)
--- inferExprType filePath expr = do
---   cacheOpenMb <- cachedRebuild filePath
---   case cacheOpenMb of
---     Nothing -> pure $ Left FileNotCached
---     Just OpenFile {..} -> do
---       inferRes <- runWriterT $ runExceptT $ evalSupplyT 0 $ evalStateT (infer' expr) ((P.emptyCheckState ofStartingEnv) {P.checkCurrentModule = Just ofModuleName})
---       pure $ bimap CompilationError (\(P.TypedValue' _ _ t) -> t) $ fst inferRes
-
--- inferExprType' :: FilePath -> P.Expr -> HandlerM P.SourceType
--- inferExprType' fp =
---   inferExprType fp >=> \case
---     Right t -> pure t
---     Left e -> throwIO e
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index ebc05546ed..6e466da1cd 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -24,6 +24,8 @@ module Language.PureScript.Lsp.State
     putNewEnv,
     putPreviousConfig,
     getPreviousConfig,
+    cachedFiles,
+    cachedFilePaths,
   )
 where
 
@@ -89,6 +91,14 @@ cachedRebuild fp = do
     st' <- readTVar st
     pure $ List.lookup fp $ openFiles st'
 
+cachedFiles :: (MonadIO m, MonadReader LspEnvironment m) => m [(FilePath, OpenFile)]
+cachedFiles = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ openFiles <$> readTVar st
+
+cachedFilePaths :: (MonadIO m, MonadReader LspEnvironment m) => m [FilePath]
+cachedFilePaths = fmap fst <$> cachedFiles
+
 cacheDependencies :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> [ExternDependency] -> m ()
 cacheDependencies moduleName deps = do
   st <- lspStateVar <$> ask
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 4209c8c6cd..566f453613 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -15,6 +15,8 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     insertIaType,
     insertIaIdent,
     insertTypeSynonym,
+    useSynonymns,
+    debugSynonyms, 
     smallestArtifact,
     debugIdeArtifacts,
     insertIaTypeName,
@@ -45,7 +47,7 @@ data IdeArtifacts
   = IdeArtifacts
       (Map Line [IdeArtifact]) -- with type var substitutions
       (Map Line [IdeArtifact]) -- without var substitutions
-      (Map P.SourceType [P.SourceType]) -- type synonym substitutions
+      (Map (P.Type ()) (P.Type ())) -- type synonym substitutions
   deriving (Show)
 
 type Line = Int
@@ -128,15 +130,14 @@ insertIaExpr expr ty = case ss of
       exprIdent = P.disqualify <$> exprIdentQual expr
 
       exprIdentQual :: P.Expr -> Maybe (P.Qualified Text)
-      exprIdentQual = \case 
-        P.Var _ ident -> Just $ P.runIdent <$> ident 
+      exprIdentQual = \case
+        P.Var _ ident -> Just $ P.runIdent <$> ident
         P.Constructor _ q -> Just $ P.runProperName <$> q
         P.Op _ q -> Just $ P.runOpName <$> q
         P.PositionedValue _ _ e -> exprIdentQual e
         P.TypedValue _ e _ -> exprIdentQual e
-        P.App e (P.TypeClassDictionary{}) -> exprIdentQual e
+        P.App e (P.TypeClassDictionary {}) -> exprIdentQual e
         _ -> Nothing
-        
 
       exprNameType :: Maybe LspNameType
       exprNameType = case expr of
@@ -151,10 +152,10 @@ insertIaExpr expr ty = case ss of
 printExpr :: P.Expr -> T.Text
 printExpr (P.Op _ (P.Qualified _ op)) = P.runOpName op -- `Op`s hit an infinite loop when pretty printed by themselves
 printExpr (P.Constructor _ n) = P.runProperName $ P.disqualify n
-printExpr (P.Var _ n) = P.runIdent $  P.disqualify n
--- printExpr 
-printExpr P.Case{} = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
-printExpr P.IfThenElse{} = "<if expr>"
+printExpr (P.Var _ n) = P.runIdent $ P.disqualify n
+-- printExpr
+printExpr P.Case {} = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
+printExpr P.IfThenElse {} = "<if expr>"
 printExpr _ = "_"
 
 ellipsis :: Int -> Text -> Text
@@ -211,9 +212,6 @@ insertIaTypeName ss name mName kind = insertAtLines ss (IaTypeName name) kind mN
 insertIaClassName :: P.SourceSpan -> P.ProperName 'P.ClassName -> Maybe P.ModuleName -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaClassName ss name mName kind = insertAtLines ss (IaClassName name) kind mName (Just $ Right $ fst $ P.getAnnForType kind)
 
-insertTypeSynonym :: P.SourceType -> P.SourceType -> IdeArtifacts -> IdeArtifacts
-insertTypeSynonym syn ty (IdeArtifacts m u s) = IdeArtifacts m u (Map.insertWith (<>) syn [ty] s)
-
 posFromQual :: P.Qualified a -> Maybe P.SourcePos
 posFromQual (P.Qualified (P.BySourcePos pos) _) = Just pos
 posFromQual _ = Nothing
@@ -257,6 +255,21 @@ generatedIdent = \case
   P.GenIdent {} -> True
   _ -> False
 
+insertTypeSynonym :: P.Type a -> P.Type a -> IdeArtifacts -> IdeArtifacts
+insertTypeSynonym syn ty (IdeArtifacts m u s) = IdeArtifacts m u (Map.insert (void syn) (void ty) s)
+
+useSynonymns :: forall a. IdeArtifacts -> P.Type a -> P.Type ()
+useSynonymns (IdeArtifacts _ _ s) ty =  P.everywhereOnTypes go (void ty)
+  where
+    go :: P.Type  () ->  P.Type ()
+    go t = 
+      Map.lookup t s
+        & maybe t go
+
+debugSynonyms :: IdeArtifacts -> Text
+debugSynonyms (IdeArtifacts _ _ s) = show $ Map.toList s <&> bimap
+  (ellipsis 100 . T.pack .  P.prettyPrintType 3) (ellipsis 100 . T.pack .  P.prettyPrintType 3)
+
 debugIdeArtifact :: IdeArtifact -> Text
 debugIdeArtifact (IdeArtifact {..}) =
   show (P.sourcePosLine $ P.spanStart iaSpan)
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 980fd7ef15..a6206ae5c0 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -29,7 +29,7 @@ import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, endSubstitutions)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, endSubstitutions, insertTypeSynonym)
 import Protolude (whenM, isJust)
 import Language.PureScript.AST.Binders (Binder)
 import Language.PureScript.AST.Declarations (Declaration, Expr (..))
@@ -437,6 +437,9 @@ substituteIdeTypes = onIdeArtifacts . substituteArtifactTypes
 endIdeSubstitutions :: MonadState CheckState m => m ()
 endIdeSubstitutions = onIdeArtifacts endSubstitutions
 
+addIdeSynonym :: MonadState CheckState m => SourceType -> SourceType -> m ()
+addIdeSynonym ty syn = onIdeArtifacts $ insertTypeSynonym syn ty
+
 whenAddingIdeArtifacts :: MonadState CheckState m => m () -> m ()
 whenAddingIdeArtifacts = whenM (gets (isJust . checkAddIdeArtifacts)) 
 
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index e119282885..1c17474f1e 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -12,15 +12,17 @@ module Language.PureScript.TypeChecker.Synonyms
 import Prelude
 
 import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State (MonadState)
+import Control.Monad.State (MonadState, StateT (runStateT), modify)
 import Data.Maybe (fromMaybe)
 import Data.Map qualified as M
 import Data.Text (Text)
 import Language.PureScript.Environment (Environment(..), TypeKind)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage')
 import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified)
-import Language.PureScript.TypeChecker.Monad (CheckState, getEnv)
+import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, addIdeSynonym)
 import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars)
+import Control.Monad.Except (Except, runExcept)
+import Data.Foldable (for_)
 
 -- | Type synonym information (arguments with kinds, aliased type), indexed by name
 type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType)
@@ -31,13 +33,22 @@ replaceAllTypeSynonyms'
   :: SynonymMap
   -> KindMap
   -> SourceType
-  -> Either MultipleErrors SourceType
-replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try
+  -> Either MultipleErrors (SourceType, [(SourceType, SourceType)])
+replaceAllTypeSynonyms' syns kinds  ty = runExcept $ runStateT (everywhereOnTypesTopDownM try ty) []
   where
-  try :: SourceType -> Either MultipleErrors SourceType
-  try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
+  try :: SourceType -> StateT [(SourceType, SourceType)] (Except MultipleErrors) SourceType
+  try t = do
+    res <- go (fst $ getAnnForType t) 0 [] [] t
+    case res of
+      Just t' -> do
+        modify ((t, t') :)
+        pure t'
+      Nothing ->
+        pure t
 
-  go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType)
+  go ::
+    SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType ->
+    StateT [(SourceType, SourceType)] (Except MultipleErrors) (Maybe SourceType)
   go ss c kargs args (TypeConstructor _ ctor)
     | Just (synArgs, body) <- M.lookup ctor syns
     , c == length synArgs
@@ -55,10 +66,15 @@ replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try
   lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text]
   lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds
 
+
 -- | Replace fully applied type synonyms
-replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType
+replaceAllTypeSynonyms :: forall e m. (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType
 replaceAllTypeSynonyms d = do
   env <- getEnv
-  either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d
+  either throwError trackUsedSynonym $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d
+  where
+    trackUsedSynonym (found, syns) = do
+      for_ syns $ uncurry addIdeSynonym
+      pure found
+
 
--- todo track synonymns
\ No newline at end of file

From a7ad826930e213d0ba982338909e84e6d6d67ae2 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 5 Nov 2024 15:47:29 +0100
Subject: [PATCH 229/297] adds hover on imports

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs | 27 +++++++++++++++----
 src/Language/PureScript/TypeChecker.hs        |  9 +++++++
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 12 +++++++++
 src/Language/PureScript/TypeChecker/Monad.hs  | 10 +++++--
 4 files changed, 51 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 610a8a24ef..885dd9bd32 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -13,14 +13,16 @@ import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.PureScript qualified as P
 import Language.PureScript.Docs.Convert.Single (convertComments)
+import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine)
-import Language.PureScript.Lsp.AtPosition (binderSourceSpan, spanToRange)
+import Language.PureScript.Lsp.AtPosition (binderSourceSpan, getImportRefNameType, spanToRange)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationTypeInModule)
-import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
+import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType, readModuleDocs)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
-import Language.PureScript.Lsp.State (cachedRebuild, cachedFilePaths)
+import Language.PureScript.Lsp.Print (printName)
+import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns)
@@ -52,7 +54,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
     debugLsp $ "Cache found: " <> show (isJust cacheOpenMb)
-    when (isNothing cacheOpenMb) do 
+    when (isNothing cacheOpenMb) do
       debugLsp $ "file path not cached: " <> T.pack filePath
       debugLsp . show =<< cachedFilePaths
     forLsp cacheOpenMb \OpenFile {..} -> do
@@ -112,9 +114,24 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (fromMaybe "_" decl) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
             IaType ty -> do
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (prettyPrintTypeSingleLine ty) (Just $ prettyPrintTypeSingleLine iaType) []
+            IaModule modName -> do
+              docsMb <- readModuleDocs modName
+              case docsMb of
+                Just docs | Just comments <- Docs.modComments docs -> markdownRes (Just $ spanToRange iaSpan) comments
+                _ -> nullRes
+            IaImport modName ref -> do
+              let name = P.declRefName ref
+                  nameType = getImportRefNameType ref
+                  name' = printName name
+              docs <- readDeclarationDocsWithNameType modName nameType name'
+              foundTypes <- getAstDeclarationTypeInModule (Just nameType) modName name'
+              markdownRes (Just $ spanToRange iaSpan) $
+                joinMarkup
+                  [ showDocs <$> docs,
+                    showTypeSection modName name' <$> head foundTypes
+                  ]
         _ -> nullRes
 
-
 showTypeSection :: P.ModuleName -> Text -> Text -> Text
 showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
 
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index a3cf489407..94589c4f21 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -596,6 +596,15 @@ typeCheckModule _ (Module _ _ _ _ Nothing) =
 typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) =
   warnAndRethrow (addHint (ErrorInModule mn)) $ do
     let (decls', imports) = partitionEithers $ fromImportDecl <$> decls
+    for_ imports $ \((modSS,_), mName, idType, _, _) -> do 
+      addIdeModule modSS mName
+      let 
+        refs = 
+          case idType of 
+            Explicit refs' -> refs'
+            Hiding refs' -> refs'
+            _ -> []
+      for_ refs (addIdeImport mName)
     modify (\s -> s { checkCurrentModule = Just mn, checkCurrentModuleImports = imports })
     decls'' <- typeCheckAll mn $ ignoreWildcardsUnderCompleteTypeSignatures <$> decls'
     checkSuperClassesAreExported <- getSuperClassExportCheck
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 566f453613..cd783311c0 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -15,6 +15,8 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     insertIaType,
     insertIaIdent,
     insertTypeSynonym,
+    insertModule,
+    insertImport,
     useSynonymns,
     debugSynonyms, 
     smallestArtifact,
@@ -80,6 +82,8 @@ data IdeArtifactValue
   | IaType P.SourceType
   | IaTypeName (P.ProperName 'P.TypeName)
   | IaClassName (P.ProperName 'P.ClassName)
+  | IaModule P.ModuleName
+  | IaImport P.ModuleName P.DeclarationRef
   deriving (Show)
 
 substituteArtifactTypes :: (P.SourceType -> P.SourceType) -> IdeArtifacts -> IdeArtifacts
@@ -212,6 +216,12 @@ insertIaTypeName ss name mName kind = insertAtLines ss (IaTypeName name) kind mN
 insertIaClassName :: P.SourceSpan -> P.ProperName 'P.ClassName -> Maybe P.ModuleName -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaClassName ss name mName kind = insertAtLines ss (IaClassName name) kind mName (Just $ Right $ fst $ P.getAnnForType kind)
 
+insertModule :: P.SourceSpan -> P.ModuleName -> IdeArtifacts -> IdeArtifacts
+insertModule ss name = insertAtLines ss (IaModule name) P.srcREmpty (Just name) Nothing
+
+insertImport :: P.ModuleName -> P.DeclarationRef -> IdeArtifacts -> IdeArtifacts
+insertImport name ref = insertAtLines (P.declRefSourceSpan ref) (IaImport name ref) P.srcREmpty (Just name) Nothing
+
 posFromQual :: P.Qualified a -> Maybe P.SourcePos
 posFromQual (P.Qualified (P.BySourcePos pos) _) = Just pos
 posFromQual _ = Nothing
@@ -295,6 +305,8 @@ debugIdeArtifactValue = \case
   IaType t -> "Type " <> debugType t
   IaTypeName name -> "TypeName: " <> P.runProperName name
   IaClassName name -> "ClassName: " <> P.runProperName name
+  IaModule name -> "Module: " <> P.runModuleName name
+  IaImport name ref -> "Import: " <> P.runModuleName name <> "." <> show ref
 
 debugType :: P.Type a -> Text
 debugType = T.pack . take 64 . P.prettyPrintType 5
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index a6206ae5c0..f268b744a6 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -22,14 +22,14 @@ import Data.List.NonEmpty qualified as NEL
 
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..))
-import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition)
+import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition, DeclarationRef)
 import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName)
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, endSubstitutions, insertTypeSynonym)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, endSubstitutions, insertTypeSynonym, insertModule, insertImport)
 import Protolude (whenM, isJust)
 import Language.PureScript.AST.Binders (Binder)
 import Language.PureScript.AST.Declarations (Declaration, Expr (..))
@@ -427,6 +427,12 @@ addIdeClassName mName ss name ty = onIdeArtifacts $ insertIaClassName ss name mN
 addIdeClassNameQual :: MonadState CheckState m => SourceSpan -> Qualified ( ProperName 'ClassName) -> SourceType -> m ()
 addIdeClassNameQual ss name ty = onIdeArtifacts $ insertIaClassName ss (disqualify name) (moduleNameFromQual name) ty
 
+addIdeModule :: MonadState CheckState m => SourceSpan -> ModuleName -> m ()
+addIdeModule ss mName = onIdeArtifacts $ insertModule ss mName
+
+addIdeImport :: MonadState CheckState m => ModuleName -> DeclarationRef -> m ()
+addIdeImport mName ref = onIdeArtifacts $ insertImport mName ref
+
 onIdeArtifacts :: MonadState CheckState m => (IdeArtifacts -> IdeArtifacts) -> m ()
 onIdeArtifacts f = whenAddingIdeArtifacts  
   $ modify $ \env -> env { checkIdeArtifacts = f (checkIdeArtifacts env) }

From d79bb1783039ba38b1e507ffd9d2d7d245e777ff Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 5 Nov 2024 18:11:30 +0100
Subject: [PATCH 230/297] goto def working with artifacts

---
 src/Language/PureScript/Lsp/AtPosition.hs     | 111 ------------------
 .../PureScript/Lsp/Handlers/Definition.hs     |  87 +++++++++-----
 src/Language/PureScript/Lsp/Handlers/Hover.hs |   5 +-
 .../PureScript/TypeChecker/IdeArtifacts.hs    |  17 +--
 4 files changed, 66 insertions(+), 154 deletions(-)

diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs
index ae5696b046..20544140fb 100644
--- a/src/Language/PureScript/Lsp/AtPosition.hs
+++ b/src/Language/PureScript/Lsp/AtPosition.hs
@@ -522,114 +522,3 @@ getImportRefNameType = \case
   P.ModuleRef _ _ -> ModNameType
   P.ReExportRef _ _ _ -> ModNameType
   P.TypeInstanceRef _ _ _ -> IdentNameType
-
--- t =
---   EverythingAtPos = Nothing,
---       apDecls =
---         [ ValueDeclaration
---             ( ValueDeclarationData
---                 { valdeclSourceAnn =
---                     ( SourceSpan
---                         { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 1},
---                           spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                         },
---                       []
---                     ),
---                   valdeclIdent = Ident "zzzzz",
---                   valdeclName = Public,
---                   valdeclBinders = [],
---                   valdeclExpression =
---                     [ GuardedExpr
---                         []
---                         ( TypedValue
---                             True
---                             ( PositionedValue
---                                 ( SourceSpan
---                                     { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                                       spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                                     }
---                                 )
---                                 []
---                                 ( Literal
---                                     ( SourceSpan
---                                         { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                                           spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                                         }
---                                     )
---                                     (NumericLiteral (Left 333333))
---                                 )
---                             )
---                             (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
---                         )
---                     ]
---                 }
---             )
---         ],
---       apExprs =
---         [ ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                 spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---               },
---             True,
---             Literal
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                     spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                   }
---               )
---               (NumericLiteral (Left 333333))
---           ),
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 1},
---                 spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---               },
---             True,
---             PositionedValue
---               ( SourceSpan
---                   { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                     spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                   }
---               )
---               []
---               ( Literal
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                         spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                       }
---                   )
---                   (NumericLiteral (Left 333333))
---               )
---           ),
---           ( SourceSpan
---               { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 1},
---                 spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---               },
---             False,
---             P.TypedValue
---               True
---               ( PositionedValue
---                   ( SourceSpan
---                       { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                         spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                       }
---                   )
---                   []
---                   ( Literal
---                       ( SourceSpan
---                           { spanStart = SourcePos {sourcePosLine = 62, sourcePosColumn = 9},
---                             spanEnd = SourcePos {sourcePosLine = 62, sourcePosColumn = 15}
---                           }
---                       )
---                       (NumericLiteral (Left 333333))
---                   )
---               )
---               (TypeConstructor (SourceSpan {spanName = "", spanStart = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}, spanEnd = SourcePos {sourcePosLine = 0, sourcePosColumn = 0}}, []) (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"})))
---           )
---         ],
---       apBinders = [],
---       apCaseAlternatives = [],
---       apDoNotationElements = [],
---       apGuards = [],
---       apTypes = [],
---       apImport = Nothing
---     }
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 2969ed398f..9a793ede0a 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -3,20 +3,24 @@
 module Language.PureScript.Lsp.Handlers.Definition where
 
 import Control.Lens ((^.))
+import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
 import Language.LSP.Server qualified as Server
 import Language.PureScript qualified as P
+import Language.PureScript.Lsp.AtPosition (getImportRefNameType, spanToRange)
 import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule)
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
-import Language.PureScript.Lsp.Util (posInSpan, sourcePosToPosition)
+import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
+import Language.PureScript.Lsp.Types (OpenFile (OpenFile, ofEndCheckState))
+import Language.PureScript.Lsp.Util (positionToSourcePos, sourcePosToPosition)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
 import Protolude
-import Language.PureScript.Lsp.AtPosition (atPosition, findDeclRefAtPos, getImportRefNameType, spanToRange)
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -29,41 +33,62 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
 
       posRes fp srcPos = locationRes fp $ Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos)
 
+      spanRes span = locationRes (P.spanName span) (spanToRange span)
+
       forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
       forLsp val f = maybe nullRes f val
 
       respondWithDeclInOtherModule :: LspNameType -> P.ModuleName -> Text -> HandlerM ()
       respondWithDeclInOtherModule nameType modName ident = do
         declSpans <- getAstDeclarationLocationInModule nameType modName ident
-        forLsp (head declSpans) $ \sourceSpan ->
-          locationRes (P.spanName sourceSpan) (spanToRange sourceSpan)
-
-      respondWithModule :: P.SourceSpan -> P.ModuleName -> HandlerM ()
-      respondWithModule ss modName =
-        if posInSpan pos ss
-          then do
-            modFpMb <- selectExternPathFromModuleName modName
-            forLsp modFpMb \modFp -> do
-              posRes modFp $ P.SourcePos 1 1
-          else nullRes
+        case head declSpans of
+          Just sourceSpan ->
+            locationRes (P.spanName sourceSpan) (spanToRange sourceSpan)
+          Nothing -> nullRes
 
-      respondWithImports ss importedModuleName imports = do
-        case findDeclRefAtPos pos imports of
-          Just import' -> do
-            let name = P.declRefName import'
-                nameType = getImportRefNameType import'
-            debugLsp $ "import: " <> show import'
-            respondWithDeclInOtherModule nameType importedModuleName (printName name)
-          _ -> do
-            debugLsp $ "respondWithModule importedModuleName: " <> show importedModuleName
-            respondWithModule ss importedModuleName
+      respondWithModule :: P.ModuleName -> HandlerM ()
+      respondWithModule modName = do
+        modFpMb <- selectExternPathFromModuleName modName
+        forLsp modFpMb \modFp -> do
+          posRes modFp $ P.SourcePos 1 1
 
   forLsp filePathMb \filePath -> do
-    atPosition
-      nullRes
-      respondWithDeclInOtherModule
-      respondWithImports
-      respondWithModule
-      posRes 
-      filePath 
-      pos
+    cacheOpenMb <- cachedRebuild filePath
+    when (isNothing cacheOpenMb) do
+      debugLsp $ "file path not cached: " <> T.pack filePath
+      debugLsp . show =<< cachedFilePaths
+
+    forLsp cacheOpenMb \OpenFile {..} -> do
+      let allArtifacts = P.checkIdeArtifacts ofEndCheckState
+          atPos = getArtifactsAtPosition (positionToSourcePos pos) allArtifacts
+      debugLsp $ "def artifacts length: " <> show (length atPos)
+      let smallest = smallestArtifact (\a -> (negate $ artifactInterest a, isNothing (iaDefinitionPos a), isNothing (iaDefinitionModule a))) atPos
+      case smallest of
+        Just (IdeArtifact _ (IaModule modName) _ _ _) -> respondWithModule modName
+        Just (IdeArtifact _ (IaImport modName ref) _ _ _) -> do
+          let nameType = getImportRefNameType ref
+              name = P.declRefName ref
+          respondWithDeclInOtherModule nameType modName (printName name)
+        Just (IdeArtifact _ (IaExpr _ (Just ident) (Just nameType)) _ (Just modName) _) -> do
+          respondWithDeclInOtherModule nameType modName ident
+        Just (IdeArtifact _ (IaTypeName name) _ (Just modName) _) -> do
+          respondWithDeclInOtherModule TyNameType modName (P.runProperName name)
+        Just (IdeArtifact _ (IaClassName name) _ (Just modName) _) -> do
+          respondWithDeclInOtherModule TyClassNameType modName (P.runProperName name)
+        Just (IdeArtifact _ _ _ _ (Just (Right defSpan))) -> do
+          spanRes defSpan
+        Just (IdeArtifact _ _ _ (Just modName) (Just (Left defPos))) -> do
+          fpMb <- selectExternPathFromModuleName modName
+          forLsp fpMb \fp -> posRes fp defPos
+        Just (IdeArtifact _ _ _ Nothing (Just (Left defPos))) -> do
+          posRes filePath defPos
+        _ -> do
+          debugLsp $ "No definition found for artifact: " <> show smallest
+          nullRes
+
+artifactInterest :: IdeArtifact -> Int
+artifactInterest (IdeArtifact {..}) = case iaValue of
+  IaBinder {} -> 2
+  IaTypeName {} -> 3
+  IaClassName {} -> 3
+  _ -> 1
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 885dd9bd32..fe4307b5f1 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -1,7 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Language.PureScript.Lsp.Handlers.Hover (hoverHandler) where
 
@@ -61,7 +59,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       let allArtifacts = P.checkIdeArtifacts ofEndCheckState
           atPos = getArtifactsAtPosition (positionToSourcePos startPos) allArtifacts
       debugLsp $ "hover artiacts length: " <> show (length atPos)
-      case smallestArtifact (\a -> (artifactInterest a, negate $ countUnkownsAndVars $ iaType a)) atPos of
+      case smallestArtifact (\a -> (negate $ artifactInterest a, negate $ countUnkownsAndVars $ iaType a)) atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
             IaExpr exprTxt ident nameType -> do
@@ -147,7 +145,6 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   IaBinder {} -> 2
   IaTypeName {} -> 3
   IaClassName {} -> 3
-  IaExpr _ _ _ -> negate (countUnkownsAndVars iaType)
   _ -> 1
 
 countUnkownsAndVars :: P.Type a -> Int
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index cd783311c0..0fa1fd4e0c 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -119,14 +119,11 @@ getArtifactsAtPosition pos (IdeArtifacts m _ _) =
 
 insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaExpr expr ty = case ss of
-  Just span | not (generatedExpr expr) -> insertAtLines span (IaExpr (exprCtr expr <> ": " <> fromMaybe "_" exprIdent) exprIdent exprNameType) ty mName defSpan
+  Just span | not (generatedExpr expr) -> 
+       insertAtLines span (IaExpr (exprCtr expr <> ": " <> fromMaybe "_" exprIdent) exprIdent (exprNameType expr)) ty mName defSpan
     where
       defSpan =
-        Left <$> case expr of
-          P.Var _ q -> posFromQual q
-          P.Constructor _ q -> posFromQual q
-          P.Op _ q -> posFromQual q
-          _ -> Nothing
+        Left <$> (posFromQual =<< exprIdentQual expr )
 
       mName = exprIdentQual expr >>= moduleNameFromQual
 
@@ -143,12 +140,16 @@ insertIaExpr expr ty = case ss of
         P.App e (P.TypeClassDictionary {}) -> exprIdentQual e
         _ -> Nothing
 
-      exprNameType :: Maybe LspNameType
-      exprNameType = case expr of
+      exprNameType :: P.Expr -> Maybe LspNameType
+      exprNameType = \case 
         P.Var _ _ -> Just IdentNameType
         P.Constructor _ _ -> Just DctorNameType
         P.Op _ _ -> Just ValOpNameType
+        P.PositionedValue _ _ e -> exprNameType e
+        P.TypedValue _ e _ -> exprNameType e
+        P.App e (P.TypeClassDictionary {}) -> exprNameType e
         _ -> Nothing
+        
   _ -> identity
   where
     ss = P.exprSourceSpan expr

From f2f80d332cbce2d2d0d3a092669e455618331099 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 6 Nov 2024 11:49:08 +0100
Subject: [PATCH 231/297] remove logs

---
 src/Language/PureScript/Lsp/Cache/Query.hs    |  2 --
 .../PureScript/Lsp/Handlers/Completion.hs     |  4 +---
 .../PureScript/Lsp/Handlers/Definition.hs     |  9 +++++---
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  5 ++--
 src/Language/PureScript/Lsp/Imports.hs        |  6 ++---
 src/Language/PureScript/Lsp/NameType.hs       |  2 +-
 src/Language/PureScript/Lsp/Rebuild.hs        | 23 ++-----------------
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 23 ++++++++++---------
 8 files changed, 27 insertions(+), 47 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 13c6e470a1..82b47f94d1 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -13,7 +13,6 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxCompletions, ge
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Language.PureScript.Names qualified as P
 import Protolude
-import Language.PureScript.Lsp.Log (debugLsp)
 
 ------------------------------------------------------------------------------------------------------------------------
 ------------ AST -------------------------------------------------------------------------------------------------------
@@ -69,7 +68,6 @@ getAstDeclarationsStartingWith ::
   Text ->
   m [CompletionResult]
 getAstDeclarationsStartingWith moduleName' prefix = do
-  debugLsp $ "prefix: " <> prefix
   limit <- getMaxCompletions
   typeLen <- getMaxTypeLength
   let offset = 0 :: Int
diff --git a/src/Language/PureScript/Lsp/Handlers/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs
index 1abaab8931..ae973b86c4 100644
--- a/src/Language/PureScript/Lsp/Handlers/Completion.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs
@@ -18,7 +18,7 @@ import Language.PureScript.Ide.Imports (Import (..))
 import Language.PureScript.Lsp.Cache.Query (CompletionResult (crModule, crName, crNameType, crType), getAstDeclarationsStartingWith, getAstDeclarationsStartingWithAndSearchingModuleNames, getAstDeclarationsStartingWithOnlyInModule)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsWithNameType)
 import Language.PureScript.Lsp.Imports (addImportToTextEdit, getIdentModuleQualifier, getMatchingImport, parseModuleNameFromFile)
-import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard)
+import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..), readableType, readableTypeIn)
 import Language.PureScript.Lsp.ServerConfig (getMaxCompletions)
@@ -50,11 +50,9 @@ completionAndResolveHandlers =
           forLsp vfMb \vf -> do
             let (range, word) = getSymbolAt (VFS._file_text vf) pos
             mNameMb <- parseModuleNameFromFile uri
-            debugLsp $ "word: " <> show word
             forLsp mNameMb \mName -> do
               let withQualifier = getIdentModuleQualifier word
                   wordWithoutQual = maybe word snd withQualifier
-              debugLsp $ "withQualifier: " <> show withQualifier
               limit <- getMaxCompletions
               matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier
               decls <- logPerfStandard "get completion declarations" case (matchingImport, withQualifier) of
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 9a793ede0a..4fc3c6bd86 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -21,6 +21,7 @@ import Language.PureScript.Lsp.Types (OpenFile (OpenFile, ofEndCheckState))
 import Language.PureScript.Lsp.Util (positionToSourcePos, sourcePosToPosition)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
 import Protolude
+import Language.PureScript.Lsp.Docs (readDeclarationDocsSourceSpan)
 
 definitionHandler :: Server.Handlers HandlerM
 definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition $ \req res -> do
@@ -44,7 +45,10 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
         case head declSpans of
           Just sourceSpan ->
             locationRes (P.spanName sourceSpan) (spanToRange sourceSpan)
-          Nothing -> nullRes
+          Nothing -> do
+            debugLsp $ "No definition in DB found for " <> show nameType <> " " <> show ident <> " in " <> show modName 
+            docSsMb <- readDeclarationDocsSourceSpan modName ident
+            forLsp docSsMb spanRes
 
       respondWithModule :: P.ModuleName -> HandlerM ()
       respondWithModule modName = do
@@ -61,7 +65,6 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
     forLsp cacheOpenMb \OpenFile {..} -> do
       let allArtifacts = P.checkIdeArtifacts ofEndCheckState
           atPos = getArtifactsAtPosition (positionToSourcePos pos) allArtifacts
-      debugLsp $ "def artifacts length: " <> show (length atPos)
       let smallest = smallestArtifact (\a -> (negate $ artifactInterest a, isNothing (iaDefinitionPos a), isNothing (iaDefinitionModule a))) atPos
       case smallest of
         Just (IdeArtifact _ (IaModule modName) _ _ _) -> respondWithModule modName
@@ -83,7 +86,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
         Just (IdeArtifact _ _ _ Nothing (Just (Left defPos))) -> do
           posRes filePath defPos
         _ -> do
-          debugLsp $ "No definition found for artifact: " <> show smallest
+          debugLsp "No relevat definition found for artifact"
           nullRes
 
 artifactInterest :: IdeArtifact -> Int
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index fe4307b5f1..387347cc4a 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -51,7 +51,6 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
 
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
-    debugLsp $ "Cache found: " <> show (isJust cacheOpenMb)
     when (isNothing cacheOpenMb) do
       debugLsp $ "file path not cached: " <> T.pack filePath
       debugLsp . show =<< cachedFilePaths
@@ -128,7 +127,9 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                   [ showDocs <$> docs,
                     showTypeSection modName name' <$> head foundTypes
                   ]
-        _ -> nullRes
+        Nothing -> do 
+          debugLsp "No hover artifact found"
+          nullRes
 
 showTypeSection :: P.ModuleName -> Text -> Text -> Text
 showTypeSection mName expr ty = "*" <> P.runModuleName mName <> "*\n" <> pursMd (expr <> " :: " <> ty)
diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs
index 891f4b1b5a..a168e32010 100644
--- a/src/Language/PureScript/Lsp/Imports.hs
+++ b/src/Language/PureScript/Lsp/Imports.hs
@@ -24,7 +24,7 @@ import Language.PureScript.CST qualified as CST
 import Language.PureScript.CST.Monad qualified as CSTM
 import Language.PureScript.Ide.Imports (Import (Import), prettyPrintImportSection, sliceImportSection)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationInModule)
-import Language.PureScript.Lsp.Log (debugLsp, errorLsp, warnLsp)
+import Language.PureScript.Lsp.Log (errorLsp, warnLsp)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.ReadFile (lspReadFileRope)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
@@ -49,9 +49,7 @@ addImportToTextEdit completionItem completeItemData = do
   pure $ set LSP.additionalTextEdits importEdits completionItem
 
 getImportEdits :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit])
-getImportEdits cid@(CompleteItemData path moduleName' importedModuleName name nameType word (Range wordStart _)) = do
-  debugLsp $ "CompletionItemData: " <> show cid
-  debugLsp $ "wordQualifierMb: " <> show (getIdentModuleQualifier word)
+getImportEdits (CompleteItemData path moduleName' importedModuleName name nameType word (Range wordStart _)) = do
   parseRes <- parseImportsFromFile (filePathToNormalizedUri path)
   case parseRes of
     Left err -> do
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index a1935ae1f1..9231d82ff1 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -20,7 +20,7 @@ data LspNameType
   | ModNameType
   | RoleNameType
   | KindNameType
-  deriving (Show, Read, Eq, Generic, A.ToJSON, A.FromJSON)
+  deriving (Show, Read, Eq, Ord, Generic, A.ToJSON, A.FromJSON)
 
 readableType :: LspNameType -> Text
 readableType = \case
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 738ff3c1dc..8a84170741 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -13,7 +13,7 @@ import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
 import Language.LSP.Server (MonadLsp, getConfig)
-import Language.PureScript (ExternsFile (efModuleName), primEnv)
+import Language.PureScript (ExternsFile, primEnv)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Environment qualified as P
@@ -25,7 +25,7 @@ import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
 import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheDependencies, cacheRebuild', cachedRebuild, getDbConn, mergeExportEnvCache, updateCachedModule, updateCachedModule')
-import Language.PureScript.Lsp.Types (ExternDependency (edExtern, edLevel), LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile, ofDependencies))
+import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile))
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Names qualified as P
@@ -158,25 +158,6 @@ couldBeFromNewImports =
     P.NameIsUndefined _ -> True
     _ -> False
 
-cachedImportsAreInActual ::
-  ( MonadReader Language.PureScript.Lsp.Types.LspEnvironment m,
-    MonadLsp ServerConfig m
-  ) =>
-  P.Module ->
-  OpenFile ->
-  m Bool
-cachedImportsAreInActual (P.Module _ _ _ decls _) (OpenFile {ofDependencies}) =
-  let cachedDirectDeps = Set.fromList $ efModuleName . edExtern <$> filter ((== 1) . edLevel) ofDependencies
-      actualDirectDeps =
-        Set.fromList $
-          decls >>= \case
-            P.ImportDeclaration _ importName _ _ -> [importName]
-            _ -> []
-   in do
-        debugLsp $ "Cached direct deps: " <> show (Set.map P.runModuleName cachedDirectDeps)
-        debugLsp $ "Actual direct deps: " <> show (Set.map P.runModuleName actualDirectDeps)
-        pure $ cachedDirectDeps `Set.isSubsetOf` actualDirectDeps
-
 buildExportEnvCacheAndHandleErrors ::
   (MonadReader Language.PureScript.Lsp.Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
   m [ExternDependency] ->
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 0fa1fd4e0c..0f979a6bc9 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -44,11 +44,12 @@ import Language.PureScript.Pretty.Types qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude
 import Safe (minimumByMay)
+import Data.Set qualified as Set
 
 data IdeArtifacts
   = IdeArtifacts
-      (Map Line [IdeArtifact]) -- with type var substitutions
-      (Map Line [IdeArtifact]) -- without var substitutions
+      (Map Line (Set IdeArtifact)) -- with type var substitutions
+      (Map Line (Set IdeArtifact)) -- without var substitutions
       (Map (P.Type ()) (P.Type ())) -- type synonym substitutions
   deriving (Show)
 
@@ -72,7 +73,7 @@ data IdeArtifact = IdeArtifact
     iaDefinitionModule :: Maybe P.ModuleName,
     iaDefinitionPos :: Maybe (Either P.SourcePos P.SourceSpan)
   }
-  deriving (Show)
+  deriving (Show, Eq, Ord)
 
 data IdeArtifactValue
   = IaExpr Text (Maybe Text) (Maybe LspNameType)
@@ -84,10 +85,10 @@ data IdeArtifactValue
   | IaClassName (P.ProperName 'P.ClassName)
   | IaModule P.ModuleName
   | IaImport P.ModuleName P.DeclarationRef
-  deriving (Show)
+  deriving (Show, Ord, Eq)
 
 substituteArtifactTypes :: (P.SourceType -> P.SourceType) -> IdeArtifacts -> IdeArtifacts
-substituteArtifactTypes f (IdeArtifacts m u s) = IdeArtifacts m (Map.map (fmap (onArtifactType f)) u) s
+substituteArtifactTypes f (IdeArtifacts m u s) = IdeArtifacts m (Map.map (Set.map (onArtifactType f)) u) s
 
 onArtifactType :: (P.SourceType -> P.SourceType) -> IdeArtifact -> IdeArtifact
 onArtifactType f (IdeArtifact {..}) = IdeArtifact iaSpan iaValue (f iaType) iaDefinitionModule iaDefinitionPos
@@ -96,12 +97,12 @@ endSubstitutions :: IdeArtifacts -> IdeArtifacts
 endSubstitutions (IdeArtifacts m u s) = IdeArtifacts (Map.unionWith (<>) m u) Map.empty s
 
 smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
-smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
+smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a))) 
 
-artifactsAtSpan :: P.SourceSpan -> IdeArtifacts -> [IdeArtifact]
+artifactsAtSpan :: P.SourceSpan -> IdeArtifacts -> Set IdeArtifact
 artifactsAtSpan span (IdeArtifacts m _ _) =
   Map.lookup (P.sourcePosLine $ P.spanStart span) m
-    & maybe [] (filter ((==) span . iaSpan))
+    & maybe Set.empty (Set.filter ((==) span . iaSpan))
 
 artifactSize :: IdeArtifact -> (Int, Int)
 artifactSize (IdeArtifact {..}) =
@@ -109,10 +110,10 @@ artifactSize (IdeArtifact {..}) =
     P.sourcePosColumn (P.spanEnd iaSpan) - P.sourcePosColumn (P.spanStart iaSpan)
   )
 
-getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
+getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts ->  [IdeArtifact]
 getArtifactsAtPosition pos (IdeArtifacts m _ _) =
   Map.lookup (P.sourcePosLine pos) m
-    & fromMaybe []
+    & maybe [] Set.toList 
     & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
   where
     posCol = P.sourcePosColumn pos
@@ -234,7 +235,7 @@ moduleNameFromQual _ = Nothing
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
 insertAtLines span value ty mName defSpan (IdeArtifacts m u s) = IdeArtifacts m (foldr insert u (linesFromSpan span)) s
   where
-    insert line = Map.insertWith (<>) line [IdeArtifact span value ty mName defSpan]
+    insert line = Map.insertWith Set.union line (Set.singleton $ IdeArtifact span value ty mName defSpan)
 
 linesFromSpan :: P.SourceSpan -> [Line]
 linesFromSpan ss = [P.sourcePosLine $ P.spanStart ss .. P.sourcePosLine $ P.spanEnd ss]

From 802325f99170972621f2adcb9c0f71706462b06b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 6 Nov 2024 15:14:34 +0100
Subject: [PATCH 232/297] use set for artifacts

---
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 39 +++++++++++--------
 1 file changed, 23 insertions(+), 16 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 0f979a6bc9..b17da7a3d8 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -18,7 +18,7 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     insertModule,
     insertImport,
     useSynonymns,
-    debugSynonyms, 
+    debugSynonyms,
     smallestArtifact,
     debugIdeArtifacts,
     insertIaTypeName,
@@ -33,6 +33,7 @@ where
 -- import Language.PureScript qualified as P
 
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Language.PureScript.AST.Binders qualified as P
 import Language.PureScript.AST.Declarations qualified as P
@@ -44,7 +45,6 @@ import Language.PureScript.Pretty.Types qualified as P
 import Language.PureScript.Types qualified as P
 import Protolude
 import Safe (minimumByMay)
-import Data.Set qualified as Set
 
 data IdeArtifacts
   = IdeArtifacts
@@ -97,7 +97,7 @@ endSubstitutions :: IdeArtifacts -> IdeArtifacts
 endSubstitutions (IdeArtifacts m u s) = IdeArtifacts (Map.unionWith (<>) m u) Map.empty s
 
 smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
-smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a))) 
+smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
 artifactsAtSpan :: P.SourceSpan -> IdeArtifacts -> Set IdeArtifact
 artifactsAtSpan span (IdeArtifacts m _ _) =
@@ -110,21 +110,22 @@ artifactSize (IdeArtifact {..}) =
     P.sourcePosColumn (P.spanEnd iaSpan) - P.sourcePosColumn (P.spanStart iaSpan)
   )
 
-getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts ->  [IdeArtifact]
+getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
 getArtifactsAtPosition pos (IdeArtifacts m _ _) =
   Map.lookup (P.sourcePosLine pos) m
-    & maybe [] Set.toList 
+    & maybe [] Set.toList
     & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
   where
     posCol = P.sourcePosColumn pos
 
 insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaExpr expr ty = case ss of
-  Just span | not (generatedExpr expr) -> 
-       insertAtLines span (IaExpr (exprCtr expr <> ": " <> fromMaybe "_" exprIdent) exprIdent (exprNameType expr)) ty mName defSpan
+  Just span
+    | not (generatedExpr expr) ->
+        insertAtLines span (IaExpr (exprCtr expr <> ": " <> fromMaybe "_" exprIdent) exprIdent (exprNameType expr)) ty mName defSpan
     where
       defSpan =
-        Left <$> (posFromQual =<< exprIdentQual expr )
+        Left <$> (posFromQual =<< exprIdentQual expr)
 
       mName = exprIdentQual expr >>= moduleNameFromQual
 
@@ -142,7 +143,7 @@ insertIaExpr expr ty = case ss of
         _ -> Nothing
 
       exprNameType :: P.Expr -> Maybe LspNameType
-      exprNameType = \case 
+      exprNameType = \case
         P.Var _ _ -> Just IdentNameType
         P.Constructor _ _ -> Just DctorNameType
         P.Op _ _ -> Just ValOpNameType
@@ -150,7 +151,6 @@ insertIaExpr expr ty = case ss of
         P.TypedValue _ e _ -> exprNameType e
         P.App e (P.TypeClassDictionary {}) -> exprNameType e
         _ -> Nothing
-        
   _ -> identity
   where
     ss = P.exprSourceSpan expr
@@ -233,7 +233,10 @@ moduleNameFromQual (P.Qualified (P.ByModuleName mn) _) = Just mn
 moduleNameFromQual _ = Nothing
 
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
-insertAtLines span value ty mName defSpan (IdeArtifacts m u s) = IdeArtifacts m (foldr insert u (linesFromSpan span)) s
+insertAtLines span@(P.SourceSpan _ start end) value ty mName defSpan ia@(IdeArtifacts m u s) =
+  if start == P.SourcePos 0 0 && end == P.SourcePos 0 0 -- ignore internal module spans
+    then ia
+    else IdeArtifacts m (foldr insert u (linesFromSpan span)) s
   where
     insert line = Map.insertWith Set.union line (Set.singleton $ IdeArtifact span value ty mName defSpan)
 
@@ -271,16 +274,20 @@ insertTypeSynonym :: P.Type a -> P.Type a -> IdeArtifacts -> IdeArtifacts
 insertTypeSynonym syn ty (IdeArtifacts m u s) = IdeArtifacts m u (Map.insert (void syn) (void ty) s)
 
 useSynonymns :: forall a. IdeArtifacts -> P.Type a -> P.Type ()
-useSynonymns (IdeArtifacts _ _ s) ty =  P.everywhereOnTypes go (void ty)
+useSynonymns (IdeArtifacts _ _ s) ty = P.everywhereOnTypes go (void ty)
   where
-    go :: P.Type  () ->  P.Type ()
-    go t = 
+    go :: P.Type () -> P.Type ()
+    go t =
       Map.lookup t s
         & maybe t go
 
 debugSynonyms :: IdeArtifacts -> Text
-debugSynonyms (IdeArtifacts _ _ s) = show $ Map.toList s <&> bimap
-  (ellipsis 100 . T.pack .  P.prettyPrintType 3) (ellipsis 100 . T.pack .  P.prettyPrintType 3)
+debugSynonyms (IdeArtifacts _ _ s) =
+  show $
+    Map.toList s
+      <&> bimap
+        (ellipsis 100 . T.pack . P.prettyPrintType 3)
+        (ellipsis 100 . T.pack . P.prettyPrintType 3)
 
 debugIdeArtifact :: IdeArtifact -> Text
 debugIdeArtifact (IdeArtifact {..}) =

From 832e21ac81f8e8f0573421618d6427c0962e2f38 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 6 Nov 2024 15:18:44 +0100
Subject: [PATCH 233/297] add log for getting diags

---
 src/Language/PureScript/Lsp/Diagnostics.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 9199b843fd..25eb585fe9 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -21,6 +21,7 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
+import Language.PureScript.Lsp.Log (debugLsp)
 
 getFileDiagnotics ::
   ( LSP.HasParams s a1,
@@ -35,6 +36,7 @@ getFileDiagnotics ::
 getFileDiagnotics msg = do
   let uri :: Types.NormalizedUri
       uri = getMsgUri msg & Types.toNormalizedUri
+  debugLsp $ "getting file diagnostics for: " <> show uri
   res <- rebuildFile uri
   pure $ addJsonEdits $ getResultDiagnostics res
 

From cc92ed0d06a8ea39ebd781506ed4af5152565d1c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 6 Nov 2024 15:19:21 +0100
Subject: [PATCH 234/297] increase cache size

---
 src/Language/PureScript/Make/Index.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index b3c508a49f..40bf178b1b 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -271,7 +271,8 @@ insertEfImport conn moduleName' ei = do
 initDb :: Connection -> IO ()
 initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"
-  SQL.execute_ conn "pragma foreign_keys = ON;"
+  SQL.execute_ conn "pragma foreign_keys=ON;"
+  SQL.execute_ conn "pragma cache_size=2000;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_
     conn

From 102a9b3969ec96385265f9b93beb252ef2fea307 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 6 Nov 2024 18:25:43 +0100
Subject: [PATCH 235/297] adds functions to cache envs

---
 src/Language/PureScript/Lsp/Cache.hs       | 49 +++++++++++++++++-----
 src/Language/PureScript/Lsp/Rebuild.hs     | 19 ++++-----
 src/Language/PureScript/Lsp/State.hs       | 47 ++++++++++++++++++++-
 src/Language/PureScript/Lsp/Types.hs       | 35 ++++++++--------
 src/Language/PureScript/Make/Index.hs      | 23 ++++++++--
 src/Language/PureScript/Sugar/Names/Env.hs | 11 +++--
 6 files changed, 136 insertions(+), 48 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index ec8f90e6d8..79fb21d7e6 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -1,24 +1,23 @@
 module Language.PureScript.Lsp.Cache where
 
-import Codec.Serialise (deserialise)
+import Codec.Serialise (deserialise, serialise)
 import Data.Aeson qualified as A
 import Data.Map qualified as Map
 import Data.Text qualified as T
 import Database.SQLite.Simple
+import Language.LSP.Server (MonadLsp, getConfig)
+import Language.PureScript qualified as P
 import Language.PureScript.AST.Declarations as P
 import Language.PureScript.Externs (ExternsFile (efModuleName))
-import Language.PureScript.Externs qualified as P
 import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
 import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Lsp.DB qualified as DB
-import Language.PureScript.Lsp.Types (LspEnvironment, ExternDependency)
-import Language.PureScript.Names qualified as P
+import Language.PureScript.Lsp.Log (logPerfStandard)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (globs, inputSrcFromFile, outputPath))
+import Language.PureScript.Lsp.Types (ExternDependency (edHash), LspEnvironment)
 import Protolude
-import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute, canonicalizePath)
+import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute)
 import System.FilePath (normalise, (</>))
-import Language.PureScript.Lsp.Log (logPerfStandard)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig(outputPath, globs, inputSrcFromFile))
-import Language.LSP.Server (getConfig, MonadLsp)
 
 selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName ExternsFile)
 selectAllExternsMap = do
@@ -28,7 +27,6 @@ selectAllExterns :: (MonadIO m, MonadReader LspEnvironment m) => m [ExternsFile]
 selectAllExterns = do
   DB.query_ (Query "SELECT value FROM externs") <&> fmap (deserialise . fromOnly)
 
-
 selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m [ExternDependency]
 selectDependencies (P.Module _ _ _ decls _) = do
   DB.queryNamed (Query query') [":module_names" := A.encode (fmap P.runModuleName importedModuleNames)]
@@ -50,7 +48,7 @@ selectDependencies (P.Module _ _ _ decls _) = do
           "module_names as (select distinct(module_name), level",
           "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
           "order by level desc)",
-          "select value, level from externs ",
+          "select value, level, id from externs ",
           "join module_names on externs.module_name = module_names.module_name ",
           "order by level desc, module_names.module_name desc;"
         ]
@@ -119,4 +117,33 @@ updateAvailableSrcs = logPerfStandard "updateAvailableSrcs" $ do
     when (absPath /= canonPath) $
       DB.executeNamed (Query "INSERT INTO available_srcs (path) VALUES (:path)") [":path" := absPath]
 
-  pure srcs
\ No newline at end of file
+  pure srcs
+
+cacheEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Environment -> m ()
+cacheEnvironment path deps env = do
+  DB.executeNamed
+    (Query "INSERT INTO environments (path, hash, value) VALUES (:deps, :env)")
+    [ ":path" := path,
+      ":hash" := hash (sort $ fmap edHash deps),
+      ":value" := serialise env
+    ]
+
+-- cachedEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe P.Environment)
+-- cachedEnvironment path deps = do
+--   res <-
+--     DB.queryNamed
+--       (Query "SELECT value FROM environments WHERE path = :path AND hash = :hash")
+--       [ ":path" := path,
+--         ":hash" := hash (sort $ fmap edHash deps)
+--       ]
+--   pure $ deserialise . fromOnly <$> listToMaybe res
+
+-- cacheExportEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Env -> m ()
+-- cacheExportEnvironment path deps env = do
+--   DB.executeNamed
+--     (Query "INSERT INTO export_environments (path, hash, value) VALUES (:deps, :env)")
+--     [ ":path" := path,
+--       ":hash" := hash (sort $ fmap edHash deps),
+--       ":value" := serialise env
+--     ]
+
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 8a84170741..7d85e9284d 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -43,7 +43,7 @@ rebuildFile ::
   NormalizedUri ->
   m RebuildResult
 rebuildFile uri =
-  logPerfStandard "Rebuild module" do
+  logPerfStandard ("Rebuild module: " <> show uri) do
     fp <- case fromNormalizedUri uri & uriToFilePath of
       Just x -> pure x
       Nothing -> throwM $ CouldNotConvertUriToFilePath uri
@@ -63,14 +63,13 @@ rebuildFile uri =
         let mkMakeActions :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
             mkMakeActions foreigns externs =
               P.buildMakeActions outputDirectory filePathMap foreigns False
-                -- & broadcastProgress chan
                 & addAllIndexing conn
                 & addRebuildCaching stVar maxCache externs m
         case cachedBuild of
-          Just open -> do
-            rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m open
-          Nothing -> do
-            rebuildWithoutCache moduleName mkMakeActions fp pwarnings m
+          -- Just open -> do
+          --   rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m open
+          _ -> do
+            rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m
 
 rebuildFromOpenFileCache ::
   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
@@ -99,7 +98,7 @@ rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName
   case fst res of
     Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
       warnLsp "Module not found error detected, rebuilding without cache"
-      rebuildWithoutCache moduleName mkMakeActions fp pwarnings m
+      rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m
     _ -> handleRebuildResult fp pwarnings res
 
 getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
@@ -112,7 +111,7 @@ getIdeCheckState =
         { P.checkAddIdeArtifacts = Just if infer then P.AllIdeExprs else P.IdentIdeExprs
         }
 
-rebuildWithoutCache ::
+rebuildWithoutFileCache ::
   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
   P.ModuleName ->
   (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
@@ -120,9 +119,9 @@ rebuildWithoutCache ::
   [CST.ParserWarning] ->
   P.Module ->
   m RebuildResult
-rebuildWithoutCache moduleName mkMakeActions fp pwarnings m = do
+rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m = do
   outputDirectory <- outputPath <$> getConfig
-  externDeps <- logPerfStandard "Select depenencies" $ selectDependencies m
+  externDeps <- logPerfStandard "Select dependencies" $ selectDependencies m
   let externs = fmap edExtern externDeps
   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
   exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 6e466da1cd..fd35543a21 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -26,6 +26,10 @@ module Language.PureScript.Lsp.State
     getPreviousConfig,
     cachedFiles,
     cachedFilePaths,
+    cachedEnvironment,
+    cacheEnvironment,
+    cachedExportEnvironment,
+    cacheExportEnvironment,
   )
 where
 
@@ -48,8 +52,8 @@ import Language.PureScript.Lsp.Types
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
-import Protolude hiding (moduleName, unzip)
 import Language.PureScript.TypeChecker qualified as P
+import Protolude hiding (moduleName, unzip)
 
 getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
@@ -99,6 +103,46 @@ cachedFiles = do
 cachedFilePaths :: (MonadIO m, MonadReader LspEnvironment m) => m [FilePath]
 cachedFilePaths = fmap fst <$> cachedFiles
 
+cacheEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Environment -> m ()
+cacheEnvironment fp deps env = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x ->
+    x
+      { environments = ((fp, hashDeps deps), env) : environments x
+      }
+
+cachedEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe P.Environment)
+cachedEnvironment fp deps = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ do
+    fmap snd .  find match . environments <$> readTVar st 
+
+  where 
+    hashed = hashDeps deps
+    match ((fp', hash'), _) = fp == fp' && hash' == hashed
+
+cacheExportEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Env -> m ()
+cacheExportEnvironment fp deps env = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x ->
+    x
+      { exportEnvs = ((fp, hashDeps deps), env) : exportEnvs x
+      }
+
+cachedExportEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe P.Env)
+cachedExportEnvironment fp deps = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ do
+    fmap snd . find match . exportEnvs <$> readTVar st
+
+  where
+    hashed = hashDeps deps
+    match ((fp', hash'), _) = fp == fp' && hash' == hashed
+
+hashDeps :: [ExternDependency] -> Int
+hashDeps = hash . sort . fmap edHash
+
+
 cacheDependencies :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> [ExternDependency] -> m ()
 cacheDependencies moduleName deps = do
   st <- lspStateVar <$> ask
@@ -149,7 +193,6 @@ buildExportEnvCache module' externs = do
             writeTVar st $ st' {exportEnv = newEnv}
             pure $ Right newEnv
 
-
 mergeExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Env -> m ()
 mergeExportEnvCache env = do
   st <- lspStateVar <$> ask
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index bd1c9ff048..66b37138a3 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -2,40 +2,40 @@
 
 module Language.PureScript.Lsp.Types where
 
+import Codec.Serialise (deserialise, serialise)
 import Control.Concurrent.STM (TVar, newTVarIO)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson qualified as A
 import Database.SQLite.Simple (Connection, FromRow (fromRow), ToRow (toRow), field)
 import Language.LSP.Protocol.Types (Range)
+import Language.PureScript.AST qualified as P
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs qualified as P
+import Language.PureScript.Lsp.LogLevel (LspLogLevel)
+import Language.PureScript.Lsp.NameType (LspNameType)
+import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (Env)
 import Language.PureScript.Sugar.Names qualified as P
-import Protolude
-import Language.PureScript.AST qualified as P
-import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
-import Language.PureScript.Lsp.LogLevel (LspLogLevel)
-import Codec.Serialise (deserialise, serialise)
-import Language.PureScript.Lsp.NameType (LspNameType)
 import Language.PureScript.TypeChecker qualified as P
+import Protolude
 
 data LspEnvironment = LspEnvironment
   { lspDbConnectionVar :: TVar (FilePath, Connection),
     lspStateVar :: TVar LspState,
-    previousConfig :: TVar  ServerConfig
+    previousConfig :: TVar ServerConfig
   }
 
 mkEnv :: FilePath -> IO LspEnvironment
 mkEnv outputPath = do
   connection <- newTVarIO =<< mkConnection outputPath
-  st <- newTVarIO (LspState mempty P.primEnv mempty)
+  st <- newTVarIO emptyState
   prevConfig <- newTVarIO $ defaultConfig outputPath
   pure $ LspEnvironment connection st prevConfig
 
 emptyState :: LspState
-emptyState = LspState mempty P.primEnv mempty
+emptyState = LspState mempty P.primEnv mempty mempty mempty
 
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
@@ -48,6 +48,8 @@ data LspConfig = LspConfig
 data LspState = LspState
   { openFiles :: [(FilePath, OpenFile)],
     exportEnv :: Env,
+    exportEnvs :: [((FilePath, Int), Env)],
+    environments :: [((FilePath, Int), P.Environment)],
     runningRequests :: Map (Either Int32 Text) (Async ())
   }
 
@@ -59,21 +61,21 @@ data OpenFile = OpenFile
     ofEndEnv :: P.Environment,
     ofEndCheckState :: P.CheckState,
     ofUncheckedModule :: P.Module,
-    ofModule ::  P.Module
+    ofModule :: P.Module
   }
 
-  
 data ExternDependency = ExternDependency
   { edExtern :: P.ExternsFile,
-    edLevel :: Int
-  } deriving (Show)
+    edLevel :: Int,
+    edHash :: Int
+  }
+  deriving (Show)
 
 instance FromRow ExternDependency where
-  fromRow = ExternDependency <$> (deserialise <$> field) <*> field
+  fromRow = ExternDependency <$> (deserialise <$> field) <*> field <*> field
 
 instance ToRow ExternDependency where
-  toRow (ExternDependency ef level) = toRow (serialise ef, level)
-
+  toRow (ExternDependency ef level updated_at) = toRow (serialise ef, level, updated_at)
 
 data CompleteItemData = CompleteItemData
   { cidPath :: FilePath,
@@ -86,7 +88,6 @@ data CompleteItemData = CompleteItemData
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
-
 decodeCompleteItemData :: Maybe A.Value -> A.Result (Maybe CompleteItemData)
 decodeCompleteItemData Nothing = pure Nothing
 decodeCompleteItemData (Just v) = A.fromJSON v
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 40bf178b1b..1ac8656da8 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -1,6 +1,17 @@
 {-# LANGUAGE BlockArguments #-}
 
-module Language.PureScript.Make.Index where
+module Language.PureScript.Make.Index
+  ( initDb,
+    addAllIndexing,
+    addAstModuleIndexing,
+    addExternIndexing,
+    indexAstModuleFromExtern,
+    indexAstDeclFromExternDecl,
+    dropTables,
+    indexExtern,
+    getExportedNames,
+  )
+where
 
 import Codec.Serialise (serialise)
 import Data.List (partition)
@@ -245,16 +256,18 @@ indexExtern conn extern = liftIO do
     [":path" := path]
   SQL.executeNamed
     conn
-    (SQL.Query "INSERT OR REPLACE INTO externs (path, ef_version, value, module_name) VALUES (:path, :ef_version, :value, :module_name)")
+    (SQL.Query "INSERT OR REPLACE INTO externs (path, ef_version, value, hash, module_name) VALUES (:path, :ef_version, :value, :module_name)")
     [ ":path" := path,
       ":ef_version" := P.efVersion extern,
-      ":value" := serialise extern,
+      ":value" := serialised,
+      ":hash" := hash serialised,
       ":module_name" := P.runModuleName name
     ]
   forM_ (P.efImports extern) $ insertEfImport conn name
   where
     name = efModuleName extern
     externPath = P.spanName (P.efSourceSpan extern)
+    serialised = serialise extern
 
 insertEfImport :: Connection -> P.ModuleName -> P.ExternsImport -> IO ()
 insertEfImport conn moduleName' ei = do
@@ -279,9 +292,11 @@ initDb conn = do
     "CREATE TABLE IF NOT EXISTS ast_declarations \
     \(module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, name TEXT, name_type TEXT, decl_ctr TEXT, ctr_type TEXT, printed_type TEXT, start_line INTEGER, end_line INTEGER, start_col INTEGER, end_col INTEGER, lines INTEGER, cols INTEGER, exported BOOLEAN, generated BOOLEAN, \
     \UNIQUE(module_name, name_type, name) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, ef_version TEXT, value BLOB, module_name TEXT, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS externs (path TEXT PRIMARY KEY, hash INT NOT NULL, ef_version TEXT, value BLOB NOT NULL, module_name TEXT NOT NULL, UNIQUE(path) on conflict replace, UNIQUE(module_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ef_imports (module_name TEXT references externs(module_name) ON DELETE CASCADE, imported_module TEXT, import_type TEXT, imported_as TEXT, value BLOB)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS export_environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
 
   addDbIndexes conn
 
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index 2ab8b00d5c..914d0e710e 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Language.PureScript.Sugar.Names.Env
   ( ImportRecord(..)
   , ImportProvenance(..)
@@ -38,6 +39,8 @@ import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage')
 import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual)
+import GHC.Generics (Generic)
+import Codec.Serialise (Serialise)
 
 -- |
 -- The details for an import: the name of the thing that is being imported
@@ -51,7 +54,7 @@ data ImportRecord a =
     , importSourceSpan :: SourceSpan
     , importProvenance :: ImportProvenance
     }
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show,  Generic, Serialise)
 
 -- |
 -- Used to track how an import was introduced into scope. This allows us to
@@ -63,7 +66,7 @@ data ImportProvenance
   | FromExplicit
   | Local
   | Prim
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic, Serialise)
 
 type ImportMap a = M.Map (Qualified a) [ImportRecord a]
 
@@ -110,7 +113,7 @@ data Imports = Imports
   -- Local names for kinds within a module mapped to their qualified names
   --
   , importedKinds :: ImportMap (ProperName 'TypeName)
-  } deriving (Show)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 nullImports :: Imports
 nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty
@@ -142,7 +145,7 @@ data Exports = Exports
   -- from.
   --
   , exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource
-  } deriving (Show)
+  } deriving (Show, Eq, Ord, Generic, Serialise)
 
 -- |
 -- An empty 'Exports' value.

From 4a83529aedd598bcab3267a0b5c4a594f188ad4e Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 6 Nov 2024 18:31:09 +0100
Subject: [PATCH 236/297] set cache size in mb

---
 src/Language/PureScript/Make/Index.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 1ac8656da8..ecfb5a030f 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -285,7 +285,7 @@ initDb :: Connection -> IO ()
 initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"
   SQL.execute_ conn "pragma foreign_keys=ON;"
-  SQL.execute_ conn "pragma cache_size=2000;"
+  SQL.execute_ conn "pragma cache_size=-6000;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_
     conn

From 05bb2aeefddaefa1bff50681c1ec059f2f5b9303 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 7 Nov 2024 12:31:54 +0100
Subject: [PATCH 237/297] adds export caching

---
 src/Language/PureScript/Lsp/Cache.hs        |   8 +-
 src/Language/PureScript/Lsp/Rebuild.hs      | 220 ++++++++++++--------
 src/Language/PureScript/Lsp/ServerConfig.hs |   2 +-
 src/Language/PureScript/Lsp/State.hs        |  23 +-
 src/Language/PureScript/Make/Index.hs       |   2 +-
 5 files changed, 158 insertions(+), 97 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index 79fb21d7e6..d6b1d473af 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -48,7 +48,7 @@ selectDependencies (P.Module _ _ _ decls _) = do
           "module_names as (select distinct(module_name), level",
           "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
           "order by level desc)",
-          "select value, level, id from externs ",
+          "select value, level, hash from externs ",
           "join module_names on externs.module_name = module_names.module_name ",
           "order by level desc, module_names.module_name desc;"
         ]
@@ -64,6 +64,12 @@ selectExternFromFilePath path = do
   res <- DB.queryNamed (Query "SELECT value FROM externs WHERE path = :path") [":path" := absPath]
   pure $ deserialise . fromOnly <$> listToMaybe res
 
+
+selectExternsCount :: (MonadIO m, MonadReader LspEnvironment m) => m Int
+selectExternsCount = do
+  res <- DB.query_ (Query "SELECT count(*) FROM externs")
+  pure $ maybe 0 fromOnly (listToMaybe res)
+
 selectExternModuleNameFromFilePath :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe P.ModuleName)
 selectExternModuleNameFromFilePath path = do
   absPath <- liftIO $ makeAbsolute path
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 7d85e9284d..51c6845f8a 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -20,12 +20,13 @@ import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
-import Language.PureScript.Lsp.Cache (selectDependencies)
-import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp)
+import Language.PureScript.Lsp.Cache (selectDependencies, selectExternsCount)
+import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp, errorLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternToExportEnv, addExternsToExportEnv, buildExportEnvCache, cacheDependencies, cacheRebuild', cachedRebuild, getDbConn, mergeExportEnvCache, updateCachedModule, updateCachedModule')
-import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState, OpenFile (OpenFile))
+import Language.PureScript.Lsp.State (addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedExportEnvironment, getDbConn, mergeExportEnvCache, updateCachedModule, cacheExportEnvironment)
+import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState)
+import Language.PureScript.Lsp.Types qualified as Types
 import Language.PureScript.Make qualified as P
 import Language.PureScript.Make.Index (addAllIndexing)
 import Language.PureScript.Names qualified as P
@@ -37,13 +38,14 @@ import Protolude hiding (moduleName, race, race_, threadDelay)
 rebuildFile ::
   forall m.
   ( MonadThrow m,
-    MonadReader Language.PureScript.Lsp.Types.LspEnvironment m,
+    MonadReader Types.LspEnvironment m,
     MonadLsp ServerConfig m
   ) =>
   NormalizedUri ->
   m RebuildResult
-rebuildFile uri =
-  logPerfStandard ("Rebuild module: " <> show uri) do
+rebuildFile uri = do 
+  debugLsp $ "Rebuilding file: " <> show uri
+  logPerfStandard ("Rebuilt file: " <> show uri) do
     fp <- case fromNormalizedUri uri & uriToFilePath of
       Just x -> pure x
       Nothing -> throwM $ CouldNotConvertUriToFilePath uri
@@ -52,6 +54,7 @@ rebuildFile uri =
       Left parseError ->
         pure $ RebuildError $ CST.toMultipleErrors fp parseError
       Right (pwarnings, m) -> do
+        debugLsp $ "Rebuilding module: " <> show (P.runModuleName $ P.getModuleName m)
         updateCachedModule m
         let moduleName = P.getModuleName m
         let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
@@ -59,94 +62,69 @@ rebuildFile uri =
         conn <- getDbConn
         stVar <- asks lspStateVar
         maxCache <- getMaxFilesInCache
-        cachedBuild <- cachedRebuild fp
         let mkMakeActions :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
             mkMakeActions foreigns externs =
               P.buildMakeActions outputDirectory filePathMap foreigns False
                 & addAllIndexing conn
                 & addRebuildCaching stVar maxCache externs m
-        case cachedBuild of
-          -- Just open -> do
-          --   rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m open
-          _ -> do
-            rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m
-
-rebuildFromOpenFileCache ::
-  (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
-  FilePath ->
-  [CST.ParserWarning] ->
-  TVar LspState ->
-  (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
-  P.Module ->
-  OpenFile ->
-  m RebuildResult
-rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName _ externDeps env _ _ _ _) = do
-  outputDirectory <- outputPath <$> getConfig
-  let externs = fmap edExtern externDeps
-  foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-  (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
-  for_ externsMb (cacheDependencies moduleName)
-  ideCheckState <- getIdeCheckState
-  res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
-    P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-      newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState (Just $ updateCachedModule' stVar) (mkMakeActions foreigns externDeps) exportEnv env externs m Nothing
-      updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
-      pure newExtern
-  case fst res of
-    Left errs -> debugLsp $ "Rebuild error detected: " <> show errs
-    _ -> pure ()
-  case fst res of
-    Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
-      warnLsp "Module not found error detected, rebuilding without cache"
-      rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m
-    _ -> handleRebuildResult fp pwarnings res
+        debugLsp $ "Selecting dependencies for module: " <> show moduleName
+        externDeps <- logPerfStandard "Selected dependencies" $ selectDependencies m
+        when (null externDeps) do 
+          warnLsp $ "No dependencies found for module: " <> show moduleName
+          checkExternsExist
+        let externs = fmap edExtern externDeps
+        foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+        exportEnv <- logPerfStandard "built export cache" $ getExportEnv fp externDeps
+        ideCheckState <- getIdeCheckState
+        (res, warnings) <- logPerfStandard "Rebuilt Module" $ liftIO $ do
+          P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+            newExtern <- rebuildModule' ideCheckState (mkMakeActions foreigns externDeps) exportEnv externs m
+            updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+            pure newExtern
+        debugLsp $ "Rebuild success: " <> show (isRight res)
+        case res of  
+          Left errs -> pure $ RebuildError errs
+          Right _ -> do 
+            cacheExportEnvironment fp externDeps exportEnv
+            pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
+        where
+          rebuildModule' ideCheckState act env ext mdl = rebuildModuleWithIndex ideCheckState act env ext mdl Nothing
 
-getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
-getIdeCheckState =
-  ideCheckState <$> getInferExpressions
-  where
-    ideCheckState :: Bool -> P.Environment -> P.CheckState
-    ideCheckState infer env =
-      (P.emptyCheckState env)
-        { P.checkAddIdeArtifacts = Just if infer then P.AllIdeExprs else P.IdentIdeExprs
-        }
+          rebuildModuleWithIndex ideCheckState act exEnv externs m' moduleIndex = do
+            let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
+            P.rebuildModuleWithProvidedEnv ideCheckState Nothing act exEnv env externs m' moduleIndex
+
+          checkExternsExist = do 
+            externCount <- selectExternsCount
+            when (externCount == 0) do 
+              errorLsp "No externs found in database, please build project"
 
-rebuildWithoutFileCache ::
-  (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
-  P.ModuleName ->
-  (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
+getExportEnv :: forall m. 
+  ( MonadThrow m,
+    MonadReader Types.LspEnvironment m,
+    MonadLsp ServerConfig m
+  ) =>
   FilePath ->
-  [CST.ParserWarning] ->
-  P.Module ->
-  m RebuildResult
-rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m = do
-  outputDirectory <- outputPath <$> getConfig
-  externDeps <- logPerfStandard "Select dependencies" $ selectDependencies m
-  let externs = fmap edExtern externDeps
-  foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-  exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
-  ideCheckState <- getIdeCheckState
-  res <- logPerfStandard "Rebuild Module" $ liftIO $ do
-    P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-      newExtern <- rebuildModule' ideCheckState (mkMakeActions foreigns externDeps) exportEnv externs m
-      updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
-      pure newExtern
-  handleRebuildResult fp pwarnings res
-  where
-    rebuildModule' ideCheckState act env ext mdl = rebuildModuleWithIndex ideCheckState act env ext mdl Nothing
+  [ExternDependency] ->
+  m P.Env
+getExportEnv fp deps = do
+  cached <- cachedExportEnvironment fp deps
+  debugLsp $ "Export env cache hit: " <> show (isJust cached)
+  cached & maybe (buildExportEnvFromPrim $ fmap edExtern deps) pure
 
-    rebuildModuleWithIndex ideCheckState act exEnv externs m' moduleIndex = do
-      let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
-      P.rebuildModuleWithProvidedEnv ideCheckState Nothing act exEnv env externs m' moduleIndex
+buildExportEnvFromPrim :: (Foldable t, MonadThrow m) => t ExternsFile -> m P.Env
+buildExportEnvFromPrim =
+  addExternsToExportEnv P.primEnv
+    >=> either (throwM . CouldNotRebuildExportEnv . P.prettyPrintMultipleErrors P.noColorPPEOptions) pure
 
-handleRebuildResult :: (MonadLsp ServerConfig f, MonadReader LspEnvironment f) => FilePath -> [CST.ParserWarning] -> (Either P.MultipleErrors ExternsFile, P.MultipleErrors) -> f RebuildResult
-handleRebuildResult fp pwarnings (result, warnings) = do
-  case result of
-    Left errors ->
-      pure $ RebuildError errors
-    Right newExtern -> do
-      addExternToExportEnv newExtern
-      pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
+-- handleRebuildResult :: ( MonadReader LspEnvironment f) =>FilePath -> [CST.ParserWarning] -> (Either P.MultipleErrors ExternsFile, P.MultipleErrors) -> f RebuildResult
+-- handleRebuildResult fp pwarnings (result, warnings) = do
+--   case result of
+--     Left errors ->
+--       pure $ RebuildError errors
+--     Right newExtern -> do
+--       -- addExternToExportEnv newExtern
+--       pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
 
 couldBeFromNewImports :: P.ErrorMessage -> Bool
 couldBeFromNewImports =
@@ -158,7 +136,7 @@ couldBeFromNewImports =
     _ -> False
 
 buildExportEnvCacheAndHandleErrors ::
-  (MonadReader Language.PureScript.Lsp.Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
+  (MonadReader Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
   m [ExternDependency] ->
   P.Module ->
   [ExternsFile] ->
@@ -181,7 +159,7 @@ buildExportEnvCacheAndHandleErrors refetchExterns m externs = do
     Right env -> pure (env, Nothing)
 
 addExternsToExportEnvOrThrow ::
-  (MonadReader Language.PureScript.Lsp.Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
+  (MonadReader Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
   P.Env ->
   [ExternsFile] ->
   m P.Env
@@ -221,3 +199,71 @@ addRebuildCaching stVar maxCache deps unchecked ma =
   ma
     { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv (P.checkEnv checkSt) checkSt unchecked astM) <* P.codegen ma prevEnv checkSt astM m docs ext
     }
+
+-- rebuildFromOpenFileCache ::
+--   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
+--   FilePath ->
+--   [CST.ParserWarning] ->
+--   TVar LspState ->
+--   (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
+--   P.Module ->
+--   OpenFile ->
+--   m RebuildResult
+-- rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName _ externDeps env _ _ _ _) = do
+--   outputDirectory <- outputPath <$> getConfig
+--   let externs = fmap edExtern externDeps
+--   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+--   (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
+--   for_ externsMb (cacheDependencies moduleName)
+--   ideCheckState <- getIdeCheckState
+--   res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
+--     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+--       newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState (Just $ updateCachedModule' stVar) (mkMakeActions foreigns externDeps) exportEnv env externs m Nothing
+--       updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+--       pure newExtern
+--   case fst res of
+--     Left errs -> debugLsp $ "Rebuild error detected: " <> show errs
+--     _ -> pure ()
+--   case fst res of
+--     Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
+--       warnLsp "Module not found error detected, rebuilding without cache"
+--       rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m
+--     _ -> handleRebuildResult fp pwarnings res
+
+getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
+getIdeCheckState =
+  ideCheckState <$> getInferExpressions
+  where
+    ideCheckState :: Bool -> P.Environment -> P.CheckState
+    ideCheckState infer env =
+      (P.emptyCheckState env)
+        { P.checkAddIdeArtifacts = Just if infer then P.AllIdeExprs else P.IdentIdeExprs
+        }
+
+-- rebuildWithoutFileCache ::
+--   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
+--   P.ModuleName ->
+--   (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
+--   FilePath ->
+--   [CST.ParserWarning] ->
+--   P.Module ->
+--   m RebuildResult
+-- rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m = do
+--   outputDirectory <- outputPath <$> getConfig
+--   externDeps <- logPerfStandard "Select dependencies" $ selectDependencies m
+--   let externs = fmap edExtern externDeps
+--   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+--   exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
+--   ideCheckState <- getIdeCheckState
+--   res <- logPerfStandard "Rebuild Module" $ liftIO $ do
+--     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+--       newExtern <- rebuildModule' ideCheckState (mkMakeActions foreigns externDeps) exportEnv externs m
+--       updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+--       pure newExtern
+--   handleRebuildResult fp pwarnings res
+--   where
+--     rebuildModule' ideCheckState act env ext mdl = rebuildModuleWithIndex ideCheckState act env ext mdl Nothing
+
+--     rebuildModuleWithIndex ideCheckState act exEnv externs m' moduleIndex = do
+--       let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
+--       P.rebuildModuleWithProvidedEnv ideCheckState Nothing act exEnv env externs m' moduleIndex
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index f977f3b166..9cfb2f72ae 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -47,7 +47,7 @@ defaultMaxCompletions :: Int
 defaultMaxCompletions = 50
 
 defaultMaxFilesInCache :: Int
-defaultMaxFilesInCache = 16
+defaultMaxFilesInCache = 32
 
 getMaxTypeLength :: (MonadLsp ServerConfig m) => m Int
 getMaxTypeLength =
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index fd35543a21..c58d73b3fa 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -103,32 +103,40 @@ cachedFiles = do
 cachedFilePaths :: (MonadIO m, MonadReader LspEnvironment m) => m [FilePath]
 cachedFilePaths = fmap fst <$> cachedFiles
 
-cacheEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Environment -> m ()
+cacheEnvironment :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Environment -> m ()
 cacheEnvironment fp deps env = do
   st <- lspStateVar <$> ask
+  maxFiles <- getMaxFilesInCache
   liftIO . atomically $ modifyTVar st $ \x ->
     x
-      { environments = ((fp, hashDeps deps), env) : environments x
+      { environments = take maxFiles $ ((fp, hashDeps deps), env) : filter ((/= fp) . fst . fst) (environments x)
       }
 
+-- use the cache environment functions for rebuilding 
+-- remove unneeded stuff from open files 
+-- look into persiting envs when client is idle (on vscode client)
+-- update default open files in client 
+
 cachedEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe P.Environment)
 cachedEnvironment fp deps = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ do
-    fmap snd .  find match . environments <$> readTVar st 
+    fmap snd .  find match . environments <$> readTVar st
 
-  where 
+  where
     hashed = hashDeps deps
     match ((fp', hash'), _) = fp == fp' && hash' == hashed
 
-cacheExportEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Env -> m ()
+cacheExportEnvironment :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Env -> m ()
 cacheExportEnvironment fp deps env = do
   st <- lspStateVar <$> ask
+  maxFiles <- getMaxFilesInCache
   liftIO . atomically $ modifyTVar st $ \x ->
     x
-      { exportEnvs = ((fp, hashDeps deps), env) : exportEnvs x
+      { exportEnvs = take maxFiles $ ((fp, hashDeps deps), env) : filter ((/= fp) . fst . fst) (exportEnvs x)
       }
 
+
 cachedExportEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe P.Env)
 cachedExportEnvironment fp deps = do
   st <- lspStateVar <$> ask
@@ -193,6 +201,7 @@ buildExportEnvCache module' externs = do
             writeTVar st $ st' {exportEnv = newEnv}
             pure $ Right newEnv
 
+
 mergeExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Env -> m ()
 mergeExportEnvCache env = do
   st <- lspStateVar <$> ask
@@ -203,7 +212,7 @@ data BuildEnvCacheException = BuildEnvCacheException Text
 
 instance Exception BuildEnvCacheException
 
-addExternsToExportEnv :: (Foldable t, Monad f) => P.Env -> t ExternsFile -> f (Either MultipleErrors P.Env)
+addExternsToExportEnv :: (Foldable t, Monad m) => P.Env -> t ExternsFile -> m (Either MultipleErrors P.Env)
 addExternsToExportEnv env externs = fmap fst . runWriterT $ runExceptT $ foldM externsEnv env externs
 
 logBuildErrors :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => MultipleErrors -> m ()
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index ecfb5a030f..938adb7657 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -256,7 +256,7 @@ indexExtern conn extern = liftIO do
     [":path" := path]
   SQL.executeNamed
     conn
-    (SQL.Query "INSERT OR REPLACE INTO externs (path, ef_version, value, hash, module_name) VALUES (:path, :ef_version, :value, :module_name)")
+    (SQL.Query "INSERT OR REPLACE INTO externs (path, ef_version, value, hash, module_name) VALUES (:path, :ef_version, :value, :hash, :module_name)")
     [ ":path" := path,
       ":ef_version" := P.efVersion extern,
       ":value" := serialised,

From 44bd44f79291ce9cd4670736dae8759d00cdfc32 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 7 Nov 2024 15:04:09 +0100
Subject: [PATCH 238/297] adds in memory caching for environments

---
 src/Language/PureScript/Lsp/Diagnostics.hs    |  2 -
 .../PureScript/Lsp/Handlers/Definition.hs     |  4 +-
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  2 +-
 src/Language/PureScript/Lsp/Rebuild.hs        | 61 +++++++++----------
 src/Language/PureScript/Lsp/State.hs          | 59 ++++--------------
 src/Language/PureScript/Lsp/Types.hs          | 13 ++--
 6 files changed, 50 insertions(+), 91 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 25eb585fe9..9199b843fd 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -21,7 +21,6 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Types (LspEnvironment)
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
-import Language.PureScript.Lsp.Log (debugLsp)
 
 getFileDiagnotics ::
   ( LSP.HasParams s a1,
@@ -36,7 +35,6 @@ getFileDiagnotics ::
 getFileDiagnotics msg = do
   let uri :: Types.NormalizedUri
       uri = getMsgUri msg & Types.toNormalizedUri
-  debugLsp $ "getting file diagnostics for: " <> show uri
   res <- rebuildFile uri
   pure $ addJsonEdits $ getResultDiagnostics res
 
diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index 4fc3c6bd86..ba37409d2f 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -17,7 +17,7 @@ import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
-import Language.PureScript.Lsp.Types (OpenFile (OpenFile, ofEndCheckState))
+import Language.PureScript.Lsp.Types (OpenFile (OpenFile, ofArtifacts))
 import Language.PureScript.Lsp.Util (positionToSourcePos, sourcePosToPosition)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
 import Protolude
@@ -63,7 +63,7 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
       debugLsp . show =<< cachedFilePaths
 
     forLsp cacheOpenMb \OpenFile {..} -> do
-      let allArtifacts = P.checkIdeArtifacts ofEndCheckState
+      let allArtifacts = ofArtifacts
           atPos = getArtifactsAtPosition (positionToSourcePos pos) allArtifacts
       let smallest = smallestArtifact (\a -> (negate $ artifactInterest a, isNothing (iaDefinitionPos a), isNothing (iaDefinitionModule a))) atPos
       case smallest of
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 387347cc4a..6d1974d456 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -55,7 +55,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       debugLsp $ "file path not cached: " <> T.pack filePath
       debugLsp . show =<< cachedFilePaths
     forLsp cacheOpenMb \OpenFile {..} -> do
-      let allArtifacts = P.checkIdeArtifacts ofEndCheckState
+      let allArtifacts = ofArtifacts
           atPos = getArtifactsAtPosition (positionToSourcePos startPos) allArtifacts
       debugLsp $ "hover artiacts length: " <> show (length atPos)
       case smallestArtifact (\a -> (negate $ artifactInterest a, negate $ countUnkownsAndVars $ iaType a)) atPos of
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 51c6845f8a..78cf08309a 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -21,10 +21,10 @@ import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
 import Language.PureScript.Lsp.Cache (selectDependencies, selectExternsCount)
-import Language.PureScript.Lsp.Log (debugLsp, logPerfStandard, warnLsp, errorLsp)
+import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternsToExportEnv, buildExportEnvCache, cacheRebuild', cachedExportEnvironment, getDbConn, mergeExportEnvCache, updateCachedModule, cacheExportEnvironment)
+import Language.PureScript.Lsp.State (addExternsToExportEnv, buildExportEnvCache, cacheEnvironment, cacheRebuild', cachedEnvironment, getDbConn, mergeExportEnvCache, updateCachedModule)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState)
 import Language.PureScript.Lsp.Types qualified as Types
 import Language.PureScript.Make qualified as P
@@ -43,9 +43,8 @@ rebuildFile ::
   ) =>
   NormalizedUri ->
   m RebuildResult
-rebuildFile uri = do 
-  debugLsp $ "Rebuilding file: " <> show uri
-  logPerfStandard ("Rebuilt file: " <> show uri) do
+rebuildFile uri = do
+  logPerfStandard ("Rebuilt file: " <> show (fold $ uriToFilePath $ fromNormalizedUri uri)) do
     fp <- case fromNormalizedUri uri & uriToFilePath of
       Just x -> pure x
       Nothing -> throwM $ CouldNotConvertUriToFilePath uri
@@ -62,55 +61,55 @@ rebuildFile uri = do
         conn <- getDbConn
         stVar <- asks lspStateVar
         maxCache <- getMaxFilesInCache
-        let mkMakeActions :: Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make
-            mkMakeActions foreigns externs =
+        let mkMakeActions :: Map P.ModuleName FilePath -> P.MakeActions P.Make
+            mkMakeActions foreigns =
               P.buildMakeActions outputDirectory filePathMap foreigns False
                 & addAllIndexing conn
-                & addRebuildCaching stVar maxCache externs m
-        debugLsp $ "Selecting dependencies for module: " <> show moduleName
+                & addRebuildCaching stVar maxCache
         externDeps <- logPerfStandard "Selected dependencies" $ selectDependencies m
-        when (null externDeps) do 
+        when (null externDeps) do
           warnLsp $ "No dependencies found for module: " <> show moduleName
           checkExternsExist
         let externs = fmap edExtern externDeps
         foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-        exportEnv <- logPerfStandard "built export cache" $ getExportEnv fp externDeps
+        (exportEnv, env) <- logPerfStandard "built export cache" $ getEnv fp externDeps
         ideCheckState <- getIdeCheckState
         (res, warnings) <- logPerfStandard "Rebuilt Module" $ liftIO $ do
           P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-            newExtern <- rebuildModule' ideCheckState (mkMakeActions foreigns externDeps) exportEnv externs m
+            newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState Nothing (mkMakeActions foreigns) exportEnv env externs m Nothing
             updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
             pure newExtern
         debugLsp $ "Rebuild success: " <> show (isRight res)
-        case res of  
+        case res of
           Left errs -> pure $ RebuildError errs
-          Right _ -> do 
-            cacheExportEnvironment fp externDeps exportEnv
+          Right _ -> do
             pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
         where
-          rebuildModule' ideCheckState act env ext mdl = rebuildModuleWithIndex ideCheckState act env ext mdl Nothing
-
-          rebuildModuleWithIndex ideCheckState act exEnv externs m' moduleIndex = do
-            let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
-            P.rebuildModuleWithProvidedEnv ideCheckState Nothing act exEnv env externs m' moduleIndex
-
-          checkExternsExist = do 
+          checkExternsExist = do
             externCount <- selectExternsCount
-            when (externCount == 0) do 
+            when (externCount == 0) do
               errorLsp "No externs found in database, please build project"
 
-getExportEnv :: forall m. 
+getEnv ::
+  forall m.
   ( MonadThrow m,
     MonadReader Types.LspEnvironment m,
     MonadLsp ServerConfig m
   ) =>
   FilePath ->
   [ExternDependency] ->
-  m P.Env
-getExportEnv fp deps = do
-  cached <- cachedExportEnvironment fp deps
+  m (P.Env, P.Environment)
+getEnv fp deps = do
+  cached <- cachedEnvironment fp deps
   debugLsp $ "Export env cache hit: " <> show (isJust cached)
-  cached & maybe (buildExportEnvFromPrim $ fmap edExtern deps) pure
+  cached & maybe fetchEnv pure
+  where
+    externs = edExtern <$> deps
+    fetchEnv = do
+      exportEnv <- buildExportEnvFromPrim externs
+      let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
+      cacheEnvironment fp deps exportEnv env
+      pure (exportEnv, env)
 
 buildExportEnvFromPrim :: (Foldable t, MonadThrow m) => t ExternsFile -> m P.Env
 buildExportEnvFromPrim =
@@ -194,10 +193,10 @@ broadcastProgress chan ma = do
     { P.progress = liftIO . atomically . writeTChan chan . Just
     }
 
-addRebuildCaching :: TVar LspState -> Int -> [ExternDependency] -> P.Module -> P.MakeActions P.Make -> P.MakeActions P.Make
-addRebuildCaching stVar maxCache deps unchecked ma =
+addRebuildCaching :: TVar LspState -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make
+addRebuildCaching stVar maxCache ma =
   ma
-    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext deps prevEnv (P.checkEnv checkSt) checkSt unchecked astM) <* P.codegen ma prevEnv checkSt astM m docs ext
+    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext (P.checkIdeArtifacts checkSt) astM) <* P.codegen ma prevEnv checkSt astM m docs ext
     }
 
 -- rebuildFromOpenFileCache ::
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index c58d73b3fa..38de67d4ef 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -7,7 +7,6 @@ module Language.PureScript.Lsp.State
     updateCachedModule,
     updateCachedModule',
     cachedRebuild,
-    cacheDependencies,
     clearCache,
     clearRebuildCache,
     clearExportCache,
@@ -28,8 +27,8 @@ module Language.PureScript.Lsp.State
     cachedFilePaths,
     cachedEnvironment,
     cacheEnvironment,
-    cachedExportEnvironment,
-    cacheExportEnvironment,
+    -- cachedExportEnvironment,
+    -- cacheExportEnvironment,
   )
 where
 
@@ -49,26 +48,25 @@ import Language.PureScript.Externs (ExternsFile (..))
 import Language.PureScript.Lsp.Log (errorLsp)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
 import Language.PureScript.Lsp.Types
-import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
-import Language.PureScript.TypeChecker qualified as P
 import Protolude hiding (moduleName, unzip)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts)
 
 getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.CheckState -> P.Module -> P.Module -> m ()
-cacheRebuild ef deps prevEnv endEnv checkSt unchecked module' = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> IdeArtifacts -> P.Module -> m ()
+cacheRebuild ef artifacts module' = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
-  liftIO $ cacheRebuild' st maxFiles ef deps prevEnv endEnv checkSt unchecked module'
+  liftIO $ cacheRebuild' st maxFiles ef artifacts module'
 
-cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> [ExternDependency] -> P.Environment -> P.Environment -> P.CheckState -> P.Module -> P.Module -> IO ()
-cacheRebuild' st maxFiles ef deps prevEnv endEnv checkSt unchecked module' = atomically . modifyTVar st $ \x ->
+cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> IdeArtifacts -> P.Module -> IO ()
+cacheRebuild' st maxFiles ef artifacts module' = atomically . modifyTVar st $ \x ->
   x
-    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef deps prevEnv endEnv checkSt unchecked module') : filter ((/= fp) . fst) (openFiles x)
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef artifacts  module') : filter ((/= fp) . fst) (openFiles x)
     }
   where
     fp = P.spanName $ efSourceSpan ef
@@ -103,13 +101,13 @@ cachedFiles = do
 cachedFilePaths :: (MonadIO m, MonadReader LspEnvironment m) => m [FilePath]
 cachedFilePaths = fmap fst <$> cachedFiles
 
-cacheEnvironment :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Environment -> m ()
-cacheEnvironment fp deps env = do
+cacheEnvironment :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Env -> P.Environment -> m ()
+cacheEnvironment fp deps exportEnv env = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
   liftIO . atomically $ modifyTVar st $ \x ->
     x
-      { environments = take maxFiles $ ((fp, hashDeps deps), env) : filter ((/= fp) . fst . fst) (environments x)
+      { environments = take maxFiles $ ((fp, hashDeps deps), (exportEnv, env)) : filter ((/= fp) . fst . fst) (environments x)
       }
 
 -- use the cache environment functions for rebuilding 
@@ -117,7 +115,7 @@ cacheEnvironment fp deps env = do
 -- look into persiting envs when client is idle (on vscode client)
 -- update default open files in client 
 
-cachedEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe P.Environment)
+cachedEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe (P.Env, P.Environment))
 cachedEnvironment fp deps = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ do
@@ -127,42 +125,11 @@ cachedEnvironment fp deps = do
     hashed = hashDeps deps
     match ((fp', hash'), _) = fp == fp' && hash' == hashed
 
-cacheExportEnvironment :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> P.Env -> m ()
-cacheExportEnvironment fp deps env = do
-  st <- lspStateVar <$> ask
-  maxFiles <- getMaxFilesInCache
-  liftIO . atomically $ modifyTVar st $ \x ->
-    x
-      { exportEnvs = take maxFiles $ ((fp, hashDeps deps), env) : filter ((/= fp) . fst . fst) (exportEnvs x)
-      }
-
-
-cachedExportEnvironment :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> [ExternDependency] -> m (Maybe P.Env)
-cachedExportEnvironment fp deps = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically $ do
-    fmap snd . find match . exportEnvs <$> readTVar st
-
-  where
-    hashed = hashDeps deps
-    match ((fp', hash'), _) = fp == fp' && hash' == hashed
 
 hashDeps :: [ExternDependency] -> Int
 hashDeps = hash . sort . fmap edHash
 
 
-cacheDependencies :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> [ExternDependency] -> m ()
-cacheDependencies moduleName deps = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically $ modifyTVar st $ \x ->
-    x
-      { openFiles =
-          openFiles x <&> \(fp, ofile) ->
-            if ofModuleName ofile == moduleName
-              then (fp, ofile {ofDependencies = deps})
-              else (fp, ofile)
-      }
-
 removedCachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m ()
 removedCachedRebuild fp = do
   st <- lspStateVar <$> ask
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 66b37138a3..68e8b1296c 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -18,8 +18,8 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (Env)
 import Language.PureScript.Sugar.Names qualified as P
-import Language.PureScript.TypeChecker qualified as P
 import Protolude
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts)
 
 data LspEnvironment = LspEnvironment
   { lspDbConnectionVar :: TVar (FilePath, Connection),
@@ -35,7 +35,7 @@ mkEnv outputPath = do
   pure $ LspEnvironment connection st prevConfig
 
 emptyState :: LspState
-emptyState = LspState mempty P.primEnv mempty mempty mempty
+emptyState = LspState mempty P.primEnv mempty mempty
 
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
@@ -48,19 +48,14 @@ data LspConfig = LspConfig
 data LspState = LspState
   { openFiles :: [(FilePath, OpenFile)],
     exportEnv :: Env,
-    exportEnvs :: [((FilePath, Int), Env)],
-    environments :: [((FilePath, Int), P.Environment)],
+    environments :: [((FilePath, Int), (P.Env, P.Environment))],
     runningRequests :: Map (Either Int32 Text) (Async ())
   }
 
 data OpenFile = OpenFile
   { ofModuleName :: P.ModuleName,
     ofExternsFile :: P.ExternsFile,
-    ofDependencies :: [ExternDependency],
-    ofStartingEnv :: P.Environment,
-    ofEndEnv :: P.Environment,
-    ofEndCheckState :: P.CheckState,
-    ofUncheckedModule :: P.Module,
+    ofArtifacts :: IdeArtifacts,
     ofModule :: P.Module
   }
 

From b97a48bfa7a80749a3e38c4a43532d7075ee64bf Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 7 Nov 2024 17:16:31 +0100
Subject: [PATCH 239/297] fixes ide binders and classnames

---
 .../PureScript/Lsp/Handlers/Definition.hs     |  1 +
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  6 +++--
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 26 ++++++++-----------
 src/Language/PureScript/TypeChecker/Kinds.hs  |  9 ++++---
 src/Language/PureScript/TypeChecker/Types.hs  |  1 +
 5 files changed, 22 insertions(+), 21 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index ba37409d2f..f54050edfe 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -94,4 +94,5 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   IaBinder {} -> 2
   IaTypeName {} -> 3
   IaClassName {} -> 3
+  IaExpr _ (Just "bind") _ -> -10 -- desugared do notation is not interesting
   _ -> 1
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 6d1974d456..fd3506e80d 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -23,7 +23,7 @@ import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns, debugIdeArtifact)
 import Protolude hiding (handle, to)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -58,13 +58,14 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       let allArtifacts = ofArtifacts
           atPos = getArtifactsAtPosition (positionToSourcePos startPos) allArtifacts
       debugLsp $ "hover artiacts length: " <> show (length atPos)
+      for_ atPos \a -> debugLsp $ "hover artifact: " <> debugIdeArtifact a
       case smallestArtifact (\a -> (negate $ artifactInterest a, negate $ countUnkownsAndVars $ iaType a)) atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
             IaExpr exprTxt ident nameType -> do
               let inferredRes =
                     pursTypeStr
-                      exprTxt
+                      (show ident <> "---" <> exprTxt)
                       ( Just $
                           prettyPrintTypeSingleLine $
                             useSynonymns allArtifacts iaType
@@ -146,6 +147,7 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   IaBinder {} -> 2
   IaTypeName {} -> 3
   IaClassName {} -> 3
+  IaExpr _ (Just "bind") _ -> -10 -- desugared do notation is not interesting
   _ -> 1
 
 countUnkownsAndVars :: P.Type a -> Int
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index b17da7a3d8..27ec8b13c9 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 -- | Stores information about the source code that is useful for the IDE
 -- | This includes value types and source spans
@@ -27,6 +26,7 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     debugIdeArtifact,
     substituteArtifactTypes,
     endSubstitutions,
+    artifactInterest,
   )
 where
 
@@ -99,6 +99,14 @@ endSubstitutions (IdeArtifacts m u s) = IdeArtifacts (Map.unionWith (<>) m u) Ma
 smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
 smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
+-- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
+artifactInterest :: IdeArtifact -> Int
+artifactInterest (IdeArtifact {..}) = case iaValue of
+  IaBinder {} -> 2
+  IaTypeName {} -> 3
+  IaClassName {} -> 3
+  _ -> 1
+
 artifactsAtSpan :: P.SourceSpan -> IdeArtifacts -> Set IdeArtifact
 artifactsAtSpan span (IdeArtifacts m _ _) =
   Map.lookup (P.sourcePosLine $ P.spanStart span) m
@@ -155,21 +163,9 @@ insertIaExpr expr ty = case ss of
   where
     ss = P.exprSourceSpan expr
 
-printExpr :: P.Expr -> T.Text
-printExpr (P.Op _ (P.Qualified _ op)) = P.runOpName op -- `Op`s hit an infinite loop when pretty printed by themselves
-printExpr (P.Constructor _ n) = P.runProperName $ P.disqualify n
-printExpr (P.Var _ n) = P.runIdent $ P.disqualify n
--- printExpr
-printExpr P.Case {} = "<case expr>" -- case expressions are too large to pretty print in hover and are on mulitple lines
-printExpr P.IfThenElse {} = "<if expr>"
-printExpr _ = "_"
-
 ellipsis :: Int -> Text -> Text
 ellipsis n t = if T.length t > n then T.take (n - 3) t <> "..." else t
 
-on1Line :: T.Text -> T.Text
-on1Line = T.intercalate " " . T.lines
-
 insertIaIdent :: P.SourceSpan -> P.Ident -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaIdent ss ident ty = case ident of
   P.Ident ident' -> insertAtLines ss (IaIdent ident') ty Nothing (Just $ Right ss)
@@ -233,8 +229,8 @@ moduleNameFromQual (P.Qualified (P.ByModuleName mn) _) = Just mn
 moduleNameFromQual _ = Nothing
 
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
-insertAtLines span@(P.SourceSpan _ start end) value ty mName defSpan ia@(IdeArtifacts m u s) =
-  if start == P.SourcePos 0 0 && end == P.SourcePos 0 0 -- ignore internal module spans
+insertAtLines span@(P.SourceSpan _ start _) value ty mName defSpan ia@(IdeArtifacts m u s) =
+  if start == P.SourcePos 0 0  -- ignore internal module spans
     then ia
     else IdeArtifacts m (foldr insert u (linesFromSpan span)) s
   where
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 7f22695e1a..3f1b40b606 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -178,7 +178,11 @@ inferKind = \tyToInfer ->
           addIdeTypeNameQual (fst ann) v (kind' $> ann)
           pure (ty, kind' $> ann)
         Just (kind, _) -> do
-          addIdeTypeNameQual (fst ann) v (kind $> ann)
+          let className = coerceProperName <$> v
+          case M.lookup className (E.typeClasses env) of 
+            Just _ -> addIdeClassNameQual (fst ann) className (kind $> ann)
+            Nothing ->
+             addIdeTypeNameQual (fst ann) v (kind $> ann)
           pure (ty, kind $> ann)
     ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do
       env <- getEnv
@@ -190,7 +194,6 @@ inferKind = \tyToInfer ->
       ty' <- checkIsSaturatedType ty
       con'' <- applyConstraint con'
       let kind = E.kindType $> ann'
-      addIdeClassNameQual (fst ann) v kind
       pure (ConstrainedType ann' con'' ty', kind)
     ty@(TypeLevelString ann _) ->
       pure (ty, E.kindSymbol $> ann)
@@ -872,7 +875,6 @@ applyConstraint (Constraint ann clsName kinds args dat) = do
   let 
      ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args
   applied <- apply ty
-  addIdeClassNameQual (fst ann) clsName applied
   let (_, kinds', args') = unapplyTypes applied
   pure $ Constraint ann clsName kinds' args' dat
 
@@ -909,7 +911,6 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do
     let allWithVars = replaceUnknownsWithVars unknownVars allTy
     let (allConstraints, (_, allKinds, allArgs)) = unapplyTypes <$> unapplyConstraints allWithVars
     varKinds <- traverse (traverse (fmap (replaceUnknownsWithVars unknownVars) . apply)) $ (snd <$> unknownVars) <> (first runProperName <$> freeVarsDict)
-    addIdeClassNameQual (fst ann) clsName allWithVars
     pure (allConstraints, allKinds, allArgs, varKinds)
 
 checkKindDeclaration
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 4b27a45d29..c3c2554d54 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -873,6 +873,7 @@ check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy)
   | VarBinder ss arg <- binder = do
       unifyTypes t tyFunction
       ret' <- withBindingGroupVisible $ bindLocalVariables [(ss, arg, argTy, Defined)] $ check ret retTy
+      addIdeBinder binder ty
       return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty
   | otherwise = internalError "Binder was not desugared"
 check' (App f arg) ret = do

From 13a9209874c35310ad72d766fe0e96290e4745ae Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 7 Nov 2024 17:23:07 +0100
Subject: [PATCH 240/297] stop prim hover

---
 src/Language/PureScript/Lsp/Handlers/Definition.hs | 14 +++-----------
 src/Language/PureScript/Lsp/Handlers/Hover.hs      | 13 +------------
 .../PureScript/TypeChecker/IdeArtifacts.hs         |  2 +-
 3 files changed, 5 insertions(+), 24 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index f54050edfe..f7508f1a60 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -19,7 +19,7 @@ import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (OpenFile, ofArtifacts))
 import Language.PureScript.Lsp.Util (positionToSourcePos, sourcePosToPosition)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, artifactInterest)
 import Protolude
 import Language.PureScript.Lsp.Docs (readDeclarationDocsSourceSpan)
 
@@ -86,13 +86,5 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
         Just (IdeArtifact _ _ _ Nothing (Just (Left defPos))) -> do
           posRes filePath defPos
         _ -> do
-          debugLsp "No relevat definition found for artifact"
-          nullRes
-
-artifactInterest :: IdeArtifact -> Int
-artifactInterest (IdeArtifact {..}) = case iaValue of
-  IaBinder {} -> 2
-  IaTypeName {} -> 3
-  IaClassName {} -> 3
-  IaExpr _ (Just "bind") _ -> -10 -- desugared do notation is not interesting
-  _ -> 1
+          debugLsp "No relevant definition found for artifact"
+          nullRes
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index fd3506e80d..9b02a5d96b 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -23,7 +23,7 @@ import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
 import Language.PureScript.Lsp.Util (positionToSourcePos)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns, debugIdeArtifact)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns, debugIdeArtifact, artifactInterest)
 import Protolude hiding (handle, to)
 
 hoverHandler :: Server.Handlers HandlerM
@@ -96,11 +96,9 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                   inferredRes = pursTypeStr name' (Just $ prettyPrintTypeSingleLine iaType) []
                   modName = fromMaybe ofModuleName iaDefinitionModule
               docs <- readDeclarationDocsWithNameType modName TyClassNameType name'
-              foundTypes <- getAstDeclarationTypeInModule (Just TyClassNameType) modName name'
               markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
                   [ Just inferredRes,
-                    showTypeSection modName (P.runProperName name) <$> head foundTypes,
                     showDocs <$> docs
                   ]
             IaIdent ident -> do
@@ -141,15 +139,6 @@ showDocs d = "**Docs**\n" <> d
 joinMarkup :: [Maybe Text] -> Text
 joinMarkup = T.intercalate "\n---\n" . catMaybes
 
--- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
-artifactInterest :: IdeArtifact -> Int
-artifactInterest (IdeArtifact {..}) = case iaValue of
-  IaBinder {} -> 2
-  IaTypeName {} -> 3
-  IaClassName {} -> 3
-  IaExpr _ (Just "bind") _ -> -10 -- desugared do notation is not interesting
-  _ -> 1
-
 countUnkownsAndVars :: P.Type a -> Int
 countUnkownsAndVars = P.everythingOnTypes (+) go
   where
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 27ec8b13c9..541f3c76d3 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -230,7 +230,7 @@ moduleNameFromQual _ = Nothing
 
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
 insertAtLines span@(P.SourceSpan _ start _) value ty mName defSpan ia@(IdeArtifacts m u s) =
-  if start == P.SourcePos 0 0  -- ignore internal module spans
+  if start == P.SourcePos 0 0 || start == P.SourcePos 1 1 -- ignore internal module spans
     then ia
     else IdeArtifacts m (foldr insert u (linesFromSpan span)) s
   where

From c1af4d9d41e7115886b5273002c646259cc480d5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 7 Nov 2024 17:59:34 +0100
Subject: [PATCH 241/297] remove hover debug and clean up

---
 src/Language/PureScript/LSP.hs                |   5 +-
 src/Language/PureScript/Lsp/Cache/Query.hs    |   8 +-
 src/Language/PureScript/Lsp/Handlers.hs       |   1 -
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  33 ++++--
 src/Language/PureScript/Lsp/Rebuild.hs        | 106 +-----------------
 src/Language/PureScript/Make.hs               |   2 -
 .../PureScript/TypeChecker/IdeArtifacts.hs    |  47 +++-----
 src/Language/PureScript/TypeChecker/Kinds.hs  |   3 +-
 src/Language/PureScript/TypeChecker/Monad.hs  |   1 -
 src/Language/PureScript/TypeChecker/Types.hs  |  21 +---
 10 files changed, 52 insertions(+), 175 deletions(-)

diff --git a/src/Language/PureScript/LSP.hs b/src/Language/PureScript/LSP.hs
index a4f47952e8..75cfdaf981 100644
--- a/src/Language/PureScript/LSP.hs
+++ b/src/Language/PureScript/LSP.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE PolyKinds #-}
-{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 module Language.PureScript.Lsp (main, serverDefinition) where
 
@@ -77,7 +76,7 @@ syncOptions =
 lspHandlers :: LspEnvironment -> Server.Handlers HandlerM
 lspHandlers lspEnv = mapHandlers goReq goNotification handlers
   where
-    goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). Server.Handler HandlerM a -> Server.Handler HandlerM a
+    goReq :: forall (a :: LSP.Method 'LSP.ClientToServer 'LSP.Request). Server.Handler HandlerM a -> Server.Handler HandlerM a
     goReq f msg@(LSP.TRequestMessage _ id method _) k = do
       let reqId = case id of
             LSP.IdInt i -> Left i
@@ -100,7 +99,7 @@ lspHandlers lspEnv = mapHandlers goReq goNotification handlers
             _ -> pure ()
           removeRunningRequest lspEnv reqId
 
-    goNotification :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). Server.Handler HandlerM a -> Server.Handler HandlerM a
+    goNotification :: forall (a :: LSP.Method 'LSP.ClientToServer 'LSP.Notification). Server.Handler HandlerM a -> Server.Handler HandlerM a
     goNotification f msg@(LSP.TNotificationMessage _ method _) = do
       let methodText = T.pack $ LSP.someMethodToMethodString $ LSP.SomeMethod method
       Lifted.withAsync (f msg) \asyncAct -> do
diff --git a/src/Language/PureScript/Lsp/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs
index 82b47f94d1..673903b315 100644
--- a/src/Language/PureScript/Lsp/Cache/Query.hs
+++ b/src/Language/PureScript/Lsp/Cache/Query.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-
 module Language.PureScript.Lsp.Cache.Query where
 
 import Database.SQLite.Simple (NamedParam ((:=)), fromOnly)
@@ -63,7 +61,7 @@ getAstDeclarationTypeInModule lspNameType moduleName' name = do
   pure $ decls <&> fromOnly
 
 getAstDeclarationsStartingWith ::
-  (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
+  (MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
   P.ModuleName ->
   Text ->
   m [CompletionResult]
@@ -92,7 +90,7 @@ getAstDeclarationsStartingWith moduleName' prefix = do
     ]
 
 getAstDeclarationsStartingWithAndSearchingModuleNames ::
-  (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
+  (MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
   P.ModuleName ->
   P.ModuleName ->
   Text ->
@@ -124,7 +122,7 @@ getAstDeclarationsStartingWithAndSearchingModuleNames moduleName' moduleNameCont
     ]
 
 getAstDeclarationsStartingWithOnlyInModule ::
-  (MonadIO m, MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
+  (MonadReader LspEnvironment m, MonadLsp ServerConfig m) =>
   P.ModuleName ->
   Text ->
   m [CompletionResult]
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 855b59cc29..0419e0243c 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module Language.PureScript.Lsp.Handlers where
 
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index 9b02a5d96b..f0af1253b4 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -22,14 +22,16 @@ import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (..))
-import Language.PureScript.Lsp.Util (positionToSourcePos)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns, debugIdeArtifact, artifactInterest)
+import Language.PureScript.Lsp.Util (positionToSourcePos, getWordAt)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns, artifactInterest, bindersAtPos)
 import Protolude hiding (handle, to)
+import Language.PureScript.Lsp.ReadFile (lspReadFileRope)
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
-  let Types.HoverParams docIdent startPos _prog = req ^. LSP.params
-      filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+  let Types.HoverParams docIdent pos _prog = req ^. LSP.params
+      uri = docIdent ^. LSP.uri
+      filePathMb = Types.uriToFilePath uri
 
       nullRes = res $ Right $ Types.InR Types.Null
 
@@ -56,16 +58,15 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
       debugLsp . show =<< cachedFilePaths
     forLsp cacheOpenMb \OpenFile {..} -> do
       let allArtifacts = ofArtifacts
-          atPos = getArtifactsAtPosition (positionToSourcePos startPos) allArtifacts
+          atPos = getArtifactsAtPosition (positionToSourcePos pos) allArtifacts
       debugLsp $ "hover artiacts length: " <> show (length atPos)
-      for_ atPos \a -> debugLsp $ "hover artifact: " <> debugIdeArtifact a
       case smallestArtifact (\a -> (negate $ artifactInterest a, negate $ countUnkownsAndVars $ iaType a)) atPos of
         Just (IdeArtifact {..}) ->
           case iaValue of
             IaExpr exprTxt ident nameType -> do
               let inferredRes =
                     pursTypeStr
-                      (show ident <> "---" <> exprTxt)
+                      exprTxt
                       ( Just $
                           prettyPrintTypeSingleLine $
                             useSynonymns allArtifacts iaType
@@ -104,8 +105,22 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             IaIdent ident -> do
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr ident (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
             IaBinder binder -> do
-              let inferredRes = pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
-              markdownRes (spanToRange <$> binderSourceSpan binder) inferredRes
+              let
+                binders = bindersAtPos (positionToSourcePos pos) allArtifacts
+
+              if length binders < 2 then do
+                let  inferredRes = pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
+                markdownRes (spanToRange <$> binderSourceSpan binder) inferredRes
+              else do -- when there are multiple binders we need to check the src code as the binder ranges sometimes appear to be for their scope, not identifiers
+                src <- lspReadFileRope (Types.toNormalizedUri uri)
+                let 
+                  (range, word) = getWordAt src pos
+                  actualBinder = fromMaybe binder $ find (\b -> T.strip (P.prettyPrintBinder b) == word) binders
+
+                let inferredRes = pursTypeStr (dispayBinderOnHover actualBinder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
+                markdownRes (Just range) inferredRes
+                
+
             IaDecl decl _ -> do
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (fromMaybe "_" decl) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
             IaType ty -> do
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 78cf08309a..00ce92dd29 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,13 +1,9 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
--- {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, buildExportEnvCacheAndHandleErrors, codegenTargets) where
 
-import Control.Category ((>>>))
-import Control.Concurrent.STM (TChan, TVar, writeTChan)
+import Control.Concurrent.STM (TVar)
 import Control.Monad.Catch (MonadThrow (throwM))
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
@@ -116,24 +112,6 @@ buildExportEnvFromPrim =
   addExternsToExportEnv P.primEnv
     >=> either (throwM . CouldNotRebuildExportEnv . P.prettyPrintMultipleErrors P.noColorPPEOptions) pure
 
--- handleRebuildResult :: ( MonadReader LspEnvironment f) =>FilePath -> [CST.ParserWarning] -> (Either P.MultipleErrors ExternsFile, P.MultipleErrors) -> f RebuildResult
--- handleRebuildResult fp pwarnings (result, warnings) = do
---   case result of
---     Left errors ->
---       pure $ RebuildError errors
---     Right newExtern -> do
---       -- addExternToExportEnv newExtern
---       pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
-
-couldBeFromNewImports :: P.ErrorMessage -> Bool
-couldBeFromNewImports =
-  P.unwrapErrorMessage >>> \case
-    P.ModuleNotFound {} -> True
-    P.UnknownImport {} -> True
-    P.UnknownImportDataConstructor {} -> True
-    P.NameIsUndefined _ -> True
-    _ -> False
-
 buildExportEnvCacheAndHandleErrors ::
   (MonadReader Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
   m [ExternDependency] ->
@@ -157,22 +135,6 @@ buildExportEnvCacheAndHandleErrors refetchExterns m externs = do
           pure (env, Just externs')
     Right env -> pure (env, Nothing)
 
-addExternsToExportEnvOrThrow ::
-  (MonadReader Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
-  P.Env ->
-  [ExternsFile] ->
-  m P.Env
-addExternsToExportEnvOrThrow env externs = do
-  res <- addExternsToExportEnv env externs
-  case res of
-    Left err ->
-      throwM $
-        CouldNotRebuildExportEnv $
-          P.prettyPrintMultipleErrors P.noColorPPEOptions err
-    Right newEnv -> do
-      mergeExportEnvCache newEnv
-      pure newEnv
-
 data RebuildResult
   = RebuildError P.MultipleErrors
   | RebuildWarning P.MultipleErrors
@@ -185,50 +147,12 @@ data RebuildException
 codegenTargets :: Set P.CodegenTarget
 codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
--- | Shuts the compiler up about progress messages
--- broadcastProgress :: (MonadLsp ServerConfig m) => TChan P.ProgressMessage -> P.MakeActions P.Make -> m (P.MakeActions P.Make)
-broadcastProgress :: (MonadIO m) => TChan (Maybe P.ProgressMessage) -> P.MakeActions m -> P.MakeActions m
-broadcastProgress chan ma = do
-  ma
-    { P.progress = liftIO . atomically . writeTChan chan . Just
-    }
-
 addRebuildCaching :: TVar LspState -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make
 addRebuildCaching stVar maxCache ma =
   ma
     { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext (P.checkIdeArtifacts checkSt) astM) <* P.codegen ma prevEnv checkSt astM m docs ext
     }
 
--- rebuildFromOpenFileCache ::
---   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
---   FilePath ->
---   [CST.ParserWarning] ->
---   TVar LspState ->
---   (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
---   P.Module ->
---   OpenFile ->
---   m RebuildResult
--- rebuildFromOpenFileCache fp pwarnings stVar mkMakeActions m (OpenFile moduleName _ externDeps env _ _ _ _) = do
---   outputDirectory <- outputPath <$> getConfig
---   let externs = fmap edExtern externDeps
---   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
---   (exportEnv, externsMb) <- logPerfStandard "build export cache" $ buildExportEnvCacheAndHandleErrors (selectDependencies m) m externs
---   for_ externsMb (cacheDependencies moduleName)
---   ideCheckState <- getIdeCheckState
---   res <- logPerfStandard "Rebuild Module with provided env" $ liftIO $ do
---     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
---       newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState (Just $ updateCachedModule' stVar) (mkMakeActions foreigns externDeps) exportEnv env externs m Nothing
---       updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
---       pure newExtern
---   case fst res of
---     Left errs -> debugLsp $ "Rebuild error detected: " <> show errs
---     _ -> pure ()
---   case fst res of
---     Left errs | any couldBeFromNewImports (P.runMultipleErrors errs) -> do
---       warnLsp "Module not found error detected, rebuilding without cache"
---       rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m
---     _ -> handleRebuildResult fp pwarnings res
-
 getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
 getIdeCheckState =
   ideCheckState <$> getInferExpressions
@@ -238,31 +162,3 @@ getIdeCheckState =
       (P.emptyCheckState env)
         { P.checkAddIdeArtifacts = Just if infer then P.AllIdeExprs else P.IdentIdeExprs
         }
-
--- rebuildWithoutFileCache ::
---   (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) =>
---   P.ModuleName ->
---   (Map P.ModuleName FilePath -> [ExternDependency] -> P.MakeActions P.Make) ->
---   FilePath ->
---   [CST.ParserWarning] ->
---   P.Module ->
---   m RebuildResult
--- rebuildWithoutFileCache moduleName mkMakeActions fp pwarnings m = do
---   outputDirectory <- outputPath <$> getConfig
---   externDeps <- logPerfStandard "Select dependencies" $ selectDependencies m
---   let externs = fmap edExtern externDeps
---   foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
---   exportEnv <- logPerfStandard "build export cache" $ addExternsToExportEnvOrThrow primEnv externs
---   ideCheckState <- getIdeCheckState
---   res <- logPerfStandard "Rebuild Module" $ liftIO $ do
---     P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
---       newExtern <- rebuildModule' ideCheckState (mkMakeActions foreigns externDeps) exportEnv externs m
---       updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
---       pure newExtern
---   handleRebuildResult fp pwarnings res
---   where
---     rebuildModule' ideCheckState act env ext mdl = rebuildModuleWithIndex ideCheckState act env ext mdl Nothing
-
---     rebuildModuleWithIndex ideCheckState act exEnv externs m' moduleIndex = do
---       let env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
---       P.rebuildModuleWithProvidedEnv ideCheckState Nothing act exEnv env externs m' moduleIndex
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 5e47f18a84..07e6139e27 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
 module Language.PureScript.Make
   ( -- * Make API
     desugarAndTypeCheck,
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 541f3c76d3..991e90697d 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -1,4 +1,3 @@
-
 -- | Stores information about the source code that is useful for the IDE
 -- | This includes value types and source spans
 module Language.PureScript.TypeChecker.IdeArtifacts
@@ -27,6 +26,7 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     substituteArtifactTypes,
     endSubstitutions,
     artifactInterest,
+    bindersAtPos
   )
 where
 
@@ -99,6 +99,19 @@ endSubstitutions (IdeArtifacts m u s) = IdeArtifacts (Map.unionWith (<>) m u) Ma
 smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
 smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
+bindersAtPos :: P.SourcePos -> IdeArtifacts -> [P.Binder]
+bindersAtPos pos (IdeArtifacts m _ _) =
+  Map.lookup (P.sourcePosLine pos) m
+    & maybe [] Set.toList
+    & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
+    & mapMaybe
+      ( \case
+          IdeArtifact {iaValue = IaBinder b} -> Just b
+          _ -> Nothing
+      )
+  where
+    posCol = P.sourcePosColumn pos
+
 -- | Prioritize artifacts that are more likely to be interesting to the developer on hover or click
 artifactInterest :: IdeArtifact -> Int
 artifactInterest (IdeArtifact {..}) = case iaValue of
@@ -130,7 +143,7 @@ insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaExpr expr ty = case ss of
   Just span
     | not (generatedExpr expr) ->
-        insertAtLines span (IaExpr (exprCtr expr <> ": " <> fromMaybe "_" exprIdent) exprIdent (exprNameType expr)) ty mName defSpan
+        insertAtLines span (IaExpr (fromMaybe "_" exprIdent) exprIdent (exprNameType expr)) ty mName defSpan
     where
       defSpan =
         Left <$> (posFromQual =<< exprIdentQual expr)
@@ -314,32 +327,4 @@ debugIdeArtifactValue = \case
   IaImport name ref -> "Import: " <> P.runModuleName name <> "." <> show ref
 
 debugType :: P.Type a -> Text
-debugType = T.pack . take 64 . P.prettyPrintType 5
-
-exprCtr :: P.Expr -> Text
-exprCtr (P.Literal _ _) = "Literal"
-exprCtr (P.UnaryMinus _ _) = "UnaryMinus"
-exprCtr (P.BinaryNoParens _ _ _) = "BinaryNoParens"
-exprCtr (P.Parens _) = "Parens"
-exprCtr (P.Accessor _ _) = "Accessor"
-exprCtr (P.ObjectUpdate _ _) = "ObjectUpdate"
-exprCtr (P.ObjectUpdateNested _ _) = "ObjectUpdateNested"
-exprCtr (P.Abs _ _) = "Abs"
-exprCtr (P.App e e') = "App (" <> exprCtr e <> ") (" <> exprCtr e' <> ")"
-exprCtr (P.VisibleTypeApp _ _) = "VisibleTypeApp"
-exprCtr (P.Unused e) = "Unused " <> exprCtr e
-exprCtr (P.Var _ _) = "Var"
-exprCtr (P.Op _ _) = "Op"
-exprCtr (P.IfThenElse _ _ _) = "IfThenElse"
-exprCtr (P.Constructor _ _) = "Constructor"
-exprCtr (P.Case _ _) = "Case"
-exprCtr (P.TypedValue _ e _) = "TypedValue " <> exprCtr e
-exprCtr (P.Let _ _ _) = "Let"
-exprCtr (P.Do _ _) = "Do"
-exprCtr (P.Ado _ _ _) = "Ado"
-exprCtr (P.TypeClassDictionary _ _ _) = "TypeClassDictionary"
-exprCtr (P.DeferredDictionary _ _) = "DeferredDictionary"
-exprCtr (P.DerivedInstancePlaceholder _ _) = "DerivedInstancePlaceholder"
-exprCtr P.AnonymousArgument = "AnonymousArgument"
-exprCtr (P.Hole _) = "Hole"
-exprCtr (P.PositionedValue _ _ e) = "PositionedValue " <> exprCtr e
+debugType = T.pack . take 64 . P.prettyPrintType 5
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 3f1b40b606..ed88dc1975 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -181,8 +181,7 @@ inferKind = \tyToInfer ->
           let className = coerceProperName <$> v
           case M.lookup className (E.typeClasses env) of 
             Just _ -> addIdeClassNameQual (fst ann) className (kind $> ann)
-            Nothing ->
-             addIdeTypeNameQual (fst ann) v (kind $> ann)
+            Nothing -> addIdeTypeNameQual (fst ann) v (kind $> ann)
           pure (ty, kind $> ann)
     ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do
       env <- getEnv
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index f268b744a6..42a3b1353c 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE GADTs #-}
-{-# OPTIONS_GHC -Wno-deprecations #-}
 
 -- |
 -- Monads for type checking and type inference and associated data types
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index c3c2554d54..1d9ffb3005 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -1,7 +1,4 @@
 {-# LANGUAGE BlockArguments #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
 -- |
 -- This module implements the type checker
 --
@@ -29,7 +26,7 @@ f
 -}
 
 import Prelude
-import Protolude (ordNub, fold, atMay, (>=>), whenM)
+import Protolude (ordNub, fold, atMay, (>=>))
 
 import Control.Arrow (first, second, (***))
 import Control.Monad (forM, forM_, guard, replicateM, unless, when, zipWithM, (<=<))
@@ -514,7 +511,7 @@ infer' (VisibleTypeApp valFn tyArg) = do
       pure $ TypedValue' True valFn''' resTy'
     _ ->
       throwError $ errorMessage $ CannotApplyExpressionOfTypeOnType valTy tyArg
-infer' e@(Var ss var) = do
+infer' (Var ss var) = do
   checkVisibility var
   ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var
   case ty of
@@ -1043,10 +1040,9 @@ checkFunctionApplication'
   -> SourceType
   -> Expr
   -> m (SourceType, Expr)
-checkFunctionApplication' fn (TypeApp ann (TypeApp ann' tyFunction' argTy) retTy) arg = do
+checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg = do
   unifyTypes tyFunction' tyFunction
-  tv@(TypedValue' _ _ argTy') <- check arg argTy
-  let arg' = tvToExpr tv
+  arg' <- tvToExpr <$> check arg argTy
   return (retTy, App fn arg')
 checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do
   u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK
@@ -1055,7 +1051,7 @@ checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do
   checkFunctionApplication fn replaced arg
 checkFunctionApplication' fn (KindedType _ ty _) arg =
   checkFunctionApplication fn ty arg
-checkFunctionApplication' fn (ConstrainedType ann con fnTy) arg = do
+checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
   checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg
@@ -1070,13 +1066,6 @@ checkFunctionApplication' fn u arg = do
   unifyTypes u (function ty ret)
   return (ret, App fn (tvToExpr tv))
 
-
-replaceUnknowns :: Int -> SourceType -> Type SourceAnn -> Type SourceAnn
-replaceUnknowns i replacement  = everywhereOnTypes go
-  where
-  go (TUnknown _ j) | i == j = replacement
-  go other = other
-
 -- |
 -- Ensure a set of property names and value does not contain duplicate labels
 --

From 8b93fe12d422bbb6c4984ab23bc8b1141471951d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 8 Nov 2024 00:49:38 +0100
Subject: [PATCH 242/297] fixes get at position on multi lines

---
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  4 ++++
 src/Language/PureScript/TypeChecker.hs        | 19 ++++++++++++++++---
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 16 +++++++++++++---
 3 files changed, 33 insertions(+), 6 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index f0af1253b4..fe57938bd5 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -86,6 +86,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                   modName = fromMaybe ofModuleName iaDefinitionModule
               docs <- readDeclarationDocsWithNameType modName TyNameType name'
               foundTypes <- getAstDeclarationTypeInModule (Just TyNameType) modName name'
+              debugLsp $ "Hovering type name: " <> name'
               markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
                   [ Just inferredRes,
@@ -96,6 +97,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
               let name' = P.runProperName name
                   inferredRes = pursTypeStr name' (Just $ prettyPrintTypeSingleLine iaType) []
                   modName = fromMaybe ofModuleName iaDefinitionModule
+              debugLsp $ "Hovering class name: " <> name'
               docs <- readDeclarationDocsWithNameType modName TyClassNameType name'
               markdownRes (Just $ spanToRange iaSpan) $
                 joinMarkup
@@ -107,6 +109,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             IaBinder binder -> do
               let
                 binders = bindersAtPos (positionToSourcePos pos) allArtifacts
+              debugLsp "Hovering binder"
 
               if length binders < 2 then do
                 let  inferredRes = pursTypeStr (dispayBinderOnHover binder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
@@ -124,6 +127,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
             IaDecl decl _ -> do
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (fromMaybe "_" decl) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
             IaType ty -> do
+              debugLsp "Hovering type"
               markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr (prettyPrintTypeSingleLine ty) (Just $ prettyPrintTypeSingleLine iaType) []
             IaModule modName -> do
               docsMb <- readModuleDocs modName
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 94589c4f21..fc6e027d09 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 -- |
 -- The top-level type checker, which checks all declarations in a module.
 --
@@ -35,7 +36,7 @@ import Language.PureScript.Environment (DataDeclType(..), Environment(..), Funct
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow)
 import Language.PureScript.Linter (checkExhaustiveExpr)
 import Language.PureScript.Linter.Wildcards (ignoreWildcardsUnderCompleteTypeSignatures)
-import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified)
+import Language.PureScript.Names (Ident, ModuleName, ProperName (runProperName, ProperName), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified, getQual)
 import Language.PureScript.Roles (Role)
 import Language.PureScript.Sugar.Names.Env (Exports(..))
 import Language.PureScript.TypeChecker.Kinds as T
@@ -46,6 +47,7 @@ import Language.PureScript.TypeChecker.Types as T
 import Language.PureScript.TypeChecker.Unify (varIfUnknown)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes)
+import Language.PureScript.Types qualified as P
 
 addDataType
   :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
@@ -393,6 +395,7 @@ typeCheckAll moduleName = traverse go
         not (M.member qualifiedClassName (typeClasses env))
       (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys)
       addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind
+      addIdeClassName (Just moduleName) (fst sa) pn kind
       return d
   go (TypeInstanceDeclaration _ _ _ _ (Left _) _ _ _ _) = internalError "typeCheckAll: type class instance generated name should have been desugared"
   go d@(TypeInstanceDeclaration sa@(ss, _) _ ch idx (Right dictName) deps className tys body) =
@@ -415,10 +418,20 @@ typeCheckAll moduleName = traverse go
           checkOverlappingInstance ss chainId dictName vars className typeClass tys'' nonOrphanModules
           _ <- traverseTypeInstanceBody checkInstanceMembers body
           deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps'
-          let dict =
+          let 
+              srcType = srcInstanceType ss vars className tys''
+              dict =
                 TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $
-                  if isPlainIdent dictName then Nothing else Just $ srcInstanceType ss vars className tys''
+                  if isPlainIdent dictName then Nothing else Just srcType
+                  
           addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict)
+          let 
+            kind = M.lookup (coerceProperName <$> className) (types env)
+
+          addIdeClassName (Just $ fromMaybe moduleName $ getQual className) ss
+            ( ProperName $ (("typeCheckAll: " <> T.pack (show tys'') <> " : ") <>) $ runProperName $ disqualify className) 
+            $ maybe P.srcTypeWildcard fst kind
+
           return d
 
   checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m ()
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index 991e90697d..faa7cb3b95 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -26,7 +26,7 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     substituteArtifactTypes,
     endSubstitutions,
     artifactInterest,
-    bindersAtPos
+    bindersAtPos,
   )
 where
 
@@ -135,9 +135,19 @@ getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
 getArtifactsAtPosition pos (IdeArtifacts m _ _) =
   Map.lookup (P.sourcePosLine pos) m
     & maybe [] Set.toList
-    & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
+    & filter (srcPosInSpan pos . iaSpan)
+
+srcPosInSpan :: P.SourcePos -> P.SourceSpan -> Bool
+srcPosInSpan P.SourcePos {..} P.SourceSpan {..} =
+  sourcePosLine >= spanStartLine
+    && sourcePosLine <= spanEndLine
+    && (sourcePosColumn >= spanStartColumn || sourcePosLine > spanStartLine)
+    && (sourcePosColumn <= spanEndColumn || sourcePosLine < spanEndLine)
   where
-    posCol = P.sourcePosColumn pos
+    spanStartLine = P.sourcePosLine spanStart
+    spanEndLine = P.sourcePosLine spanEnd
+    spanStartColumn = P.sourcePosColumn spanStart
+    spanEndColumn = P.sourcePosColumn spanEnd
 
 insertIaExpr :: P.Expr -> P.SourceType -> IdeArtifacts -> IdeArtifacts
 insertIaExpr expr ty = case ss of

From c02599cd8d4f81137726789bcfb9394f10f9e463 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 8 Nov 2024 00:58:15 +0100
Subject: [PATCH 243/297] fix binder type

---
 src/Language/PureScript/TypeChecker/Types.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 1d9ffb3005..f59ba189ad 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -870,7 +870,7 @@ check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy)
   | VarBinder ss arg <- binder = do
       unifyTypes t tyFunction
       ret' <- withBindingGroupVisible $ bindLocalVariables [(ss, arg, argTy, Defined)] $ check ret retTy
-      addIdeBinder binder ty
+      addIdeBinder binder argTy
       return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty
   | otherwise = internalError "Binder was not desugared"
 check' (App f arg) ret = do

From e2715bd6d93626ad478687ded9166ef3ed56e57f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 10 Nov 2024 08:10:11 +0100
Subject: [PATCH 244/297] adds full rebuild caching

---
 src/Language/PureScript/Lsp/Cache.hs       |  70 ++++++-----
 src/Language/PureScript/Lsp/Diagnostics.hs |   4 +-
 src/Language/PureScript/Lsp/Rebuild.hs     | 135 ++++++++++++---------
 src/Language/PureScript/Lsp/State.hs       |  39 ++++--
 src/Language/PureScript/Lsp/Types.hs       |  12 +-
 5 files changed, 165 insertions(+), 95 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs
index d6b1d473af..44752204b0 100644
--- a/src/Language/PureScript/Lsp/Cache.hs
+++ b/src/Language/PureScript/Lsp/Cache.hs
@@ -14,6 +14,7 @@ import Language.PureScript.Ide.Error (IdeError (GeneralError))
 import Language.PureScript.Lsp.DB qualified as DB
 import Language.PureScript.Lsp.Log (logPerfStandard)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (globs, inputSrcFromFile, outputPath))
+import Language.PureScript.Lsp.State (hashDepHashs)
 import Language.PureScript.Lsp.Types (ExternDependency (edHash), LspEnvironment)
 import Protolude
 import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, getDirectoryContents, makeAbsolute)
@@ -29,34 +30,47 @@ selectAllExterns = do
 
 selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m [ExternDependency]
 selectDependencies (P.Module _ _ _ decls _) = do
-  DB.queryNamed (Query query') [":module_names" := A.encode (fmap P.runModuleName importedModuleNames)]
+  DB.queryNamed (Query query') [":module_names" := A.encode (P.runModuleName <$> importedModuleNames decls)]
   where
-    query' =
-      unlines
-        [ "with recursive",
-          "graph(imported_module, level) as (",
-          " select module_name , 1 as level",
-          " from ef_imports where module_name IN (SELECT value FROM json_each(:module_names))",
-          " union ",
-          " select d.imported_module as dep, graph.level + 1 as level",
-          " from graph join ef_imports d on graph.imported_module = d.module_name",
-          "),",
-          "topo as (",
-          " select imported_module, max(level) as level",
-          " from graph group by imported_module",
-          "),",
-          "module_names as (select distinct(module_name), level",
-          "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
-          "order by level desc)",
-          "select value, level, hash from externs ",
-          "join module_names on externs.module_name = module_names.module_name ",
-          "order by level desc, module_names.module_name desc;"
-        ]
-
-    importedModuleNames =
-      decls >>= \case
-        P.ImportDeclaration _ importName _ _ -> [importName]
-        _ -> []
+    query' = selectFromExternsTopoQuery ["value", "level", "hash"]
+
+selectDependencyHash :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m Int
+selectDependencyHash (P.Module _ _ _ decls _) = selectDependencyHashFromImports (importedModuleNames decls)
+
+selectDependencyHashFromImports :: (MonadIO m, MonadReader LspEnvironment m) => [P.ModuleName] -> m Int
+selectDependencyHashFromImports importedModulesNames =
+  hashDepHashs . fmap fromOnly <$> DB.queryNamed (Query query') [":module_names" := A.encode (P.runModuleName <$> importedModulesNames)]
+  where
+    query' = selectFromExternsTopoQuery ["hash"]
+
+importedModuleNames :: [Declaration] -> [P.ModuleName]
+importedModuleNames decls =
+  decls >>= \case
+    P.ImportDeclaration _ importName _ _ -> [importName]
+    _ -> []
+
+selectFromExternsTopoQuery :: [Text] -> Text
+selectFromExternsTopoQuery cols =
+  unlines
+    [ "with recursive",
+      "graph(imported_module, level) as (",
+      " select module_name , 1 as level",
+      " from ef_imports where module_name IN (SELECT value FROM json_each(:module_names))",
+      " union ",
+      " select d.imported_module as dep, graph.level + 1 as level",
+      " from graph join ef_imports d on graph.imported_module = d.module_name",
+      "),",
+      "topo as (",
+      " select imported_module, max(level) as level",
+      " from graph group by imported_module",
+      "),",
+      "module_names as (select distinct(module_name), level",
+      "from topo join ef_imports on topo.imported_module = ef_imports.module_name ",
+      "order by level desc)",
+      "select " <> T.intercalate ", " cols <> " from externs ",
+      "join module_names on externs.module_name = module_names.module_name ",
+      "order by level desc, module_names.module_name desc;"
+    ]
 
 selectExternFromFilePath :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe ExternsFile)
 selectExternFromFilePath path = do
@@ -64,7 +78,6 @@ selectExternFromFilePath path = do
   res <- DB.queryNamed (Query "SELECT value FROM externs WHERE path = :path") [":path" := absPath]
   pure $ deserialise . fromOnly <$> listToMaybe res
 
-
 selectExternsCount :: (MonadIO m, MonadReader LspEnvironment m) => m Int
 selectExternsCount = do
   res <- DB.query_ (Query "SELECT count(*) FROM externs")
@@ -152,4 +165,3 @@ cacheEnvironment path deps env = do
 --       ":hash" := hash (sort $ fmap edHash deps),
 --       ":value" := serialise env
 --     ]
-
diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 9199b843fd..373545b5bb 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -16,9 +16,9 @@ import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
-import Language.PureScript.Lsp.Rebuild (RebuildResult (RebuildError, RebuildWarning), rebuildFile)
+import Language.PureScript.Lsp.Rebuild (rebuildFile)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
-import Language.PureScript.Lsp.Types (LspEnvironment)
+import Language.PureScript.Lsp.Types (LspEnvironment, RebuildResult (RebuildWarning, RebuildError))
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
 
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 00ce92dd29..c4ba6737ee 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,12 +1,13 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
 
-module Language.PureScript.Lsp.Rebuild (RebuildResult (..), rebuildFile, buildExportEnvCacheAndHandleErrors, codegenTargets) where
+module Language.PureScript.Lsp.Rebuild (rebuildFile, buildExportEnvCacheAndHandleErrors, codegenTargets, rebuildFilePathFromUri) where
 
 import Control.Concurrent.STM (TVar)
 import Control.Monad.Catch (MonadThrow (throwM))
 import Data.Map.Lazy qualified as M
 import Data.Set qualified as Set
+import Data.Text qualified as T
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
 import Language.LSP.Server (MonadLsp, getConfig)
 import Language.PureScript (ExternsFile, primEnv)
@@ -15,12 +16,13 @@ import Language.PureScript.CST qualified as CST
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs qualified as P
+import Language.PureScript.Ide.Imports (Import (Import), sliceImportSection)
 import Language.PureScript.Ide.Rebuild (updateCacheDb)
-import Language.PureScript.Lsp.Cache (selectDependencies, selectExternsCount)
+import Language.PureScript.Lsp.Cache (selectDependencies, selectDependencyHashFromImports, selectExternsCount)
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternsToExportEnv, buildExportEnvCache, cacheEnvironment, cacheRebuild', cachedEnvironment, getDbConn, mergeExportEnvCache, updateCachedModule)
+import Language.PureScript.Lsp.State (addExternsToExportEnv, buildExportEnvCache, cacheEnvironment, cacheRebuild', cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, mergeExportEnvCache, updateCachedRebuildResult)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState)
 import Language.PureScript.Lsp.Types qualified as Types
 import Language.PureScript.Make qualified as P
@@ -31,6 +33,11 @@ import Language.PureScript.Sugar.Names qualified as P
 import Language.PureScript.TypeChecker qualified as P
 import Protolude hiding (moduleName, race, race_, threadDelay)
 
+rebuildFilePathFromUri :: (MonadThrow m) => NormalizedUri -> m FilePath
+rebuildFilePathFromUri uri = case fromNormalizedUri uri & uriToFilePath of
+  Just x -> pure x
+  Nothing -> throwM $ CouldNotConvertUriToFilePath uri
+
 rebuildFile ::
   forall m.
   ( MonadThrow m,
@@ -38,53 +45,75 @@ rebuildFile ::
     MonadLsp ServerConfig m
   ) =>
   NormalizedUri ->
-  m RebuildResult
+  m Types.RebuildResult
 rebuildFile uri = do
-  logPerfStandard ("Rebuilt file: " <> show (fold $ uriToFilePath $ fromNormalizedUri uri)) do
-    fp <- case fromNormalizedUri uri & uriToFilePath of
-      Just x -> pure x
-      Nothing -> throwM $ CouldNotConvertUriToFilePath uri
+  fp <- rebuildFilePathFromUri uri
+  logPerfStandard ("Rebuilt file: " <> T.pack fp) do
     input <- lspReadFileText uri
-    case sequence $ CST.parseFromFile fp input of
-      Left parseError ->
-        pure $ RebuildError $ CST.toMultipleErrors fp parseError
-      Right (pwarnings, m) -> do
-        debugLsp $ "Rebuilding module: " <> show (P.runModuleName $ P.getModuleName m)
-        updateCachedModule m
-        let moduleName = P.getModuleName m
-        let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
-        outputDirectory <- outputPath <$> getConfig
-        conn <- getDbConn
-        stVar <- asks lspStateVar
-        maxCache <- getMaxFilesInCache
-        let mkMakeActions :: Map P.ModuleName FilePath -> P.MakeActions P.Make
-            mkMakeActions foreigns =
-              P.buildMakeActions outputDirectory filePathMap foreigns False
-                & addAllIndexing conn
-                & addRebuildCaching stVar maxCache
-        externDeps <- logPerfStandard "Selected dependencies" $ selectDependencies m
-        when (null externDeps) do
-          warnLsp $ "No dependencies found for module: " <> show moduleName
-          checkExternsExist
-        let externs = fmap edExtern externDeps
-        foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
-        (exportEnv, env) <- logPerfStandard "built export cache" $ getEnv fp externDeps
-        ideCheckState <- getIdeCheckState
-        (res, warnings) <- logPerfStandard "Rebuilt Module" $ liftIO $ do
-          P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-            newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState Nothing (mkMakeActions foreigns) exportEnv env externs m Nothing
-            updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
-            pure newExtern
-        debugLsp $ "Rebuild success: " <> show (isRight res)
-        case res of
-          Left errs -> pure $ RebuildError errs
-          Right _ -> do
-            pure $ RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
-        where
-          checkExternsExist = do
-            externCount <- selectExternsCount
-            when (externCount == 0) do
-              errorLsp "No externs found in database, please build project"
+    cachedRes <- getCachedRebuildResult fp input
+    debugLsp $ T.pack fp <> " rebuild cache hit: " <> show (isJust cachedRes)
+    case cachedRes of
+      Just res -> pure res
+      Nothing -> do
+        case sequence $ CST.parseFromFile fp input of
+          Left parseError ->
+            pure $ Types.RebuildError $ CST.toMultipleErrors fp parseError
+          Right (pwarnings, m) -> do
+            debugLsp $ "Rebuilding module: " <> show (P.runModuleName $ P.getModuleName m)
+            externDeps <- logPerfStandard "Selected dependencies" $ selectDependencies m
+            let moduleName = P.getModuleName m
+                filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+                depHash = hashDeps externDeps
+            outputDirectory <- outputPath <$> getConfig
+            conn <- getDbConn
+            stVar <- asks lspStateVar
+            maxCache <- getMaxFilesInCache
+            let mkMakeActions :: Map P.ModuleName FilePath -> P.MakeActions P.Make
+                mkMakeActions foreigns =
+                  P.buildMakeActions outputDirectory filePathMap foreigns False
+                    & addAllIndexing conn
+                    & addRebuildCaching stVar maxCache input depHash
+            when (null externDeps) do
+              warnLsp $ "No dependencies found for module: " <> show moduleName
+              checkExternsExist
+            let externs = fmap edExtern externDeps
+            foreigns <- P.inferForeignModules (M.singleton moduleName (Right fp))
+            (exportEnv, env) <- logPerfStandard "built export cache" $ getEnv fp externDeps
+            ideCheckState <- getIdeCheckState
+            (res, warnings) <- logPerfStandard "Rebuilt Module" $ liftIO $ do
+              P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
+                newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState Nothing (mkMakeActions foreigns) exportEnv env externs m Nothing
+                updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
+                pure newExtern
+
+            debugLsp $ "Rebuild success: " <> show (isRight res)
+            rebuildRes <- case res of
+              Left errs -> pure $ Types.RebuildError errs
+              Right _ -> do
+                pure $ Types.RebuildWarning (CST.toMultipleWarnings fp pwarnings <> warnings)
+            updateCachedRebuildResult fp rebuildRes
+            pure rebuildRes
+            where
+              checkExternsExist = do
+                externCount <- selectExternsCount
+                when (externCount == 0) do
+                  errorLsp "No externs found in database, please build project"
+
+getCachedRebuildResult :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => FilePath -> Text -> m (Maybe Types.RebuildResult)
+getCachedRebuildResult fp input = do
+  file <- cachedOpenFileFromSrc fp input
+  file & maybe (pure Nothing) \Types.OpenFile {..} -> do
+    case sliceImportSection $ T.lines input of
+      Left _ -> pure Nothing
+      Right (_, _, imports, _) -> do
+        hash' <- selectDependencyHashFromImports $ getImportModuleName <$> imports
+        if hash' == ofDepHash
+          then do 
+            pure ofRebuildResult
+          else pure Nothing
+
+getImportModuleName :: Import -> P.ModuleName
+getImportModuleName (Import mn _ _) = mn
 
 getEnv ::
   forall m.
@@ -135,10 +164,6 @@ buildExportEnvCacheAndHandleErrors refetchExterns m externs = do
           pure (env, Just externs')
     Right env -> pure (env, Nothing)
 
-data RebuildResult
-  = RebuildError P.MultipleErrors
-  | RebuildWarning P.MultipleErrors
-
 data RebuildException
   = CouldNotConvertUriToFilePath NormalizedUri
   | CouldNotRebuildExportEnv [Char]
@@ -147,10 +172,10 @@ data RebuildException
 codegenTargets :: Set P.CodegenTarget
 codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
-addRebuildCaching :: TVar LspState -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make
-addRebuildCaching stVar maxCache ma =
+addRebuildCaching :: TVar LspState -> Int -> Text -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make
+addRebuildCaching stVar maxCache src depHash ma =
   ma
-    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache ext (P.checkIdeArtifacts checkSt) astM) <* P.codegen ma prevEnv checkSt astM m docs ext
+    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache src ext (P.checkIdeArtifacts checkSt) astM depHash) <* P.codegen ma prevEnv checkSt astM m docs ext
     }
 
 getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 38de67d4ef..f3738013c2 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -27,6 +27,10 @@ module Language.PureScript.Lsp.State
     cachedFilePaths,
     cachedEnvironment,
     cacheEnvironment,
+    hashDeps,
+    hashDepHashs,
+    cachedOpenFileFromSrc,
+    updateCachedRebuildResult,
     -- cachedExportEnvironment,
     -- cacheExportEnvironment,
   )
@@ -57,16 +61,16 @@ getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
 -- | Sets rebuild cache to the given ExternsFile
-cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => ExternsFile -> IdeArtifacts -> P.Module -> m ()
-cacheRebuild ef artifacts module' = do
+cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => Text -> ExternsFile -> IdeArtifacts -> P.Module -> Int -> m ()
+cacheRebuild src ef artifacts module' depHash = do
   st <- lspStateVar <$> ask
   maxFiles <- getMaxFilesInCache
-  liftIO $ cacheRebuild' st maxFiles ef artifacts module'
+  liftIO $ cacheRebuild' st maxFiles src ef artifacts module' depHash
 
-cacheRebuild' :: TVar LspState -> Int -> ExternsFile -> IdeArtifacts -> P.Module -> IO ()
-cacheRebuild' st maxFiles ef artifacts module' = atomically . modifyTVar st $ \x ->
+cacheRebuild' :: TVar LspState -> Int -> Text -> ExternsFile -> IdeArtifacts -> P.Module -> Int -> IO ()
+cacheRebuild' st maxFiles src ef artifacts module' depHash = atomically . modifyTVar st $ \x ->
   x
-    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) ef artifacts  module') : filter ((/= fp) . fst) (openFiles x)
+    { openFiles = List.take maxFiles $ (fp, OpenFile (efModuleName ef) src ef artifacts  module' depHash Nothing) : filter ((/= fp) . fst) (openFiles x)
     }
   where
     fp = P.spanName $ efSourceSpan ef
@@ -86,6 +90,25 @@ updateCachedModule' st module' = liftIO . atomically $ modifyTVar st $ \x ->
             else (fp, ofile)
     }
 
+updateCachedRebuildResult :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> RebuildResult -> m ()
+updateCachedRebuildResult fp result = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x ->
+    x
+      { openFiles =
+          openFiles x <&> \(fp', ofile) ->
+            if fp == fp'
+              then (fp', ofile {ofRebuildResult = Just result})
+              else (fp', ofile)
+      }
+
+cachedOpenFileFromSrc :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> Text  -> m (Maybe OpenFile)
+cachedOpenFileFromSrc fp input = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ do
+    st' <- readTVar st
+    pure $ snd <$> List.find (\(fp', ofile) -> fp == fp' && input == ofSrc ofile) (openFiles st')
+
 cachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m (Maybe OpenFile)
 cachedRebuild fp = do
   st <- lspStateVar <$> ask
@@ -127,8 +150,10 @@ cachedEnvironment fp deps = do
 
 
 hashDeps :: [ExternDependency] -> Int
-hashDeps = hash . sort . fmap edHash
+hashDeps = hashDepHashs . fmap edHash
 
+hashDepHashs :: [Int] -> Int
+hashDepHashs = hash . sort
 
 removedCachedRebuild :: (MonadIO m, MonadReader LspEnvironment m) => FilePath -> m ()
 removedCachedRebuild fp = do
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 68e8b1296c..8911cadd40 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -11,6 +11,7 @@ import Language.LSP.Protocol.Types (Range)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
+import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs qualified as P
 import Language.PureScript.Lsp.LogLevel (LspLogLevel)
 import Language.PureScript.Lsp.NameType (LspNameType)
@@ -18,8 +19,8 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (Env)
 import Language.PureScript.Sugar.Names qualified as P
-import Protolude
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts)
+import Protolude
 
 data LspEnvironment = LspEnvironment
   { lspDbConnectionVar :: TVar (FilePath, Connection),
@@ -54,11 +55,18 @@ data LspState = LspState
 
 data OpenFile = OpenFile
   { ofModuleName :: P.ModuleName,
+    ofSrc :: Text,
     ofExternsFile :: P.ExternsFile,
     ofArtifacts :: IdeArtifacts,
-    ofModule :: P.Module
+    ofModule :: P.Module,
+    ofDepHash :: Int,
+    ofRebuildResult :: Maybe RebuildResult
   }
 
+data RebuildResult
+  = RebuildError P.MultipleErrors
+  | RebuildWarning P.MultipleErrors
+
 data ExternDependency = ExternDependency
   { edExtern :: P.ExternsFile,
     edLevel :: Int,

From 2e373e10277f8d1be91c91b47c5fbe7a443dc8e3 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 12 Nov 2024 00:29:29 +0100
Subject: [PATCH 245/297] remove test logs

---
 purescript.cabal                              |  5 +-
 src/Language/PureScript/Lsp/Handlers.hs       | 19 +++---
 .../PureScript/Lsp/Handlers/ClearCache.hs     | 28 +++++++++
 .../PureScript/Lsp/Handlers/DebugCacheSize.hs | 62 +++++++++++++++++++
 src/Language/PureScript/Lsp/Handlers/Hover.hs |  7 ++-
 src/Language/PureScript/Lsp/NameType.hs       |  2 +-
 src/Language/PureScript/Lsp/State.hs          | 15 ++++-
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 11 ++--
 stack.yaml                                    |  1 +
 9 files changed, 126 insertions(+), 24 deletions(-)
 create mode 100644 src/Language/PureScript/Lsp/Handlers/ClearCache.hs
 create mode 100644 src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs

diff --git a/purescript.cabal b/purescript.cabal
index 3a1433612e..49c825dbca 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -214,7 +214,8 @@ common defaults
     lsp >=2.2.0 && <3.0,
     lsp-types >=2.2.0 && <3.0,
     unliftio-core >= 0.2.0.0 && < 0.3,
-    text-rope >= 0.2 && < 1.0
+    text-rope >= 0.2 && < 1.0,
+    ghc-datasize >= 0.2 && <= 0.2.7
 
 library
   import: defaults
@@ -350,7 +351,9 @@ library
     Language.PureScript.Lsp.Diagnostics
     Language.PureScript.Lsp.Handlers
     Language.PureScript.Lsp.Handlers.Build
+    Language.PureScript.Lsp.Handlers.ClearCache
     Language.PureScript.Lsp.Handlers.Completion
+    Language.PureScript.Lsp.Handlers.DebugCacheSize
     Language.PureScript.Lsp.Handlers.Definition
     Language.PureScript.Lsp.Handlers.DeleteOutput
     Language.PureScript.Lsp.Handlers.Diagnostic
diff --git a/src/Language/PureScript/Lsp/Handlers.hs b/src/Language/PureScript/Lsp/Handlers.hs
index 0419e0243c..8127aef688 100644
--- a/src/Language/PureScript/Lsp/Handlers.hs
+++ b/src/Language/PureScript/Lsp/Handlers.hs
@@ -5,6 +5,7 @@
 
 module Language.PureScript.Lsp.Handlers where
 
+import Protolude
 import Control.Lens ((^.))
 import Data.Aeson qualified as A
 import Language.LSP.Protocol.Lens qualified as LSP
@@ -24,9 +25,10 @@ import Language.PureScript.Lsp.Handlers.Hover (hoverHandler)
 import Language.PureScript.Lsp.Handlers.Index (indexHandler)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ServerConfig (setTraceValue)
-import Language.PureScript.Lsp.State (cancelRequest, clearCache, clearExportCache, clearRebuildCache, getDbConn, removedCachedRebuild)
+import Language.PureScript.Lsp.State (cancelRequest, getDbConn, removedCachedRebuild)
 import Language.PureScript.Make.Index (dropTables, initDb)
-import Protolude
+import Language.PureScript.Lsp.Handlers.ClearCache (clearCacheHandlers)
+import Language.PureScript.Lsp.Handlers.DebugCacheSize (debugCacheSizeHandler)
 
 handlers :: Server.Handlers HandlerM
 handlers =
@@ -39,7 +41,9 @@ handlers =
       diagnosticAndCodeActionHandlers,
       formatHandler,
       hoverHandler,
-      indexHandler
+      indexHandler,
+      clearCacheHandlers, 
+      debugCacheSizeHandler
     ]
   where
     -- Simple handlers that don't need to be in their own module
@@ -68,15 +72,6 @@ handlers =
           Server.notificationHandler Message.SMethod_CancelRequest $ \msg -> do
             let reqId = msg ^. LSP.params . LSP.id
             cancelRequest reqId,
-          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache") $ \_req res -> do
-            clearCache
-            res $ Right A.Null,
-          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:exports") $ \_req res -> do
-            clearExportCache
-            res $ Right A.Null,
-          Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:rebuilds") $ \_req res -> do
-            clearRebuildCache
-            res $ Right A.Null,
           Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"create-index-tables") $ \_req res -> do
             conn <- getDbConn
             liftIO $ initDb conn
diff --git a/src/Language/PureScript/Lsp/Handlers/ClearCache.hs b/src/Language/PureScript/Lsp/Handlers/ClearCache.hs
new file mode 100644
index 0000000000..1608dbe99d
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/ClearCache.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TypeApplications #-}
+module Language.PureScript.Lsp.Handlers.ClearCache where
+
+import Protolude
+
+import Data.Aeson qualified as A
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Server qualified as Server
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.State (clearCache, clearExportCache, clearRebuildCache, clearEnvCache)
+
+clearCacheHandlers :: Server.Handlers HandlerM
+
+clearCacheHandlers =
+  mconcat
+    [ Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache") $ \_req res -> do
+        clearCache
+        res $ Right A.Null,
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:exports") $ \_req res -> do
+        clearExportCache
+        res $ Right A.Null,
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:environments") $ \_req res -> do
+        clearEnvCache
+        res $ Right A.Null,
+      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:rebuilds") $ \_req res -> do
+        clearRebuildCache
+        res $ Right A.Null
+    ]
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
new file mode 100644
index 0000000000..379c227fe9
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE NumDecimals #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Language.PureScript.Lsp.Handlers.DebugCacheSize (debugCacheSizeHandler) where
+
+import Data.Aeson qualified as A
+import Data.Text qualified as T
+import GHC.DataSize
+import Language.LSP.Protocol.Message qualified as Message
+import Language.LSP.Server qualified as Server
+import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Monad (HandlerM)
+import Language.PureScript.Lsp.State (getState)
+import Language.PureScript.Lsp.Types (LspState (environments, exportEnv, openFiles), OpenFile (..))
+import Numeric (showFFloat)
+import Protolude hiding (to)
+
+debugCacheSizeHandler :: Server.Handlers HandlerM
+debugCacheSizeHandler =
+  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"debug-cache-size") $ \_req res -> do
+    debugLsp "Debugging cache sizes"
+    st <- getState
+    for_ (openFiles st) \(fp, file@(OpenFile {..})) -> do
+      debugSize (T.pack fp <> " - rebuild result") ofRebuildResult
+      debugSize (T.pack fp <> " - artifacts") ofArtifacts
+      debugNfSize (T.pack fp <> " - artifacts") ofArtifacts
+      debugSize (T.pack fp <> " - Full file") file
+
+    for_ (environments st) \((fp, _), (exportEnv, env)) -> do
+      debugSize (T.pack fp <> " - Export env") exportEnv
+      debugSize (T.pack fp <> " - Environment") env
+      debugNfSize (T.pack fp <> " - Environment") env
+
+    debugSize "Current export env" $ exportEnv st
+
+    debugLsp "Finished debugging cache sizes"
+
+    res $ Right A.Null
+
+debugSize :: Text -> a -> HandlerM ()
+debugSize label a = do
+  closure <- liftIO $ closureSize a
+  debugLsp $
+      label <> " - closure:\n" <> toMb closure
+
+debugNfSize :: NFData a => Text -> a -> HandlerM ()
+debugNfSize label a = do
+  !evaluated <- liftIO $ recursiveSizeNF a
+  debugLsp $
+      label <> " - evaluated:\n" <> toMb evaluated
+
+toMb :: Word -> Text
+toMb w =
+  T.pack $
+    formatFloatN
+      ( fromIntegral w / 1e6
+      )
+      <> "MB"
+
+formatFloatN :: Float -> [Char]
+formatFloatN floatNum = showFFloat (Just 4) floatNum ""
diff --git a/src/Language/PureScript/Lsp/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs
index fe57938bd5..fc87d845e8 100644
--- a/src/Language/PureScript/Lsp/Handlers/Hover.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs
@@ -26,6 +26,7 @@ import Language.PureScript.Lsp.Util (positionToSourcePos, getWordAt)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, useSynonymns, artifactInterest, bindersAtPos)
 import Protolude hiding (handle, to)
 import Language.PureScript.Lsp.ReadFile (lspReadFileRope)
+import Language.PureScript.TypeChecker.IdeArtifacts qualified as Artifiacts
 
 hoverHandler :: Server.Handlers HandlerM
 hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req res -> do
@@ -61,7 +62,7 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
           atPos = getArtifactsAtPosition (positionToSourcePos pos) allArtifacts
       debugLsp $ "hover artiacts length: " <> show (length atPos)
       case smallestArtifact (\a -> (negate $ artifactInterest a, negate $ countUnkownsAndVars $ iaType a)) atPos of
-        Just (IdeArtifact {..}) ->
+        Just a@(IdeArtifact {..}) ->
           case iaValue of
             IaExpr exprTxt ident nameType -> do
               let inferredRes =
@@ -118,9 +119,9 @@ hoverHandler = Server.requestHandler Message.SMethod_TextDocumentHover $ \req re
                 src <- lspReadFileRope (Types.toNormalizedUri uri)
                 let 
                   (range, word) = getWordAt src pos
-                  actualBinder = fromMaybe binder $ find (\b -> T.strip (P.prettyPrintBinder b) == word) binders
+                  (binderArtifact, actualBinder) = fromMaybe (a, binder) $ find (\(_, b) -> T.strip (P.prettyPrintBinder b) == word) binders
 
-                let inferredRes = pursTypeStr (dispayBinderOnHover actualBinder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) []
+                let inferredRes = pursTypeStr (dispayBinderOnHover actualBinder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts $ Artifiacts.iaType binderArtifact) []
                 markdownRes (Just range) inferredRes
                 
 
diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs
index 9231d82ff1..7df4915c3e 100644
--- a/src/Language/PureScript/Lsp/NameType.hs
+++ b/src/Language/PureScript/Lsp/NameType.hs
@@ -20,7 +20,7 @@ data LspNameType
   | ModNameType
   | RoleNameType
   | KindNameType
-  deriving (Show, Read, Eq, Ord, Generic, A.ToJSON, A.FromJSON)
+  deriving (Show, Read, Eq, Ord, Generic, A.ToJSON, A.FromJSON, NFData)
 
 readableType :: LspNameType -> Text
 readableType = \case
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index f3738013c2..326c185804 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -1,13 +1,15 @@
 {-# LANGUAGE TypeOperators #-}
 
 module Language.PureScript.Lsp.State
-  ( getDbConn,
+  ( getState, 
+    getDbConn,
     cacheRebuild,
     cacheRebuild',
     updateCachedModule,
     updateCachedModule',
     cachedRebuild,
     clearCache,
+    clearEnvCache,
     clearRebuildCache,
     clearExportCache,
     mergeExportEnvCache,
@@ -60,6 +62,10 @@ import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts)
 getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
+
+getState :: (MonadReader LspEnvironment m, MonadIO m) => m LspState
+getState = liftIO . readTVarIO . lspStateVar =<< ask
+
 -- | Sets rebuild cache to the given ExternsFile
 cacheRebuild :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => Text -> ExternsFile -> IdeArtifacts -> P.Module -> Int -> m ()
 cacheRebuild src ef artifacts module' depHash = do
@@ -168,13 +174,18 @@ clearRebuildCache = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ modifyTVar st $ \x -> x {openFiles = []}
 
+clearEnvCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
+clearEnvCache = do
+  st <- lspStateVar <$> ask
+  liftIO . atomically $ modifyTVar st $ \x -> x {environments = []}
+
 clearExportCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
 clearExportCache = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ modifyTVar st $ \x -> x {exportEnv = P.primEnv}
 
 clearCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
-clearCache = clearRebuildCache >> clearExportCache
+clearCache = clearRebuildCache >> clearEnvCache >> clearExportCache
 
 buildExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> [ExternsFile] -> m (Either MultipleErrors P.Env)
 buildExportEnvCache module' externs = do
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index faa7cb3b95..dced963d30 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 -- | Stores information about the source code that is useful for the IDE
 -- | This includes value types and source spans
 module Language.PureScript.TypeChecker.IdeArtifacts
@@ -51,7 +52,7 @@ data IdeArtifacts
       (Map Line (Set IdeArtifact)) -- with type var substitutions
       (Map Line (Set IdeArtifact)) -- without var substitutions
       (Map (P.Type ()) (P.Type ())) -- type synonym substitutions
-  deriving (Show)
+  deriving (Show, Generic, NFData)
 
 type Line = Int
 
@@ -73,7 +74,7 @@ data IdeArtifact = IdeArtifact
     iaDefinitionModule :: Maybe P.ModuleName,
     iaDefinitionPos :: Maybe (Either P.SourcePos P.SourceSpan)
   }
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 data IdeArtifactValue
   = IaExpr Text (Maybe Text) (Maybe LspNameType)
@@ -85,7 +86,7 @@ data IdeArtifactValue
   | IaClassName (P.ProperName 'P.ClassName)
   | IaModule P.ModuleName
   | IaImport P.ModuleName P.DeclarationRef
-  deriving (Show, Ord, Eq)
+  deriving (Show, Ord, Eq, Generic, NFData)
 
 substituteArtifactTypes :: (P.SourceType -> P.SourceType) -> IdeArtifacts -> IdeArtifacts
 substituteArtifactTypes f (IdeArtifacts m u s) = IdeArtifacts m (Map.map (Set.map (onArtifactType f)) u) s
@@ -99,14 +100,14 @@ endSubstitutions (IdeArtifacts m u s) = IdeArtifacts (Map.unionWith (<>) m u) Ma
 smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
 smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
-bindersAtPos :: P.SourcePos -> IdeArtifacts -> [P.Binder]
+bindersAtPos :: P.SourcePos -> IdeArtifacts -> [(IdeArtifact,  P.Binder)]
 bindersAtPos pos (IdeArtifacts m _ _) =
   Map.lookup (P.sourcePosLine pos) m
     & maybe [] Set.toList
     & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
     & mapMaybe
       ( \case
-          IdeArtifact {iaValue = IaBinder b} -> Just b
+          a@(IdeArtifact {iaValue = IaBinder b}) -> Just (a, b)
           _ -> Nothing
       )
   where
diff --git a/stack.yaml b/stack.yaml
index 0b0cf5888e..390c4e0aa5 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -32,6 +32,7 @@ extra-deps:
 - lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215
 - mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409
 - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071
+- ghc-datasize-0.2.7@sha256:3397b0306f179836a0f5912e9888b5a0d2c40c2a6bba12965e82144a22de15a3,1132
 nix:
   packages:
   - zlib

From 2c29c0ccfc0b1a1442335fbd75c02cc973f892b2 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 12 Nov 2024 01:06:12 +0100
Subject: [PATCH 246/297] remove export env from state

---
 .../PureScript/Lsp/Handlers/ClearCache.hs     |  5 +-
 .../PureScript/Lsp/Handlers/DebugCacheSize.hs |  5 +-
 src/Language/PureScript/Lsp/Rebuild.hs        | 29 +--------
 src/Language/PureScript/Lsp/State.hs          | 63 +------------------
 src/Language/PureScript/Lsp/Types.hs          |  4 +-
 5 files changed, 8 insertions(+), 98 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/ClearCache.hs b/src/Language/PureScript/Lsp/Handlers/ClearCache.hs
index 1608dbe99d..ccf8493f43 100644
--- a/src/Language/PureScript/Lsp/Handlers/ClearCache.hs
+++ b/src/Language/PureScript/Lsp/Handlers/ClearCache.hs
@@ -7,7 +7,7 @@ import Data.Aeson qualified as A
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Monad (HandlerM)
-import Language.PureScript.Lsp.State (clearCache, clearExportCache, clearRebuildCache, clearEnvCache)
+import Language.PureScript.Lsp.State (clearCache, clearRebuildCache, clearEnvCache)
 
 clearCacheHandlers :: Server.Handlers HandlerM
 
@@ -16,9 +16,6 @@ clearCacheHandlers =
     [ Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache") $ \_req res -> do
         clearCache
         res $ Right A.Null,
-      Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:exports") $ \_req res -> do
-        clearExportCache
-        res $ Right A.Null,
       Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"clear-cache:environments") $ \_req res -> do
         clearEnvCache
         res $ Right A.Null,
diff --git a/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
index 379c227fe9..f381998650 100644
--- a/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
@@ -12,7 +12,7 @@ import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Log (debugLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.State (getState)
-import Language.PureScript.Lsp.Types (LspState (environments, exportEnv, openFiles), OpenFile (..))
+import Language.PureScript.Lsp.Types (LspState (environments, openFiles), OpenFile (..))
 import Numeric (showFFloat)
 import Protolude hiding (to)
 
@@ -30,9 +30,6 @@ debugCacheSizeHandler =
     for_ (environments st) \((fp, _), (exportEnv, env)) -> do
       debugSize (T.pack fp <> " - Export env") exportEnv
       debugSize (T.pack fp <> " - Environment") env
-      debugNfSize (T.pack fp <> " - Environment") env
-
-    debugSize "Current export env" $ exportEnv st
 
     debugLsp "Finished debugging cache sizes"
 
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index c4ba6737ee..60627e1930 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
 
-module Language.PureScript.Lsp.Rebuild (rebuildFile, buildExportEnvCacheAndHandleErrors, codegenTargets, rebuildFilePathFromUri) where
+module Language.PureScript.Lsp.Rebuild (rebuildFile, codegenTargets, rebuildFilePathFromUri) where
 
 import Control.Concurrent.STM (TVar)
 import Control.Monad.Catch (MonadThrow (throwM))
@@ -10,7 +10,7 @@ import Data.Set qualified as Set
 import Data.Text qualified as T
 import Language.LSP.Protocol.Types (NormalizedUri, fromNormalizedUri, uriToFilePath)
 import Language.LSP.Server (MonadLsp, getConfig)
-import Language.PureScript (ExternsFile, primEnv)
+import Language.PureScript (ExternsFile)
 import Language.PureScript.AST qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Environment qualified as P
@@ -22,7 +22,7 @@ import Language.PureScript.Lsp.Cache (selectDependencies, selectDependencyHashFr
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternsToExportEnv, buildExportEnvCache, cacheEnvironment, cacheRebuild', cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, mergeExportEnvCache, updateCachedRebuildResult)
+import Language.PureScript.Lsp.State (addExternsToExportEnv, cacheEnvironment, cacheRebuild', cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, updateCachedRebuildResult)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState)
 import Language.PureScript.Lsp.Types qualified as Types
 import Language.PureScript.Make qualified as P
@@ -141,29 +141,6 @@ buildExportEnvFromPrim =
   addExternsToExportEnv P.primEnv
     >=> either (throwM . CouldNotRebuildExportEnv . P.prettyPrintMultipleErrors P.noColorPPEOptions) pure
 
-buildExportEnvCacheAndHandleErrors ::
-  (MonadReader Types.LspEnvironment m, MonadLsp ServerConfig m, MonadThrow m) =>
-  m [ExternDependency] ->
-  P.Module ->
-  [ExternsFile] ->
-  m (P.Env, Maybe [ExternDependency])
-buildExportEnvCacheAndHandleErrors refetchExterns m externs = do
-  fromCache <- buildExportEnvCache m externs
-  case fromCache of
-    Left err -> do
-      warnLsp $ "Error building export env cache: " <> show err
-      externs' <- refetchExterns
-      envRes <- addExternsToExportEnv primEnv $ edExtern <$> externs'
-      case envRes of
-        Left err' ->
-          throwM $
-            CouldNotRebuildExportEnv $
-              P.prettyPrintMultipleErrors P.noColorPPEOptions err'
-        Right env -> do
-          mergeExportEnvCache env
-          pure (env, Just externs')
-    Right env -> pure (env, Nothing)
-
 data RebuildException
   = CouldNotConvertUriToFilePath NormalizedUri
   | CouldNotRebuildExportEnv [Char]
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index 326c185804..d129aa507f 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -11,13 +11,8 @@ module Language.PureScript.Lsp.State
     clearCache,
     clearEnvCache,
     clearRebuildCache,
-    clearExportCache,
-    mergeExportEnvCache,
     removedCachedRebuild,
-    buildExportEnvCache,
-    addExternToExportEnv,
     addExternsToExportEnv,
-    getExportEnv,
     cancelRequest,
     addRunningRequest,
     removeRunningRequest,
@@ -42,16 +37,14 @@ import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
 import Data.List qualified as List
 import Data.Map qualified as Map
-import Data.Text qualified as T
 import Database.SQLite.Simple (Connection)
 import Language.LSP.Protocol.Types (type (|?) (..))
 import Language.LSP.Server (MonadLsp)
-import Language.PureScript (MultipleErrors, prettyPrintMultipleErrors)
+import Language.PureScript (MultipleErrors)
 import Language.PureScript.DB (mkConnection)
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors qualified as P
 import Language.PureScript.Externs (ExternsFile (..))
-import Language.PureScript.Lsp.Log (errorLsp)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, getMaxFilesInCache)
 import Language.PureScript.Lsp.Types
 import Language.PureScript.Sugar.Names (externsEnv)
@@ -62,7 +55,6 @@ import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts)
 getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
 
-
 getState :: (MonadReader LspEnvironment m, MonadIO m) => m LspState
 getState = liftIO . readTVarIO . lspStateVar =<< ask
 
@@ -179,36 +171,8 @@ clearEnvCache = do
   st <- lspStateVar <$> ask
   liftIO . atomically $ modifyTVar st $ \x -> x {environments = []}
 
-clearExportCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
-clearExportCache = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically $ modifyTVar st $ \x -> x {exportEnv = P.primEnv}
-
 clearCache :: (MonadReader LspEnvironment m, MonadIO m) => m ()
-clearCache = clearRebuildCache >> clearEnvCache >> clearExportCache
-
-buildExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> [ExternsFile] -> m (Either MultipleErrors P.Env)
-buildExportEnvCache module' externs = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically $ do
-    st' <- readTVar st
-    if Map.member (P.getModuleName module') (exportEnv st')
-      then pure $ Right $ exportEnv st'
-      else do
-        let notInEnv :: ExternsFile -> Bool
-            notInEnv = flip Map.notMember (exportEnv st') . efModuleName
-        result <- addExternsToExportEnv (exportEnv st') (filter notInEnv externs)
-        case result of
-          Left err -> pure $ Left err
-          Right newEnv -> do
-            writeTVar st $ st' {exportEnv = newEnv}
-            pure $ Right newEnv
-
-
-mergeExportEnvCache :: (MonadIO m, MonadReader LspEnvironment m) => P.Env -> m ()
-mergeExportEnvCache env = do
-  st <- lspStateVar <$> ask
-  liftIO . atomically $ modifyTVar st $ \x -> x {exportEnv = env}
+clearCache = clearRebuildCache >> clearEnvCache
 
 data BuildEnvCacheException = BuildEnvCacheException Text
   deriving (Show)
@@ -218,29 +182,6 @@ instance Exception BuildEnvCacheException
 addExternsToExportEnv :: (Foldable t, Monad m) => P.Env -> t ExternsFile -> m (Either MultipleErrors P.Env)
 addExternsToExportEnv env externs = fmap fst . runWriterT $ runExceptT $ foldM externsEnv env externs
 
-logBuildErrors :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => MultipleErrors -> m ()
-logBuildErrors = errorLsp . printBuildErrors
-
-printBuildErrors :: MultipleErrors -> Text
-printBuildErrors = T.pack . prettyPrintMultipleErrors P.noColorPPEOptions
-
-addExternToExportEnv :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => ExternsFile -> m ()
-addExternToExportEnv ef = do
-  stVar <- lspStateVar <$> ask
-  error <- liftIO $ atomically $ do
-    st <- readTVar stVar
-    result <- addExternsToExportEnv (exportEnv st) [ef]
-    case result of
-      Left err -> pure $ Just err
-      Right newEnv -> do
-        writeTVar stVar $ st {exportEnv = newEnv}
-        pure Nothing
-
-  for_ error logBuildErrors
-
-getExportEnv :: (MonadReader LspEnvironment m, MonadIO m) => m P.Env
-getExportEnv = exportEnv <$> (liftIO . readTVarIO =<< lspStateVar <$> ask)
-
 addRunningRequest :: (MonadIO m) => LspEnvironment -> Either Int32 Text -> Async () -> m ()
 addRunningRequest env requestId req = liftIO . atomically $ modifyTVar (lspStateVar env) $ \x ->
   x
diff --git a/src/Language/PureScript/Lsp/Types.hs b/src/Language/PureScript/Lsp/Types.hs
index 8911cadd40..9c856a44e9 100644
--- a/src/Language/PureScript/Lsp/Types.hs
+++ b/src/Language/PureScript/Lsp/Types.hs
@@ -17,7 +17,6 @@ import Language.PureScript.Lsp.LogLevel (LspLogLevel)
 import Language.PureScript.Lsp.NameType (LspNameType)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig, defaultConfig)
 import Language.PureScript.Names qualified as P
-import Language.PureScript.Sugar.Names (Env)
 import Language.PureScript.Sugar.Names qualified as P
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts)
 import Protolude
@@ -36,7 +35,7 @@ mkEnv outputPath = do
   pure $ LspEnvironment connection st prevConfig
 
 emptyState :: LspState
-emptyState = LspState mempty P.primEnv mempty mempty
+emptyState = LspState mempty mempty mempty
 
 data LspConfig = LspConfig
   { confOutputPath :: FilePath,
@@ -48,7 +47,6 @@ data LspConfig = LspConfig
 
 data LspState = LspState
   { openFiles :: [(FilePath, OpenFile)],
-    exportEnv :: Env,
     environments :: [((FilePath, Int), (P.Env, P.Environment))],
     runningRequests :: Map (Either Int32 Text) (Async ())
   }

From 2ff0537a59e49d4428b57e48d8c53e8674ac9fe6 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 12 Nov 2024 11:41:49 +0100
Subject: [PATCH 247/297] adds option to show error module and filepath

---
 src/Language/PureScript/Lsp/Diagnostics.hs  | 43 +++++++++++----------
 src/Language/PureScript/Lsp/ServerConfig.hs |  8 +++-
 2 files changed, 29 insertions(+), 22 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index 373545b5bb..ced9cc0e7b 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -10,15 +10,15 @@ import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Types (Diagnostic, Uri)
 import Language.LSP.Protocol.Types qualified as Types
-import Language.LSP.Server (MonadLsp)
+import Language.LSP.Server (MonadLsp, getConfig)
 import Language.PureScript qualified as P
 import Language.PureScript.Errors (ErrorMessage (ErrorMessage), MultipleErrors (runMultipleErrors), errorCode, errorDocUri, errorSpan, noColorPPEOptions, prettyPrintSingleError)
 import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig)
-import Language.PureScript.Lsp.Types (LspEnvironment, RebuildResult (RebuildWarning, RebuildError))
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (showErrorFilepath, showErrorModule))
+import Language.PureScript.Lsp.Types (LspEnvironment, RebuildResult (RebuildError, RebuildWarning))
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
 
@@ -36,7 +36,8 @@ getFileDiagnotics msg = do
   let uri :: Types.NormalizedUri
       uri = getMsgUri msg & Types.toNormalizedUri
   res <- rebuildFile uri
-  pure $ addJsonEdits $ getResultDiagnostics res
+  config <- getConfig
+  pure $ addJsonEdits $ getResultDiagnostics config res
 
 addJsonEdits :: [(Types.Diagnostic, [TitledTextEdit])] -> [Types.Diagnostic]
 addJsonEdits diags =
@@ -49,44 +50,46 @@ addJsonEdits diags =
         if length diags > 1 then diags >>= fmap tteEdit . filter tteIsUnusedImport . snd else []
    in diags
         <&> \(diag, edits) ->
-          let
-            withApplyAlls = 
-               edits
-                 <&> addAllEdits allEdits
+          let withApplyAlls =
+                edits
+                  <&> addAllEdits allEdits
                   <&> addImportEdits importEdits
-
-          in
-           set LSP.data_ (Just $ A.toJSON withApplyAlls) diag
+           in set LSP.data_ (Just $ A.toJSON withApplyAlls) diag
 
 getMsgUri :: (LSP.HasParams s a1, LSP.HasTextDocument a1 a2, LSP.HasUri a2 a3) => s -> a3
 getMsgUri msg = msg ^. LSP.params . LSP.textDocument . LSP.uri
 
 getResultDiagnostics ::
+  ServerConfig ->
   RebuildResult ->
   [(Types.Diagnostic, [TitledTextEdit])]
-getResultDiagnostics res = case res of
-  RebuildError errors -> errorsToDiagnostics Types.DiagnosticSeverity_Error errors
-  RebuildWarning errors -> errorsToDiagnostics Types.DiagnosticSeverity_Warning errors
+getResultDiagnostics config res = case res of
+  RebuildError errors -> errorsToDiagnostics config Types.DiagnosticSeverity_Error errors
+  RebuildWarning errors -> errorsToDiagnostics config Types.DiagnosticSeverity_Warning errors
 
-errorsToDiagnostics :: Types.DiagnosticSeverity -> P.MultipleErrors -> [(Types.Diagnostic, [TitledTextEdit])]
-errorsToDiagnostics severity errs =
-  errorMessageDiagnostic severity <$> runMultipleErrors errs
+errorsToDiagnostics :: ServerConfig -> Types.DiagnosticSeverity -> P.MultipleErrors -> [(Types.Diagnostic, [TitledTextEdit])]
+errorsToDiagnostics config severity errs =
+  errorMessageDiagnostic config severity <$> runMultipleErrors errs
 
-errorMessageDiagnostic :: Types.DiagnosticSeverity -> ErrorMessage -> (Types.Diagnostic, [TitledTextEdit])
-errorMessageDiagnostic severity msg@((ErrorMessage _hints _)) =
+errorMessageDiagnostic :: ServerConfig -> Types.DiagnosticSeverity -> ErrorMessage -> (Types.Diagnostic, [TitledTextEdit])
+errorMessageDiagnostic config severity msg@((ErrorMessage _hints _)) =
   ( Types.Diagnostic
       (Types.Range start end)
       (Just severity)
       (Just $ Types.InR $ errorCode msg)
       (Just $ Types.CodeDescription $ Types.Uri $ errorDocUri msg)
       (T.pack <$> spanName)
-      (T.pack $ render $ prettyPrintSingleError noColorPPEOptions $ Errors.withoutPosition $ Errors.withoutModule msg)
+      (T.pack $ render $ prettyPrintSingleError noColorPPEOptions $ checkWithPosition $ checkWithModule msg)
       Nothing
       Nothing
       Nothing,
     maybeToList (getErrorTextEdit msg)
   )
   where
+    checkWithPosition = if showErrorFilepath config then identity else Errors.withoutPosition
+
+    checkWithModule = if showErrorModule config then identity else Errors.withoutModule
+
     notFound = Types.Position 0 0
     (spanName, start, end) = getPositions $ errorSpan msg
 
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index 9cfb2f72ae..abfc6747b7 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -17,7 +17,9 @@ data ServerConfig = ServerConfig
     maxTypeLength :: Maybe Int,
     maxCompletions :: Maybe Int, 
     maxFilesInCache :: Maybe Int, 
-    inferExpressions :: Bool
+    inferExpressions :: Bool,
+    showErrorModule :: Bool,
+    showErrorFilepath :: Bool
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
@@ -32,7 +34,9 @@ defaultConfig outputPath =
       maxTypeLength = Just defaultMaxTypeLength,
       maxCompletions = Just defaultMaxCompletions, 
       maxFilesInCache = Just defaultMaxFilesInCache,
-      inferExpressions = True
+      inferExpressions = True,
+      showErrorModule = False,
+      showErrorFilepath = False
     }
 
 setTraceValue :: (MonadLsp ServerConfig m) => TraceValue -> m ()

From dc0e98167dc247cf04b666a1f313519cdd370d38 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 12 Nov 2024 12:04:20 +0100
Subject: [PATCH 248/297] better name for diagnostics options

---
 src/Language/PureScript/Lsp/Diagnostics.hs    | 6 +++---
 src/Language/PureScript/Lsp/Handlers/Build.hs | 5 +++--
 src/Language/PureScript/Lsp/ServerConfig.hs   | 8 ++++----
 3 files changed, 10 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs
index ced9cc0e7b..200739d661 100644
--- a/src/Language/PureScript/Lsp/Diagnostics.hs
+++ b/src/Language/PureScript/Lsp/Diagnostics.hs
@@ -17,7 +17,7 @@ import Language.PureScript.Errors qualified as Errors
 import Language.PureScript.Errors.JSON (toSuggestion)
 import Language.PureScript.Errors.JSON qualified as JsonErrors
 import Language.PureScript.Lsp.Rebuild (rebuildFile)
-import Language.PureScript.Lsp.ServerConfig (ServerConfig (showErrorFilepath, showErrorModule))
+import Language.PureScript.Lsp.ServerConfig (ServerConfig (showDiagnosticsFilepath, showDiagnosticsModule))
 import Language.PureScript.Lsp.Types (LspEnvironment, RebuildResult (RebuildError, RebuildWarning))
 import Protolude hiding (to)
 import Text.PrettyPrint.Boxes (render)
@@ -86,9 +86,9 @@ errorMessageDiagnostic config severity msg@((ErrorMessage _hints _)) =
     maybeToList (getErrorTextEdit msg)
   )
   where
-    checkWithPosition = if showErrorFilepath config then identity else Errors.withoutPosition
+    checkWithPosition = if showDiagnosticsFilepath config then identity else Errors.withoutPosition
 
-    checkWithModule = if showErrorModule config then identity else Errors.withoutModule
+    checkWithModule = if showDiagnosticsModule config then identity else Errors.withoutModule
 
     notFound = Types.Position 0 0
     (spanName, start, end) = getPositions $ errorSpan msg
diff --git a/src/Language/PureScript/Lsp/Handlers/Build.hs b/src/Language/PureScript/Lsp/Handlers/Build.hs
index dd73d211a1..aef815d026 100644
--- a/src/Language/PureScript/Lsp/Handlers/Build.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Build.hs
@@ -46,6 +46,7 @@ buildForLsp = do
         conn
         outDir
         False
+  config <- getConfig
   pure $ addJsonEdits $
-    (errorMessageDiagnostic Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
-      <> (errorMessageDiagnostic Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
+    (errorMessageDiagnostic config Types.DiagnosticSeverity_Error <$> either P.runMultipleErrors (const []) result)
+      <> (errorMessageDiagnostic config Types.DiagnosticSeverity_Warning <$> P.runMultipleErrors warnings)
\ No newline at end of file
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index abfc6747b7..e6bab7f9f3 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -18,8 +18,8 @@ data ServerConfig = ServerConfig
     maxCompletions :: Maybe Int, 
     maxFilesInCache :: Maybe Int, 
     inferExpressions :: Bool,
-    showErrorModule :: Bool,
-    showErrorFilepath :: Bool
+    showDiagnosticsModule :: Bool,
+    showDiagnosticsFilepath :: Bool
   }
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
@@ -35,8 +35,8 @@ defaultConfig outputPath =
       maxCompletions = Just defaultMaxCompletions, 
       maxFilesInCache = Just defaultMaxFilesInCache,
       inferExpressions = True,
-      showErrorModule = False,
-      showErrorFilepath = False
+      showDiagnosticsModule = False,
+      showDiagnosticsFilepath = False
     }
 
 setTraceValue :: (MonadLsp ServerConfig m) => TraceValue -> m ()

From 674829e561e37713536606acaf971bab9f54285b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 12 Nov 2024 18:05:24 +0100
Subject: [PATCH 249/297] use force instead of NFData

---
 src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs | 2 +-
 src/Language/PureScript/Make.hs                        | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
index f381998650..c676fb6199 100644
--- a/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
@@ -43,7 +43,7 @@ debugSize label a = do
 
 debugNfSize :: NFData a => Text -> a -> HandlerM ()
 debugNfSize label a = do
-  !evaluated <- liftIO $ recursiveSizeNF a
+  !evaluated <- liftIO $ closureSize $ force a
   debugLsp $
       label <> " - evaluated:\n" <> toMb evaluated
 
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 07e6139e27..eb87275f62 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -51,7 +51,7 @@ import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName
 import Language.PureScript.Renamer (renameInModule)
 import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
-import Language.PureScript.TypeChecker qualified as P
+import Language.PureScript.TypeChecker.Monad qualified as P
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 import Prelude
@@ -120,7 +120,7 @@ rebuildModuleWithProvidedEnv initialCheckState onDesugared MakeActions {..} exEn
 
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
-
+  
       corefn = CF.moduleToCoreFn env' mod'
       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized

From 4d672f03a0c36ba9ab3a6404d29057e0a1c58a63 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 12 Nov 2024 18:08:17 +0100
Subject: [PATCH 250/297] adds debug-cache-size-evaluated

---
 .../PureScript/Lsp/Handlers/DebugCacheSize.hs | 51 ++++++++++++-------
 1 file changed, 34 insertions(+), 17 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
index c676fb6199..ee515dd05e 100644
--- a/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
+++ b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs
@@ -18,34 +18,51 @@ import Protolude hiding (to)
 
 debugCacheSizeHandler :: Server.Handlers HandlerM
 debugCacheSizeHandler =
-  Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"debug-cache-size") $ \_req res -> do
-    debugLsp "Debugging cache sizes"
-    st <- getState
-    for_ (openFiles st) \(fp, file@(OpenFile {..})) -> do
-      debugSize (T.pack fp <> " - rebuild result") ofRebuildResult
-      debugSize (T.pack fp <> " - artifacts") ofArtifacts
-      debugNfSize (T.pack fp <> " - artifacts") ofArtifacts
-      debugSize (T.pack fp <> " - Full file") file
+  mconcat
+    [ Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"debug-cache-size") $ \_req res -> do
+        debugLsp "Debugging cache sizes"
+        st <- getState
+        for_ (openFiles st) \(fp, file@(OpenFile {..})) -> do
+          debugSize (T.pack fp <> " - rebuild result") ofRebuildResult
+          debugSize (T.pack fp <> " - artifacts") ofArtifacts
+          debugSize (T.pack fp <> " - Full file") file
 
-    for_ (environments st) \((fp, _), (exportEnv, env)) -> do
-      debugSize (T.pack fp <> " - Export env") exportEnv
-      debugSize (T.pack fp <> " - Environment") env
+        for_ (environments st) \((fp, _), (exportEnv, env)) -> do
+          debugSize (T.pack fp <> " - Export env") exportEnv
+          debugSize (T.pack fp <> " - Environment") env
 
-    debugLsp "Finished debugging cache sizes"
+        debugLsp "Finished debugging cache sizes"
 
-    res $ Right A.Null
+        res $ Right A.Null
+    , Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"debug-cache-size-evaluated") $ \_req res -> do
+        debugLsp "Debugging cache sizes"
+        st <- getState
+        for_ (openFiles st) \(fp, file@(OpenFile {..})) -> do
+          debugSize (T.pack fp <> " - artifacts") ofArtifacts
+          debugNfSize (T.pack fp <> " - artifacts") ofArtifacts
+          debugSize (T.pack fp <> " - Full file") file
+
+        for_ (environments st) \((fp, _), (_, env)) -> do
+          debugSize (T.pack fp <> " - Environment") env
+          debugNfSize (T.pack fp <> " - Environment") env
+
+        debugLsp "Finished debugging cache sizes"
+
+        res $ Right A.Null
+    ]
 
 debugSize :: Text -> a -> HandlerM ()
 debugSize label a = do
   closure <- liftIO $ closureSize a
   debugLsp $
-      label <> " - closure:\n" <> toMb closure
+    label <> " - closure:\n" <> toMb closure
 
-debugNfSize :: NFData a => Text -> a -> HandlerM ()
+debugNfSize :: (NFData a) => Text -> a -> HandlerM ()
 debugNfSize label a = do
-  !evaluated <- liftIO $ closureSize $ force a
+  let !forced = force a
+  !evaluated <- liftIO $ closureSize forced
   debugLsp $
-      label <> " - evaluated:\n" <> toMb evaluated
+    label <> " - evaluated:\n" <> toMb evaluated
 
 toMb :: Word -> Text
 toMb w =

From d2dc3b7ca07d8139f2923e55fc5ae191230420cb Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 15 Nov 2024 10:57:42 +0100
Subject: [PATCH 251/297] adds refences handler placeholder

---
 purescript.cabal                              |   1 +
 .../PureScript/Lsp/Handlers/References.hs     | 112 ++++++++++++++++++
 2 files changed, 113 insertions(+)
 create mode 100644 src/Language/PureScript/Lsp/Handlers/References.hs

diff --git a/purescript.cabal b/purescript.cabal
index 49c825dbca..5c97480c50 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -360,6 +360,7 @@ library
     Language.PureScript.Lsp.Handlers.Format
     Language.PureScript.Lsp.Handlers.Hover
     Language.PureScript.Lsp.Handlers.Index
+    Language.PureScript.Lsp.Handlers.References
     Language.PureScript.Lsp.Log
     Language.PureScript.Lsp.LogLevel
     Language.PureScript.Lsp.Monad
diff --git a/src/Language/PureScript/Lsp/Handlers/References.hs b/src/Language/PureScript/Lsp/Handlers/References.hs
new file mode 100644
index 0000000000..adbd699b03
--- /dev/null
+++ b/src/Language/PureScript/Lsp/Handlers/References.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Language.PureScript.Lsp.Handlers.References where
+
+-- import Protolude
+
+-- import Control.Lens ((^.))
+-- import Data.Text qualified as T
+-- import Language.LSP.Protocol.Lens qualified as LSP
+-- import Language.LSP.Protocol.Message qualified as Message
+-- import Language.LSP.Protocol.Types qualified as Types
+-- import Language.LSP.Server qualified as Server
+-- import Language.PureScript qualified as P
+-- import Language.PureScript.Lsp.AtPosition (getImportRefNameType, spanToRange)
+-- import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
+-- import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule)
+-- import Language.PureScript.Lsp.Log (debugLsp, warnLsp)
+-- import Language.PureScript.Lsp.Monad (HandlerM)
+-- import Language.PureScript.Lsp.NameType (LspNameType (..))
+-- import Language.PureScript.Lsp.Print (printName)
+-- import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
+-- import Language.PureScript.Lsp.Types (OpenFile (OpenFile, ofArtifacts))
+-- import Language.PureScript.Lsp.Util (positionToSourcePos, sourcePosToPosition)
+-- import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, artifactInterest, debugIdeArtifact)
+-- import Language.PureScript.Lsp.Docs (readDeclarationDocsSourceSpan)
+
+
+
+-- referenceHandler :: Server.Handlers HandlerM
+-- referenceHandler = Server.requestHandler Message.SMethod_TextDocumentReferences $ \req res -> do
+
+--   let Types.ReferenceParams docIdent pos _prog _prog' ctx = req ^. LSP.params
+--       filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+--       includeDeclaration = ctx ^. LSP.includeDeclaration
+
+--   res $ Right $ Types.InL $  [ Types.Location _ _ ]
+
+
+  -- let Types.DefinitionParams docIdent pos _prog _prog' = req ^. LSP.params
+  --     filePathMb = Types.uriToFilePath $ docIdent ^. LSP.uri
+
+  --     nullRes = res $ Right $ Types.InR $ Types.InR Types.Null
+
+  --     locationRes fp range = res $ Right $ Types.InL $ Types.Definition $ Types.InL $ Types.Location (Types.filePathToUri fp) range
+
+  --     posRes fp srcPos = locationRes fp $ Types.Range (sourcePosToPosition srcPos) (sourcePosToPosition srcPos)
+
+  --     spanRes span = locationRes (P.spanName span) (spanToRange span)
+
+  --     forLsp :: Maybe a -> (a -> HandlerM ()) -> HandlerM ()
+  --     forLsp val f = maybe nullRes f val
+
+  --     respondWithDeclInOtherModule :: LspNameType -> P.ModuleName -> Text -> HandlerM ()
+  --     respondWithDeclInOtherModule nameType modName ident = do
+  --       declSpans <- getAstDeclarationLocationInModule nameType modName ident
+  --       case head declSpans of
+  --         Just sourceSpan ->
+  --           locationRes (P.spanName sourceSpan) (spanToRange sourceSpan)
+  --         Nothing -> do
+  --           debugLsp $ "No definition in DB found for " <> show nameType <> " " <> show ident <> " in " <> show modName 
+  --           docSsMb <- readDeclarationDocsSourceSpan modName ident
+  --           forLsp docSsMb spanRes
+
+  --     respondWithModule :: P.ModuleName -> HandlerM ()
+  --     respondWithModule modName = do
+  --       modFpMb <- selectExternPathFromModuleName modName
+  --       forLsp modFpMb \modFp -> do
+  --         posRes modFp $ P.SourcePos 1 1
+  -- debugLsp $ "goto def filePath found " <> show (isJust filePathMb)
+  -- forLsp filePathMb \filePath -> do
+  --   cacheOpenMb <- cachedRebuild filePath
+  --   debugLsp $ "cacheOpenMb found " <> show (isJust cacheOpenMb)
+  --   when (isNothing cacheOpenMb) do
+  --     warnLsp $ "file path not cached: " <> T.pack filePath
+  --     warnLsp . show =<< cachedFilePaths
+
+  --   forLsp cacheOpenMb \OpenFile {..} -> do
+  --     let allArtifacts = ofArtifacts
+  --         atPos = getArtifactsAtPosition (positionToSourcePos pos) allArtifacts
+  --     debugLsp $ "Found " <> show (length atPos) <> " artifacts at position"
+  --     let smallest = smallestArtifact (\a -> (negate $ artifactInterest a, isNothing (iaDefinitionPos a), isNothing (iaDefinitionModule a))) atPos
+  --     debugLsp $ "Smallest artifact: " <> maybe "Nothing" debugIdeArtifact smallest
+  --     case smallest of
+  --       Just (IdeArtifact _ (IaModule modName) _ _ _) -> do
+  --         debugLsp "Module definition"
+  --         respondWithModule modName
+  --       Just (IdeArtifact _ (IaImport modName ref) _ _ _) -> do
+  --         let nameType = getImportRefNameType ref
+  --             name = P.declRefName ref
+  --         respondWithDeclInOtherModule nameType modName (printName name)
+  --       Just (IdeArtifact _ (IaExpr _ (Just ident) (Just nameType)) _ (Just modName) _) -> do
+  --         debugLsp "Expr definition"
+  --         respondWithDeclInOtherModule nameType modName ident
+  --       Just (IdeArtifact _ (IaTypeName name) _ (Just modName) _) -> do
+  --         debugLsp "Type definition"
+  --         respondWithDeclInOtherModule TyNameType modName (P.runProperName name)
+  --       Just (IdeArtifact _ (IaClassName name) _ (Just modName) _) -> do
+  --         debugLsp "Class definition"
+  --         respondWithDeclInOtherModule TyClassNameType modName (P.runProperName name)
+  --       Just (IdeArtifact _ _ _ _ (Just (Right defSpan))) -> do
+  --         debugLsp "Span definition"
+  --         spanRes defSpan
+  --       Just (IdeArtifact _ _ _ (Just modName) (Just (Left defPos))) -> do
+  --         debugLsp "Module position definition"
+  --         fpMb <- selectExternPathFromModuleName modName
+  --         forLsp fpMb \fp -> posRes fp defPos
+  --       Just (IdeArtifact _ _ _ Nothing (Just (Left defPos))) -> do
+  --         debugLsp "Position definition"
+  --         posRes filePath defPos
+  --       _ -> do
+  --         debugLsp "No relevant definition found for artifact"
+  --         nullRes
\ No newline at end of file

From 48f96dcd22552f00569a5fad09d83578c1ae93db Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 15 Nov 2024 10:58:07 +0100
Subject: [PATCH 252/297] adds debug logs for definition

---
 .../PureScript/Lsp/Handlers/Definition.hs     | 26 ++++++++++++++-----
 1 file changed, 19 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs
index f7508f1a60..ac349fc2c1 100644
--- a/src/Language/PureScript/Lsp/Handlers/Definition.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs
@@ -2,6 +2,8 @@
 
 module Language.PureScript.Lsp.Handlers.Definition where
 
+import Protolude
+
 import Control.Lens ((^.))
 import Data.Text qualified as T
 import Language.LSP.Protocol.Lens qualified as LSP
@@ -12,15 +14,14 @@ import Language.PureScript qualified as P
 import Language.PureScript.Lsp.AtPosition (getImportRefNameType, spanToRange)
 import Language.PureScript.Lsp.Cache (selectExternPathFromModuleName)
 import Language.PureScript.Lsp.Cache.Query (getAstDeclarationLocationInModule)
-import Language.PureScript.Lsp.Log (debugLsp)
+import Language.PureScript.Lsp.Log (debugLsp, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.NameType (LspNameType (..))
 import Language.PureScript.Lsp.Print (printName)
 import Language.PureScript.Lsp.State (cachedFilePaths, cachedRebuild)
 import Language.PureScript.Lsp.Types (OpenFile (OpenFile, ofArtifacts))
 import Language.PureScript.Lsp.Util (positionToSourcePos, sourcePosToPosition)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, artifactInterest)
-import Protolude
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifact (..), IdeArtifactValue (..), getArtifactsAtPosition, smallestArtifact, artifactInterest, debugIdeArtifact)
 import Language.PureScript.Lsp.Docs (readDeclarationDocsSourceSpan)
 
 definitionHandler :: Server.Handlers HandlerM
@@ -55,35 +56,46 @@ definitionHandler = Server.requestHandler Message.SMethod_TextDocumentDefinition
         modFpMb <- selectExternPathFromModuleName modName
         forLsp modFpMb \modFp -> do
           posRes modFp $ P.SourcePos 1 1
-
+  debugLsp $ "goto def filePath found " <> show (isJust filePathMb)
   forLsp filePathMb \filePath -> do
     cacheOpenMb <- cachedRebuild filePath
+    debugLsp $ "cacheOpenMb found " <> show (isJust cacheOpenMb)
     when (isNothing cacheOpenMb) do
-      debugLsp $ "file path not cached: " <> T.pack filePath
-      debugLsp . show =<< cachedFilePaths
+      warnLsp $ "file path not cached: " <> T.pack filePath
+      warnLsp . show =<< cachedFilePaths
 
     forLsp cacheOpenMb \OpenFile {..} -> do
       let allArtifacts = ofArtifacts
           atPos = getArtifactsAtPosition (positionToSourcePos pos) allArtifacts
+      debugLsp $ "Found " <> show (length atPos) <> " artifacts at position"
       let smallest = smallestArtifact (\a -> (negate $ artifactInterest a, isNothing (iaDefinitionPos a), isNothing (iaDefinitionModule a))) atPos
+      debugLsp $ "Smallest artifact: " <> maybe "Nothing" debugIdeArtifact smallest
       case smallest of
-        Just (IdeArtifact _ (IaModule modName) _ _ _) -> respondWithModule modName
+        Just (IdeArtifact _ (IaModule modName) _ _ _) -> do
+          debugLsp "Module definition"
+          respondWithModule modName
         Just (IdeArtifact _ (IaImport modName ref) _ _ _) -> do
           let nameType = getImportRefNameType ref
               name = P.declRefName ref
           respondWithDeclInOtherModule nameType modName (printName name)
         Just (IdeArtifact _ (IaExpr _ (Just ident) (Just nameType)) _ (Just modName) _) -> do
+          debugLsp "Expr definition"
           respondWithDeclInOtherModule nameType modName ident
         Just (IdeArtifact _ (IaTypeName name) _ (Just modName) _) -> do
+          debugLsp "Type definition"
           respondWithDeclInOtherModule TyNameType modName (P.runProperName name)
         Just (IdeArtifact _ (IaClassName name) _ (Just modName) _) -> do
+          debugLsp "Class definition"
           respondWithDeclInOtherModule TyClassNameType modName (P.runProperName name)
         Just (IdeArtifact _ _ _ _ (Just (Right defSpan))) -> do
+          debugLsp "Span definition"
           spanRes defSpan
         Just (IdeArtifact _ _ _ (Just modName) (Just (Left defPos))) -> do
+          debugLsp "Module position definition"
           fpMb <- selectExternPathFromModuleName modName
           forLsp fpMb \fp -> posRes fp defPos
         Just (IdeArtifact _ _ _ Nothing (Just (Left defPos))) -> do
+          debugLsp "Position definition"
           posRes filePath defPos
         _ -> do
           debugLsp "No relevant definition found for artifact"

From d56fe727ec8332f1d7e5bb4fe092117e554af1d9 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 25 Nov 2024 15:54:26 +0100
Subject: [PATCH 253/297] adds format in place

---
 .../PureScript/Lsp/Handlers/Format.hs         | 34 +++++++++++++------
 src/Language/PureScript/Lsp/ServerConfig.hs   | 25 ++++++++++++--
 2 files changed, 47 insertions(+), 12 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Format.hs b/src/Language/PureScript/Lsp/Handlers/Format.hs
index 045aec6002..006b8afa44 100644
--- a/src/Language/PureScript/Lsp/Handlers/Format.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Format.hs
@@ -4,24 +4,38 @@ import Control.Lens ((^.))
 import Language.LSP.Protocol.Lens qualified as LSP
 import Language.LSP.Protocol.Message qualified as Message
 import Language.LSP.Protocol.Types qualified as Types
+import Language.LSP.Server (getConfig)
 import Language.LSP.Server qualified as Server
 import Language.PureScript.Lsp.Imports (parseImportsFromFile, printImports)
-import Language.PureScript.Lsp.Log (warnLsp)
+import Language.PureScript.Lsp.Log (debugLsp, warnLsp)
 import Language.PureScript.Lsp.Monad (HandlerM)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
+import Language.PureScript.Lsp.ServerConfig (Formatter (..), ServerConfig (formatter))
 import Protolude
 import System.Process (readProcess)
+import Data.String qualified as S
 
 formatHandler :: Server.Handlers HandlerM
 formatHandler = Server.requestHandler Message.SMethod_TextDocumentFormatting $ \req res -> do
   let uri = req ^. LSP.params . LSP.textDocument . LSP.uri
       normalizedUri = Types.toNormalizedUri uri
-  parsedImportsRes <- parseImportsFromFile normalizedUri
-  contents <- case parsedImportsRes of
-    Left err -> do
-      warnLsp $ "Failed to parse imports from file: " <> err
-      lspReadFileText $ Types.toNormalizedUri uri
-    Right imoprts -> pure $ printImports imoprts
-
-  formatted <- liftIO $ readProcess "purs-tidy" ["format"] (toS contents)
-  res $ Right $ Types.InL [Types.TextEdit (Types.Range (Types.Position 0 0) (Types.Position 100000 0)) (toS formatted)]
\ No newline at end of file
+      filePath = Types.uriToFilePath uri
+  debugLsp $ "Formatting file: " <> show filePath
+  config <- getConfig
+  case (formatter config, filePath) of
+    (PursTidyFormatInPlace, Just fp) -> do
+      void $ liftIO $ readProcess "purs-tidy" ["format-in-place"] fp
+      res $ Right $ Types.InR Types.Null
+    (PursTidyFormatInPlace, Nothing) -> do
+      res $ Left $ Message.TResponseError (Types.InR Types.ErrorCodes_InternalError) "File path not found" Nothing
+    (PursTidy, _) -> do
+      parsedImportsRes <- parseImportsFromFile normalizedUri
+      contents <- case parsedImportsRes of
+        Left err -> do
+          warnLsp $ "Failed to parse imports from file: " <> err
+          lspReadFileText $ Types.toNormalizedUri uri
+        Right imports -> pure $ printImports imports
+      formatted <- liftIO $ readProcess "purs-tidy" ["format"] (toS contents)
+      let lines' = toEnum $ length $ S.lines formatted
+      res $ Right $ Types.InL [Types.TextEdit (Types.Range (Types.Position 0 0) (Types.Position (lines' + 1) 0)) (toS formatted)]
+    _ -> res $ Left $ Message.TResponseError (Types.InR Types.ErrorCodes_InvalidParams) "No formatter set" Nothing
diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index e6bab7f9f3..68f6c02861 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -2,11 +2,13 @@
 
 module Language.PureScript.Lsp.ServerConfig where
 
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson (FromJSON, ToJSON, fromJSON)
 import Language.LSP.Protocol.Types (TraceValue (..))
 import Language.LSP.Server (MonadLsp, getConfig, setConfig)
 import Language.PureScript.Lsp.LogLevel (LspLogLevel (..))
 import Protolude
+import Data.Aeson qualified as A
+import Data.Aeson.Types qualified as AT
 
 data ServerConfig = ServerConfig
   { outputPath :: FilePath,
@@ -14,6 +16,7 @@ data ServerConfig = ServerConfig
     inputSrcFromFile :: Maybe FilePath,
     logLevel :: LspLogLevel,
     traceValue :: Maybe TraceValue,
+    formatter :: Formatter,
     maxTypeLength :: Maybe Int,
     maxCompletions :: Maybe Int, 
     maxFilesInCache :: Maybe Int, 
@@ -31,6 +34,7 @@ defaultConfig outputPath =
       inputSrcFromFile = Nothing,
       logLevel = LogAll,
       traceValue = Nothing,
+      formatter = PursTidy,
       maxTypeLength = Just defaultMaxTypeLength,
       maxCompletions = Just defaultMaxCompletions, 
       maxFilesInCache = Just defaultMaxFilesInCache,
@@ -67,4 +71,21 @@ getMaxFilesInCache =
 
 
 getInferExpressions :: (MonadLsp ServerConfig m) => m Bool
-getInferExpressions = inferExpressions <$> getConfig  
\ No newline at end of file
+getInferExpressions = inferExpressions <$> getConfig  
+
+
+data Formatter = NoFormatter | PursTidy | PursTidyFormatInPlace
+  deriving (Show, Eq)
+
+instance FromJSON Formatter where 
+  parseJSON v = case v of
+    A.String "none" -> pure NoFormatter
+    A.String "purs-tidy" -> pure PursTidy
+    A.String "purs-tidy-format-in-place" -> pure PursTidyFormatInPlace
+    _ -> AT.typeMismatch "String" v
+
+instance ToJSON Formatter where
+  toJSON = \case
+    NoFormatter -> A.String "none"
+    PursTidy -> A.String "purs-tidy"
+    PursTidyFormatInPlace -> A.String "purs-tidy-format-in-place"
\ No newline at end of file

From f624114e057a510252052b42a22e3871d30945d5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 25 Nov 2024 15:59:27 +0100
Subject: [PATCH 254/297] remove unused import

---
 src/Language/PureScript/Lsp/ServerConfig.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs
index 68f6c02861..cfcf85aaf8 100644
--- a/src/Language/PureScript/Lsp/ServerConfig.hs
+++ b/src/Language/PureScript/Lsp/ServerConfig.hs
@@ -2,7 +2,7 @@
 
 module Language.PureScript.Lsp.ServerConfig where
 
-import Data.Aeson (FromJSON, ToJSON, fromJSON)
+import Data.Aeson (FromJSON, ToJSON)
 import Language.LSP.Protocol.Types (TraceValue (..))
 import Language.LSP.Server (MonadLsp, getConfig, setConfig)
 import Language.PureScript.Lsp.LogLevel (LspLogLevel (..))

From 29b54d249f644058ef55d41c8e522e57f32b1a88 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 25 Nov 2024 18:15:22 +0100
Subject: [PATCH 255/297] use longer of ranges

---
 src/Language/PureScript/Lsp/Handlers/Format.hs | 2 +-
 src/Language/PureScript/Make/Actions.hs        | 5 +++++
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Format.hs b/src/Language/PureScript/Lsp/Handlers/Format.hs
index 006b8afa44..0a5b86c9ba 100644
--- a/src/Language/PureScript/Lsp/Handlers/Format.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Format.hs
@@ -36,6 +36,6 @@ formatHandler = Server.requestHandler Message.SMethod_TextDocumentFormatting $ \
           lspReadFileText $ Types.toNormalizedUri uri
         Right imports -> pure $ printImports imports
       formatted <- liftIO $ readProcess "purs-tidy" ["format"] (toS contents)
-      let lines' = toEnum $ length $ S.lines formatted
+      let lines' = toEnum $ max (length $ S.lines formatted) (length $ lines contents)
       res $ Right $ Types.InL [Types.TextEdit (Types.Range (Types.Position 0 0) (Types.Position (lines' + 1) 0)) (toS formatted)]
     _ -> res $ Left $ Message.TResponseError (Types.InR Types.ErrorCodes_InvalidParams) "No formatter set" Nothing
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index c2914d21fa..5e53f84228 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -114,6 +114,8 @@ data MakeActions m = MakeActions
     -- | Read the externs file for a module as a string and also return the actual
     -- path for the file.
     readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile),
+    -- | Run actions using the final CheckState
+    -- checkState :: CheckState -> m (),
     -- | Run the code generator for the module and write any required output files.
     codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m (),
     -- | Check ffi and print it in the output directory.
@@ -247,6 +249,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
       codegenTargets <- asks optionsCodegenTargets
       when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module {..} ->
         writeJSONFile (outputFilename modName "docs.json") docsMod
+    
+    -- checkState :: CheckState -> Make ()
+    -- checkState _ = return ()
 
     codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
     codegen _prevEnv _endEnv _m m docs exts = do

From db07957389877589605782156d5c208aa604565a Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 25 Nov 2024 19:17:29 +0100
Subject: [PATCH 256/297] fix format in place

---
 src/Language/PureScript/Lsp/Handlers/Format.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Handlers/Format.hs b/src/Language/PureScript/Lsp/Handlers/Format.hs
index 0a5b86c9ba..b57aeba5ce 100644
--- a/src/Language/PureScript/Lsp/Handlers/Format.hs
+++ b/src/Language/PureScript/Lsp/Handlers/Format.hs
@@ -24,7 +24,7 @@ formatHandler = Server.requestHandler Message.SMethod_TextDocumentFormatting $ \
   config <- getConfig
   case (formatter config, filePath) of
     (PursTidyFormatInPlace, Just fp) -> do
-      void $ liftIO $ readProcess "purs-tidy" ["format-in-place"] fp
+      void $ liftIO $ readProcess "purs-tidy" ["format-in-place", fp] []
       res $ Right $ Types.InR Types.Null
     (PursTidyFormatInPlace, Nothing) -> do
       res $ Left $ Message.TResponseError (Types.InR Types.ErrorCodes_InternalError) "File path not found" Nothing
@@ -33,7 +33,7 @@ formatHandler = Server.requestHandler Message.SMethod_TextDocumentFormatting $ \
       contents <- case parsedImportsRes of
         Left err -> do
           warnLsp $ "Failed to parse imports from file: " <> err
-          lspReadFileText $ Types.toNormalizedUri uri
+          lspReadFileText normalizedUri
         Right imports -> pure $ printImports imports
       formatted <- liftIO $ readProcess "purs-tidy" ["format"] (toS contents)
       let lines' = toEnum $ max (length $ S.lines formatted) (length $ lines contents)

From a26dfe08374f42168e69f51da3124e07070260af Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 28 Nov 2024 18:01:21 +0100
Subject: [PATCH 257/297] adds partial artifacts

---
 src/Language/PureScript/Lsp/Rebuild.hs        | 13 ++---
 src/Language/PureScript/Lsp/State.hs          | 13 ++++-
 src/Language/PureScript/Make.hs               | 29 +++++++-----
 src/Language/PureScript/Make/Actions.hs       | 26 +++++++---
 src/Language/PureScript/TypeChecker.hs        |  2 -
 .../PureScript/TypeChecker/IdeArtifacts.hs    | 47 ++++++++++++-------
 src/Language/PureScript/TypeChecker/Monad.hs  |  5 +-
 7 files changed, 88 insertions(+), 47 deletions(-)

diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 60627e1930..58e7962482 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -22,7 +22,7 @@ import Language.PureScript.Lsp.Cache (selectDependencies, selectDependencyHashFr
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternsToExportEnv, cacheEnvironment, cacheRebuild', cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, updateCachedRebuildResult)
+import Language.PureScript.Lsp.State (addExternsToExportEnv, cacheEnvironment, cacheRebuild', cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, updateCachedRebuildResult, mergePartialArtifacts)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState)
 import Language.PureScript.Lsp.Types qualified as Types
 import Language.PureScript.Make qualified as P
@@ -72,7 +72,7 @@ rebuildFile uri = do
                 mkMakeActions foreigns =
                   P.buildMakeActions outputDirectory filePathMap foreigns False
                     & addAllIndexing conn
-                    & addRebuildCaching stVar maxCache input depHash
+                    & addRebuildCaching moduleName stVar maxCache input depHash
             when (null externDeps) do
               warnLsp $ "No dependencies found for module: " <> show moduleName
               checkExternsExist
@@ -82,7 +82,7 @@ rebuildFile uri = do
             ideCheckState <- getIdeCheckState
             (res, warnings) <- logPerfStandard "Rebuilt Module" $ liftIO $ do
               P.runMake (P.defaultOptions {P.optionsCodegenTargets = codegenTargets}) do
-                newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState Nothing (mkMakeActions foreigns) exportEnv env externs m Nothing
+                newExtern <- P.rebuildModuleWithProvidedEnv ideCheckState (mkMakeActions foreigns) exportEnv env externs m Nothing
                 updateCacheDb codegenTargets outputDirectory fp Nothing moduleName
                 pure newExtern
 
@@ -149,10 +149,11 @@ data RebuildException
 codegenTargets :: Set P.CodegenTarget
 codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
-addRebuildCaching :: TVar LspState -> Int -> Text -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make
-addRebuildCaching stVar maxCache src depHash ma =
+addRebuildCaching :: P.ModuleName  -> TVar LspState -> Int -> Text -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make
+addRebuildCaching modName stVar maxCache src depHash ma =
   ma
-    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (liftIO $ cacheRebuild' stVar maxCache src ext (P.checkIdeArtifacts checkSt) astM depHash) <* P.codegen ma prevEnv checkSt astM m docs ext
+    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (P.makeIO "Cache rebuild" $ cacheRebuild' stVar maxCache src ext (P.checkIdeArtifacts checkSt) astM depHash) <* P.codegen ma prevEnv checkSt astM m docs ext
+    , P.withCheckStateOnError = \checkSt -> P.makeIO "replace artifacts" $ mergePartialArtifacts stVar (P.checkIdeArtifacts checkSt) modName
     }
 
 getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs
index d129aa507f..4584a697eb 100644
--- a/src/Language/PureScript/Lsp/State.hs
+++ b/src/Language/PureScript/Lsp/State.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Lsp.State
     getDbConn,
     cacheRebuild,
     cacheRebuild',
+    mergePartialArtifacts,
     updateCachedModule,
     updateCachedModule',
     cachedRebuild,
@@ -50,7 +51,8 @@ import Language.PureScript.Lsp.Types
 import Language.PureScript.Sugar.Names (externsEnv)
 import Language.PureScript.Sugar.Names.Env qualified as P
 import Protolude hiding (moduleName, unzip)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, handlePartialArtifacts)
+import Language.PureScript.Names qualified as P
 
 getDbConn :: (MonadReader LspEnvironment m, MonadIO m) => m Connection
 getDbConn = liftIO . fmap snd . readTVarIO . lspDbConnectionVar =<< ask
@@ -73,6 +75,15 @@ cacheRebuild' st maxFiles src ef artifacts module' depHash = atomically . modify
   where
     fp = P.spanName $ efSourceSpan ef
 
+mergePartialArtifacts :: TVar LspState -> IdeArtifacts -> P.ModuleName -> IO ()
+mergePartialArtifacts st artifacts moduleName  = atomically . modifyTVar st $ \x ->
+  x
+    { openFiles = openFiles x <&> \(fp, ofile) ->
+      if ofModuleName ofile == moduleName
+        then (fp, ofile {ofArtifacts = handlePartialArtifacts (ofArtifacts ofile) artifacts})
+        else (fp, ofile)
+    }
+
 updateCachedModule :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m ()
 updateCachedModule module' = do
   st <- lspStateVar <$> ask
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index eb87275f62..ac8f7ce3b8 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,6 +1,5 @@
 module Language.PureScript.Make
   ( -- * Make API
-    desugarAndTypeCheck,
     rebuildModule,
     rebuildModule',
     rebuildModuleWithProvidedEnv,
@@ -18,6 +17,7 @@ import Control.Monad (foldM, unless, when, (<=<))
 import Control.Monad.Base (MonadBase (liftBase))
 import Control.Monad.Error.Class (MonadError (..))
 import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.State (get)
 import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
 import Control.Monad.Trans.Control (MonadBaseControl (..))
 import Control.Monad.Trans.State (runStateT)
@@ -91,13 +91,12 @@ rebuildModuleWithIndex ::
   m ExternsFile
 rebuildModuleWithIndex act exEnv externs m moduleIndex = do
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
-  rebuildModuleWithProvidedEnv emptyCheckState Nothing act exEnv env externs m moduleIndex
+  rebuildModuleWithProvidedEnv emptyCheckState act exEnv env externs m moduleIndex
 
 rebuildModuleWithProvidedEnv ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
   (Environment -> CheckState) ->
-  Maybe (Module -> m ()) ->
   MakeActions m ->
   Env ->
   Environment ->
@@ -105,11 +104,12 @@ rebuildModuleWithProvidedEnv ::
   Module ->
   Maybe (Int, Int) ->
   m ExternsFile
-rebuildModuleWithProvidedEnv initialCheckState onDesugared MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do
+rebuildModuleWithProvidedEnv initialCheckState MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
-  ((Module ss coms _ elaborated exps, checkSt), nextVar) <- desugarAndTypeCheck initialCheckState onDesugared moduleName externs withPrim exEnv env
+  ((Module ss coms _ elaborated exps, checkSt), nextVar) <-
+    desugarAndTypeCheck initialCheckState withCheckStateOnError withCheckState moduleName externs withPrim exEnv env
   let env' = P.checkEnv checkSt
 
   -- desugar case declarations *after* type- and exhaustiveness checking
@@ -120,7 +120,7 @@ rebuildModuleWithProvidedEnv initialCheckState onDesugared MakeActions {..} exEn
 
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
-  
+
       corefn = CF.moduleToCoreFn env' mod'
       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
@@ -146,20 +146,22 @@ rebuildModuleWithProvidedEnv initialCheckState onDesugared MakeActions {..} exEn
   return exts
 
 desugarAndTypeCheck ::
-  (MonadError MultipleErrors m, MonadWriter MultipleErrors m, Foldable t) =>
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
   (Environment -> CheckState) ->
-  t (Module -> m b) ->
+  (CheckState -> m ()) ->
+  (CheckState -> m ()) ->
   ModuleName ->
   [ExternsFile] ->
   Module ->
   Env ->
   Environment ->
   m ((Module, CheckState), Integer)
-desugarAndTypeCheck initialCheckState onDesugared moduleName externs withPrim exEnv env = runSupplyT 0 $ do
+desugarAndTypeCheck initialCheckState withCheckStateOnError withCheckState moduleName externs withPrim exEnv env = runSupplyT 0 $ do
   (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
-  for_ onDesugared $ lift . \f -> f desugared
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-  (checked, checkSt@(CheckState {..})) <- runStateT (typeCheckModule modulesExports desugared) $ initialCheckState env
+  (checked, checkSt@(CheckState {..})) <- runStateT (catchError (typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
+  lift $ withCheckState checkSt
   let usedImports' =
         foldl'
           ( flip $ \(fromModuleName, newtypeCtorName) ->
@@ -172,6 +174,11 @@ desugarAndTypeCheck initialCheckState onDesugared moduleName externs withPrim ex
   -- constraints in order to not report them as unused.
   censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
   return (checked, checkSt)
+  where
+    mergeCheckState errs = do
+      checkSt <- get
+      lift $ lift $ withCheckStateOnError checkSt
+      throwError errs
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
 --
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 5e53f84228..38dd0546e6 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -51,6 +51,7 @@ import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestam
 import Language.PureScript.Names (Ident (..), ModuleName, runModuleName)
 import Language.PureScript.Options (CodegenTarget (..), Options (..))
 import Language.PureScript.Pretty.Common (SMap (..))
+import Language.PureScript.TypeChecker (CheckState)
 import Paths_purescript qualified as Paths
 import SourceMap (generate)
 import SourceMap.Types (Mapping (..), Pos (..), SourceMapping (..))
@@ -59,7 +60,6 @@ import System.FilePath (makeRelative, normalise, splitDirectories, splitPath, (<
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr)
 import Prelude
-import Language.PureScript.TypeChecker (CheckState)
 
 -- | Determines when to rebuild a module
 data RebuildPolicy
@@ -114,8 +114,10 @@ data MakeActions m = MakeActions
     -- | Read the externs file for a module as a string and also return the actual
     -- path for the file.
     readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile),
+    -- | Run actions using the final CheckState when type checking fails
+    withCheckStateOnError :: CheckState -> m (),
     -- | Run actions using the final CheckState
-    -- checkState :: CheckState -> m (),
+    withCheckState :: CheckState -> m (),
     -- | Run the code generator for the module and write any required output files.
     codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m (),
     -- | Check ffi and print it in the output directory.
@@ -180,7 +182,19 @@ buildMakeActions ::
   Bool ->
   MakeActions Make
 buildMakeActions outputDir filePathMap foreigns usePrefix =
-  MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb writePackageJson outputPrimDocs
+  MakeActions
+    getInputTimestampsAndHashes
+    getOutputTimestamp
+    readExterns
+    withCheckState
+    withCheckState
+    codegen
+    ffiCodegen
+    progress
+    readCacheDb
+    writeCacheDb
+    writePackageJson
+    outputPrimDocs
   where
     getInputTimestampsAndHashes ::
       ModuleName ->
@@ -249,9 +263,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
       codegenTargets <- asks optionsCodegenTargets
       when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module {..} ->
         writeJSONFile (outputFilename modName "docs.json") docsMod
-    
-    -- checkState :: CheckState -> Make ()
-    -- checkState _ = return ()
+
+    withCheckState :: CheckState -> Make ()
+    withCheckState _ = return ()
 
     codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
     codegen _prevEnv _endEnv _m m docs exts = do
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index fc6e027d09..2bdce5b599 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -343,7 +343,6 @@ typeCheckAll moduleName = traverse go
           addValue moduleName name ty nameKind
           addIdeDecl d ty
           addIdeIdent ss name ty
-          endIdeSubstitutions
           return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
         _ -> internalError "typesOf did not return a singleton"
   go ValueDeclaration{} = internalError "Binders were not desugared"
@@ -363,7 +362,6 @@ typeCheckAll moduleName = traverse go
         addValue moduleName name ty nameKind
         addIdeIdent ss name ty
         return (sai, nameKind, val)
-      endIdeSubstitutions
       return . BindingGroupDeclaration $ NEL.fromList vals''
   go d@(ExternDataDeclaration (ss, _) name kind) = do
     warnAndRethrow (addHint (ErrorInForeignImportData name) . addHint (positionedError ss)) $ do
diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
index dced963d30..affe066472 100644
--- a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
+++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+
 -- | Stores information about the source code that is useful for the IDE
 -- | This includes value types and source spans
 module Language.PureScript.TypeChecker.IdeArtifacts
@@ -25,9 +26,9 @@ module Language.PureScript.TypeChecker.IdeArtifacts
     moduleNameFromQual,
     debugIdeArtifact,
     substituteArtifactTypes,
-    endSubstitutions,
     artifactInterest,
     bindersAtPos,
+    handlePartialArtifacts,
   )
 where
 
@@ -50,14 +51,29 @@ import Safe (minimumByMay)
 data IdeArtifacts
   = IdeArtifacts
       (Map Line (Set IdeArtifact)) -- with type var substitutions
-      (Map Line (Set IdeArtifact)) -- without var substitutions
       (Map (P.Type ()) (P.Type ())) -- type synonym substitutions
   deriving (Show, Generic, NFData)
 
 type Line = Int
 
 emptyIdeArtifacts :: IdeArtifacts
-emptyIdeArtifacts = IdeArtifacts Map.empty Map.empty Map.empty
+emptyIdeArtifacts = IdeArtifacts Map.empty Map.empty
+
+handlePartialArtifacts :: IdeArtifacts -> IdeArtifacts -> IdeArtifacts
+handlePartialArtifacts (IdeArtifacts existing sy) (IdeArtifacts partial syPartial) =
+  IdeArtifacts newArtifacts (Map.union syPartial sy)
+  where
+    newArtifacts = Map.unionWith Set.union partial (Map.filterWithKey (\k _ -> not (k `Set.member` linesUsed)) existing)
+
+    linesUsed :: Set Line
+    linesUsed =
+      partial
+        & Map.toList
+          >>= (\(_, as) -> getArtifactLines <$> Set.toList as)
+        & Set.unions
+
+getArtifactLines :: IdeArtifact -> Set Line
+getArtifactLines ia = Set.fromList [P.sourcePosLine $ P.spanStart $ iaSpan ia .. P.sourcePosLine $ P.spanEnd $ iaSpan ia]
 
 debugIdeArtifacts :: IdeArtifacts -> Text
 debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts
@@ -65,7 +81,7 @@ debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts
     showCount :: (Int, Int) -> Text
     showCount (line, count) = show line <> ": " <> show count
     lineCounts :: IdeArtifacts -> [(Int, Int)]
-    lineCounts (IdeArtifacts m _ _) = Map.toList m <&> fmap length
+    lineCounts (IdeArtifacts m _) = Map.toList m <&> fmap length
 
 data IdeArtifact = IdeArtifact
   { iaSpan :: P.SourceSpan,
@@ -89,19 +105,16 @@ data IdeArtifactValue
   deriving (Show, Ord, Eq, Generic, NFData)
 
 substituteArtifactTypes :: (P.SourceType -> P.SourceType) -> IdeArtifacts -> IdeArtifacts
-substituteArtifactTypes f (IdeArtifacts m u s) = IdeArtifacts m (Map.map (Set.map (onArtifactType f)) u) s
+substituteArtifactTypes f (IdeArtifacts m s) = IdeArtifacts (Map.map (Set.map (onArtifactType f)) m) s
 
 onArtifactType :: (P.SourceType -> P.SourceType) -> IdeArtifact -> IdeArtifact
 onArtifactType f (IdeArtifact {..}) = IdeArtifact iaSpan iaValue (f iaType) iaDefinitionModule iaDefinitionPos
 
-endSubstitutions :: IdeArtifacts -> IdeArtifacts
-endSubstitutions (IdeArtifacts m u s) = IdeArtifacts (Map.unionWith (<>) m u) Map.empty s
-
 smallestArtifact :: (Ord a) => (IdeArtifact -> a) -> [IdeArtifact] -> Maybe IdeArtifact
 smallestArtifact tieBreaker = minimumByMay (compare `on` (\a -> (artifactSize a, tieBreaker a)))
 
-bindersAtPos :: P.SourcePos -> IdeArtifacts -> [(IdeArtifact,  P.Binder)]
-bindersAtPos pos (IdeArtifacts m _ _) =
+bindersAtPos :: P.SourcePos -> IdeArtifacts -> [(IdeArtifact, P.Binder)]
+bindersAtPos pos (IdeArtifacts m _) =
   Map.lookup (P.sourcePosLine pos) m
     & maybe [] Set.toList
     & filter (\ia -> P.sourcePosColumn (P.spanStart (iaSpan ia)) <= posCol && P.sourcePosColumn (P.spanEnd (iaSpan ia)) >= posCol)
@@ -122,7 +135,7 @@ artifactInterest (IdeArtifact {..}) = case iaValue of
   _ -> 1
 
 artifactsAtSpan :: P.SourceSpan -> IdeArtifacts -> Set IdeArtifact
-artifactsAtSpan span (IdeArtifacts m _ _) =
+artifactsAtSpan span (IdeArtifacts m _) =
   Map.lookup (P.sourcePosLine $ P.spanStart span) m
     & maybe Set.empty (Set.filter ((==) span . iaSpan))
 
@@ -133,7 +146,7 @@ artifactSize (IdeArtifact {..}) =
   )
 
 getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact]
-getArtifactsAtPosition pos (IdeArtifacts m _ _) =
+getArtifactsAtPosition pos (IdeArtifacts m _) =
   Map.lookup (P.sourcePosLine pos) m
     & maybe [] Set.toList
     & filter (srcPosInSpan pos . iaSpan)
@@ -253,10 +266,10 @@ moduleNameFromQual (P.Qualified (P.ByModuleName mn) _) = Just mn
 moduleNameFromQual _ = Nothing
 
 insertAtLines :: P.SourceSpan -> IdeArtifactValue -> P.SourceType -> Maybe P.ModuleName -> Maybe (Either P.SourcePos P.SourceSpan) -> IdeArtifacts -> IdeArtifacts
-insertAtLines span@(P.SourceSpan _ start _) value ty mName defSpan ia@(IdeArtifacts m u s) =
+insertAtLines span@(P.SourceSpan _ start _) value ty mName defSpan ia@(IdeArtifacts m s) =
   if start == P.SourcePos 0 0 || start == P.SourcePos 1 1 -- ignore internal module spans
     then ia
-    else IdeArtifacts m (foldr insert u (linesFromSpan span)) s
+    else IdeArtifacts (foldr insert m (linesFromSpan span)) s
   where
     insert line = Map.insertWith Set.union line (Set.singleton $ IdeArtifact span value ty mName defSpan)
 
@@ -291,10 +304,10 @@ generatedIdent = \case
   _ -> False
 
 insertTypeSynonym :: P.Type a -> P.Type a -> IdeArtifacts -> IdeArtifacts
-insertTypeSynonym syn ty (IdeArtifacts m u s) = IdeArtifacts m u (Map.insert (void syn) (void ty) s)
+insertTypeSynonym syn ty (IdeArtifacts m s) = IdeArtifacts m (Map.insert (void syn) (void ty) s)
 
 useSynonymns :: forall a. IdeArtifacts -> P.Type a -> P.Type ()
-useSynonymns (IdeArtifacts _ _ s) ty = P.everywhereOnTypes go (void ty)
+useSynonymns (IdeArtifacts _ s) ty = P.everywhereOnTypes go (void ty)
   where
     go :: P.Type () -> P.Type ()
     go t =
@@ -302,7 +315,7 @@ useSynonymns (IdeArtifacts _ _ s) ty = P.everywhereOnTypes go (void ty)
         & maybe t go
 
 debugSynonyms :: IdeArtifacts -> Text
-debugSynonyms (IdeArtifacts _ _ s) =
+debugSynonyms (IdeArtifacts _ s) =
   show $
     Map.toList s
       <&> bimap
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 42a3b1353c..6c8674a9b3 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -28,7 +28,7 @@ import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
-import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, endSubstitutions, insertTypeSynonym, insertModule, insertImport)
+import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, insertTypeSynonym, insertModule, insertImport)
 import Protolude (whenM, isJust)
 import Language.PureScript.AST.Binders (Binder)
 import Language.PureScript.AST.Declarations (Declaration, Expr (..))
@@ -439,9 +439,6 @@ onIdeArtifacts f = whenAddingIdeArtifacts
 substituteIdeTypes :: MonadState CheckState m => (SourceType -> SourceType) -> m ()
 substituteIdeTypes = onIdeArtifacts . substituteArtifactTypes
 
-endIdeSubstitutions :: MonadState CheckState m => m ()
-endIdeSubstitutions = onIdeArtifacts endSubstitutions
-
 addIdeSynonym :: MonadState CheckState m => SourceType -> SourceType -> m ()
 addIdeSynonym ty syn = onIdeArtifacts $ insertTypeSynonym syn ty
 

From e08c60547e0017eff102d0bffd2caeb39e60ed0d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 29 Nov 2024 17:11:23 +0100
Subject: [PATCH 258/297] adds env tables and sql functions

---
 src/Language/PureScript/Environment.hs       |  35 +++++
 src/Language/PureScript/Make/Index.hs        | 130 ++++++++++++++++++-
 src/Language/PureScript/Names.hs             |  14 +-
 src/Language/PureScript/Sugar/TypeClasses.hs |   1 +
 src/Language/PureScript/Types.hs             |  10 +-
 5 files changed, 185 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 560055d334..66c05dc5c6 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -29,6 +29,9 @@ import Language.PureScript.TypeClassDictionaries (NamedDict)
 import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables)
 import Language.PureScript.Constants.Prim qualified as C
 import Codec.Serialise qualified as S
+import Database.SQLite.Simple.ToField (ToField (toField))
+import Database.SQLite.Simple.FromField (FromField (fromField))
+import Database.SQLite.Simple (ToRow (toRow))
 
 -- | The @Environment@ defines all values and types which are currently in scope:
 data Environment = Environment
@@ -78,6 +81,15 @@ data TypeClassData = TypeClassData
 
 instance NFData TypeClassData
 
+instance ToField TypeClassData where
+  toField = toField . S.serialise
+
+instance FromField TypeClassData where
+  fromField = fmap S.deserialise . fromField
+
+-- instance ToRow TypeClassData where 
+--     toRow = _
+
 -- | A functional dependency indicates a relationship between two sets of
 -- type arguments in a class declaration.
 data FunctionalDependency = FunctionalDependency
@@ -241,6 +253,12 @@ data NameVisibility
 instance NFData NameVisibility
 instance Serialise NameVisibility
 
+instance ToField NameVisibility where
+  toField = toField . S.serialise
+
+instance FromField NameVisibility where
+  fromField = fmap S.deserialise . fromField
+
 -- | A flag for whether a name is for an private or public value - only public values will be
 -- included in a generated externs file.
 data NameKind
@@ -256,6 +274,12 @@ data NameKind
 instance NFData NameKind
 instance Serialise NameKind
 
+instance ToField NameKind where
+  toField = toField . S.serialise
+
+instance FromField NameKind where
+  fromField = fmap S.deserialise . fromField
+
 -- | The kinds of a type
 data TypeKind
   = DataType DataDeclType [(Text, Maybe SourceType, Role)] [(ProperName 'ConstructorName, [SourceType])]
@@ -273,6 +297,12 @@ data TypeKind
 instance NFData TypeKind
 instance Serialise TypeKind
 
+instance ToField TypeKind where
+  toField = toField . S.serialise
+
+instance FromField TypeKind where
+  fromField = fmap S.deserialise . fromField
+
 -- | The type ('data' or 'newtype') of a data type declaration
 data DataDeclType
   = Data
@@ -283,6 +313,11 @@ data DataDeclType
 
 instance NFData DataDeclType
 instance Serialise DataDeclType
+instance ToField DataDeclType where
+  toField = toField . S.serialise
+
+instance FromField DataDeclType where
+  fromField = fmap S.deserialise . fromField
 
 showDataDeclType :: DataDeclType -> Text
 showDataDeclType Data = "data"
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 938adb7657..a00e1a0d6e 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Language.PureScript.Make.Index
   ( initDb,
@@ -10,17 +11,22 @@ module Language.PureScript.Make.Index
     dropTables,
     indexExtern,
     getExportedNames,
+    selectEnvValue,
+    insertEnvValue,
   )
 where
 
-import Codec.Serialise (serialise)
+import Codec.Serialise (deserialise, serialise)
+import Control.Arrow ((>>>))
 import Data.List (partition)
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Database.SQLite.Simple (Connection, NamedParam ((:=)))
+import Database.SQLite.Simple (Connection, NamedParam ((:=)), type (:.) (..))
 import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
 import Language.LSP.Server (MonadLsp)
+-- import Database.SQLite.Simple.Types ((:.))
+import Language.PureScript (internalCompilerError)
 import Language.PureScript qualified as P
 import Language.PureScript.Environment (Environment)
 import Language.PureScript.Externs (ExternsFile (efModuleName))
@@ -297,7 +303,7 @@ initDb conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS export_environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
-
+  initEnvTables conn
   addDbIndexes conn
 
 addDbIndexes :: Connection -> IO ()
@@ -321,3 +327,121 @@ dropTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS ast_modules"
   SQL.execute_ conn "DROP TABLE IF EXISTS externs"
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
+
+
+-- indexEnv :: Connection -> P.Environment -> IO ()
+-- indexEnv conn env = 
+
+type DbQualifer a = (Maybe P.ModuleName, Maybe Int, Maybe Int, a)
+
+toDbQualifer :: P.Qualified a -> DbQualifer a
+toDbQualifer (P.Qualified (P.BySourcePos pos) a) = (Nothing, Just (P.sourcePosLine pos), Just (P.sourcePosColumn pos), a)
+toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (Just mn, Nothing, Nothing, a)
+
+type EnvValue = (P.SourceType, P.NameKind, P.NameVisibility)
+
+insertEnvValue :: Connection -> P.Qualified P.Ident -> EnvValue -> IO ()
+insertEnvValue conn ident val =
+  SQL.execute
+    conn
+    "INSERT OR REPLACE INTO env_values (module_name, line, column, ident, source_type, name_kind, name_visibility) VALUES (?, ?, ?, ?, ?, ?, ?)"
+    (toDbQualifer ident :. val)
+
+selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
+selectEnvValue conn ident =
+  SQL.query
+    conn
+    "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name IS ? AND line IS ? AND column is ? AND ident = ?"
+    (toDbQualifer ident)
+    <&> head
+
+type EnvType = (P.SourceType, P.TypeKind)
+
+insertType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> EnvType -> IO ()
+insertType conn ident val =
+  SQL.execute
+    conn
+    "INSERT OR REPLACE INTO env_types (module_name, line, column, type_name, source_type, type_kind) VALUES (?, ?, ?, ?, ?, ?)"
+    (toDbQualifer ident :. val)
+
+selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe EnvType)
+selectType conn ident =
+  SQL.query
+    conn
+    "SELECT source_type, type_kind FROM env_types WHERE module_name IS ? AND line IS ? AND column is ? AND type_name = ?"
+    (toDbQualifer ident)
+    <&> head
+
+insertDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) -> IO ()
+insertDataConstructor conn ident (ddt, ty, st, idents) =
+  SQL.execute
+    conn
+    "INSERT OR REPLACE INTO env_data_constructors (constructor_name, data_decl_type, type_name, source_type, idents) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)"
+    (toDbQualifer ident :. (ddt, ty, st, serialise idents))
+
+selectDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> IO (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
+selectDataConstructor conn ident =
+  SQL.query
+    conn
+    "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name IS ? AND line IS ? AND column is ? AND constructor_name = ?"
+    (toDbQualifer ident)
+    <&> (head >>> fmap deserialiseIdents)
+  where
+    deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
+
+insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(Text, Maybe P.SourceType)], P.SourceType) -> IO ()
+insertTypeSynonym conn ident (idents, st) =
+  SQL.execute
+    conn
+    "INSERT OR REPLACE INTO env_type_synonyms (module_name, line, column, type_name, idents, source_type) VALUES (?, ?, ?, ?, ?)"
+    (toDbQualifer ident :. (serialise idents, st))
+
+selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
+selectTypeSynonym conn ident =
+  SQL.query
+    conn
+    "SELECT idents, source_type FROM env_type_synonyms WHERE module_name IS ? AND line IS ? AND column is ? AND type_name = ?"
+    (toDbQualifer ident)
+    <&> (head >>> fmap deserialiseIdents)
+    where
+      deserialiseIdents (idents, st) = (deserialise idents, st)
+
+insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
+insertTypeClass conn ident tcd =
+  SQL.execute
+    conn
+    "INSERT OR REPLACE INTO env_type_classes (module_name, line, column, class_name, class) VALUES (?, ?, ?, ?, ?)"
+    (toDbQualifer ident :. SQL.Only tcd)
+
+selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
+selectTypeClass conn ident =
+  SQL.query
+    conn
+    "SELECT class FROM env_type_classes WHERE module_name IS ? AND line IS ? AND column is ? AND class_name = ?"
+    (toDbQualifer ident)
+    <&> (fmap SQL.fromOnly . head)
+
+initEnvTables :: Connection -> IO ()
+initEnvTables conn = do
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, line INT, column INT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, line INT, column INT, type_name TEXT PRIMARY KEY, source_type BLOB, type_kind TEXT, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, line INT, column INT, constructor_name TEXT PRIMARY KEY, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, line INT, column INT, type_name TEXT PRIMARY KEY, idents BLOB, source_type BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, line INT, column INT, class_name TEXT PRIMARY KEY, class BLOB, debug TEXT)"
+
+addEnvIndexes :: Connection -> IO ()
+addEnvIndexes conn = do 
+  SQL.execute_ conn "CREATE UNIQUE INDEX env_values_idx ON env_values(module_name, line, column, ident)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX env_types_idx ON env_types(module_name, line, column, type_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX env_data_constructors_idx ON env_data_constructors(module_name, line, column, constructor_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX env_type_synonyms_idx ON env_type_synonyms(module_name, line, column, type_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX env_type_classes_idx ON env_type_classes(module_name, line, column, class_name)"
+
+
+dropEnvTables :: Connection -> IO ()
+dropEnvTables conn = do
+  SQL.execute_ conn "DROP TABLE IF EXISTS env_values"
+  SQL.execute_ conn "DROP TABLE IF EXISTS env_types"
+  SQL.execute_ conn "DROP TABLE IF EXISTS env_data_constructors"
+  SQL.execute_ conn "DROP TABLE IF EXISTS env_type_synonyms"
+  SQL.execute_ conn "DROP TABLE IF EXISTS env_type_classes"
\ No newline at end of file
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 7d3b289877..39e011bde0 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -23,6 +23,8 @@ import Data.Text qualified as T
 
 import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
 import Data.Aeson qualified as A
+import Database.SQLite.Simple.ToField (ToField (toField))
+import Database.SQLite.Simple.FromField (FromField (fromField), ResultError (ConversionFailed), returnError)
 
 -- | A sum of the possible name types, useful for error and lint messages.
 data Name
@@ -159,6 +161,7 @@ coerceOpName = OpName . runOpName
 --
 newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
   deriving (Show, Eq, Ord, Generic)
+  deriving newtype (ToField, FromField)
 
 instance NFData (ProperName a)
 instance Serialise (ProperName a)
@@ -169,6 +172,8 @@ instance ToJSON (ProperName a) where
 instance FromJSON (ProperName a) where
   parseJSON = fmap ProperName . parseJSON
 
+  
+
 -- |
 -- The closed set of proper name types.
 --
@@ -192,7 +197,7 @@ coerceProperName = ProperName . runProperName
 --
 newtype ModuleName = ModuleName Text
   deriving (Show, Eq, Ord, Generic)
-  deriving newtype Serialise
+  deriving newtype (Serialise, ToField, FromField)
 
 instance NFData ModuleName
 
@@ -323,3 +328,10 @@ instance FromJSONKey ModuleName where
 
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData)
 $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
+
+instance ToField Ident where 
+  toField = toField . A.encode
+
+
+instance FromField Ident where
+  fromField  f = (either (returnError ConversionFailed f) pure . A.eitherDecode) =<< fromField f
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index cf39dfd173..b0b29985c2 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -82,6 +82,7 @@ desugarTypeClassesUsingMemberMap classes = flip evalStateT initialState . desuga
       ]
 
 
+-- TODO add desugarModuleSqlite which uses the DB instead of MemberMap to store the type class data
 
 desugarModule
   :: (MonadSupply m, MonadError MultipleErrors m)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index ef00e21a07..0791fe7e64 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -6,7 +6,7 @@ module Language.PureScript.Types where
 import Prelude
 import Protolude (ordNub, fromMaybe)
 
-import Codec.Serialise (Serialise)
+import Codec.Serialise (Serialise, serialise, deserialise)
 import Control.Applicative ((<|>))
 import Control.Arrow (first, second)
 import Control.DeepSeq (NFData)
@@ -28,6 +28,8 @@ import Language.PureScript.Constants.Prim qualified as C
 import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName)
 import Language.PureScript.Label (Label)
 import Language.PureScript.PSString (PSString)
+import Database.SQLite.Simple.ToField (ToField (toField))
+import Database.SQLite.Simple.FromField (FromField (fromField))
 
 type SourceType = Type SourceAnn
 type SourceConstraint = Constraint SourceAnn
@@ -115,6 +117,12 @@ data Type a
 instance NFData a => NFData (Type a)
 instance Serialise a => Serialise (Type a)
 
+instance Serialise a => ToField (Type a) where
+  toField = toField . serialise
+
+instance Serialise a => FromField (Type a) where
+  fromField = fmap deserialise <$> fromField
+
 srcTUnknown :: Int -> SourceType
 srcTUnknown = TUnknown NullSourceAnn
 

From d6afa0be28cfae628856114cf69617cd4b7b983c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Sun, 1 Dec 2024 21:35:42 +0100
Subject: [PATCH 259/297] adds env indexing

---
 src/Language/PureScript/Environment.hs       |   1 -
 src/Language/PureScript/Make/Index.hs        | 124 ++++++++++++++-----
 src/Language/PureScript/Sugar/TypeClasses.hs |   1 -
 3 files changed, 91 insertions(+), 35 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 66c05dc5c6..b12b9e711b 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -31,7 +31,6 @@ import Language.PureScript.Constants.Prim qualified as C
 import Codec.Serialise qualified as S
 import Database.SQLite.Simple.ToField (ToField (toField))
 import Database.SQLite.Simple.FromField (FromField (fromField))
-import Database.SQLite.Simple (ToRow (toRow))
 
 -- | The @Environment@ defines all values and types which are currently in scope:
 data Environment = Environment
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index a00e1a0d6e..3e965afbea 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -13,39 +13,62 @@ module Language.PureScript.Make.Index
     getExportedNames,
     selectEnvValue,
     insertEnvValue,
+    insertType,
+    selectType,
+    insertDataConstructor,
+    selectDataConstructor,
+    insertTypeSynonym,
+    selectTypeSynonym,
+    selectTypeClass,
   )
 where
 
 import Codec.Serialise (deserialise, serialise)
 import Control.Arrow ((>>>))
+-- import Database.SQLite.Simple.Types ((:.))
+
+import Control.Concurrent.Async.Lifted (mapConcurrently_)
 import Data.List (partition)
+import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple (Connection, NamedParam ((:=)), type (:.) (..))
 import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
 import Language.LSP.Server (MonadLsp)
--- import Database.SQLite.Simple.Types ((:.))
-import Language.PureScript (internalCompilerError)
+import Language.PureScript (internalError)
 import Language.PureScript qualified as P
+import Language.PureScript.AST.Declarations (DeclarationRef)
 import Language.PureScript.Environment (Environment)
+import Language.PureScript.Environment qualified as E
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), declNameType, externDeclNameType, lspNameType)
 import Language.PureScript.Lsp.Print (addDataDeclArgKind, printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType, printTypeClassKind)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
+import Language.PureScript.Names (Qualified ())
 import Language.PureScript.TypeChecker.Monad (emptyCheckState)
 import Protolude hiding (moduleName)
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
   addAstModuleIndexing conn $
-    addExternIndexing conn ma
+    addEnvIndexing conn $
+      addExternIndexing conn ma
 
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
   ma
-    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (indexAstModule conn (P.checkEnv checkSt) astM ext (getExportedNames ext)) <* P.codegen ma prevEnv checkSt astM m docs ext
+    { P.codegen = \prevEnv checkSt astM m docs ext ->
+        lift (indexAstModule conn (P.checkEnv checkSt) astM ext (getExportedNames ext)) <* P.codegen ma prevEnv checkSt astM m docs ext
+    }
+
+addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+addEnvIndexing conn ma =
+  ma
+    { P.codegen = \prevEnv checkSt astM@(P.Module _ _ _ _ refs) m docs ext -> do
+        lift (indexExportedEnv (P.getModuleName astM) (P.checkEnv checkSt) refs conn)
+        P.codegen ma prevEnv checkSt astM m docs ext
     }
 
 indexAstModule :: (MonadIO m) => Connection -> Environment -> P.Module -> ExternsFile -> Set P.Name -> m ()
@@ -327,16 +350,51 @@ dropTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS ast_modules"
   SQL.execute_ conn "DROP TABLE IF EXISTS externs"
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
+  dropEnvTables conn
+
+indexExportedEnv :: (MonadIO m) => P.ModuleName -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
+indexExportedEnv moduleName env refs conn = liftIO do
+  deleteModuleEnv
+  envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
+  envFromModule E.types & filter typeExported & mapConcurrently_ (uncurry $ insertType conn)
+  envFromModule E.dataConstructors & filter dataConstructorExported & mapConcurrently_ (uncurry $ insertDataConstructor conn)
+  envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn)
+  envFromModule E.typeClasses & filter typeClasseExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
+  where
+    envFromModule :: (E.Environment -> Map.Map (Qualified k) v) -> [(Qualified k, v)]
+    envFromModule f = f env & Map.toList & filter ((== Just moduleName) . P.getQual . fst)
 
+    deleteModuleEnv = do
+      SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
 
--- indexEnv :: Connection -> P.Environment -> IO ()
--- indexEnv conn env = 
+    refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool
+    refMatch f (k, _) = maybe True (any (f k)) refs
 
-type DbQualifer a = (Maybe P.ModuleName, Maybe Int, Maybe Int, a)
+    nameExported = refMatch \k -> \case
+      P.ValueRef _ ident -> ident == P.disqualify k
+      _ -> False
+
+    typeClasseExported = refMatch \k -> \case
+      P.TypeClassRef _ className -> className == P.disqualify k
+      _ -> False
+
+    typeExported = refMatch \k -> \case
+      P.TypeRef _ typeName _ -> typeName == P.disqualify k
+      _ -> False
+
+    dataConstructorExported = refMatch \k -> \case
+      P.TypeRef _ _ ctrs -> maybe False (elem (P.disqualify k)) ctrs
+      _ -> False
+
+type DbQualifer a = (P.ModuleName, a)
 
 toDbQualifer :: P.Qualified a -> DbQualifer a
-toDbQualifer (P.Qualified (P.BySourcePos pos) a) = (Nothing, Just (P.sourcePosLine pos), Just (P.sourcePosColumn pos), a)
-toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (Just mn, Nothing, Nothing, a)
+toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (mn, a)
+toDbQualifer (P.Qualified (P.BySourcePos _) _) = internalError "toDbQualifer called with BySourcePos"
 
 type EnvValue = (P.SourceType, P.NameKind, P.NameVisibility)
 
@@ -344,14 +402,14 @@ insertEnvValue :: Connection -> P.Qualified P.Ident -> EnvValue -> IO ()
 insertEnvValue conn ident val =
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_values (module_name, line, column, ident, source_type, name_kind, name_visibility) VALUES (?, ?, ?, ?, ?, ?, ?)"
+    "INSERT OR REPLACE INTO env_values (module_name, ident, source_type, name_kind, name_visibility) VALUES (?, ?, ?, ?, ?)"
     (toDbQualifer ident :. val)
 
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
 selectEnvValue conn ident =
   SQL.query
     conn
-    "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name IS ? AND line IS ? AND column is ? AND ident = ?"
+    "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name = ? AND ident = ?"
     (toDbQualifer ident)
     <&> head
 
@@ -361,14 +419,14 @@ insertType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> EnvType ->
 insertType conn ident val =
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_types (module_name, line, column, type_name, source_type, type_kind) VALUES (?, ?, ?, ?, ?, ?)"
+    "INSERT OR REPLACE INTO env_types (module_name, type_name, source_type, type_kind) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. val)
 
 selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe EnvType)
 selectType conn ident =
   SQL.query
     conn
-    "SELECT source_type, type_kind FROM env_types WHERE module_name IS ? AND line IS ? AND column is ? AND type_name = ?"
+    "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?"
     (toDbQualifer ident)
     <&> head
 
@@ -376,14 +434,14 @@ insertDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorN
 insertDataConstructor conn ident (ddt, ty, st, idents) =
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_data_constructors (constructor_name, data_decl_type, type_name, source_type, idents) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)"
+    "INSERT OR REPLACE INTO env_data_constructors (module_name, constructor_name, data_decl_type, type_name, source_type, idents) VALUES (?, ?, ?, ?, ?, ?)"
     (toDbQualifer ident :. (ddt, ty, st, serialise idents))
 
 selectDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> IO (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
 selectDataConstructor conn ident =
   SQL.query
     conn
-    "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name IS ? AND line IS ? AND column is ? AND constructor_name = ?"
+    "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND constructor_name = ?"
     (toDbQualifer ident)
     <&> (head >>> fmap deserialiseIdents)
   where
@@ -393,50 +451,50 @@ insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(
 insertTypeSynonym conn ident (idents, st) =
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_synonyms (module_name, line, column, type_name, idents, source_type) VALUES (?, ?, ?, ?, ?)"
+    "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. (serialise idents, st))
 
 selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
 selectTypeSynonym conn ident =
   SQL.query
     conn
-    "SELECT idents, source_type FROM env_type_synonyms WHERE module_name IS ? AND line IS ? AND column is ? AND type_name = ?"
+    "SELECT idents, source_type FROM env_type_synonyms WHERE module_name = ? AND type_name = ?"
     (toDbQualifer ident)
     <&> (head >>> fmap deserialiseIdents)
-    where
-      deserialiseIdents (idents, st) = (deserialise idents, st)
+  where
+    deserialiseIdents (idents, st) = (deserialise idents, st)
 
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
 insertTypeClass conn ident tcd =
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_classes (module_name, line, column, class_name, class) VALUES (?, ?, ?, ?, ?)"
+    "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)"
     (toDbQualifer ident :. SQL.Only tcd)
 
 selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
 selectTypeClass conn ident =
   SQL.query
     conn
-    "SELECT class FROM env_type_classes WHERE module_name IS ? AND line IS ? AND column is ? AND class_name = ?"
+    "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
     (toDbQualifer ident)
     <&> (fmap SQL.fromOnly . head)
 
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, line INT, column INT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, line INT, column INT, type_name TEXT PRIMARY KEY, source_type BLOB, type_kind TEXT, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, line INT, column INT, constructor_name TEXT PRIMARY KEY, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, line INT, column INT, type_name TEXT PRIMARY KEY, idents BLOB, source_type BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, line INT, column INT, class_name TEXT PRIMARY KEY, class BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, type_name TEXT PRIMARY KEY, source_type BLOB, type_kind TEXT, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT PRIMARY KEY, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT PRIMARY KEY, idents BLOB, source_type BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT PRIMARY KEY, class BLOB, debug TEXT)"
+  addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
-addEnvIndexes conn = do 
-  SQL.execute_ conn "CREATE UNIQUE INDEX env_values_idx ON env_values(module_name, line, column, ident)"
-  SQL.execute_ conn "CREATE UNIQUE INDEX env_types_idx ON env_types(module_name, line, column, type_name)"
-  SQL.execute_ conn "CREATE UNIQUE INDEX env_data_constructors_idx ON env_data_constructors(module_name, line, column, constructor_name)"
-  SQL.execute_ conn "CREATE UNIQUE INDEX env_type_synonyms_idx ON env_type_synonyms(module_name, line, column, type_name)"
-  SQL.execute_ conn "CREATE UNIQUE INDEX env_type_classes_idx ON env_type_classes(module_name, line, column, class_name)"
-
+addEnvIndexes conn = do
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_values_idx ON env_values(module_name, ident)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_types_idx ON env_types(module_name, type_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_data_constructors_idx ON env_data_constructors(module_name, constructor_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_synonyms_idx ON env_type_synonyms(module_name, type_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_classes_idx ON env_type_classes(module_name, class_name)"
 
 dropEnvTables :: Connection -> IO ()
 dropEnvTables conn = do
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index b0b29985c2..f02e027baf 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -81,7 +81,6 @@ desugarTypeClassesUsingMemberMap classes = flip evalStateT initialState . desuga
       , classes
       ]
 
-
 -- TODO add desugarModuleSqlite which uses the DB instead of MemberMap to store the type class data
 
 desugarModule

From 70838144edb2a833d2f585068b265bfbfbc9a998 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 2 Dec 2024 01:52:55 +0100
Subject: [PATCH 260/297] starts rebuildModuleWithIndexDb

---
 src/Language/PureScript/Environment.hs        |  27 ++-
 src/Language/PureScript/Make.hs               |  12 ++
 src/Language/PureScript/Make/Index.hs         | 165 +++++++++++++++++-
 src/Language/PureScript/Names.hs              |   6 +
 src/Language/PureScript/TypeChecker/Monad.hs  |  19 +-
 .../PureScript/TypeClassDictionaries.hs       |   1 +
 6 files changed, 207 insertions(+), 23 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index b12b9e711b..a617e32d01 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -5,7 +5,7 @@ import Prelude
 
 import GHC.Generics (Generic)
 import Control.DeepSeq (NFData)
-import Control.Monad (unless)
+import Control.Monad (unless, (>=>))
 import Codec.Serialise (Serialise)
 import Data.Aeson ((.=), (.:))
 import Data.Aeson qualified as A
@@ -30,7 +30,7 @@ import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVa
 import Language.PureScript.Constants.Prim qualified as C
 import Codec.Serialise qualified as S
 import Database.SQLite.Simple.ToField (ToField (toField))
-import Database.SQLite.Simple.FromField (FromField (fromField))
+import Database.SQLite.Simple.FromField (FromField (fromField), FieldParser)
 
 -- | The @Environment@ defines all values and types which are currently in scope:
 data Environment = Environment
@@ -253,10 +253,12 @@ instance NFData NameVisibility
 instance Serialise NameVisibility
 
 instance ToField NameVisibility where
-  toField = toField . S.serialise
-
+  toField = toField . show
 instance FromField NameVisibility where
-  fromField = fmap S.deserialise . fromField
+  fromField = (fromField :: FieldParser Text) >=> \case
+    "Undefined" -> pure Undefined
+    "Defined" -> pure Defined
+    other -> fail $ "invalid NameVisibility: '" ++ T.unpack other ++ "'"
 
 -- | A flag for whether a name is for an private or public value - only public values will be
 -- included in a generated externs file.
@@ -274,10 +276,14 @@ instance NFData NameKind
 instance Serialise NameKind
 
 instance ToField NameKind where
-  toField = toField . S.serialise
+  toField = toField . show
 
 instance FromField NameKind where
-  fromField = fmap S.deserialise . fromField
+  fromField = (fromField :: FieldParser Text) >=> \case
+    "Private" -> pure Private
+    "Public" -> pure Public
+    "External" -> pure External
+    other -> fail $ "invalid NameKind: '" ++ T.unpack other ++ "'"
 
 -- | The kinds of a type
 data TypeKind
@@ -313,10 +319,13 @@ data DataDeclType
 instance NFData DataDeclType
 instance Serialise DataDeclType
 instance ToField DataDeclType where
-  toField = toField . S.serialise
+  toField = toField . showDataDeclType
 
 instance FromField DataDeclType where
-  fromField = fmap S.deserialise . fromField
+  fromField = (fromField :: FieldParser Text) >=> \case 
+    "data" -> pure Data
+    "newtype" -> pure Newtype
+    other -> fail $ "invalid DataDeclType: '" ++ T.unpack other ++ "'"
 
 showDataDeclType :: DataDeclType -> Text
 showDataDeclType Data = "data"
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index ac8f7ce3b8..5ce752fa34 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -93,6 +93,18 @@ rebuildModuleWithIndex act exEnv externs m moduleIndex = do
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
   rebuildModuleWithProvidedEnv emptyCheckState act exEnv env externs m moduleIndex
 
+rebuildModuleWithIndexDb ::
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  MakeActions m ->
+  Env ->
+  Module ->
+  Maybe (Int, Int) ->
+  m ExternsFile
+rebuildModuleWithIndexDb act exEnv m moduleIndex = do
+  env <- selectEnvFromImports
+  rebuildModuleWithProvidedEnv emptyCheckState act exEnv env externs m moduleIndex
+
 rebuildModuleWithProvidedEnv ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 3e965afbea..a0351881b9 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -20,6 +20,8 @@ module Language.PureScript.Make.Index
     insertTypeSynonym,
     selectTypeSynonym,
     selectTypeClass,
+    selectEnv,
+    selectEnvFromImports,
   )
 where
 
@@ -27,7 +29,8 @@ import Codec.Serialise (deserialise, serialise)
 import Control.Arrow ((>>>))
 -- import Database.SQLite.Simple.Types ((:.))
 
-import Control.Concurrent.Async.Lifted (mapConcurrently_)
+import Control.Concurrent.Async.Lifted (mapConcurrently, mapConcurrently_)
+import Control.Monad.Writer (MonadWriter (tell), execWriter)
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -48,7 +51,10 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Names (Qualified ())
 import Language.PureScript.TypeChecker.Monad (emptyCheckState)
+import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue))
+import Language.PureScript.Types (Constraint (..))
 import Protolude hiding (moduleName)
+import Data.Aeson qualified as A
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
@@ -359,11 +365,29 @@ indexExportedEnv moduleName env refs conn = liftIO do
   envFromModule E.types & filter typeExported & mapConcurrently_ (uncurry $ insertType conn)
   envFromModule E.dataConstructors & filter dataConstructorExported & mapConcurrently_ (uncurry $ insertDataConstructor conn)
   envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn)
-  envFromModule E.typeClasses & filter typeClasseExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
+  envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
+  dicts
+    & filter ((== Just moduleName) . P.getQual . tcdValue)
+    & mapConcurrently_ (insertNamedDict conn)
   where
     envFromModule :: (E.Environment -> Map.Map (Qualified k) v) -> [(Qualified k, v)]
     envFromModule f = f env & Map.toList & filter ((== Just moduleName) . P.getQual . fst)
 
+    dicts :: [NamedDict]
+    dicts =
+      E.typeClassDictionaries env
+        & Map.elems
+          >>= Map.elems
+          >>= Map.elems
+          >>= toList
+        <&> localToQualified
+
+    localToQualified :: NamedDict -> NamedDict
+    localToQualified dict =
+      if P.isQualified (tcdValue dict)
+        then dict
+        else dict {tcdValue = P.Qualified (P.ByModuleName moduleName) (P.disqualify $ tcdValue dict)}
+
     deleteModuleEnv = do
       SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
@@ -378,7 +402,7 @@ indexExportedEnv moduleName env refs conn = liftIO do
       P.ValueRef _ ident -> ident == P.disqualify k
       _ -> False
 
-    typeClasseExported = refMatch \k -> \case
+    typeClassExported = refMatch \k -> \case
       P.TypeClassRef _ className -> className == P.disqualify k
       _ -> False
 
@@ -390,6 +414,63 @@ indexExportedEnv moduleName env refs conn = liftIO do
       P.TypeRef _ _ ctrs -> maybe False (elem (P.disqualify k)) ctrs
       _ -> False
 
+selectEnv :: (MonadIO m) => Connection -> [P.ModuleName] -> m E.Environment
+selectEnv conn deps = do
+  values <- liftIO $ join <$> mapConcurrently (selectModuleEnvValues conn) deps
+  types <- liftIO $ join <$> mapConcurrently (selectModuleEnvTypes conn) deps
+  dataConstructors <- liftIO $ join <$> mapConcurrently (selectModuleDataConstructors conn) deps
+  typeSynonyms <- liftIO $ join <$> mapConcurrently (selectModuleTypeSynonyms conn) deps
+  typeClasses <- liftIO $ join <$> mapConcurrently (selectModuleTypeClasses conn) deps
+  pure
+    E.initEnvironment
+      { E.names = Map.fromList values,
+        E.types = Map.fromList types,
+        E.dataConstructors = Map.fromList dataConstructors,
+        E.typeSynonyms = Map.fromList typeSynonyms,
+        E.typeClasses = Map.fromList typeClasses
+      }
+
+selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> P.Env -> m E.Environment
+selectEnvFromImports conn (P.Module _ _ moduleName' decls _) env = liftIO do
+  case Map.lookup moduleName' env of
+    Just (_, P.Imports {..}, _) -> do
+      names <- selectWithKeys importedValues selectEnvValue --  importedValues & Map.keys & mapConcurrently selectValues & fmap (Map.fromList . catMaybes) --  mapConcurrently (selectEnvValue conn) <&> catMaybes <&> _
+      types <- selectWithKeys importedTypes selectType
+      typeSynonyms <- selectWithKeys importedTypes selectTypeSynonym
+      dataConstructors <- selectWithKeys importedDataConstructors selectDataConstructor
+      typeClasses <- selectWithKeys importedTypeClasses selectTypeClass
+      dicts <- selectDictsByClassName conn dictionaryClassnames
+      pure $ E.Environment names (P.allPrimTypes <> types) dataConstructors typeSynonyms (P.typeClassDictionariesEnvMap dicts) (P.allPrimClasses <> typeClasses)
+    Nothing -> pure E.initEnvironment
+  where
+    selectWithKeys :: (Ord a) => Map.Map a x -> (Connection -> a -> IO (Maybe b)) -> IO (Map.Map a b)
+    selectWithKeys a sel = a & Map.keys & mapConcurrently selWithKey <&> Map.fromList . catMaybes
+      where
+        selWithKey key = do
+          val <- sel conn key
+          pure $ fmap (key,) val
+
+    dictionaryClassnames :: [P.Qualified (P.ProperName 'P.ClassName)]
+    dictionaryClassnames = execWriter . onDecls =<< decls
+      where
+        (onDecls, _, _) = P.everywhereOnValuesM pure onExpr pure
+
+        onExpr e = do
+          case e of
+            P.TypeClassDictionary c _ _ -> tell [constraintClass c]
+            P.DeferredDictionary c _ -> tell [c]
+            P.DerivedInstancePlaceholder c _ -> tell [c]
+            _ -> pure ()
+          pure e
+
+-- selectValues :: Qualified P.Ident -> IO (Maybe (Qualified P.Ident, (P.SourceType, E.NameKind, E.NameVisibility)))
+-- selectValues ident = do
+--   val <- selectEnvValue conn ident
+--   pure $ fmap (ident, ) val
+
+-- selectValues :: [Qualified P.Ident] -> IO (Map (Qualified P.Ident) (P.SourceType, E.NameKind, E.NameVisibility))
+-- selectValues = _
+
 type DbQualifer a = (P.ModuleName, a)
 
 toDbQualifer :: P.Qualified a -> DbQualifer a
@@ -413,6 +494,14 @@ selectEnvValue conn ident =
     (toDbQualifer ident)
     <&> head
 
+selectModuleEnvValues :: Connection -> P.ModuleName -> IO [(P.Qualified P.Ident, (P.SourceType, P.NameKind, P.NameVisibility))]
+selectModuleEnvValues conn moduleName' =
+  SQL.query
+    conn
+    "SELECT ident, source_type, name_kind, name_visibility FROM env_values WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ident, st, nk, nv) -> (P.Qualified (P.ByModuleName moduleName') ident, (st, nk, nv)))
+
 type EnvType = (P.SourceType, P.TypeKind)
 
 insertType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> EnvType -> IO ()
@@ -430,6 +519,14 @@ selectType conn ident =
     (toDbQualifer ident)
     <&> head
 
+selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), EnvType)]
+selectModuleEnvTypes conn moduleName' =
+  SQL.query
+    conn
+    "SELECT type_name, source_type, type_kind FROM env_types WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ty, st, tk) -> (P.Qualified (P.ByModuleName moduleName') ty, (st, tk)))
+
 insertDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) -> IO ()
 insertDataConstructor conn ident (ddt, ty, st, idents) =
   SQL.execute
@@ -447,6 +544,14 @@ selectDataConstructor conn ident =
   where
     deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
 
+selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
+selectModuleDataConstructors conn moduleName' =
+  SQL.query
+    conn
+    "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
+
 insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(Text, Maybe P.SourceType)], P.SourceType) -> IO ()
 insertTypeSynonym conn ident (idents, st) =
   SQL.execute
@@ -464,6 +569,14 @@ selectTypeSynonym conn ident =
   where
     deserialiseIdents (idents, st) = (deserialise idents, st)
 
+selectModuleTypeSynonyms :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), ([(Text, Maybe P.SourceType)], P.SourceType))]
+selectModuleTypeSynonyms conn moduleName' =
+  SQL.query
+    conn
+    "SELECT type_name, idents, source_type FROM env_type_synonyms WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st)))
+
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
 insertTypeClass conn ident tcd =
   SQL.execute
@@ -479,13 +592,50 @@ selectTypeClass conn ident =
     (toDbQualifer ident)
     <&> (fmap SQL.fromOnly . head)
 
+selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
+selectModuleTypeClasses conn moduleName' =
+  SQL.query
+    conn
+    "SELECT class_name, class FROM env_type_classes WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (first (P.Qualified (P.ByModuleName moduleName')))
+
+insertNamedDict :: Connection -> NamedDict -> IO ()
+insertNamedDict conn dict =
+  SQL.execute
+    conn
+    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_name, dict) VALUES (?, ?, ?, ?)"
+    (toDbQualifer (tcdValue dict) :. (tcdClassName dict, serialise dict))
+
+selectDictsByClassName :: Connection -> [P.Qualified (P.ProperName 'P.ClassName)] -> IO [NamedDict]
+selectDictsByClassName conn classNames =
+  SQL.query 
+    conn
+    "SELECT dict FROM env_type_class_instances WHERE class_name IN (SELECT value FROM json_each(?))"
+    (SQL.Only $ A.encode classNames)
+    <&> fmap (SQL.fromOnly >>> deserialise)
+
+
+-- insertTypeClassInstance ::
+--   Connection ->
+--   P.Qualified (P.ProperName 'P.ClassName) ->
+--   P.Qualified P.Ident ->
+--   NEL.NonEmpty NamedDict ->
+--   IO ()
+-- insertTypeClassInstance conn className instanceName dicts =
+--   SQL.execute
+--     conn
+--     "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_name, dicts) VALUES (?, ?, ?, ?)"
+--     (toDbQualifer instanceName :. (className,  serialise dicts))
+
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, type_name TEXT PRIMARY KEY, source_type BLOB, type_kind TEXT, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT PRIMARY KEY, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT PRIMARY KEY, idents BLOB, source_type BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT PRIMARY KEY, class BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, type_name TEXT, source_type BLOB, type_kind TEXT, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT, class BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_name TEXT, dict BLOB, debug TEXT)"
   addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
@@ -495,6 +645,7 @@ addEnvIndexes conn = do
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_data_constructors_idx ON env_data_constructors(module_name, constructor_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_synonyms_idx ON env_type_synonyms(module_name, type_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_classes_idx ON env_type_classes(module_name, class_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idx ON env_type_class_instances(module_name, instance_name)"
 
 dropEnvTables :: Connection -> IO ()
 dropEnvTables conn = do
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 39e011bde0..cc0cee34a2 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -25,6 +25,7 @@ import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
 import Data.Aeson qualified as A
 import Database.SQLite.Simple.ToField (ToField (toField))
 import Database.SQLite.Simple.FromField (FromField (fromField), ResultError (ConversionFailed), returnError)
+import Data.Data (Typeable)
 
 -- | A sum of the possible name types, useful for error and lint messages.
 data Name
@@ -241,6 +242,11 @@ data Qualified a = Qualified QualifiedBy a
 
 instance NFData a => NFData (Qualified a)
 instance Serialise a => Serialise (Qualified a)
+instance ToJSON a => ToField (Qualified a) where
+  toField = toField . A.encode
+
+instance (FromJSON a, Typeable a) => FromField (Qualified a) where
+  fromField  f = (either (returnError ConversionFailed f) pure . A.eitherDecode) =<< fromField f
 
 showQualified :: (a -> Text) -> Qualified a -> Text
 showQualified f (Qualified (BySourcePos  _) a) = f a
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 6c8674a9b3..3caa9d58db 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -206,18 +206,23 @@ withTypeClassDictionaries
 withTypeClassDictionaries entries action = do
   orig <- get
 
-  let mentries =
-        M.fromListWith (M.unionWith (M.unionWith (<>)))
-          [ (qb, M.singleton className (M.singleton tcdValue (pure entry)))
-          | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className }
-              <- entries
-          ]
-
+  let mentries = typeClassDictionariesEnvMap entries
+  
   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } }
   a <- action
   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
   return a
 
+
+typeClassDictionariesEnvMap :: [NamedDict] 
+  -> M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
+typeClassDictionariesEnvMap entries =
+  M.fromListWith (M.unionWith (M.unionWith (<>)))
+    [ (qb, M.singleton className (M.singleton tcdValue (pure entry)))
+    | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className }
+        <- entries
+    ]
+
 -- | Get the currently available map of type class dictionaries
 getTypeClassDictionaries
   :: (MonadState CheckState m)
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 79393ba004..3f6cd66ee9 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -42,6 +42,7 @@ data TypeClassDictionaryInScope v
 
 instance NFData v => NFData (TypeClassDictionaryInScope v)
 instance Serialise v => Serialise (TypeClassDictionaryInScope v)
+-- instance
 
 type NamedDict = TypeClassDictionaryInScope (Qualified Ident)
 

From 2a6a449b78863742b94042e0b7a98a1073ac9f1c Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 2 Dec 2024 22:20:31 +0100
Subject: [PATCH 261/297] adds selectEnvFromImports using env

---
 purescript.cabal                             |   1 +
 src/Language/PureScript/AST/Operators.hs     |   4 +
 src/Language/PureScript/Docs/Convert.hs      |  39 +++
 src/Language/PureScript/Externs.hs           |   7 +
 src/Language/PureScript/Make.hs              | 117 ++++++++-
 src/Language/PureScript/Make/Actions.hs      |   8 +
 src/Language/PureScript/Make/Index.hs        | 227 ++++--------------
 src/Language/PureScript/Make/Index/Select.hs | 235 +++++++++++++++++++
 src/Language/PureScript/Names.hs             |   6 +
 src/Language/PureScript/Sugar.hs             |   8 +-
 src/Language/PureScript/Sugar/Operators.hs   |  13 +-
 11 files changed, 463 insertions(+), 202 deletions(-)
 create mode 100644 src/Language/PureScript/Make/Index/Select.hs

diff --git a/purescript.cabal b/purescript.cabal
index 5c97480c50..367fc073ea 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -378,6 +378,7 @@ library
     Language.PureScript.Make.BuildPlan
     Language.PureScript.Make.Cache
     Language.PureScript.Make.Index
+    Language.PureScript.Make.Index.Select
     Language.PureScript.Make.Monad
     Language.PureScript.ModuleDependencies
     Language.PureScript.Names
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index eb217a2444..7c8f0b5ea5 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -12,6 +12,7 @@ import Data.Aeson ((.=))
 import Data.Aeson qualified as A
 
 import Language.PureScript.Crash (internalError)
+import Database.SQLite.Simple.FromField (FromField (fromField))
 
 -- |
 -- A precedence level for an infix operator
@@ -27,6 +28,9 @@ data Associativity = Infixl | Infixr | Infix
 instance NFData Associativity
 instance Serialise Associativity
 
+instance FromField Associativity where
+  fromField = fmap readAssoc . fromField
+
 showAssoc :: Associativity -> String
 showAssoc Infixl = "infixl"
 showAssoc Infixr = "infixr"
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index a7dc1758c7..6f93cbd626 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -3,6 +3,7 @@
 
 module Language.PureScript.Docs.Convert
   ( convertModule
+  , convertModuleWithoutExterns
   ) where
 
 import Protolude hiding (check)
@@ -29,6 +30,8 @@ import Language.PureScript.Sugar qualified as P
 import Language.PureScript.Types qualified as P
 import Language.PureScript.Constants.Prim qualified as Prim
 import Language.PureScript.Sugar (RebracketCaller(CalledByDocs))
+import Language.PureScript.Externs (ExternsFixity)
+import Language.PureScript.Sugar.Operators (fromExternFixities)
 
 -- |
 -- Convert a single module to a Docs.Module, making use of a pre-existing
@@ -45,6 +48,17 @@ convertModule ::
 convertModule externs env checkEnv =
   fmap (insertValueTypesAndAdjustKinds checkEnv . convertSingleModule) . partiallyDesugar externs env
 
+
+convertModuleWithoutExterns ::
+  MonadError P.MultipleErrors m =>
+  [(P.ModuleName, [ExternsFixity])] ->
+  [(P.ModuleName, [P.ExternsTypeFixity])] ->
+  P.Env ->
+  P.Environment ->
+  P.Module ->
+  m Module
+convertModuleWithoutExterns fixities typeFixities env checkEnv =
+  fmap (insertValueTypesAndAdjustKinds checkEnv . convertSingleModule) . partiallyDesugarWithouExterns fixities typeFixities env
 -- |
 -- Convert FFI declarations into `DataDeclaration` so that the declaration's
 -- roles (if any) can annotate the generated type parameter names.
@@ -271,3 +285,28 @@ partiallyDesugar externs env = evalSupplyT 0 . desugar'
 
   isInstanceDecl P.TypeInstanceDeclaration {} = True
   isInstanceDecl _ = False
+
+-- |
+-- Partially desugar modules so that they are suitable for extracting
+-- documentation information from. This version does not use externs files
+--
+partiallyDesugarWithouExterns ::
+  (MonadError P.MultipleErrors m) =>
+  [(P.ModuleName, [ExternsFixity])] ->
+  [(P.ModuleName, [P.ExternsTypeFixity])] ->
+  P.Env ->
+  P.Module ->
+  m P.Module
+partiallyDesugarWithouExterns  fixities typeFixities env = evalSupplyT 0 . desugar'
+  where
+  desugar' =
+    P.desugarDoModule
+      >=> P.desugarAdoModule
+      >=> P.desugarLetPatternModule
+      >>> P.desugarCasesModule
+      >=> P.desugarTypeDeclarationsModule
+      >=> fmap fst . runWriterT . flip evalStateT (env, mempty) . P.desugarImports
+      >=> P.rebracketFiltered' CalledByDocs isInstanceDecl  (fromExternFixities fixities typeFixities)
+
+  isInstanceDecl P.TypeInstanceDeclaration {} = True
+  isInstanceDecl _ = False
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index 6a67f0da46..c8c26cb2d7 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -39,6 +39,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary
 import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType)
 
 import Paths_purescript as Paths
+import Database.SQLite.Simple (FromRow (fromRow), field)
 
 -- | The data which will be serialized to an externs file
 data ExternsFile = ExternsFile
@@ -93,6 +94,9 @@ data ExternsFixity = ExternsFixity
 
 instance Serialise ExternsFixity
 
+instance FromRow ExternsFixity where 
+  fromRow = ExternsFixity <$> field <*> field <*> field <*> field
+
 -- | A type fixity declaration in an externs file
 data ExternsTypeFixity = ExternsTypeFixity
   {
@@ -108,6 +112,9 @@ data ExternsTypeFixity = ExternsTypeFixity
 
 instance Serialise ExternsTypeFixity
 
+instance FromRow ExternsTypeFixity where 
+  fromRow = ExternsTypeFixity <$> field <*> field <*> field <*> field
+
 -- | A type or value declaration appearing in an externs file
 data ExternsDeclaration =
   -- | A type declaration
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 5ce752fa34..5c6744812b 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module Language.PureScript.Make
   ( -- * Make API
     rebuildModule,
@@ -31,6 +33,7 @@ import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
 import Data.Set qualified as S
 import Data.Text qualified as T
+import Database.SQLite.Simple (Connection)
 import Debug.Trace (traceMarkerIO)
 import Language.PureScript.AST (ErrorMessageHint (..), Module (..), SourceSpan (..), getModuleName, getModuleSourceSpan, importPrim)
 import Language.PureScript.CST qualified as CST
@@ -39,17 +42,18 @@ import Language.PureScript.Crash (internalError)
 import Language.PureScript.Docs.Convert qualified as Docs
 import Language.PureScript.Environment (Environment, initEnvironment)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
-import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile)
+import Language.PureScript.Externs (ExternsFile, ExternsFixity, ExternsTypeFixity, applyExternsFileToEnvironment, moduleToExternsFile)
 import Language.PureScript.Linter (Name (..), lint, lintImports)
 import Language.PureScript.Make.Actions as Actions
 import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult)
 import Language.PureScript.Make.BuildPlan qualified as BuildPlan
 import Language.PureScript.Make.Cache qualified as Cache
+import Language.PureScript.Make.Index.Select (selectEnvFromImports, selectFixitiesFromModule)
 import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
 import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
 import Language.PureScript.Renamer (renameInModule)
-import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
+import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, desugarUsingDb, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
 import Language.PureScript.TypeChecker.Monad qualified as P
 import System.Directory (doesFileExist)
@@ -95,15 +99,16 @@ rebuildModuleWithIndex act exEnv externs m moduleIndex = do
 
 rebuildModuleWithIndexDb ::
   forall m.
-  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) =>
   MakeActions m ->
+  Connection ->
   Env ->
   Module ->
   Maybe (Int, Int) ->
   m ExternsFile
-rebuildModuleWithIndexDb act exEnv m moduleIndex = do
-  env <- selectEnvFromImports
-  rebuildModuleWithProvidedEnv emptyCheckState act exEnv env externs m moduleIndex
+rebuildModuleWithIndexDb act conn exEnv m moduleIndex = do
+  env <- selectEnvFromImports conn m exEnv
+  rebuildModuleWithProvidedEnvDb emptyCheckState act conn exEnv env m moduleIndex
 
 rebuildModuleWithProvidedEnv ::
   forall m.
@@ -157,6 +162,60 @@ rebuildModuleWithProvidedEnv initialCheckState MakeActions {..} exEnv env extern
   evalSupplyT nextVar'' $ codegen env checkSt mod' renamed docs exts
   return exts
 
+rebuildModuleWithProvidedEnvDb ::
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) =>
+  (Environment -> CheckState) ->
+  MakeActions m ->
+  Connection ->
+  Env ->
+  Environment ->
+  Module ->
+  Maybe (Int, Int) ->
+  m ExternsFile
+rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv env m@(Module _ _ moduleName _ _) moduleIndex = do
+  progress $ CompilingModule moduleName moduleIndex
+  let withPrim = importPrim m
+  lint withPrim
+  (ops, typeOps) <- liftIO $ selectFixitiesFromModule conn m
+
+  ((Module ss coms _ elaborated exps, checkSt), nextVar) <-
+    desugarAndTypeCheckDb initialCheckState withCheckStateOnError withCheckState moduleName withPrim exEnv env ops typeOps
+  let env' = P.checkEnv checkSt
+
+  -- desugar case declarations *after* type- and exhaustiveness checking
+  -- since pattern guards introduces cases which the exhaustiveness checker
+  -- reports as not-exhaustive.
+  (deguarded, nextVar') <- runSupplyT nextVar $ do
+    desugarCaseGuards elaborated
+
+  regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
+  let mod' = Module ss coms moduleName regrouped exps
+
+      corefn = CF.moduleToCoreFn env' mod'
+      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
+      (renamedIdents, renamed) = renameInModule optimized
+      exts = moduleToExternsFile mod' env' renamedIdents
+  ffiCodegen renamed
+  -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
+  -- but I have not done so for two reasons:
+  -- 1. This should never fail; any genuine errors in the code should have been
+  -- caught earlier in this function. Therefore if we do fail here it indicates
+  -- a bug in the compiler, which should be reported as such.
+  -- 2. We do not want to perform any extra work generating docs unless the
+  -- user has asked for docs to be generated.
+  let docs = case Docs.convertModuleWithoutExterns ops typeOps exEnv env' withPrim of
+        Left errs ->
+          internalError $
+            "Failed to produce docs for "
+              ++ T.unpack (runModuleName moduleName)
+              ++ "; details:\n"
+              ++ prettyPrintMultipleErrors defaultPPEOptions errs
+        Right d -> d
+
+  evalSupplyT nextVar'' $ codegen env checkSt mod' renamed docs exts
+  return exts
+
 desugarAndTypeCheck ::
   forall m.
   (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
@@ -192,19 +251,56 @@ desugarAndTypeCheck initialCheckState withCheckStateOnError withCheckState modul
       lift $ lift $ withCheckStateOnError checkSt
       throwError errs
 
+desugarAndTypeCheckDb ::
+  forall m.
+  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  (Environment -> CheckState) ->
+  (CheckState -> m ()) ->
+  (CheckState -> m ()) ->
+  ModuleName ->
+  Module ->
+  Env ->
+  Environment ->
+  [(ModuleName, [ExternsFixity])] ->
+  [(ModuleName, [ExternsTypeFixity])] ->
+  m ((Module, CheckState), Integer)
+desugarAndTypeCheckDb initialCheckState withCheckStateOnError withCheckState moduleName withPrim exEnv env ops typeOps = runSupplyT 0 $ do
+  (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb ops typeOps env withPrim) (exEnv, mempty)
+  let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
+  (checked, checkSt@(CheckState {..})) <- runStateT (catchError (typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
+  lift $ withCheckState checkSt
+  let usedImports' =
+        foldl'
+          ( flip $ \(fromModuleName, newtypeCtorName) ->
+              M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName
+          )
+          usedImports
+          checkConstructorImportsForCoercible
+  -- Imports cannot be linted before type checking because we need to
+  -- known which newtype constructors are used to solve Coercible
+  -- constraints in order to not report them as unused.
+  censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
+  return (checked, checkSt)
+  where
+    mergeCheckState errs = do
+      checkSt <- get
+      lift $ lift $ withCheckStateOnError checkSt
+      throwError errs
+
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
 --
 -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without
 -- having to typecheck those modules again.
 make ::
   forall m.
-  (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  (MonadBaseControl IO m, MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
   MakeActions m ->
   [CST.PartialResult Module] ->
   m [ExternsFile]
 make ma@MakeActions {..} ms = do
   checkModuleNames
   cacheDb <- readCacheDb
+  conn <- getDbConnection
 
   (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms
 
@@ -225,6 +321,7 @@ make ma@MakeActions {..} ms = do
     let moduleName = getModuleName . CST.resPartial $ m
     let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
     buildModule
+      conn
       lock
       buildPlan
       moduleName
@@ -298,8 +395,8 @@ make ma@MakeActions {..} ms = do
     inOrderOf :: (Ord a) => [a] -> [a] -> [a]
     inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
 
-    buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
-    buildModule lock buildPlan moduleName cnt fp pwarnings mres deps = do
+    buildModule :: Connection -> QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
+    buildModule conn lock buildPlan moduleName cnt fp pwarnings mres deps = do
       result <- flip catchError (return . BuildJobFailed) $ do
         let pwarnings' = CST.toMultipleWarnings fp pwarnings
         tell pwarnings'
@@ -332,7 +429,7 @@ make ma@MakeActions {..} ms = do
               -- Force the externs and warnings to avoid retaining excess module
               -- data after the module is finished compiling.
               extsAndWarnings <- evaluate . force <=< listen $ do
-                rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
+                rebuildModuleWithIndexDb ma conn env m (Just (idx, cnt))
               liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
               return extsAndWarnings
             return $ BuildJobSucceeded (pwarnings' <> warnings) exts
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 38dd0546e6..98f6bf0de7 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -60,6 +60,8 @@ import System.FilePath (makeRelative, normalise, splitDirectories, splitPath, (<
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr)
 import Prelude
+import Database.SQLite.Simple (Connection)
+import Language.PureScript.DB (mkConnection)
 
 -- | Determines when to rebuild a module
 data RebuildPolicy
@@ -130,6 +132,8 @@ data MakeActions m = MakeActions
     -- | Write the given cache database to some external source (e.g. a file on
     -- disk).
     writeCacheDb :: CacheDb -> m (),
+    -- | Get database connection 
+    getDbConnection :: m Connection,
     -- | Write to the output directory the package.json file allowing Node.js to
     -- load .js files as ES modules.
     writePackageJson :: m (),
@@ -193,6 +197,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     progress
     readCacheDb
     writeCacheDb
+    getDbConnection
     writePackageJson
     outputPrimDocs
   where
@@ -353,6 +358,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     writeCacheDb :: CacheDb -> Make ()
     writeCacheDb = writeCacheDb' outputDir
 
+    getDbConnection :: Make Connection
+    getDbConnection = liftIO $ snd <$> mkConnection outputDir
+
     writePackageJson :: Make ()
     writePackageJson = writePackageJson' outputDir
 
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index a0351881b9..fd530351b5 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -11,26 +11,15 @@ module Language.PureScript.Make.Index
     dropTables,
     indexExtern,
     getExportedNames,
-    selectEnvValue,
     insertEnvValue,
     insertType,
-    selectType,
     insertDataConstructor,
-    selectDataConstructor,
     insertTypeSynonym,
-    selectTypeSynonym,
-    selectTypeClass,
-    selectEnv,
-    selectEnvFromImports,
   )
 where
 
-import Codec.Serialise (deserialise, serialise)
-import Control.Arrow ((>>>))
--- import Database.SQLite.Simple.Types ((:.))
-
-import Control.Concurrent.Async.Lifted (mapConcurrently, mapConcurrently_)
-import Control.Monad.Writer (MonadWriter (tell), execWriter)
+import Codec.Serialise (serialise)
+import Control.Concurrent.Async.Lifted (mapConcurrently_)
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -39,7 +28,6 @@ import Database.SQLite.Simple (Connection, NamedParam ((:=)), type (:.) (..))
 import Database.SQLite.Simple qualified as SQL
 import Distribution.Compat.Directory (makeAbsolute)
 import Language.LSP.Server (MonadLsp)
-import Language.PureScript (internalError)
 import Language.PureScript qualified as P
 import Language.PureScript.AST.Declarations (DeclarationRef)
 import Language.PureScript.Environment (Environment)
@@ -52,9 +40,9 @@ import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Names (Qualified ())
 import Language.PureScript.TypeChecker.Monad (emptyCheckState)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue))
-import Language.PureScript.Types (Constraint (..))
 import Protolude hiding (moduleName)
 import Data.Aeson qualified as A
+import Language.PureScript.Make.Index.Select (toDbQualifer)
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
@@ -86,6 +74,7 @@ indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs
     [ ":module_name" := P.runModuleName moduleName',
       ":path" := path
     ]
+
   SQL.execute conn "DELETE FROM ast_declarations WHERE module_name = ?" (SQL.Only $ P.runModuleName moduleName')
 
   let declsSorted :: [P.Declaration]
@@ -96,6 +85,7 @@ indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs
         _ -> False
 
   forM_ declsSorted \decl -> do
+    indexFixity conn moduleName' decl
     let (ss, _) = P.declSourceAnn decl
         start = P.spanStart ss
         end = P.spanEnd ss
@@ -193,6 +183,38 @@ indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs
     disqualifyIfInModule (P.Qualified (P.BySourcePos _) name) = Just name
     disqualifyIfInModule _ = Nothing
 
+indexFixity :: Connection -> P.ModuleName -> P.Declaration -> IO ()
+indexFixity conn moduleName' = \case
+  P.FixityDeclaration _ (Left (P.ValueFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName val_mod) name) op)) -> 
+    SQL.executeNamed
+      conn
+      ( SQL.Query
+          "INSERT INTO value_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \
+          \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)"
+      )
+      [ ":module_name" :=  P.runModuleName moduleName',
+        ":op_name" := P.runOpName op,
+        ":alias_module_name" :=  P.runModuleName val_mod,
+        ":alias" := A.encode name,
+        ":associativity" := P.showAssoc assoc,
+        ":precedence" := prec
+      ]
+  P.FixityDeclaration _ (Right (P.TypeFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName ty_mod) name) op)) ->
+    SQL.executeNamed 
+     conn 
+     ( SQL.Query
+         "INSERT INTO type_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \
+         \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)"
+     )
+     [ ":module_name" :=  P.runModuleName moduleName',
+       ":op_name" := P.runOpName op,
+       ":alias_module_name" :=  P.runModuleName ty_mod,
+       ":alias" := A.encode name,
+       ":associativity" := P.showAssoc assoc,
+       ":precedence" := prec
+     ]
+  _ -> pure ()
+
 findMap :: (a -> Maybe b) -> [a] -> Maybe b
 findMap f = listToMaybe . mapMaybe f
 
@@ -332,6 +354,8 @@ initDb conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS export_environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
   initEnvTables conn
   addDbIndexes conn
 
@@ -359,7 +383,10 @@ dropTables conn = do
   dropEnvTables conn
 
 indexExportedEnv :: (MonadIO m) => P.ModuleName -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
-indexExportedEnv moduleName env refs conn = liftIO do
+indexExportedEnv moduleName env refs conn = do 
+ when (moduleName == P.ModuleName "Data.Unit") do
+   putErrLn $ T.intercalate "\n" . fmap T.pack $ P.debugEnv env
+ liftIO do
   deleteModuleEnv
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
   envFromModule E.types & filter typeExported & mapConcurrently_ (uncurry $ insertType conn)
@@ -414,69 +441,6 @@ indexExportedEnv moduleName env refs conn = liftIO do
       P.TypeRef _ _ ctrs -> maybe False (elem (P.disqualify k)) ctrs
       _ -> False
 
-selectEnv :: (MonadIO m) => Connection -> [P.ModuleName] -> m E.Environment
-selectEnv conn deps = do
-  values <- liftIO $ join <$> mapConcurrently (selectModuleEnvValues conn) deps
-  types <- liftIO $ join <$> mapConcurrently (selectModuleEnvTypes conn) deps
-  dataConstructors <- liftIO $ join <$> mapConcurrently (selectModuleDataConstructors conn) deps
-  typeSynonyms <- liftIO $ join <$> mapConcurrently (selectModuleTypeSynonyms conn) deps
-  typeClasses <- liftIO $ join <$> mapConcurrently (selectModuleTypeClasses conn) deps
-  pure
-    E.initEnvironment
-      { E.names = Map.fromList values,
-        E.types = Map.fromList types,
-        E.dataConstructors = Map.fromList dataConstructors,
-        E.typeSynonyms = Map.fromList typeSynonyms,
-        E.typeClasses = Map.fromList typeClasses
-      }
-
-selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> P.Env -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ moduleName' decls _) env = liftIO do
-  case Map.lookup moduleName' env of
-    Just (_, P.Imports {..}, _) -> do
-      names <- selectWithKeys importedValues selectEnvValue --  importedValues & Map.keys & mapConcurrently selectValues & fmap (Map.fromList . catMaybes) --  mapConcurrently (selectEnvValue conn) <&> catMaybes <&> _
-      types <- selectWithKeys importedTypes selectType
-      typeSynonyms <- selectWithKeys importedTypes selectTypeSynonym
-      dataConstructors <- selectWithKeys importedDataConstructors selectDataConstructor
-      typeClasses <- selectWithKeys importedTypeClasses selectTypeClass
-      dicts <- selectDictsByClassName conn dictionaryClassnames
-      pure $ E.Environment names (P.allPrimTypes <> types) dataConstructors typeSynonyms (P.typeClassDictionariesEnvMap dicts) (P.allPrimClasses <> typeClasses)
-    Nothing -> pure E.initEnvironment
-  where
-    selectWithKeys :: (Ord a) => Map.Map a x -> (Connection -> a -> IO (Maybe b)) -> IO (Map.Map a b)
-    selectWithKeys a sel = a & Map.keys & mapConcurrently selWithKey <&> Map.fromList . catMaybes
-      where
-        selWithKey key = do
-          val <- sel conn key
-          pure $ fmap (key,) val
-
-    dictionaryClassnames :: [P.Qualified (P.ProperName 'P.ClassName)]
-    dictionaryClassnames = execWriter . onDecls =<< decls
-      where
-        (onDecls, _, _) = P.everywhereOnValuesM pure onExpr pure
-
-        onExpr e = do
-          case e of
-            P.TypeClassDictionary c _ _ -> tell [constraintClass c]
-            P.DeferredDictionary c _ -> tell [c]
-            P.DerivedInstancePlaceholder c _ -> tell [c]
-            _ -> pure ()
-          pure e
-
--- selectValues :: Qualified P.Ident -> IO (Maybe (Qualified P.Ident, (P.SourceType, E.NameKind, E.NameVisibility)))
--- selectValues ident = do
---   val <- selectEnvValue conn ident
---   pure $ fmap (ident, ) val
-
--- selectValues :: [Qualified P.Ident] -> IO (Map (Qualified P.Ident) (P.SourceType, E.NameKind, E.NameVisibility))
--- selectValues = _
-
-type DbQualifer a = (P.ModuleName, a)
-
-toDbQualifer :: P.Qualified a -> DbQualifer a
-toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (mn, a)
-toDbQualifer (P.Qualified (P.BySourcePos _) _) = internalError "toDbQualifer called with BySourcePos"
-
 type EnvValue = (P.SourceType, P.NameKind, P.NameVisibility)
 
 insertEnvValue :: Connection -> P.Qualified P.Ident -> EnvValue -> IO ()
@@ -486,22 +450,6 @@ insertEnvValue conn ident val =
     "INSERT OR REPLACE INTO env_values (module_name, ident, source_type, name_kind, name_visibility) VALUES (?, ?, ?, ?, ?)"
     (toDbQualifer ident :. val)
 
-selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
-selectEnvValue conn ident =
-  SQL.query
-    conn
-    "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name = ? AND ident = ?"
-    (toDbQualifer ident)
-    <&> head
-
-selectModuleEnvValues :: Connection -> P.ModuleName -> IO [(P.Qualified P.Ident, (P.SourceType, P.NameKind, P.NameVisibility))]
-selectModuleEnvValues conn moduleName' =
-  SQL.query
-    conn
-    "SELECT ident, source_type, name_kind, name_visibility FROM env_values WHERE module_name = ?"
-    (SQL.Only moduleName')
-    <&> fmap (\(ident, st, nk, nv) -> (P.Qualified (P.ByModuleName moduleName') ident, (st, nk, nv)))
-
 type EnvType = (P.SourceType, P.TypeKind)
 
 insertType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> EnvType -> IO ()
@@ -511,22 +459,6 @@ insertType conn ident val =
     "INSERT OR REPLACE INTO env_types (module_name, type_name, source_type, type_kind) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. val)
 
-selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe EnvType)
-selectType conn ident =
-  SQL.query
-    conn
-    "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?"
-    (toDbQualifer ident)
-    <&> head
-
-selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), EnvType)]
-selectModuleEnvTypes conn moduleName' =
-  SQL.query
-    conn
-    "SELECT type_name, source_type, type_kind FROM env_types WHERE module_name = ?"
-    (SQL.Only moduleName')
-    <&> fmap (\(ty, st, tk) -> (P.Qualified (P.ByModuleName moduleName') ty, (st, tk)))
-
 insertDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) -> IO ()
 insertDataConstructor conn ident (ddt, ty, st, idents) =
   SQL.execute
@@ -534,24 +466,6 @@ insertDataConstructor conn ident (ddt, ty, st, idents) =
     "INSERT OR REPLACE INTO env_data_constructors (module_name, constructor_name, data_decl_type, type_name, source_type, idents) VALUES (?, ?, ?, ?, ?, ?)"
     (toDbQualifer ident :. (ddt, ty, st, serialise idents))
 
-selectDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> IO (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
-selectDataConstructor conn ident =
-  SQL.query
-    conn
-    "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND constructor_name = ?"
-    (toDbQualifer ident)
-    <&> (head >>> fmap deserialiseIdents)
-  where
-    deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
-
-selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
-selectModuleDataConstructors conn moduleName' =
-  SQL.query
-    conn
-    "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ?"
-    (SQL.Only moduleName')
-    <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
-
 insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(Text, Maybe P.SourceType)], P.SourceType) -> IO ()
 insertTypeSynonym conn ident (idents, st) =
   SQL.execute
@@ -559,24 +473,6 @@ insertTypeSynonym conn ident (idents, st) =
     "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. (serialise idents, st))
 
-selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
-selectTypeSynonym conn ident =
-  SQL.query
-    conn
-    "SELECT idents, source_type FROM env_type_synonyms WHERE module_name = ? AND type_name = ?"
-    (toDbQualifer ident)
-    <&> (head >>> fmap deserialiseIdents)
-  where
-    deserialiseIdents (idents, st) = (deserialise idents, st)
-
-selectModuleTypeSynonyms :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), ([(Text, Maybe P.SourceType)], P.SourceType))]
-selectModuleTypeSynonyms conn moduleName' =
-  SQL.query
-    conn
-    "SELECT type_name, idents, source_type FROM env_type_synonyms WHERE module_name = ?"
-    (SQL.Only moduleName')
-    <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st)))
-
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
 insertTypeClass conn ident tcd =
   SQL.execute
@@ -584,22 +480,6 @@ insertTypeClass conn ident tcd =
     "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)"
     (toDbQualifer ident :. SQL.Only tcd)
 
-selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
-selectTypeClass conn ident =
-  SQL.query
-    conn
-    "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
-    (toDbQualifer ident)
-    <&> (fmap SQL.fromOnly . head)
-
-selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
-selectModuleTypeClasses conn moduleName' =
-  SQL.query
-    conn
-    "SELECT class_name, class FROM env_type_classes WHERE module_name = ?"
-    (SQL.Only moduleName')
-    <&> fmap (first (P.Qualified (P.ByModuleName moduleName')))
-
 insertNamedDict :: Connection -> NamedDict -> IO ()
 insertNamedDict conn dict =
   SQL.execute
@@ -607,27 +487,6 @@ insertNamedDict conn dict =
     "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_name, dict) VALUES (?, ?, ?, ?)"
     (toDbQualifer (tcdValue dict) :. (tcdClassName dict, serialise dict))
 
-selectDictsByClassName :: Connection -> [P.Qualified (P.ProperName 'P.ClassName)] -> IO [NamedDict]
-selectDictsByClassName conn classNames =
-  SQL.query 
-    conn
-    "SELECT dict FROM env_type_class_instances WHERE class_name IN (SELECT value FROM json_each(?))"
-    (SQL.Only $ A.encode classNames)
-    <&> fmap (SQL.fromOnly >>> deserialise)
-
-
--- insertTypeClassInstance ::
---   Connection ->
---   P.Qualified (P.ProperName 'P.ClassName) ->
---   P.Qualified P.Ident ->
---   NEL.NonEmpty NamedDict ->
---   IO ()
--- insertTypeClassInstance conn className instanceName dicts =
---   SQL.execute
---     conn
---     "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_name, dicts) VALUES (?, ?, ?, ?)"
---     (toDbQualifer instanceName :. (className,  serialise dicts))
-
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
new file mode 100644
index 0000000000..91e02b8ee8
--- /dev/null
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Language.PureScript.Make.Index.Select where
+
+import Codec.Serialise (deserialise)
+import Control.Arrow ((>>>))
+import Control.Concurrent.Async.Lifted (mapConcurrently)
+import Control.Monad.Writer (MonadWriter (tell), execWriter)
+import Data.Aeson qualified as A
+import Data.Map qualified as Map
+import Database.SQLite.Simple (Connection)
+import Database.SQLite.Simple qualified as SQL
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.AST.Traversals qualified as P
+import Language.PureScript.Crash (internalError)
+import Language.PureScript.Environment qualified as E
+import Language.PureScript.Environment qualified as P
+import Language.PureScript.Externs (ExternsFixity, ExternsTypeFixity)
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Sugar.Names.Env qualified as P
+import Language.PureScript.TypeChecker.Monad qualified as P
+import Language.PureScript.TypeClassDictionaries (NamedDict)
+import Language.PureScript.Types (Constraint (..))
+import Language.PureScript.Types qualified as P
+import Protolude hiding (moduleName)
+
+selectFixitiesFromModule :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
+selectFixitiesFromModule conn (P.Module _ _ _ decls _) = do
+  fixities <- selectValueFixities conn opNames
+  typeFixities <- selectTypeFixities conn typeOpNames
+  pure (fixities, typeFixities)
+  where
+    opNames :: [P.Qualified (P.OpName 'P.ValueOpName)]
+    opNames = execWriter . getDeclOps =<< decls
+
+    (getDeclOps, _, _) = P.everywhereOnValuesM pure getExprOp pure
+
+    getExprOp e = do
+      case e of
+        P.Op _ op -> tell [op] >> pure e
+        _ -> pure e
+
+    typeOpNames :: [P.Qualified (P.OpName 'P.TypeOpName)]
+    typeOpNames = getDeclTypeOps =<< decls
+
+    (getDeclTypeOps, _, _, _, _) = P.accumTypes \case
+      P.TypeOp _ op -> [op]
+      _ -> []
+
+selectValueFixities :: Connection -> [P.Qualified (P.OpName 'P.ValueOpName)] -> IO [(P.ModuleName, [ExternsFixity])]
+selectValueFixities conn ops = collectModuleNames . catMaybes <$> mapConcurrently (selectValueFixity conn) ops
+
+-- TODO: select all in module at one go for better performance
+selectValueFixity :: Connection -> P.Qualified (P.OpName 'P.ValueOpName) -> IO (Maybe (P.ModuleName, ExternsFixity))
+selectValueFixity conn (P.Qualified (P.ByModuleName m) op) =
+  SQL.query
+    conn
+    "SELECT associativity, precedence, op_name, alias FROM env_value_fixities WHERE op_name = ? and module_name = ?"
+    (op, m)
+    <&> fmap (m,) . head
+selectValueFixity _ _ = internalError "selectValueFixity called with BySourcePos"
+
+selectTypeFixities :: Connection -> [P.Qualified (P.OpName 'P.TypeOpName)] -> IO [(P.ModuleName, [ExternsTypeFixity])]
+selectTypeFixities conn ops = collectModuleNames . catMaybes <$> mapConcurrently (selectTypeFixity conn) ops
+
+selectTypeFixity :: Connection -> P.Qualified (P.OpName 'P.TypeOpName) -> IO (Maybe (P.ModuleName, ExternsTypeFixity))
+selectTypeFixity conn (P.Qualified (P.ByModuleName m) op) =
+  SQL.query
+    conn
+    "SELECT  associativity, precedence, op_name, alias FROM env_type_fixities WHERE op_name = ? and module_name = ?"
+    (op, m)
+    <&> fmap (m,) . head
+selectTypeFixity _ _ = internalError "selectTypeFixity called with BySourcePos"
+
+collectModuleNames :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
+collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
+
+selectEnv :: (MonadIO m) => Connection -> [P.ModuleName] -> m E.Environment
+selectEnv conn deps = do
+  values <- liftIO $ join <$> mapConcurrently (selectModuleEnvValues conn) deps
+  types <- liftIO $ join <$> mapConcurrently (selectModuleEnvTypes conn) deps
+  dataConstructors <- liftIO $ join <$> mapConcurrently (selectModuleDataConstructors conn) deps
+  typeSynonyms <- liftIO $ join <$> mapConcurrently (selectModuleTypeSynonyms conn) deps
+  typeClasses <- liftIO $ join <$> mapConcurrently (selectModuleTypeClasses conn) deps
+  pure
+    E.initEnvironment
+      { E.names = Map.fromList values,
+        E.types = Map.fromList types,
+        E.dataConstructors = Map.fromList dataConstructors,
+        E.typeSynonyms = Map.fromList typeSynonyms,
+        E.typeClasses = Map.fromList typeClasses
+      }
+
+selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> P.Env -> m E.Environment
+selectEnvFromImports conn (P.Module _ _ moduleName' decls _) env = do
+  case Map.lookup moduleName' env of
+    Just (_, P.Imports {..}, _) -> liftIO do
+      putErrLn (show moduleName' :: Text)
+      when (moduleName' == P.ModuleName "Data.Exists") do
+        putErrLn ("selectEnvFromImports" :: Text)
+        print importedTypes
+      names <- selectWithKeys importedValues selectEnvValue
+      types <- selectWithKeys importedTypes selectType
+      typeSynonyms <- selectWithKeys importedTypes selectTypeSynonym
+      dataConstructors <- selectWithKeys importedDataConstructors selectDataConstructor
+      typeClasses <- selectWithKeys importedTypeClasses selectTypeClass
+      dicts <- selectDictsByClassName conn dictionaryClassnames
+      pure $ E.Environment names (P.allPrimTypes <> types) dataConstructors typeSynonyms (P.typeClassDictionariesEnvMap dicts) (P.allPrimClasses <> typeClasses)
+    Nothing -> internalError $ "selectEnvFromImports: module not found in env: " <> show moduleName'
+  where
+    selectWithKeys :: (Ord a, Show a) => Map.Map a x -> (Connection -> a -> IO (Maybe b)) -> IO (Map.Map a b)
+    selectWithKeys a sel = a & Map.keys & mapConcurrently selWithKey <&> Map.fromList
+      where
+        selWithKey key = do
+          val <- sel conn key
+          case val of
+            Nothing -> internalError $ "selectEnvFromImports: key not found: " <> show key
+            Just val' -> pure (key, val')
+
+    dictionaryClassnames :: [P.Qualified (P.ProperName 'P.ClassName)]
+    dictionaryClassnames = execWriter . onDecls =<< decls
+      where
+        (onDecls, _, _) = P.everywhereOnValuesM getDeclClasses getExprClasses pure
+
+        getDeclClasses e = do
+          case e of
+            P.TypeClassDeclaration _ c _ _ _ _ -> tell [P.Qualified (P.ByModuleName moduleName') c]
+            _ -> pure ()
+          pure e
+
+        getExprClasses e = do
+          case e of
+            P.TypeClassDictionary c _ _ -> tell [constraintClass c]
+            P.DeferredDictionary c _ -> tell [c]
+            P.DerivedInstancePlaceholder c _ -> tell [c]
+            _ -> pure ()
+          pure e
+
+selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
+selectEnvValue conn ident =
+  SQL.query
+    conn
+    "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name = ? AND ident = ?"
+    (toDbQualifer ident)
+    <&> head
+
+selectModuleEnvValues :: Connection -> P.ModuleName -> IO [(P.Qualified P.Ident, (P.SourceType, P.NameKind, P.NameVisibility))]
+selectModuleEnvValues conn moduleName' =
+  SQL.query
+    conn
+    "SELECT ident, source_type, name_kind, name_visibility FROM env_values WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ident, st, nk, nv) -> (P.Qualified (P.ByModuleName moduleName') ident, (st, nk, nv)))
+
+selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe (P.SourceType, P.TypeKind))
+selectType conn ident =
+  SQL.query
+    conn
+    "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?"
+    (toDbQualifer ident)
+    <&> head
+
+selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), (P.SourceType, P.TypeKind))]
+selectModuleEnvTypes conn moduleName' =
+  SQL.query
+    conn
+    "SELECT type_name, source_type, type_kind FROM env_types WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ty, st, tk) -> (P.Qualified (P.ByModuleName moduleName') ty, (st, tk)))
+
+selectDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> IO (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
+selectDataConstructor conn ident =
+  SQL.query
+    conn
+    "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND constructor_name = ?"
+    (toDbQualifer ident)
+    <&> (head >>> fmap deserialiseIdents)
+  where
+    deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
+
+selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
+selectModuleDataConstructors conn moduleName' =
+  SQL.query
+    conn
+    "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
+
+selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
+selectTypeSynonym conn ident =
+  SQL.query
+    conn
+    "SELECT idents, source_type FROM env_type_synonyms WHERE module_name = ? AND type_name = ?"
+    (toDbQualifer ident)
+    <&> (head >>> fmap deserialiseIdents)
+  where
+    deserialiseIdents (idents, st) = (deserialise idents, st)
+
+selectModuleTypeSynonyms :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), ([(Text, Maybe P.SourceType)], P.SourceType))]
+selectModuleTypeSynonyms conn moduleName' =
+  SQL.query
+    conn
+    "SELECT type_name, idents, source_type FROM env_type_synonyms WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st)))
+
+selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
+selectTypeClass conn ident =
+  SQL.query
+    conn
+    "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
+    (toDbQualifer ident)
+    <&> (fmap SQL.fromOnly . head)
+
+selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
+selectModuleTypeClasses conn moduleName' =
+  SQL.query
+    conn
+    "SELECT class_name, class FROM env_type_classes WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (first (P.Qualified (P.ByModuleName moduleName')))
+
+selectDictsByClassName :: Connection -> [P.Qualified (P.ProperName 'P.ClassName)] -> IO [NamedDict]
+selectDictsByClassName conn classNames =
+  SQL.query
+    conn
+    "SELECT dict FROM env_type_class_instances WHERE class_name IN (SELECT value FROM json_each(?))"
+    (SQL.Only $ A.encode classNames)
+    <&> fmap (SQL.fromOnly >>> deserialise)
+
+type DbQualifer a = (P.ModuleName, a)
+
+toDbQualifer :: P.Qualified a -> DbQualifer a
+toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (mn, a)
+toDbQualifer (P.Qualified (P.BySourcePos _) _) = internalError "toDbQualifer called with BySourcePos"
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index cc0cee34a2..7dc03150ff 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -137,6 +137,12 @@ newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
 instance NFData (OpName a)
 instance Serialise (OpName a)
 
+instance ToField (OpName a) where
+  toField = toField . A.encode
+
+instance Typeable a => FromField (OpName a) where
+  fromField  f = (either (returnError ConversionFailed f) pure . A.eitherDecode) =<< fromField f
+
 instance ToJSON (OpName a) where
   toJSON = toJSON . runOpName
 
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index d093af4573..e4a3d38346 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -1,6 +1,6 @@
 -- |
 -- Desugaring passes
-module Language.PureScript.Sugar (desugar, desugarLsp, module S) where
+module Language.PureScript.Sugar (desugar, desugarUsingDb, module S) where
 
 import Control.Category ((>>>))
 import Control.Monad.Supply.Class (MonadSupply)
@@ -73,7 +73,7 @@ desugar externs =
     >=> desugarTypeClasses externs
     >=> createBindingGroupsModule
 
-desugarLsp ::
+desugarUsingDb ::
   (MonadSupply m) =>
   (MonadWriter MultipleErrors m) =>
   (MonadError MultipleErrors m) =>
@@ -83,7 +83,7 @@ desugarLsp ::
   Environment ->
   Module ->
   m Module
-desugarLsp fixities typeFixities env =
+desugarUsingDb fixities typeFixities env =
   desugarSignedLiterals
     >>> desugarObjectConstructors
     >=> desugarDoModule
@@ -92,7 +92,7 @@ desugarLsp fixities typeFixities env =
     >>> desugarCasesModule
     >=> desugarTypeDeclarationsModule
     >=> desugarImports
-    >=> rebracketFixitiesOnly fixities typeFixities
+    >=> rebracketFixitiesOnly (const True) fixities typeFixities
     >=> checkFixityExports
     >=> deriveInstances
     >=> desugarTypeClassesUsingMemberMap typeClassData
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 5f0a785c80..18f19319d1 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -10,7 +10,9 @@ module Language.PureScript.Sugar.Operators
     rebracket,
     rebracketFixitiesOnly,
     rebracketFiltered,
+    rebracketFiltered',
     checkFixityExports,
+    fromExternFixities,
   )
 where
 
@@ -78,14 +80,17 @@ rebracketFixitiesOnly ::
   forall m.
   (MonadError MultipleErrors m) =>
   (MonadSupply m) =>
+  (Declaration -> Bool) ->
   [(P.ModuleName, [ExternsFixity])] ->
   [(P.ModuleName, [ExternsTypeFixity])] ->
   Module ->
   m Module
-rebracketFixitiesOnly exFixities exTypeFixities =
-  rebracketFiltered' CalledByCompile (const False) $
-    fixities <> typeFixities
-
+rebracketFixitiesOnly pred_ exFixities exTypeFixities =
+  rebracketFiltered' CalledByCompile pred_ $ fromExternFixities exFixities exTypeFixities
+    -- fixities <> typeFixities
+-- 
+fromExternFixities :: (Foldable t1, Foldable t2) => t2 (P.ModuleName, [ExternsFixity]) -> t1 (P.ModuleName, [ExternsTypeFixity]) -> [Either ValueFixityRecord TypeFixityRecord]
+fromExternFixities exFixities exTypeFixities  = fixities <> typeFixities
   where 
     fixities = concatMap (\(mName, fs) -> fmap (fromFixity mName) fs) exFixities
     typeFixities = concatMap (\(mName, fs) -> fmap (fromTypeFixity mName) fs) exTypeFixities

From 2e15089b4ea8347aa4e0cb87bbf7ad6516cdcd21 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 2 Dec 2024 23:50:51 +0100
Subject: [PATCH 262/297] fixes operator selecting

---
 src/Language/PureScript/Make.hs              |   2 +-
 src/Language/PureScript/Make/Index.hs        |   2 -
 src/Language/PureScript/Make/Index/Select.hs | 228 +++++++++++++------
 3 files changed, 163 insertions(+), 69 deletions(-)

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 5c6744812b..b035ca11be 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -107,7 +107,7 @@ rebuildModuleWithIndexDb ::
   Maybe (Int, Int) ->
   m ExternsFile
 rebuildModuleWithIndexDb act conn exEnv m moduleIndex = do
-  env <- selectEnvFromImports conn m exEnv
+  env <- selectEnvFromImports conn m
   rebuildModuleWithProvidedEnvDb emptyCheckState act conn exEnv env m moduleIndex
 
 rebuildModuleWithProvidedEnv ::
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index fd530351b5..8362ef044c 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -384,8 +384,6 @@ dropTables conn = do
 
 indexExportedEnv :: (MonadIO m) => P.ModuleName -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
 indexExportedEnv moduleName env refs conn = do 
- when (moduleName == P.ModuleName "Data.Unit") do
-   putErrLn $ T.intercalate "\n" . fmap T.pack $ P.debugEnv env
  liftIO do
   deleteModuleEnv
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 91e02b8ee8..e2472332bf 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -4,10 +4,11 @@ module Language.PureScript.Make.Index.Select where
 
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
-import Control.Concurrent.Async.Lifted (mapConcurrently)
+import Control.Concurrent.Async.Lifted (forConcurrently, mapConcurrently)
 import Control.Monad.Writer (MonadWriter (tell), execWriter)
 import Data.Aeson qualified as A
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Database.SQLite.Simple (Connection)
 import Database.SQLite.Simple qualified as SQL
 import Language.PureScript.AST.Declarations qualified as P
@@ -17,17 +18,16 @@ import Language.PureScript.Environment qualified as E
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFixity, ExternsTypeFixity)
 import Language.PureScript.Names qualified as P
-import Language.PureScript.Sugar.Names.Env qualified as P
 import Language.PureScript.TypeChecker.Monad qualified as P
-import Language.PureScript.TypeClassDictionaries (NamedDict)
-import Language.PureScript.Types (Constraint (..))
+import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdValue))
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
+import Protolude.Partial (fromJust)
 
 selectFixitiesFromModule :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModule conn (P.Module _ _ _ decls _) = do
-  fixities <- selectValueFixities conn opNames
-  typeFixities <- selectTypeFixities conn typeOpNames
+selectFixitiesFromModule conn (P.Module _ _ modName decls _) = do
+  fixities <- selectValueFixities conn modName opNames
+  typeFixities <- selectTypeFixities conn modName typeOpNames
   pure (fixities, typeFixities)
   where
     opNames :: [P.Qualified (P.OpName 'P.ValueOpName)]
@@ -47,30 +47,35 @@ selectFixitiesFromModule conn (P.Module _ _ _ decls _) = do
       P.TypeOp _ op -> [op]
       _ -> []
 
-selectValueFixities :: Connection -> [P.Qualified (P.OpName 'P.ValueOpName)] -> IO [(P.ModuleName, [ExternsFixity])]
-selectValueFixities conn ops = collectModuleNames . catMaybes <$> mapConcurrently (selectValueFixity conn) ops
+selectValueFixities :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.ValueOpName)] -> IO [(P.ModuleName, [ExternsFixity])]
+selectValueFixities conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectValueFixity conn modName) ops
 
 -- TODO: select all in module at one go for better performance
-selectValueFixity :: Connection -> P.Qualified (P.OpName 'P.ValueOpName) -> IO (Maybe (P.ModuleName, ExternsFixity))
-selectValueFixity conn (P.Qualified (P.ByModuleName m) op) =
+selectValueFixity :: Connection -> P.ModuleName -> P.Qualified (P.OpName 'P.ValueOpName) -> IO (Maybe (P.ModuleName, ExternsFixity))
+selectValueFixity conn modName op =
   SQL.query
     conn
-    "SELECT associativity, precedence, op_name, alias FROM env_value_fixities WHERE op_name = ? and module_name = ?"
-    (op, m)
+    "SELECT associativity, precedence, op_name, alias FROM value_operators WHERE op_name = ? and module_name = ?"
+    (P.disqualify op, m)
     <&> fmap (m,) . head
-selectValueFixity _ _ = internalError "selectValueFixity called with BySourcePos"
+    where 
+      m = fromMaybe modName $ P.getQual op
 
-selectTypeFixities :: Connection -> [P.Qualified (P.OpName 'P.TypeOpName)] -> IO [(P.ModuleName, [ExternsTypeFixity])]
-selectTypeFixities conn ops = collectModuleNames . catMaybes <$> mapConcurrently (selectTypeFixity conn) ops
 
-selectTypeFixity :: Connection -> P.Qualified (P.OpName 'P.TypeOpName) -> IO (Maybe (P.ModuleName, ExternsTypeFixity))
-selectTypeFixity conn (P.Qualified (P.ByModuleName m) op) =
+
+selectTypeFixities :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.TypeOpName)] -> IO [(P.ModuleName, [ExternsTypeFixity])]
+selectTypeFixities conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectTypeFixity conn modName) ops
+
+selectTypeFixity :: Connection -> P.ModuleName -> P.Qualified (P.OpName 'P.TypeOpName) -> IO (Maybe (P.ModuleName, ExternsTypeFixity))
+selectTypeFixity conn modName op =
   SQL.query
     conn
-    "SELECT  associativity, precedence, op_name, alias FROM env_type_fixities WHERE op_name = ? and module_name = ?"
-    (op, m)
+    "SELECT  associativity, precedence, op_name, alias FROM type_operators WHERE op_name = ? and module_name = ?"
+    (P.disqualify op, m)
     <&> fmap (m,) . head
-selectTypeFixity _ _ = internalError "selectTypeFixity called with BySourcePos"
+    where 
+      m = fromMaybe modName $ P.getQual op
+
 
 collectModuleNames :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
 collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
@@ -91,50 +96,111 @@ selectEnv conn deps = do
         E.typeClasses = Map.fromList typeClasses
       }
 
-selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> P.Env -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ moduleName' decls _) env = do
-  case Map.lookup moduleName' env of
-    Just (_, P.Imports {..}, _) -> liftIO do
-      putErrLn (show moduleName' :: Text)
-      when (moduleName' == P.ModuleName "Data.Exists") do
-        putErrLn ("selectEnvFromImports" :: Text)
-        print importedTypes
-      names <- selectWithKeys importedValues selectEnvValue
-      types <- selectWithKeys importedTypes selectType
-      typeSynonyms <- selectWithKeys importedTypes selectTypeSynonym
-      dataConstructors <- selectWithKeys importedDataConstructors selectDataConstructor
-      typeClasses <- selectWithKeys importedTypeClasses selectTypeClass
-      dicts <- selectDictsByClassName conn dictionaryClassnames
-      pure $ E.Environment names (P.allPrimTypes <> types) dataConstructors typeSynonyms (P.typeClassDictionariesEnvMap dicts) (P.allPrimClasses <> typeClasses)
-    Nothing -> internalError $ "selectEnvFromImports: module not found in env: " <> show moduleName'
+selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
+selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
+  envFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
+    P.ImportDeclaration _ mName idt _ -> do
+      case idt of
+        P.Implicit -> importModule mName
+        P.Explicit refs -> do
+          edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
+          pure $ foldl' (>>>) identity edits
+        P.Hiding refs -> importModuleHiding refs mName
+    _ -> pure identity
+  pure $ foldl' (&) E.initEnvironment envFns
   where
-    selectWithKeys :: (Ord a, Show a) => Map.Map a x -> (Connection -> a -> IO (Maybe b)) -> IO (Map.Map a b)
-    selectWithKeys a sel = a & Map.keys & mapConcurrently selWithKey <&> Map.fromList
-      where
-        selWithKey key = do
-          val <- sel conn key
-          case val of
-            Nothing -> internalError $ "selectEnvFromImports: key not found: " <> show key
-            Just val' -> pure (key, val')
-
-    dictionaryClassnames :: [P.Qualified (P.ProperName 'P.ClassName)]
-    dictionaryClassnames = execWriter . onDecls =<< decls
-      where
-        (onDecls, _, _) = P.everywhereOnValuesM getDeclClasses getExprClasses pure
-
-        getDeclClasses e = do
-          case e of
-            P.TypeClassDeclaration _ c _ _ _ _ -> tell [P.Qualified (P.ByModuleName moduleName') c]
-            _ -> pure ()
-          pure e
-
-        getExprClasses e = do
-          case e of
-            P.TypeClassDictionary c _ _ -> tell [constraintClass c]
-            P.DeferredDictionary c _ -> tell [c]
-            P.DerivedInstancePlaceholder c _ -> tell [c]
-            _ -> pure ()
-          pure e
+    importModule = importModuleHiding []
+
+    importModuleHiding hideRefs mName = do
+      let hiddenIdents =
+            Set.fromList $
+              hideRefs >>= \case
+                P.ValueRef _ ident -> [ident]
+                _ -> []
+
+          hiddenTypes =
+            Set.fromList $
+              hideRefs >>= \case
+                P.TypeRef _ tyName _ -> [tyName]
+                _ -> []
+
+          hiddenCtrs =
+            Set.fromList $
+              hideRefs >>= \case
+                P.TypeRef _ _ ctrs -> fold ctrs
+                _ -> []
+          hiddenTypeClasses =
+            Set.fromList $
+              hideRefs >>= \case
+                P.TypeClassRef _ className -> [className]
+                _ -> []
+
+          hiddenInstances =
+            Set.fromList $
+              hideRefs >>= \case
+                P.TypeInstanceRef _ ident _ -> [ident]
+                _ -> []
+
+      names <-
+        filter (\(ident, _) -> not $ Set.member (P.disqualify ident) hiddenIdents)
+          <$> selectModuleEnvValues conn mName
+      types <-
+        filter (\(ty, _) -> not $ Set.member (P.disqualify ty) hiddenTypes)
+          <$> selectModuleEnvTypes conn mName
+      dataConstructors <-
+        filter (\(ctr, _) -> not $ Set.member (P.disqualify ctr) hiddenCtrs)
+          <$> selectModuleDataConstructors conn mName
+      typeSynonyms <-
+        filter (\(ty, _) -> not $ Set.member (P.disqualify ty) hiddenTypes)
+          <$> selectModuleTypeSynonyms conn mName
+      typeClasses <- 
+        filter (\(tc, _) -> not $ Set.member (P.disqualify tc) hiddenTypeClasses)
+          <$> selectModuleTypeClasses conn mName
+      instances <- 
+        filter (\inst -> not $ Set.member (P.disqualify $ tcdValue inst) hiddenInstances)
+          <$> selectModuleClassInstances conn mName
+      pure $ \env' ->
+        env'
+          { E.names = E.names env' <> Map.fromList names,
+            E.types = E.types env' <> Map.fromList types,
+            E.dataConstructors = E.dataConstructors env' <> Map.fromList dataConstructors,
+            E.typeSynonyms = E.typeSynonyms env' <> Map.fromList typeSynonyms,
+            E.typeClasses = E.typeClasses env' <> Map.fromList typeClasses,
+            E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
+          }
+
+    importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
+    importRef mName = \case
+      P.TypeClassRef _ className -> do
+        let qual = P.Qualified (P.ByModuleName mName) className
+        typeClass <- selectTypeClass conn qual
+        pure $ \env' -> env' {E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)]}
+      P.TypeRef _ tyName ctrs -> do
+        let qual = P.Qualified (P.ByModuleName mName) tyName
+        type' <- selectType conn qual
+        ctrVals <-  case ctrs of 
+          Nothing -> selectTypeDataConstructors conn qual 
+          Just ctrs' -> forConcurrently ctrs' \ctr -> do
+            let qual' = P.Qualified (P.ByModuleName mName) ctr
+            val <- selectDataConstructor conn qual'
+            pure (qual', fromJust val)
+
+        pure $ \env' ->
+          env'
+            { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
+              E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+            }
+      P.ValueRef _ ident -> do
+        let qual = P.Qualified (P.ByModuleName mName) ident
+        val <- selectEnvValue conn qual
+        pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
+      P.TypeInstanceRef _ ident _ -> do
+        let qual = P.Qualified (P.ByModuleName mName) ident
+        val <- selectClassInstance conn qual
+        pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust val]}
+      P.ModuleRef _ m -> importModule m
+      P.ReExportRef _ _ ref -> importRef mName ref
+      _ -> pure identity
 
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
 selectEnvValue conn ident =
@@ -178,6 +244,17 @@ selectDataConstructor conn ident =
   where
     deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
 
+selectTypeDataConstructors :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
+selectTypeDataConstructors conn ident =
+  SQL.query
+    conn
+    "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND type_name = ?"
+    (toDbQualifer ident)
+    <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
+  where
+    moduleName' = fromJust $ P.getQual ident
+  --   deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
+    
 selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
 selectModuleDataConstructors conn moduleName' =
   SQL.query
@@ -220,8 +297,27 @@ selectModuleTypeClasses conn moduleName' =
     (SQL.Only moduleName')
     <&> fmap (first (P.Qualified (P.ByModuleName moduleName')))
 
-selectDictsByClassName :: Connection -> [P.Qualified (P.ProperName 'P.ClassName)] -> IO [NamedDict]
-selectDictsByClassName conn classNames =
+selectClassInstance ::
+  Connection ->
+  P.Qualified P.Ident ->
+  IO (Maybe NamedDict)
+selectClassInstance conn ident =
+  SQL.query
+    conn
+    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND ident = ?"
+    (toDbQualifer ident)
+    <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
+
+selectModuleClassInstances :: Connection -> P.ModuleName -> IO [NamedDict]
+selectModuleClassInstances conn moduleName' =
+  SQL.query
+    conn
+    "SELECT dict FROM env_type_class_instances WHERE module_name = ?"
+    (SQL.Only moduleName')
+    <&> fmap (SQL.fromOnly >>> deserialise)
+
+selectClassInstancesByClassName :: Connection -> [P.Qualified (P.ProperName 'P.ClassName)] -> IO [NamedDict]
+selectClassInstancesByClassName conn classNames =
   SQL.query
     conn
     "SELECT dict FROM env_type_class_instances WHERE class_name IN (SELECT value FROM json_each(?))"

From 62519c2f64d13ada41d0d18e5efc300b7dcb3ae4 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 3 Dec 2024 00:29:51 +0100
Subject: [PATCH 263/297] type classes importing associated types

---
 src/Language/PureScript/Make/Index.hs        |  5 +-
 src/Language/PureScript/Make/Index/Select.hs | 67 ++++++++++----------
 2 files changed, 37 insertions(+), 35 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 8362ef044c..451656b6fd 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -387,7 +387,7 @@ indexExportedEnv moduleName env refs conn = do
  liftIO do
   deleteModuleEnv
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
-  envFromModule E.types & filter typeExported & mapConcurrently_ (uncurry $ insertType conn)
+  envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn)
   envFromModule E.dataConstructors & filter dataConstructorExported & mapConcurrently_ (uncurry $ insertDataConstructor conn)
   envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn)
   envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
@@ -431,6 +431,9 @@ indexExportedEnv moduleName env refs conn = do
       P.TypeClassRef _ className -> className == P.disqualify k
       _ -> False
 
+    typeOrClassExported :: (Qualified (P.ProperName 'P.TypeName), b) -> Bool
+    typeOrClassExported kv = typeExported kv || typeClassExported (first (fmap P.coerceProperName) kv)
+
     typeExported = refMatch \k -> \case
       P.TypeRef _ typeName _ -> typeName == P.disqualify k
       _ -> False
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index e2472332bf..823778b25d 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -23,6 +23,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
+import Language.PureScript.Names (coerceProperName)
 
 selectFixitiesFromModule :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModule conn (P.Module _ _ modName decls _) = do
@@ -58,10 +59,8 @@ selectValueFixity conn modName op =
     "SELECT associativity, precedence, op_name, alias FROM value_operators WHERE op_name = ? and module_name = ?"
     (P.disqualify op, m)
     <&> fmap (m,) . head
-    where 
-      m = fromMaybe modName $ P.getQual op
-
-
+  where
+    m = fromMaybe modName $ P.getQual op
 
 selectTypeFixities :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.TypeOpName)] -> IO [(P.ModuleName, [ExternsTypeFixity])]
 selectTypeFixities conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectTypeFixity conn modName) ops
@@ -73,31 +72,14 @@ selectTypeFixity conn modName op =
     "SELECT  associativity, precedence, op_name, alias FROM type_operators WHERE op_name = ? and module_name = ?"
     (P.disqualify op, m)
     <&> fmap (m,) . head
-    where 
-      m = fromMaybe modName $ P.getQual op
-
+  where
+    m = fromMaybe modName $ P.getQual op
 
 collectModuleNames :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
 collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
 
-selectEnv :: (MonadIO m) => Connection -> [P.ModuleName] -> m E.Environment
-selectEnv conn deps = do
-  values <- liftIO $ join <$> mapConcurrently (selectModuleEnvValues conn) deps
-  types <- liftIO $ join <$> mapConcurrently (selectModuleEnvTypes conn) deps
-  dataConstructors <- liftIO $ join <$> mapConcurrently (selectModuleDataConstructors conn) deps
-  typeSynonyms <- liftIO $ join <$> mapConcurrently (selectModuleTypeSynonyms conn) deps
-  typeClasses <- liftIO $ join <$> mapConcurrently (selectModuleTypeClasses conn) deps
-  pure
-    E.initEnvironment
-      { E.names = Map.fromList values,
-        E.types = Map.fromList types,
-        E.dataConstructors = Map.fromList dataConstructors,
-        E.typeSynonyms = Map.fromList typeSynonyms,
-        E.typeClasses = Map.fromList typeClasses
-      }
-
 selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
+selectEnvFromImports conn (P.Module _ _ _mName' decls _) = liftIO do
   envFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
     P.ImportDeclaration _ mName idt _ -> do
       case idt of
@@ -107,7 +89,16 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
           pure $ foldl' (>>>) identity edits
         P.Hiding refs -> importModuleHiding refs mName
     _ -> pure identity
-  pure $ foldl' (&) E.initEnvironment envFns
+  let env = foldl' (&) E.initEnvironment envFns
+      -- imports :: [(P.ModuleName, P.ImportDeclarationType)]
+      -- imports =
+      --   decls >>= \case
+      --     P.ImportDeclaration _ mName idt _ -> [(mName, idt)]
+      --     _ -> []
+  -- when (mName' == P.ModuleName "Data.HeytingAlgebra") do
+  --   (putErrLn :: [Char] -> IO ()) $ intercalate "\n" $ fmap (show :: (P.ModuleName, P.ImportDeclarationType) -> [Char]) imports
+  --   putErrLn $ intercalate "\n" $ debugTypeClasses env
+  pure env
   where
     importModule = importModuleHiding []
 
@@ -153,10 +144,10 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
       typeSynonyms <-
         filter (\(ty, _) -> not $ Set.member (P.disqualify ty) hiddenTypes)
           <$> selectModuleTypeSynonyms conn mName
-      typeClasses <- 
+      typeClasses <-
         filter (\(tc, _) -> not $ Set.member (P.disqualify tc) hiddenTypeClasses)
           <$> selectModuleTypeClasses conn mName
-      instances <- 
+      instances <-
         filter (\inst -> not $ Set.member (P.disqualify $ tcdValue inst) hiddenInstances)
           <$> selectModuleClassInstances conn mName
       pure $ \env' ->
@@ -172,23 +163,30 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
     importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
     importRef mName = \case
       P.TypeClassRef _ className -> do
-        let qual = P.Qualified (P.ByModuleName mName) className
+        let 
+           qual = P.Qualified (P.ByModuleName mName) className
+           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
         typeClass <- selectTypeClass conn qual
-        pure $ \env' -> env' {E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)]}
+        type' <- selectType conn typeQual
+        pure $ \env' ->
+          env'
+            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)]
+            , E.types = E.types env' <> Map.fromList [(typeQual, fromJust type')]
+            }
       P.TypeRef _ tyName ctrs -> do
         let qual = P.Qualified (P.ByModuleName mName) tyName
         type' <- selectType conn qual
-        ctrVals <-  case ctrs of 
-          Nothing -> selectTypeDataConstructors conn qual 
+        ctrVals <- case ctrs of
+          Nothing -> selectTypeDataConstructors conn qual
           Just ctrs' -> forConcurrently ctrs' \ctr -> do
             let qual' = P.Qualified (P.ByModuleName mName) ctr
             val <- selectDataConstructor conn qual'
             pure (qual', fromJust val)
-
         pure $ \env' ->
           env'
             { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
               E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+              -- E.typeClasses = E.typeClasses env' <> maybe mempty (\tc -> Map.fromList [(classQual, tc)]) class'
             }
       P.ValueRef _ ident -> do
         let qual = P.Qualified (P.ByModuleName mName) ident
@@ -253,8 +251,9 @@ selectTypeDataConstructors conn ident =
     <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
   where
     moduleName' = fromJust $ P.getQual ident
-  --   deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
-    
+
+--   deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
+
 selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
 selectModuleDataConstructors conn moduleName' =
   SQL.query

From af7f8fdbba51492252a8976f3b6ff41d5f3a047b Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 3 Dec 2024 23:45:37 +0100
Subject: [PATCH 264/297] operators importing

---
 src/Language/PureScript/Externs.hs            |  25 +-
 src/Language/PureScript/Make.hs               |  17 +-
 src/Language/PureScript/Make/Index.hs         |  34 ++-
 src/Language/PureScript/Make/Index/Select.hs  | 245 ++++++++++++------
 src/Language/PureScript/Names.hs              | 164 ++++++------
 .../PureScript/Sugar/Operators/Common.hs      |  14 +-
 6 files changed, 309 insertions(+), 190 deletions(-)

diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index c8c26cb2d7..bd25ba7b73 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -40,6 +40,7 @@ import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType)
 
 import Paths_purescript as Paths
 import Database.SQLite.Simple (FromRow (fromRow), field)
+import Control.Applicative ((<|>))
 
 -- | The data which will be serialized to an externs file
 data ExternsFile = ExternsFile
@@ -90,12 +91,19 @@ data ExternsFixity = ExternsFixity
   , efOperator :: OpName 'ValueOpName
   -- | The value the operator is an alias for
   , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))
-  } deriving (Show, Generic, NFData)
+  } deriving (Show, Eq, Ord, Generic, NFData)
 
 instance Serialise ExternsFixity
 
-instance FromRow ExternsFixity where 
-  fromRow = ExternsFixity <$> field <*> field <*> field <*> field
+instance FromRow ExternsFixity where
+  fromRow = do
+    assoc <- field
+    prec <- field
+    op <- field
+    aliasMod <- field
+    alias <- (Right <$> field) <|> (Left <$> field) 
+    pure $ ExternsFixity assoc prec op (Qualified (ByModuleName aliasMod) alias)
+    -- ExternsFixity <$> field <*> field <*> field <*> field
 
 -- | A type fixity declaration in an externs file
 data ExternsTypeFixity = ExternsTypeFixity
@@ -108,12 +116,17 @@ data ExternsTypeFixity = ExternsTypeFixity
   , efTypeOperator :: OpName 'TypeOpName
   -- | The value the operator is an alias for
   , efTypeAlias :: Qualified (ProperName 'TypeName)
-  } deriving (Show, Generic, NFData)
+  } deriving (Show, Eq, Ord, Generic, NFData)
 
 instance Serialise ExternsTypeFixity
 
-instance FromRow ExternsTypeFixity where 
-  fromRow = ExternsTypeFixity <$> field <*> field <*> field <*> field
+instance FromRow ExternsTypeFixity where
+  fromRow = do
+    assoc <- field
+    prec <- field
+    op <- field
+    aliasMod <- field
+    ExternsTypeFixity assoc prec op . Qualified (ByModuleName aliasMod) <$> field
 
 -- | A type or value declaration appearing in an externs file
 data ExternsDeclaration =
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index b035ca11be..e255ec0e2e 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Language.PureScript.Make
   ( -- * Make API
@@ -27,7 +28,7 @@ import Control.Monad.Writer.Class (MonadWriter (..), censor)
 import Control.Monad.Writer.Strict (MonadTrans (lift), runWriterT)
 import Data.Foldable (fold, for_)
 import Data.Function (on)
-import Data.List (foldl', sortOn)
+import Data.List (foldl', sortOn, intercalate)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
@@ -48,10 +49,10 @@ import Language.PureScript.Make.Actions as Actions
 import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult)
 import Language.PureScript.Make.BuildPlan qualified as BuildPlan
 import Language.PureScript.Make.Cache qualified as Cache
-import Language.PureScript.Make.Index.Select (selectEnvFromImports, selectFixitiesFromModule)
+import Language.PureScript.Make.Index.Select (getModuleFixities, selectEnvFromImports, selectFixitiesFromModuleImportsAndDecls, selectFixitiesFromModuleImports)
 import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
-import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
+import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName)
 import Language.PureScript.Renamer (renameInModule)
 import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, desugarUsingDb, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
@@ -59,6 +60,8 @@ import Language.PureScript.TypeChecker.Monad qualified as P
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 import Prelude
+import Language.PureScript.Docs.Types qualified as Docs
+import Protolude (Print(putErrLn))
 
 -- | Rebuild a single module.
 --
@@ -177,8 +180,12 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv env
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
-  (ops, typeOps) <- liftIO $ selectFixitiesFromModule conn m
-
+  (ops, typeOps) <- liftIO $ selectFixitiesFromModuleImports conn m
+  -- when (moduleName == ModuleName "Data.NaturalTransformation") $ do 
+  --   putErrLn ( "ops:" :: T.Text)
+  --   putErrLn $ intercalate "\n" $ fmap show ops
+  --   putErrLn ( "type ops:" :: T.Text)
+  --   putErrLn $ intercalate "\n" $ fmap show typeOps
   ((Module ss coms _ elaborated exps, checkSt), nextVar) <-
     desugarAndTypeCheckDb initialCheckState withCheckStateOnError withCheckState moduleName withPrim exEnv env ops typeOps
   let env' = P.checkEnv checkSt
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 451656b6fd..0f0b1c4698 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -195,7 +195,7 @@ indexFixity conn moduleName' = \case
       [ ":module_name" :=  P.runModuleName moduleName',
         ":op_name" := P.runOpName op,
         ":alias_module_name" :=  P.runModuleName val_mod,
-        ":alias" := A.encode name,
+        ":alias" := either P.runIdent P.runProperName name,
         ":associativity" := P.showAssoc assoc,
         ":precedence" := prec
       ]
@@ -384,7 +384,7 @@ dropTables conn = do
 
 indexExportedEnv :: (MonadIO m) => P.ModuleName -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
 indexExportedEnv moduleName env refs conn = do 
- liftIO do
+ liftIO $ labelError "indexExportedEnv" do
   deleteModuleEnv
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
   envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn)
@@ -445,7 +445,7 @@ indexExportedEnv moduleName env refs conn = do
 type EnvValue = (P.SourceType, P.NameKind, P.NameVisibility)
 
 insertEnvValue :: Connection -> P.Qualified P.Ident -> EnvValue -> IO ()
-insertEnvValue conn ident val =
+insertEnvValue conn ident val = labelError "insertEnvValue" do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_values (module_name, ident, source_type, name_kind, name_visibility) VALUES (?, ?, ?, ?, ?)"
@@ -454,39 +454,43 @@ insertEnvValue conn ident val =
 type EnvType = (P.SourceType, P.TypeKind)
 
 insertType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> EnvType -> IO ()
-insertType conn ident val =
+insertType conn ident val = labelError "insertType" do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_types (module_name, type_name, source_type, type_kind) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. val)
 
 insertDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) -> IO ()
-insertDataConstructor conn ident (ddt, ty, st, idents) =
+insertDataConstructor conn ident (ddt, ty, st, idents) = labelError "insertDataConstructor" do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_data_constructors (module_name, constructor_name, data_decl_type, type_name, source_type, idents) VALUES (?, ?, ?, ?, ?, ?)"
     (toDbQualifer ident :. (ddt, ty, st, serialise idents))
 
 insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(Text, Maybe P.SourceType)], P.SourceType) -> IO ()
-insertTypeSynonym conn ident (idents, st) =
+insertTypeSynonym conn ident (idents, st) = labelError "insertTypeSynonym" do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. (serialise idents, st))
 
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
-insertTypeClass conn ident tcd =
+insertTypeClass conn ident tcd = labelError "insertTypeClass" do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)"
     (toDbQualifer ident :. SQL.Only tcd)
 
 insertNamedDict :: Connection -> NamedDict -> IO ()
-insertNamedDict conn dict =
+insertNamedDict conn dict = labelError "insertNamedDict" do
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_name, dict) VALUES (?, ?, ?, ?)"
-    (toDbQualifer (tcdValue dict) :. (tcdClassName dict, serialise dict))
+    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, dict) VALUES (?, ?, ?, ?, ?)"
+    (toDbQualifer (tcdValue dict) :. (clasMod, className, serialise dict))
+
+  where 
+    (clasMod, className) = toDbQualifer (tcdClassName dict)
+    
 
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
@@ -495,7 +499,7 @@ initEnvTables conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT, class BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_name TEXT, dict BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_module TEXT, class_name TEXT, dict BLOB, debug TEXT)"
   addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
@@ -513,4 +517,10 @@ dropEnvTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS env_types"
   SQL.execute_ conn "DROP TABLE IF EXISTS env_data_constructors"
   SQL.execute_ conn "DROP TABLE IF EXISTS env_type_synonyms"
-  SQL.execute_ conn "DROP TABLE IF EXISTS env_type_classes"
\ No newline at end of file
+  SQL.execute_ conn "DROP TABLE IF EXISTS env_type_classes"
+
+
+labelError :: Text -> IO a -> IO a 
+labelError label action = catch action \(e :: SomeException) -> do 
+  putErrLn $ "Error: " <> label <> ": " <> show e
+  throwIO e
\ No newline at end of file
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 823778b25d..ebdf9344bb 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -5,81 +5,180 @@ module Language.PureScript.Make.Index.Select where
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
 import Control.Concurrent.Async.Lifted (forConcurrently, mapConcurrently)
-import Control.Monad.Writer (MonadWriter (tell), execWriter)
 import Data.Aeson qualified as A
+import Data.ByteString.Lazy qualified as Lazy
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Database.SQLite.Simple (Connection)
 import Database.SQLite.Simple qualified as SQL
+import Language.PureScript.AST.Declarations (ImportDeclarationType)
 import Language.PureScript.AST.Declarations qualified as P
-import Language.PureScript.AST.Traversals qualified as P
+import Language.PureScript.AST.Operators qualified as P
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Environment qualified as P
-import Language.PureScript.Externs (ExternsFixity, ExternsTypeFixity)
+import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
+import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.TypeChecker.Monad qualified as P
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdValue))
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
-import Language.PureScript.Names (coerceProperName)
-
-selectFixitiesFromModule :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModule conn (P.Module _ _ modName decls _) = do
-  fixities <- selectValueFixities conn modName opNames
-  typeFixities <- selectTypeFixities conn modName typeOpNames
-  pure (fixities, typeFixities)
-  where
-    opNames :: [P.Qualified (P.OpName 'P.ValueOpName)]
-    opNames = execWriter . getDeclOps =<< decls
-
-    (getDeclOps, _, _) = P.everywhereOnValuesM pure getExprOp pure
 
-    getExprOp e = do
-      case e of
-        P.Op _ op -> tell [op] >> pure e
-        _ -> pure e
+selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
+selectFixitiesFromModuleImportsAndDecls conn module' = labelError "selectFixitiesFromModuleImportsAndDecls" $ do
+  (fixitiesFromImports, typeFixitiesFromImports) <- selectFixitiesFromModuleImports conn module'
+  let (fixitiesFromDecls, typeFixitiesFromDecls) = getModuleFixities module'
+  pure ((P.getModuleName module', fixitiesFromDecls) : fixitiesFromImports, (P.getModuleName module', typeFixitiesFromDecls) : typeFixitiesFromImports)
 
-    typeOpNames :: [P.Qualified (P.OpName 'P.TypeOpName)]
-    typeOpNames = getDeclTypeOps =<< decls
-
-    (getDeclTypeOps, _, _, _, _) = P.accumTypes \case
-      P.TypeOp _ op -> [op]
-      _ -> []
-
-selectValueFixities :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.ValueOpName)] -> IO [(P.ModuleName, [ExternsFixity])]
-selectValueFixities conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectValueFixity conn modName) ops
+getModuleFixities :: P.Module -> ([ExternsFixity], [ExternsTypeFixity])
+getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTypeFixitiesInModule)
+  where
+    externsFixitiesInModule :: [ExternsFixity]
+    externsFixitiesInModule =
+      fixitiesInModule <&> \(P.ValueFixity (P.Fixity assoc prec) ident opName) ->
+        ExternsFixity assoc prec opName ident
+
+    externsTypeFixitiesInModule :: [ExternsTypeFixity]
+    externsTypeFixitiesInModule =
+      typeFixitiesInModule <&> \(P.TypeFixity (P.Fixity assoc prec) ident opName) ->
+        ExternsTypeFixity assoc prec opName ident
+
+    (fixitiesInModule, typeFixitiesInModule) =
+      partitionEithers $
+        decls >>= \case
+          P.FixityDeclaration _ fixity -> [fixity]
+          _ -> []
+
+selectFixitiesFromModuleImports :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
+selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _) = labelError "selectFixitiesFromModuleImports" $ do
+  valueOps <- catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn))
+  typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn))
+  pure (valueOps, typeOps)
+  where
+    onImports :: (P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [a])) -> P.Declaration -> IO (Maybe (P.ModuleName, [a]))
+    onImports f = \case
+      P.ImportDeclaration _ mn idt _ -> Just <$> f mn idt
+      _ -> pure Nothing
+
+selectImportValueFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsFixity])
+selectImportValueFixities conn modName = labelError "selectImportValueFixities" . \case
+  P.Implicit -> selectValueFixitiesFromModule conn modName
+  P.Explicit refs | refsValueOps refs /= [] -> selectExplicitValueFixitiesFromModule conn modName (refsValueOps refs)
+  P.Hiding refs -> selectNonHiddenValueFixitiesFromModule conn modName (refsValueOps refs)
+  _ -> pure (modName, [])
+
+refsValueOps :: [P.DeclarationRef] -> [P.OpName 'P.ValueOpName]
+refsValueOps = mapMaybe refValueOp
+
+refValueOp :: P.DeclarationRef -> Maybe (P.OpName 'P.ValueOpName)
+refValueOp = \case
+  P.ValueOpRef _ ident -> Just ident
+  _ -> Nothing
+
+selectValueFixitiesFromModule :: Connection -> P.ModuleName -> IO (P.ModuleName, [ExternsFixity])
+selectValueFixitiesFromModule conn modName = labelError "selectValueFixitiesFromModule" do
+  (modName,)
+    <$> SQL.query
+      conn
+      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ?"
+      (SQL.Only modName)
+
+selectExplicitValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
+selectExplicitValueFixitiesFromModule _ modName [] = pure (modName, [])
+selectExplicitValueFixitiesFromModule conn modName ops = labelError "selectExplicitValueFixitiesFromModule" do
+  (modName,)
+    <$> SQL.query
+      conn
+      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name IN (SELECT value FROM json_each(?))"
+      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
+
+selectNonHiddenValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
+selectNonHiddenValueFixitiesFromModule conn modName [] = selectValueFixitiesFromModule conn modName
+selectNonHiddenValueFixitiesFromModule conn modName ops = labelError "selectNonHiddenValueFixitiesFromModule" do
+  (modName,)
+    <$> SQL.query
+      conn
+      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name NOT IN (SELECT value FROM json_each(?))"
+      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
+
+byteToText :: Lazy.ByteString -> Text
+byteToText = decodeUtf8 . Lazy.toStrict
+
+selectImportTypeFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsTypeFixity])
+selectImportTypeFixities conn modName = \case
+  P.Implicit -> selectTypeFixitiesFromModule conn modName
+  P.Explicit refs | refsTypeOps refs /= [] -> selectExplicitTypeFixitiesFromModule conn modName (refsTypeOps refs)
+  P.Hiding refs -> selectNonHiddenTypeFixitiesFromModule conn modName (refsTypeOps refs)
+  _ -> pure (modName, [])
+
+refsTypeOps :: [P.DeclarationRef] -> [P.OpName 'P.TypeOpName]
+refsTypeOps = mapMaybe refTypeOp
+
+refTypeOp :: P.DeclarationRef -> Maybe (P.OpName 'P.TypeOpName)
+refTypeOp = \case
+  P.TypeOpRef _ ident -> Just ident
+  _ -> Nothing
+
+selectTypeFixitiesFromModule :: Connection -> P.ModuleName -> IO (P.ModuleName, [ExternsTypeFixity])
+selectTypeFixitiesFromModule conn modName = do
+  (modName,)
+    <$> SQL.query
+      conn
+      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ?"
+      (SQL.Only modName)
+
+selectExplicitTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
+selectExplicitTypeFixitiesFromModule _ modName [] = pure (modName, [])
+selectExplicitTypeFixitiesFromModule conn modName ops = labelError "selectExplicitTypeFixitiesFromModule" do
+  (modName,)
+    <$> SQL.query
+      conn
+      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name IN (SELECT value FROM json_each(?))"
+      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
+
+selectNonHiddenTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
+selectNonHiddenTypeFixitiesFromModule conn modName [] = selectTypeFixitiesFromModule conn modName
+selectNonHiddenTypeFixitiesFromModule conn modName ops = labelError "selectNonHiddenTypeFixitiesFromModule" do
+  (modName,)
+    <$> SQL.query
+      conn
+      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name NOT IN (SELECT value FROM json_each(?))"
+      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
+
+selectValueFixitiesFromNames :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.ValueOpName)] -> IO [(P.ModuleName, [ExternsFixity])]
+selectValueFixitiesFromNames conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectValueFixity conn modName) ops
 
--- TODO: select all in module at one go for better performance
 selectValueFixity :: Connection -> P.ModuleName -> P.Qualified (P.OpName 'P.ValueOpName) -> IO (Maybe (P.ModuleName, ExternsFixity))
-selectValueFixity conn modName op =
+selectValueFixity conn _modName (P.Qualified (P.ByModuleName m) op) = labelError "selectValueFixity" do
   SQL.query
     conn
-    "SELECT associativity, precedence, op_name, alias FROM value_operators WHERE op_name = ? and module_name = ?"
-    (P.disqualify op, m)
+    "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE op_name = ? and module_name = ?"
+    (op, m)
     <&> fmap (m,) . head
-  where
-    m = fromMaybe modName $ P.getQual op
+selectValueFixity _ _ _ = pure Nothing
+
+-- where
+--   m = fromMaybe modName $ P.getQual op
 
-selectTypeFixities :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.TypeOpName)] -> IO [(P.ModuleName, [ExternsTypeFixity])]
-selectTypeFixities conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectTypeFixity conn modName) ops
+selectTypeFixitiesFromNames :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.TypeOpName)] -> IO [(P.ModuleName, [ExternsTypeFixity])]
+selectTypeFixitiesFromNames conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectTypeFixity conn modName) ops
 
 selectTypeFixity :: Connection -> P.ModuleName -> P.Qualified (P.OpName 'P.TypeOpName) -> IO (Maybe (P.ModuleName, ExternsTypeFixity))
-selectTypeFixity conn modName op =
+selectTypeFixity conn _modName (P.Qualified (P.ByModuleName m) op) =
   SQL.query
     conn
-    "SELECT  associativity, precedence, op_name, alias FROM type_operators WHERE op_name = ? and module_name = ?"
-    (P.disqualify op, m)
+    "SELECT  associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE op_name = ? and module_name = ?"
+    (op, m)
     <&> fmap (m,) . head
-  where
-    m = fromMaybe modName $ P.getQual op
+selectTypeFixity _ _ _ = pure Nothing
 
-collectModuleNames :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
-collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
+collectModuleNames :: (Ord a) => [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
+collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure) . ordNub
 
 selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ _mName' decls _) = liftIO do
+selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
   envFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
     P.ImportDeclaration _ mName idt _ -> do
       case idt of
@@ -90,15 +189,7 @@ selectEnvFromImports conn (P.Module _ _ _mName' decls _) = liftIO do
         P.Hiding refs -> importModuleHiding refs mName
     _ -> pure identity
   let env = foldl' (&) E.initEnvironment envFns
-      -- imports :: [(P.ModuleName, P.ImportDeclarationType)]
-      -- imports =
-      --   decls >>= \case
-      --     P.ImportDeclaration _ mName idt _ -> [(mName, idt)]
-      --     _ -> []
-  -- when (mName' == P.ModuleName "Data.HeytingAlgebra") do
-  --   (putErrLn :: [Char] -> IO ()) $ intercalate "\n" $ fmap (show :: (P.ModuleName, P.ImportDeclarationType) -> [Char]) imports
-  --   putErrLn $ intercalate "\n" $ debugTypeClasses env
-  pure env
+  return env
   where
     importModule = importModuleHiding []
 
@@ -163,15 +254,14 @@ selectEnvFromImports conn (P.Module _ _ _mName' decls _) = liftIO do
     importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
     importRef mName = \case
       P.TypeClassRef _ className -> do
-        let 
-           qual = P.Qualified (P.ByModuleName mName) className
-           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
+        let qual = P.Qualified (P.ByModuleName mName) className
+            typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
         typeClass <- selectTypeClass conn qual
         type' <- selectType conn typeQual
         pure $ \env' ->
           env'
-            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)]
-            , E.types = E.types env' <> Map.fromList [(typeQual, fromJust type')]
+            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)],
+              E.types = E.types env' <> Map.fromList [(typeQual, fromJust type')]
             }
       P.TypeRef _ tyName ctrs -> do
         let qual = P.Qualified (P.ByModuleName mName) tyName
@@ -201,7 +291,7 @@ selectEnvFromImports conn (P.Module _ _ _mName' decls _) = liftIO do
       _ -> pure identity
 
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
-selectEnvValue conn ident =
+selectEnvValue conn ident = labelError "selectEnvValue" do
   SQL.query
     conn
     "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name = ? AND ident = ?"
@@ -209,7 +299,7 @@ selectEnvValue conn ident =
     <&> head
 
 selectModuleEnvValues :: Connection -> P.ModuleName -> IO [(P.Qualified P.Ident, (P.SourceType, P.NameKind, P.NameVisibility))]
-selectModuleEnvValues conn moduleName' =
+selectModuleEnvValues conn moduleName' = labelError "selectModuleEnvValues" do
   SQL.query
     conn
     "SELECT ident, source_type, name_kind, name_visibility FROM env_values WHERE module_name = ?"
@@ -217,7 +307,7 @@ selectModuleEnvValues conn moduleName' =
     <&> fmap (\(ident, st, nk, nv) -> (P.Qualified (P.ByModuleName moduleName') ident, (st, nk, nv)))
 
 selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe (P.SourceType, P.TypeKind))
-selectType conn ident =
+selectType conn ident = labelError "selectType" do
   SQL.query
     conn
     "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?"
@@ -225,7 +315,7 @@ selectType conn ident =
     <&> head
 
 selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), (P.SourceType, P.TypeKind))]
-selectModuleEnvTypes conn moduleName' =
+selectModuleEnvTypes conn moduleName' = labelError "selectModuleEnvTypes" do
   SQL.query
     conn
     "SELECT type_name, source_type, type_kind FROM env_types WHERE module_name = ?"
@@ -233,7 +323,7 @@ selectModuleEnvTypes conn moduleName' =
     <&> fmap (\(ty, st, tk) -> (P.Qualified (P.ByModuleName moduleName') ty, (st, tk)))
 
 selectDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> IO (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
-selectDataConstructor conn ident =
+selectDataConstructor conn ident = labelError "selectDataConstructor" do
   SQL.query
     conn
     "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND constructor_name = ?"
@@ -243,7 +333,7 @@ selectDataConstructor conn ident =
     deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
 
 selectTypeDataConstructors :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
-selectTypeDataConstructors conn ident =
+selectTypeDataConstructors conn ident = labelError "selectTypeDataConstructors" do
   SQL.query
     conn
     "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND type_name = ?"
@@ -255,7 +345,7 @@ selectTypeDataConstructors conn ident =
 --   deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
 
 selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
-selectModuleDataConstructors conn moduleName' =
+selectModuleDataConstructors conn moduleName' = labelError "selectModuleDataConstructors" do
   SQL.query
     conn
     "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ?"
@@ -263,7 +353,7 @@ selectModuleDataConstructors conn moduleName' =
     <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
 
 selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
-selectTypeSynonym conn ident =
+selectTypeSynonym conn ident = labelError "selectTypeSynonym" do
   SQL.query
     conn
     "SELECT idents, source_type FROM env_type_synonyms WHERE module_name = ? AND type_name = ?"
@@ -273,7 +363,7 @@ selectTypeSynonym conn ident =
     deserialiseIdents (idents, st) = (deserialise idents, st)
 
 selectModuleTypeSynonyms :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), ([(Text, Maybe P.SourceType)], P.SourceType))]
-selectModuleTypeSynonyms conn moduleName' =
+selectModuleTypeSynonyms conn moduleName' = labelError "selectModuleTypeSynonyms" do
   SQL.query
     conn
     "SELECT type_name, idents, source_type FROM env_type_synonyms WHERE module_name = ?"
@@ -281,7 +371,7 @@ selectModuleTypeSynonyms conn moduleName' =
     <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st)))
 
 selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
-selectTypeClass conn ident =
+selectTypeClass conn ident = labelError "selectTypeClass" do
   SQL.query
     conn
     "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
@@ -289,7 +379,7 @@ selectTypeClass conn ident =
     <&> (fmap SQL.fromOnly . head)
 
 selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
-selectModuleTypeClasses conn moduleName' =
+selectModuleTypeClasses conn moduleName' = labelError "selectModuleTypeClasses" do
   SQL.query
     conn
     "SELECT class_name, class FROM env_type_classes WHERE module_name = ?"
@@ -300,7 +390,7 @@ selectClassInstance ::
   Connection ->
   P.Qualified P.Ident ->
   IO (Maybe NamedDict)
-selectClassInstance conn ident =
+selectClassInstance conn ident =  labelError "selectClassInstance" do
   SQL.query
     conn
     "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND ident = ?"
@@ -308,20 +398,19 @@ selectClassInstance conn ident =
     <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
 
 selectModuleClassInstances :: Connection -> P.ModuleName -> IO [NamedDict]
-selectModuleClassInstances conn moduleName' =
+selectModuleClassInstances conn moduleName' = labelError "selectModuleClassInstances" do
   SQL.query
     conn
     "SELECT dict FROM env_type_class_instances WHERE module_name = ?"
     (SQL.Only moduleName')
     <&> fmap (SQL.fromOnly >>> deserialise)
 
-selectClassInstancesByClassName :: Connection -> [P.Qualified (P.ProperName 'P.ClassName)] -> IO [NamedDict]
-selectClassInstancesByClassName conn classNames =
-  SQL.query
-    conn
-    "SELECT dict FROM env_type_class_instances WHERE class_name IN (SELECT value FROM json_each(?))"
-    (SQL.Only $ A.encode classNames)
-    <&> fmap (SQL.fromOnly >>> deserialise)
+
+labelError :: Text -> IO a -> IO a 
+labelError label action = catch action \(e :: SomeException) -> do 
+  putErrLn $ "Error: " <> label <> ": " <> show e
+  throwIO e
+
 
 type DbQualifer a = (P.ModuleName, a)
 
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index 7dc03150ff..cf29011816 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -1,31 +1,28 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 -- |
 -- Data types for names
---
 module Language.PureScript.Names where
 
-import Prelude
-
 import Codec.Serialise (Serialise)
 import Control.Applicative ((<|>))
-import Control.Monad.Supply.Class (MonadSupply(..))
 import Control.DeepSeq (NFData)
-import Data.Functor.Contravariant (contramap)
-import Data.Vector qualified as V
-
-import GHC.Generics (Generic)
-import Data.Aeson (FromJSON(..), FromJSONKey(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..), defaultOptions, parseJSON2, toJSON2, withArray)
+import Control.Monad.Supply.Class (MonadSupply (..))
+import Data.Aeson (FromJSON (..), FromJSONKey (..), Options (..), SumEncoding (..), ToJSON (..), ToJSONKey (..), defaultOptions, parseJSON2, toJSON2, withArray)
+import Data.Aeson qualified as A
 import Data.Aeson.TH (deriveJSON)
+import Data.Functor.Contravariant (contramap)
 import Data.Text (Text)
 import Data.Text qualified as T
-
-import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
-import Data.Aeson qualified as A
+import Data.Vector qualified as V
+import Database.SQLite.Simple.FromField (FromField (fromField))
 import Database.SQLite.Simple.ToField (ToField (toField))
-import Database.SQLite.Simple.FromField (FromField (fromField), ResultError (ConversionFailed), returnError)
-import Data.Data (Typeable)
+import GHC.Generics (Generic)
+import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
+import Prelude
+import Language.PureScript.Crash (internalError)
+import Protolude (isUpper)
 
 -- | A sum of the possible name types, useful for error and lint messages.
 data Name
@@ -39,6 +36,7 @@ data Name
   deriving (Eq, Ord, Show, Generic)
 
 instance NFData Name
+
 instance Serialise Name
 
 getIdentName :: Name -> Maybe Ident
@@ -71,39 +69,44 @@ getClassName _ = Nothing
 -- `Ident` because functions that match on `Ident` can ignore all
 -- `InternalIdent`s with a single pattern, and thus don't have to change if
 -- a new `InternalIdentData` constructor is created.
---
 data InternalIdentData
-  -- Used by CoreFn.Laziness
-  = RuntimeLazyFactory | Lazy !Text
+  = -- Used by CoreFn.Laziness
+    RuntimeLazyFactory
+  | Lazy !Text
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData InternalIdentData
+
 instance Serialise InternalIdentData
 
 -- |
 -- Names for value identifiers
---
 data Ident
-  -- |
-  -- An alphanumeric identifier
-  --
-  = Ident Text
-  -- |
-  -- A generated name for an identifier
-  --
-  | GenIdent (Maybe Text) Integer
-  -- |
-  -- A generated name used only for type-checking
-  --
-  | UnusedIdent
-  -- |
-  -- A generated name used only for internal transformations
-  --
-  | InternalIdent !InternalIdentData
+  = -- |
+    -- An alphanumeric identifier
+    Ident Text
+  | -- |
+    -- A generated name for an identifier
+    GenIdent (Maybe Text) Integer
+  | -- |
+    -- A generated name used only for type-checking
+    UnusedIdent
+  | -- |
+    -- A generated name used only for internal transformations
+    InternalIdent !InternalIdentData
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData Ident
+
 instance Serialise Ident
+instance ToField Ident where
+  toField = \case 
+    Ident a -> toField a
+    _ -> internalError "unexpected InternalIdent in DB"
+    
+
+instance FromField Ident where
+  fromField a = Ident <$> fromField a
 
 unusedIdent :: Text
 unusedIdent = "$__unused"
@@ -113,35 +116,35 @@ runIdent (Ident i) = i
 runIdent (GenIdent Nothing n) = "$" <> T.pack (show n)
 runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n)
 runIdent UnusedIdent = unusedIdent
-runIdent InternalIdent{} = error "unexpected InternalIdent"
+runIdent InternalIdent {} = error "unexpected InternalIdent"
 
 showIdent :: Ident -> Text
 showIdent = runIdent
 
-freshIdent :: MonadSupply m => Text -> m Ident
+freshIdent :: (MonadSupply m) => Text -> m Ident
 freshIdent name = GenIdent (Just name) <$> fresh
 
-freshIdent' :: MonadSupply m => m Ident
+freshIdent' :: (MonadSupply m) => m Ident
 freshIdent' = GenIdent Nothing <$> fresh
 
 isPlainIdent :: Ident -> Bool
-isPlainIdent Ident{} = True
+isPlainIdent Ident {} = True
 isPlainIdent _ = False
 
 -- |
 -- Operator alias names.
---
-newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
+newtype OpName (a :: OpNameType) = OpName {runOpName :: Text}
   deriving (Show, Eq, Ord, Generic)
 
 instance NFData (OpName a)
+
 instance Serialise (OpName a)
 
 instance ToField (OpName a) where
-  toField = toField . A.encode
+  toField  (OpName a) = toField a
 
-instance Typeable a => FromField (OpName a) where
-  fromField  f = (either (returnError ConversionFailed f) pure . A.eitherDecode) =<< fromField f
+instance FromField (OpName a) where
+  fromField a = OpName <$> fromField a
 
 instance ToJSON (OpName a) where
   toJSON = toJSON . runOpName
@@ -154,7 +157,6 @@ showOp op = "(" <> runOpName op <> ")"
 
 -- |
 -- The closed set of operator alias types.
---
 data OpNameType = ValueOpName | TypeOpName | AnyOpName
 
 eraseOpName :: OpName a -> OpName 'AnyOpName
@@ -165,12 +167,11 @@ coerceOpName = OpName . runOpName
 
 -- |
 -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
---
-newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
+newtype ProperName (a :: ProperNameType) = ProperName {runProperName :: Text}
   deriving (Show, Eq, Ord, Generic)
-  deriving newtype (ToField, FromField)
 
 instance NFData (ProperName a)
+
 instance Serialise (ProperName a)
 
 instance ToJSON (ProperName a) where
@@ -179,11 +180,19 @@ instance ToJSON (ProperName a) where
 instance FromJSON (ProperName a) where
   parseJSON = fmap ProperName . parseJSON
 
-  
 
+instance ToField (ProperName a) where
+  toField  (ProperName a) = toField a
+
+instance FromField (ProperName a) where
+  fromField a = do 
+    n <- fromField a
+    if isUpper $ T.head n then
+      pure $ ProperName n
+    else
+      fail "ProperName must be capitalized"
 -- |
 -- The closed set of proper name types.
---
 data ProperNameType
   = TypeName
   | ConstructorName
@@ -195,13 +204,11 @@ data ProperNameType
 -- Coerces a ProperName from one ProperNameType to another. This should be used
 -- with care, and is primarily used to convert ClassNames into TypeNames after
 -- classes have been desugared.
---
 coerceProperName :: ProperName a -> ProperName b
 coerceProperName = ProperName . runProperName
 
 -- |
 -- Module names
---
 newtype ModuleName = ModuleName Text
   deriving (Show, Eq, Ord, Generic)
   deriving newtype (Serialise, ToField, FromField)
@@ -226,6 +233,7 @@ pattern ByNullSourcePos :: QualifiedBy
 pattern ByNullSourcePos = BySourcePos (SourcePos 0 0)
 
 instance NFData QualifiedBy
+
 instance Serialise QualifiedBy
 
 isBySourcePos :: QualifiedBy -> Bool
@@ -242,20 +250,15 @@ toMaybeModuleName (BySourcePos _) = Nothing
 
 -- |
 -- A qualified name, i.e. a name with an optional module name
---
 data Qualified a = Qualified QualifiedBy a
   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
 
-instance NFData a => NFData (Qualified a)
-instance Serialise a => Serialise (Qualified a)
-instance ToJSON a => ToField (Qualified a) where
-  toField = toField . A.encode
-
-instance (FromJSON a, Typeable a) => FromField (Qualified a) where
-  fromField  f = (either (returnError ConversionFailed f) pure . A.eitherDecode) =<< fromField f
+instance (NFData a) => NFData (Qualified a)
 
+instance (Serialise a) => Serialise (Qualified a)
+    
 showQualified :: (a -> Text) -> Qualified a -> Text
-showQualified f (Qualified (BySourcePos  _) a) = f a
+showQualified f (Qualified (BySourcePos _) a) = f a
 showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a
 
 getQual :: Qualified a -> Maybe ModuleName
@@ -263,14 +266,12 @@ getQual (Qualified qb _) = toMaybeModuleName qb
 
 -- |
 -- Provide a default module name, if a name is unqualified
---
 qualify :: ModuleName -> Qualified a -> (ModuleName, a)
 qualify m (Qualified (BySourcePos _) a) = (m, a)
 qualify _ (Qualified (ByModuleName m) a) = (m, a)
 
 -- |
 -- Makes a qualified value from a name and module name.
---
 mkQualified :: a -> ModuleName -> Qualified a
 mkQualified name mn = Qualified (ByModuleName mn) name
 
@@ -281,48 +282,44 @@ disqualify (Qualified _ a) = a
 -- |
 -- Remove the qualification from a value when it is qualified with a particular
 -- module name.
---
 disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a
 disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a
 disqualifyFor _ _ = Nothing
 
 -- |
 -- Checks whether a qualified value is actually qualified with a module reference
---
 isQualified :: Qualified a -> Bool
-isQualified (Qualified (BySourcePos  _) _) = False
+isQualified (Qualified (BySourcePos _) _) = False
 isQualified _ = True
 
 -- |
 -- Checks whether a qualified value is not actually qualified with a module reference
---
 isUnqualified :: Qualified a -> Bool
 isUnqualified = not . isQualified
 
 -- |
 -- Checks whether a qualified value is qualified with a particular module
---
 isQualifiedWith :: ModuleName -> Qualified a -> Bool
 isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn'
 isQualifiedWith _ _ = False
 
-instance ToJSON a => ToJSON (Qualified a) where
+instance (ToJSON a) => ToJSON (Qualified a) where
   toJSON (Qualified qb a) = case qb of
     ByModuleName mn -> toJSON2 (mn, a)
     BySourcePos ss -> toJSON2 (ss, a)
 
-instance FromJSON a => FromJSON (Qualified a) where
+instance (FromJSON a) => FromJSON (Qualified a) where
   parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName'
     where
-    byModule = do
-      (mn, a) <- parseJSON2 v
-      pure $ Qualified (ByModuleName mn) a
-    bySourcePos = do
-      (ss, a) <- parseJSON2 v
-      pure $ Qualified (BySourcePos ss) a
-    byMaybeModuleName' = do
-      (mn, a) <- parseJSON2 v
-      pure $ Qualified (byMaybeModuleName mn) a
+      byModule = do
+        (mn, a) <- parseJSON2 v
+        pure $ Qualified (ByModuleName mn) a
+      bySourcePos = do
+        (ss, a) <- parseJSON2 v
+        pure $ Qualified (BySourcePos ss) a
+      byMaybeModuleName' = do
+        (mn, a) <- parseJSON2 v
+        pure $ Qualified (byMaybeModuleName mn) a
 
 instance ToJSON ModuleName where
   toJSON (ModuleName name) = toJSON (T.splitOn "." name)
@@ -338,12 +335,7 @@ instance ToJSONKey ModuleName where
 instance FromJSONKey ModuleName where
   fromJSONKey = fmap moduleNameFromString fromJSONKey
 
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData)
-$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident)
-
-instance ToField Ident where 
-  toField = toField . A.encode
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''InternalIdentData)
+$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Ident)
 
 
-instance FromField Ident where
-  fromField  f = (either (returnError ConversionFailed f) pure . A.eitherDecode) =<< fromField f
diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs
index 7fd6df9645..2132210f6a 100644
--- a/src/Language/PureScript/Sugar/Operators/Common.hs
+++ b/src/Language/PureScript/Sugar/Operators/Common.hs
@@ -1,4 +1,5 @@
-module Language.PureScript.Sugar.Operators.Common where
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+module Language.PureScript.Sugar.Operators.Common (Chain, matchOperators, token) where
 
 import Prelude
 
@@ -104,9 +105,10 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains
       opInfo :: M.Map (Qualified (OpName nameType)) (Integer, Associativity)
       opInfo = M.fromList $ concatMap (\(n, o) -> map (\(name, assoc) -> (name, (n, assoc))) o) (zip [0..] ops)
       opPrec :: Qualified (OpName nameType) -> Integer
-      opPrec = fst . fromJust . flip M.lookup opInfo
+      opPrec a = fst $ fromJust' a  $ M.lookup a opInfo
       opAssoc :: Qualified (OpName nameType) -> Associativity
-      opAssoc = snd . fromJust . flip M.lookup opInfo
+      opAssoc a = snd $ fromJust' a  $ M.lookup a opInfo 
+
       chainOpSpans :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan)
       chainOpSpans = foldr (\(ss, name) -> M.alter (Just . maybe (pure ss) (NEL.cons ss)) name) M.empty . mapMaybe fromOp $ rights chain
       opUsages :: Qualified (OpName nameType) -> Int
@@ -142,3 +144,9 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains
   mkPositionedError chainOpSpans grp =
     ErrorMessage
       [PositionedError (fromJust . flip M.lookup chainOpSpans =<< grp)]
+
+fromJust' :: Show a => a -> Maybe b -> b
+fromJust' a m = case m of 
+  Just b -> b
+  Nothing -> internalError $ "mkErrors: lookup not found for: " ++ show a
+        
\ No newline at end of file

From c1e361952f693ce845e7c56936ddd7a3823efacd Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 4 Dec 2024 00:27:58 +0100
Subject: [PATCH 265/297] clean up

---
 src/Language/PureScript/Make/Index.hs        | 61 ++++++++-----------
 src/Language/PureScript/Make/Index/Select.hs | 63 +++++++-------------
 2 files changed, 48 insertions(+), 76 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 0f0b1c4698..adce9e0421 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -20,6 +20,7 @@ where
 
 import Codec.Serialise (serialise)
 import Control.Concurrent.Async.Lifted (mapConcurrently_)
+import Data.Aeson qualified as A
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -37,12 +38,11 @@ import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), declNameTy
 import Language.PureScript.Lsp.Print (addDataDeclArgKind, printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType, printTypeClassKind)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
+import Language.PureScript.Make.Index.Select (toDbQualifer)
 import Language.PureScript.Names (Qualified ())
 import Language.PureScript.TypeChecker.Monad (emptyCheckState)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue))
 import Protolude hiding (moduleName)
-import Data.Aeson qualified as A
-import Language.PureScript.Make.Index.Select (toDbQualifer)
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
@@ -185,34 +185,34 @@ indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs
 
 indexFixity :: Connection -> P.ModuleName -> P.Declaration -> IO ()
 indexFixity conn moduleName' = \case
-  P.FixityDeclaration _ (Left (P.ValueFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName val_mod) name) op)) -> 
+  P.FixityDeclaration _ (Left (P.ValueFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName val_mod) name) op)) ->
     SQL.executeNamed
       conn
       ( SQL.Query
           "INSERT INTO value_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \
           \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)"
       )
-      [ ":module_name" :=  P.runModuleName moduleName',
+      [ ":module_name" := P.runModuleName moduleName',
         ":op_name" := P.runOpName op,
-        ":alias_module_name" :=  P.runModuleName val_mod,
+        ":alias_module_name" := P.runModuleName val_mod,
         ":alias" := either P.runIdent P.runProperName name,
         ":associativity" := P.showAssoc assoc,
         ":precedence" := prec
       ]
   P.FixityDeclaration _ (Right (P.TypeFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName ty_mod) name) op)) ->
-    SQL.executeNamed 
-     conn 
-     ( SQL.Query
-         "INSERT INTO type_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \
-         \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)"
-     )
-     [ ":module_name" :=  P.runModuleName moduleName',
-       ":op_name" := P.runOpName op,
-       ":alias_module_name" :=  P.runModuleName ty_mod,
-       ":alias" := A.encode name,
-       ":associativity" := P.showAssoc assoc,
-       ":precedence" := prec
-     ]
+    SQL.executeNamed
+      conn
+      ( SQL.Query
+          "INSERT INTO type_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \
+          \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)"
+      )
+      [ ":module_name" := P.runModuleName moduleName',
+        ":op_name" := P.runOpName op,
+        ":alias_module_name" := P.runModuleName ty_mod,
+        ":alias" := A.encode name,
+        ":associativity" := P.showAssoc assoc,
+        ":precedence" := prec
+      ]
   _ -> pure ()
 
 findMap :: (a -> Maybe b) -> [a] -> Maybe b
@@ -383,8 +383,7 @@ dropTables conn = do
   dropEnvTables conn
 
 indexExportedEnv :: (MonadIO m) => P.ModuleName -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
-indexExportedEnv moduleName env refs conn = do 
- liftIO $ labelError "indexExportedEnv" do
+indexExportedEnv moduleName env refs conn = liftIO do
   deleteModuleEnv
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
   envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn)
@@ -445,7 +444,7 @@ indexExportedEnv moduleName env refs conn = do
 type EnvValue = (P.SourceType, P.NameKind, P.NameVisibility)
 
 insertEnvValue :: Connection -> P.Qualified P.Ident -> EnvValue -> IO ()
-insertEnvValue conn ident val = labelError "insertEnvValue" do
+insertEnvValue conn ident val = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_values (module_name, ident, source_type, name_kind, name_visibility) VALUES (?, ?, ?, ?, ?)"
@@ -454,43 +453,41 @@ insertEnvValue conn ident val = labelError "insertEnvValue" do
 type EnvType = (P.SourceType, P.TypeKind)
 
 insertType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> EnvType -> IO ()
-insertType conn ident val = labelError "insertType" do
+insertType conn ident val = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_types (module_name, type_name, source_type, type_kind) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. val)
 
 insertDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) -> IO ()
-insertDataConstructor conn ident (ddt, ty, st, idents) = labelError "insertDataConstructor" do
+insertDataConstructor conn ident (ddt, ty, st, idents) = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_data_constructors (module_name, constructor_name, data_decl_type, type_name, source_type, idents) VALUES (?, ?, ?, ?, ?, ?)"
     (toDbQualifer ident :. (ddt, ty, st, serialise idents))
 
 insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(Text, Maybe P.SourceType)], P.SourceType) -> IO ()
-insertTypeSynonym conn ident (idents, st) = labelError "insertTypeSynonym" do
+insertTypeSynonym conn ident (idents, st) = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type) VALUES (?, ?, ?, ?)"
     (toDbQualifer ident :. (serialise idents, st))
 
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
-insertTypeClass conn ident tcd = labelError "insertTypeClass" do
+insertTypeClass conn ident tcd = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)"
     (toDbQualifer ident :. SQL.Only tcd)
 
 insertNamedDict :: Connection -> NamedDict -> IO ()
-insertNamedDict conn dict = labelError "insertNamedDict" do
+insertNamedDict conn dict = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, dict) VALUES (?, ?, ?, ?, ?)"
     (toDbQualifer (tcdValue dict) :. (clasMod, className, serialise dict))
-
-  where 
+  where
     (clasMod, className) = toDbQualifer (tcdClassName dict)
-    
 
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
@@ -518,9 +515,3 @@ dropEnvTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS env_data_constructors"
   SQL.execute_ conn "DROP TABLE IF EXISTS env_type_synonyms"
   SQL.execute_ conn "DROP TABLE IF EXISTS env_type_classes"
-
-
-labelError :: Text -> IO a -> IO a 
-labelError label action = catch action \(e :: SomeException) -> do 
-  putErrLn $ "Error: " <> label <> ": " <> show e
-  throwIO e
\ No newline at end of file
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index ebdf9344bb..cf952943ac 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -27,7 +27,7 @@ import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModuleImportsAndDecls conn module' = labelError "selectFixitiesFromModuleImportsAndDecls" $ do
+selectFixitiesFromModuleImportsAndDecls conn module' = do
   (fixitiesFromImports, typeFixitiesFromImports) <- selectFixitiesFromModuleImports conn module'
   let (fixitiesFromDecls, typeFixitiesFromDecls) = getModuleFixities module'
   pure ((P.getModuleName module', fixitiesFromDecls) : fixitiesFromImports, (P.getModuleName module', typeFixitiesFromDecls) : typeFixitiesFromImports)
@@ -52,7 +52,7 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
           _ -> []
 
 selectFixitiesFromModuleImports :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _) = labelError "selectFixitiesFromModuleImports" $ do
+selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _) =  do
   valueOps <- catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn))
   typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn))
   pure (valueOps, typeOps)
@@ -63,7 +63,7 @@ selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _) = labelError "sele
       _ -> pure Nothing
 
 selectImportValueFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsFixity])
-selectImportValueFixities conn modName = labelError "selectImportValueFixities" . \case
+selectImportValueFixities conn modName = \case
   P.Implicit -> selectValueFixitiesFromModule conn modName
   P.Explicit refs | refsValueOps refs /= [] -> selectExplicitValueFixitiesFromModule conn modName (refsValueOps refs)
   P.Hiding refs -> selectNonHiddenValueFixitiesFromModule conn modName (refsValueOps refs)
@@ -78,7 +78,7 @@ refValueOp = \case
   _ -> Nothing
 
 selectValueFixitiesFromModule :: Connection -> P.ModuleName -> IO (P.ModuleName, [ExternsFixity])
-selectValueFixitiesFromModule conn modName = labelError "selectValueFixitiesFromModule" do
+selectValueFixitiesFromModule conn modName =  do
   (modName,)
     <$> SQL.query
       conn
@@ -87,7 +87,7 @@ selectValueFixitiesFromModule conn modName = labelError "selectValueFixitiesFrom
 
 selectExplicitValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
 selectExplicitValueFixitiesFromModule _ modName [] = pure (modName, [])
-selectExplicitValueFixitiesFromModule conn modName ops = labelError "selectExplicitValueFixitiesFromModule" do
+selectExplicitValueFixitiesFromModule conn modName ops =  do
   (modName,)
     <$> SQL.query
       conn
@@ -96,7 +96,7 @@ selectExplicitValueFixitiesFromModule conn modName ops = labelError "selectExpli
 
 selectNonHiddenValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
 selectNonHiddenValueFixitiesFromModule conn modName [] = selectValueFixitiesFromModule conn modName
-selectNonHiddenValueFixitiesFromModule conn modName ops = labelError "selectNonHiddenValueFixitiesFromModule" do
+selectNonHiddenValueFixitiesFromModule conn modName ops =  do
   (modName,)
     <$> SQL.query
       conn
@@ -131,7 +131,7 @@ selectTypeFixitiesFromModule conn modName = do
 
 selectExplicitTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
 selectExplicitTypeFixitiesFromModule _ modName [] = pure (modName, [])
-selectExplicitTypeFixitiesFromModule conn modName ops = labelError "selectExplicitTypeFixitiesFromModule" do
+selectExplicitTypeFixitiesFromModule conn modName ops =  do
   (modName,)
     <$> SQL.query
       conn
@@ -140,7 +140,7 @@ selectExplicitTypeFixitiesFromModule conn modName ops = labelError "selectExplic
 
 selectNonHiddenTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
 selectNonHiddenTypeFixitiesFromModule conn modName [] = selectTypeFixitiesFromModule conn modName
-selectNonHiddenTypeFixitiesFromModule conn modName ops = labelError "selectNonHiddenTypeFixitiesFromModule" do
+selectNonHiddenTypeFixitiesFromModule conn modName ops =  do
   (modName,)
     <$> SQL.query
       conn
@@ -151,7 +151,7 @@ selectValueFixitiesFromNames :: Connection -> P.ModuleName -> [P.Qualified (P.Op
 selectValueFixitiesFromNames conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectValueFixity conn modName) ops
 
 selectValueFixity :: Connection -> P.ModuleName -> P.Qualified (P.OpName 'P.ValueOpName) -> IO (Maybe (P.ModuleName, ExternsFixity))
-selectValueFixity conn _modName (P.Qualified (P.ByModuleName m) op) = labelError "selectValueFixity" do
+selectValueFixity conn _modName (P.Qualified (P.ByModuleName m) op) =  do
   SQL.query
     conn
     "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE op_name = ? and module_name = ?"
@@ -159,20 +159,6 @@ selectValueFixity conn _modName (P.Qualified (P.ByModuleName m) op) = labelError
     <&> fmap (m,) . head
 selectValueFixity _ _ _ = pure Nothing
 
--- where
---   m = fromMaybe modName $ P.getQual op
-
-selectTypeFixitiesFromNames :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.TypeOpName)] -> IO [(P.ModuleName, [ExternsTypeFixity])]
-selectTypeFixitiesFromNames conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectTypeFixity conn modName) ops
-
-selectTypeFixity :: Connection -> P.ModuleName -> P.Qualified (P.OpName 'P.TypeOpName) -> IO (Maybe (P.ModuleName, ExternsTypeFixity))
-selectTypeFixity conn _modName (P.Qualified (P.ByModuleName m) op) =
-  SQL.query
-    conn
-    "SELECT  associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE op_name = ? and module_name = ?"
-    (op, m)
-    <&> fmap (m,) . head
-selectTypeFixity _ _ _ = pure Nothing
 
 collectModuleNames :: (Ord a) => [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
 collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure) . ordNub
@@ -291,7 +277,7 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
       _ -> pure identity
 
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
-selectEnvValue conn ident = labelError "selectEnvValue" do
+selectEnvValue conn ident = do
   SQL.query
     conn
     "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name = ? AND ident = ?"
@@ -299,7 +285,7 @@ selectEnvValue conn ident = labelError "selectEnvValue" do
     <&> head
 
 selectModuleEnvValues :: Connection -> P.ModuleName -> IO [(P.Qualified P.Ident, (P.SourceType, P.NameKind, P.NameVisibility))]
-selectModuleEnvValues conn moduleName' = labelError "selectModuleEnvValues" do
+selectModuleEnvValues conn moduleName' = do
   SQL.query
     conn
     "SELECT ident, source_type, name_kind, name_visibility FROM env_values WHERE module_name = ?"
@@ -307,7 +293,7 @@ selectModuleEnvValues conn moduleName' = labelError "selectModuleEnvValues" do
     <&> fmap (\(ident, st, nk, nv) -> (P.Qualified (P.ByModuleName moduleName') ident, (st, nk, nv)))
 
 selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe (P.SourceType, P.TypeKind))
-selectType conn ident = labelError "selectType" do
+selectType conn ident = do
   SQL.query
     conn
     "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?"
@@ -315,7 +301,7 @@ selectType conn ident = labelError "selectType" do
     <&> head
 
 selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), (P.SourceType, P.TypeKind))]
-selectModuleEnvTypes conn moduleName' = labelError "selectModuleEnvTypes" do
+selectModuleEnvTypes conn moduleName' = do
   SQL.query
     conn
     "SELECT type_name, source_type, type_kind FROM env_types WHERE module_name = ?"
@@ -323,7 +309,7 @@ selectModuleEnvTypes conn moduleName' = labelError "selectModuleEnvTypes" do
     <&> fmap (\(ty, st, tk) -> (P.Qualified (P.ByModuleName moduleName') ty, (st, tk)))
 
 selectDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> IO (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
-selectDataConstructor conn ident = labelError "selectDataConstructor" do
+selectDataConstructor conn ident = do
   SQL.query
     conn
     "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND constructor_name = ?"
@@ -333,7 +319,7 @@ selectDataConstructor conn ident = labelError "selectDataConstructor" do
     deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
 
 selectTypeDataConstructors :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
-selectTypeDataConstructors conn ident = labelError "selectTypeDataConstructors" do
+selectTypeDataConstructors conn ident = do
   SQL.query
     conn
     "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND type_name = ?"
@@ -345,7 +331,7 @@ selectTypeDataConstructors conn ident = labelError "selectTypeDataConstructors"
 --   deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
 
 selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
-selectModuleDataConstructors conn moduleName' = labelError "selectModuleDataConstructors" do
+selectModuleDataConstructors conn moduleName' = do
   SQL.query
     conn
     "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ?"
@@ -353,7 +339,7 @@ selectModuleDataConstructors conn moduleName' = labelError "selectModuleDataCons
     <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
 
 selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
-selectTypeSynonym conn ident = labelError "selectTypeSynonym" do
+selectTypeSynonym conn ident = do
   SQL.query
     conn
     "SELECT idents, source_type FROM env_type_synonyms WHERE module_name = ? AND type_name = ?"
@@ -363,7 +349,7 @@ selectTypeSynonym conn ident = labelError "selectTypeSynonym" do
     deserialiseIdents (idents, st) = (deserialise idents, st)
 
 selectModuleTypeSynonyms :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), ([(Text, Maybe P.SourceType)], P.SourceType))]
-selectModuleTypeSynonyms conn moduleName' = labelError "selectModuleTypeSynonyms" do
+selectModuleTypeSynonyms conn moduleName' = do
   SQL.query
     conn
     "SELECT type_name, idents, source_type FROM env_type_synonyms WHERE module_name = ?"
@@ -371,7 +357,7 @@ selectModuleTypeSynonyms conn moduleName' = labelError "selectModuleTypeSynonyms
     <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st)))
 
 selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
-selectTypeClass conn ident = labelError "selectTypeClass" do
+selectTypeClass conn ident = do
   SQL.query
     conn
     "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
@@ -379,7 +365,7 @@ selectTypeClass conn ident = labelError "selectTypeClass" do
     <&> (fmap SQL.fromOnly . head)
 
 selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
-selectModuleTypeClasses conn moduleName' = labelError "selectModuleTypeClasses" do
+selectModuleTypeClasses conn moduleName' = do
   SQL.query
     conn
     "SELECT class_name, class FROM env_type_classes WHERE module_name = ?"
@@ -390,7 +376,7 @@ selectClassInstance ::
   Connection ->
   P.Qualified P.Ident ->
   IO (Maybe NamedDict)
-selectClassInstance conn ident =  labelError "selectClassInstance" do
+selectClassInstance conn ident =  do
   SQL.query
     conn
     "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND ident = ?"
@@ -398,7 +384,7 @@ selectClassInstance conn ident =  labelError "selectClassInstance" do
     <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
 
 selectModuleClassInstances :: Connection -> P.ModuleName -> IO [NamedDict]
-selectModuleClassInstances conn moduleName' = labelError "selectModuleClassInstances" do
+selectModuleClassInstances conn moduleName' = do
   SQL.query
     conn
     "SELECT dict FROM env_type_class_instances WHERE module_name = ?"
@@ -406,11 +392,6 @@ selectModuleClassInstances conn moduleName' = labelError "selectModuleClassInsta
     <&> fmap (SQL.fromOnly >>> deserialise)
 
 
-labelError :: Text -> IO a -> IO a 
-labelError label action = catch action \(e :: SomeException) -> do 
-  putErrLn $ "Error: " <> label <> ": " <> show e
-  throwIO e
-
 
 type DbQualifer a = (P.ModuleName, a)
 

From e956f3a97e657f41594e2d465c6c43cee404d16f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 4 Dec 2024 00:53:52 +0100
Subject: [PATCH 266/297] adds op alias importing

---
 src/Language/PureScript/Make/Index.hs        |  3 +-
 src/Language/PureScript/Make/Index/Select.hs | 67 +++++++++++++-------
 2 files changed, 46 insertions(+), 24 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index adce9e0421..26f912dbb0 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -20,7 +20,6 @@ where
 
 import Codec.Serialise (serialise)
 import Control.Concurrent.Async.Lifted (mapConcurrently_)
-import Data.Aeson qualified as A
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -209,7 +208,7 @@ indexFixity conn moduleName' = \case
       [ ":module_name" := P.runModuleName moduleName',
         ":op_name" := P.runOpName op,
         ":alias_module_name" := P.runModuleName ty_mod,
-        ":alias" := A.encode name,
+        ":alias" := name,
         ":associativity" := P.showAssoc assoc,
         ":precedence" := prec
       ]
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index cf952943ac..38f2760024 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -4,7 +4,7 @@ module Language.PureScript.Make.Index.Select where
 
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
-import Control.Concurrent.Async.Lifted (forConcurrently, mapConcurrently)
+import Control.Concurrent.Async.Lifted (forConcurrently)
 import Data.Aeson qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.Map qualified as Map
@@ -25,6 +25,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
+import Data.Text qualified as T
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImportsAndDecls conn module' = do
@@ -52,7 +53,7 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
           _ -> []
 
 selectFixitiesFromModuleImports :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _) =  do
+selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _) = do
   valueOps <- catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn))
   typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn))
   pure (valueOps, typeOps)
@@ -78,7 +79,7 @@ refValueOp = \case
   _ -> Nothing
 
 selectValueFixitiesFromModule :: Connection -> P.ModuleName -> IO (P.ModuleName, [ExternsFixity])
-selectValueFixitiesFromModule conn modName =  do
+selectValueFixitiesFromModule conn modName = do
   (modName,)
     <$> SQL.query
       conn
@@ -87,7 +88,7 @@ selectValueFixitiesFromModule conn modName =  do
 
 selectExplicitValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
 selectExplicitValueFixitiesFromModule _ modName [] = pure (modName, [])
-selectExplicitValueFixitiesFromModule conn modName ops =  do
+selectExplicitValueFixitiesFromModule conn modName ops = do
   (modName,)
     <$> SQL.query
       conn
@@ -96,7 +97,7 @@ selectExplicitValueFixitiesFromModule conn modName ops =  do
 
 selectNonHiddenValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
 selectNonHiddenValueFixitiesFromModule conn modName [] = selectValueFixitiesFromModule conn modName
-selectNonHiddenValueFixitiesFromModule conn modName ops =  do
+selectNonHiddenValueFixitiesFromModule conn modName ops = do
   (modName,)
     <$> SQL.query
       conn
@@ -131,7 +132,7 @@ selectTypeFixitiesFromModule conn modName = do
 
 selectExplicitTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
 selectExplicitTypeFixitiesFromModule _ modName [] = pure (modName, [])
-selectExplicitTypeFixitiesFromModule conn modName ops =  do
+selectExplicitTypeFixitiesFromModule conn modName ops = do
   (modName,)
     <$> SQL.query
       conn
@@ -140,26 +141,13 @@ selectExplicitTypeFixitiesFromModule conn modName ops =  do
 
 selectNonHiddenTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
 selectNonHiddenTypeFixitiesFromModule conn modName [] = selectTypeFixitiesFromModule conn modName
-selectNonHiddenTypeFixitiesFromModule conn modName ops =  do
+selectNonHiddenTypeFixitiesFromModule conn modName ops = do
   (modName,)
     <$> SQL.query
       conn
       "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name NOT IN (SELECT value FROM json_each(?))"
       (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
 
-selectValueFixitiesFromNames :: Connection -> P.ModuleName -> [P.Qualified (P.OpName 'P.ValueOpName)] -> IO [(P.ModuleName, [ExternsFixity])]
-selectValueFixitiesFromNames conn modName ops = collectModuleNames . catMaybes <$> mapConcurrently (selectValueFixity conn modName) ops
-
-selectValueFixity :: Connection -> P.ModuleName -> P.Qualified (P.OpName 'P.ValueOpName) -> IO (Maybe (P.ModuleName, ExternsFixity))
-selectValueFixity conn _modName (P.Qualified (P.ByModuleName m) op) =  do
-  SQL.query
-    conn
-    "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE op_name = ? and module_name = ?"
-    (op, m)
-    <&> fmap (m,) . head
-selectValueFixity _ _ _ = pure Nothing
-
-
 collectModuleNames :: (Ord a) => [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
 collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure) . ordNub
 
@@ -274,7 +262,27 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
         pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust val]}
       P.ModuleRef _ m -> importModule m
       P.ReExportRef _ _ ref -> importRef mName ref
-      _ -> pure identity
+      P.ValueOpRef _ opName -> do
+        (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
+        if isUpper $ T.head alias
+          then do
+            let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
+            val <- selectDataConstructor conn qual
+            pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJust val)]}
+          else do
+            let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
+            val <- selectEnvValue conn qual
+            pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
+      P.TypeOpRef _ opName -> do 
+        (aliasModName, alias) <- fromJust <$> selectTypeOperatorAlias conn mName opName
+        let qual = P.Qualified (P.ByModuleName aliasModName) alias
+        val <- selectType conn qual
+        pure $ \env' -> 
+          env' 
+            { E.types = E.types env' <> Map.fromList [(qual, fromJust val)]
+            }
+
+
 
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
 selectEnvValue conn ident = do
@@ -376,7 +384,7 @@ selectClassInstance ::
   Connection ->
   P.Qualified P.Ident ->
   IO (Maybe NamedDict)
-selectClassInstance conn ident =  do
+selectClassInstance conn ident = do
   SQL.query
     conn
     "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND ident = ?"
@@ -391,6 +399,21 @@ selectModuleClassInstances conn moduleName' = do
     (SQL.Only moduleName')
     <&> fmap (SQL.fromOnly >>> deserialise)
 
+selectValueOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe (P.ModuleName, Text))
+selectValueOperatorAlias conn modName opName = do
+  SQL.query
+    conn
+    "SELECT alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name = ?"
+    (modName, P.runOpName opName)
+    <&> head
+
+selectTypeOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.TypeOpName -> IO (Maybe (P.ModuleName, P.ProperName 'P.TypeName))
+selectTypeOperatorAlias conn modName opName = do
+  SQL.query
+    conn
+    "SELECT alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name = ?"
+    (modName, P.runOpName opName)
+    <&> head
 
 
 type DbQualifer a = (P.ModuleName, a)

From d842ca5b98f616e765a62bb233313c163b9c69d8 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 4 Dec 2024 02:58:01 +0100
Subject: [PATCH 267/297] adds dict constructor importing

---
 src/Language/PureScript/Make/Index.hs        | 12 +++-
 src/Language/PureScript/Make/Index/Select.hs | 73 ++++++++++++++------
 2 files changed, 61 insertions(+), 24 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 26f912dbb0..833fe00dae 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -386,7 +386,7 @@ indexExportedEnv moduleName env refs conn = liftIO do
   deleteModuleEnv
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
   envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn)
-  envFromModule E.dataConstructors & filter dataConstructorExported & mapConcurrently_ (uncurry $ insertDataConstructor conn)
+  envFromModule E.dataConstructors & filter dataConstructorExportedOrDict & mapConcurrently_ (uncurry $ insertDataConstructor conn)
   envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn)
   envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
   dicts
@@ -430,12 +430,20 @@ indexExportedEnv moduleName env refs conn = liftIO do
       _ -> False
 
     typeOrClassExported :: (Qualified (P.ProperName 'P.TypeName), b) -> Bool
-    typeOrClassExported kv = typeExported kv || typeClassExported (first (fmap P.coerceProperName) kv)
+    typeOrClassExported kv = 
+        P.isDictTypeName (P.disqualify $ fst kv)
+          || typeExported kv 
+          || typeClassExported (first (fmap P.coerceProperName) kv)
 
     typeExported = refMatch \k -> \case
       P.TypeRef _ typeName _ -> typeName == P.disqualify k
       _ -> False
 
+    dataConstructorExportedOrDict :: (Qualified (P.ProperName 'P.ConstructorName), b) -> Bool
+    dataConstructorExportedOrDict kv = 
+        P.isDictTypeName (P.disqualify $ fst kv)
+          || dataConstructorExported kv
+
     dataConstructorExported = refMatch \k -> \case
       P.TypeRef _ _ ctrs -> maybe False (elem (P.disqualify k)) ctrs
       _ -> False
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 38f2760024..d92fba3dbc 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -9,6 +9,7 @@ import Data.Aeson qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.Map qualified as Map
 import Data.Set qualified as Set
+import Data.Text qualified as T
 import Database.SQLite.Simple (Connection)
 import Database.SQLite.Simple qualified as SQL
 import Language.PureScript.AST.Declarations (ImportDeclarationType)
@@ -25,7 +26,6 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
-import Data.Text qualified as T
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImportsAndDecls conn module' = do
@@ -152,7 +152,7 @@ collectModuleNames :: (Ord a) => [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
 collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure) . ordNub
 
 selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
+selectEnvFromImports conn (P.Module _ _ nName' decls _) = liftIO do
   envFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
     P.ImportDeclaration _ mName idt _ -> do
       case idt of
@@ -232,10 +232,30 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
             typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
         typeClass <- selectTypeClass conn qual
         type' <- selectType conn typeQual
+        let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
+        dictVal@(_, dictKind) <- fromJustWithErr (nName', dictName) <$> selectType conn dictName
+
+        let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
+            ctrMb =
+              P.Qualified (P.ByModuleName mName) <$> case dictKind of
+                P.DataType _ _ [(ctr', _)] -> Just ctr'
+                _ -> Nothing
+
+        ctrData <- ctrMb & maybe (pure Nothing) (\ctr -> selectDataConstructor conn ctr)
         pure $ \env' ->
           env'
             { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)],
-              E.types = E.types env' <> Map.fromList [(typeQual, fromJust type')]
+              E.types =
+                E.types env'
+                  <> Map.fromList
+                    [ (typeQual, fromJust type'),
+                      (dictName, dictVal)
+                    ],
+              E.dataConstructors =
+                E.dataConstructors env'
+                  <> Map.fromList case (ctrMb, ctrData) of
+                    (Just ctr', Just ctrData') -> [(ctr', ctrData')]
+                    _ -> []
             }
       P.TypeRef _ tyName ctrs -> do
         let qual = P.Qualified (P.ByModuleName mName) tyName
@@ -250,7 +270,6 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
           env'
             { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
               E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
-              -- E.typeClasses = E.typeClasses env' <> maybe mempty (\tc -> Map.fromList [(classQual, tc)]) class'
             }
       P.ValueRef _ ident -> do
         let qual = P.Qualified (P.ByModuleName mName) ident
@@ -273,17 +292,15 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
             let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
             val <- selectEnvValue conn qual
             pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
-      P.TypeOpRef _ opName -> do 
+      P.TypeOpRef _ opName -> do
         (aliasModName, alias) <- fromJust <$> selectTypeOperatorAlias conn mName opName
         let qual = P.Qualified (P.ByModuleName aliasModName) alias
         val <- selectType conn qual
-        pure $ \env' -> 
-          env' 
+        pure $ \env' ->
+          env'
             { E.types = E.types env' <> Map.fromList [(qual, fromJust val)]
             }
 
-
-
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
 selectEnvValue conn ident = do
   SQL.query
@@ -301,12 +318,16 @@ selectModuleEnvValues conn moduleName' = do
     <&> fmap (\(ident, st, nk, nv) -> (P.Qualified (P.ByModuleName moduleName') ident, (st, nk, nv)))
 
 selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe (P.SourceType, P.TypeKind))
-selectType conn ident = do
-  SQL.query
-    conn
-    "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?"
-    (toDbQualifer ident)
-    <&> head
+selectType conn ident = case Map.lookup ident P.allPrimTypes of
+  Just a -> pure $ Just a
+  Nothing ->
+    SQL.query
+      conn
+      "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?"
+      (modName, ty_name)
+      <&> head
+  where
+    (modName, ty_name) = toDbQualifer ident
 
 selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), (P.SourceType, P.TypeKind))]
 selectModuleEnvTypes conn moduleName' = do
@@ -365,12 +386,16 @@ selectModuleTypeSynonyms conn moduleName' = do
     <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st)))
 
 selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
-selectTypeClass conn ident = do
-  SQL.query
-    conn
-    "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
-    (toDbQualifer ident)
-    <&> (fmap SQL.fromOnly . head)
+selectTypeClass conn ident = case Map.lookup ident P.allPrimClasses of
+  Just a -> pure $ Just a
+  Nothing ->
+    SQL.query
+      conn
+      "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
+      (modName, className)
+      <&> (fmap SQL.fromOnly . head)
+  where
+    (modName, className) = toDbQualifer ident
 
 selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
 selectModuleTypeClasses conn moduleName' = do
@@ -415,9 +440,13 @@ selectTypeOperatorAlias conn modName opName = do
     (modName, P.runOpName opName)
     <&> head
 
-
 type DbQualifer a = (P.ModuleName, a)
 
 toDbQualifer :: P.Qualified a -> DbQualifer a
 toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (mn, a)
 toDbQualifer (P.Qualified (P.BySourcePos _) _) = internalError "toDbQualifer called with BySourcePos"
+
+fromJustWithErr :: (Show e) => e -> Maybe a -> a
+fromJustWithErr err = \case
+  Just a -> a
+  Nothing -> internalError $ "fromJustWithErr: " <> show err
\ No newline at end of file

From b7c2adcb414243b4dfcc73fd73f91172f1ccb4ed Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 4 Dec 2024 11:07:07 +0100
Subject: [PATCH 268/297] try getting class dicts but failing as before
 typechecking

---
 src/Language/PureScript/Make/Index.hs        |   9 +-
 src/Language/PureScript/Make/Index/Select.hs | 135 ++++++++++++++-----
 2 files changed, 106 insertions(+), 38 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 833fe00dae..a226424730 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -42,6 +42,7 @@ import Language.PureScript.Names (Qualified ())
 import Language.PureScript.TypeChecker.Monad (emptyCheckState)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue))
 import Protolude hiding (moduleName)
+import Data.Aeson qualified as A
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
@@ -491,8 +492,8 @@ insertNamedDict :: Connection -> NamedDict -> IO ()
 insertNamedDict conn dict = do
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, dict) VALUES (?, ?, ?, ?, ?)"
-    (toDbQualifer (tcdValue dict) :. (clasMod, className, serialise dict))
+    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, idents, dict) VALUES (?, ?, ?, ?, ?, ?)"
+    (toDbQualifer (tcdValue dict) :. (clasMod, className, A.encode (tcdValue dict), serialise dict))
   where
     (clasMod, className) = toDbQualifer (tcdClassName dict)
 
@@ -503,7 +504,7 @@ initEnvTables conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT, class BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_module TEXT, class_name TEXT, dict BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, dict BLOB, debug TEXT)"
   addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
@@ -514,6 +515,8 @@ addEnvIndexes conn = do
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_synonyms_idx ON env_type_synonyms(module_name, type_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_classes_idx ON env_type_classes(module_name, class_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idx ON env_type_class_instances(module_name, instance_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idents_idx ON env_type_class_instances(idents)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_class_name_idx ON env_type_class_instances(class_name)"
 
 dropEnvTables :: Connection -> IO ()
 dropEnvTables conn = do
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index d92fba3dbc..629000babb 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -7,6 +7,7 @@ import Control.Arrow ((>>>))
 import Control.Concurrent.Async.Lifted (forConcurrently)
 import Data.Aeson qualified as A
 import Data.ByteString.Lazy qualified as Lazy
+import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
@@ -15,6 +16,7 @@ import Database.SQLite.Simple qualified as SQL
 import Language.PureScript.AST.Declarations (ImportDeclarationType)
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.Operators qualified as P
+import Language.PureScript.AST.Traversals qualified as P
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Environment qualified as P
@@ -148,12 +150,30 @@ selectNonHiddenTypeFixitiesFromModule conn modName ops = do
       "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name NOT IN (SELECT value FROM json_each(?))"
       (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
 
+
+type ClassDict =
+  Map.Map
+    P.QualifiedBy
+    ( Map.Map
+        (P.Qualified (P.ProperName 'P.ClassName))
+        (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty NamedDict))
+    )
+
+unionClassDicts :: [ClassDict] -> ClassDict
+unionClassDicts = foldl' unionClassDict Map.empty
+
+unionClassDict :: ClassDict -> ClassDict -> ClassDict
+unionClassDict = Map.unionWith (Map.unionWith (Map.unionWith (<>)))
+
 collectModuleNames :: (Ord a) => [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
 collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure) . ordNub
 
+classDictNamedDicts :: ClassDict -> [NamedDict]
+classDictNamedDicts = concatMap NEL.toList . concatMap Map.elems . concatMap Map.elems . Map.elems
+
 selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ nName' decls _) = liftIO do
-  envFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
+selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
+  importFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
     P.ImportDeclaration _ mName idt _ -> do
       case idt of
         P.Implicit -> importModule mName
@@ -162,11 +182,40 @@ selectEnvFromImports conn (P.Module _ _ nName' decls _) = liftIO do
           pure $ foldl' (>>>) identity edits
         P.Hiding refs -> importModuleHiding refs mName
     _ -> pure identity
-  let env = foldl' (&) E.initEnvironment envFns
-  return env
+
+  putErrLn $ ("dicts: "  :: Text) <> show dicts
+  constraintFns <- forConcurrently typeConstraints \c ->
+    case P.constraintClass c of
+      P.Qualified (P.ByModuleName mName) className ->
+        importClass mName className
+      _ -> pure identity
+
+  pure $ foldl' (&) E.initEnvironment (constraintFns <> importFns)
   where
+    dicts = classDictNamedDicts $ unionClassDicts $ getDeclDicts <$> decls
+
+    getDeclDicts :: P.Declaration -> ClassDict
+    getDeclDicts d = execState (onDecl d) Map.empty
+
+    (onDecl, _, _) = P.everywhereOnValuesM pure goExpr pure 
+
+    goExpr :: P.Expr -> State ClassDict P.Expr
+    goExpr = \case
+      e@(P.TypeClassDictionary _ dict _) -> do  
+        modify (unionClassDict dict)
+        pure e
+      e -> pure e
+
+    typeConstraints :: [P.SourceConstraint]
+    typeConstraints = getDeclTypeConstraints =<< decls
+
+    (getDeclTypeConstraints, _, _, _, _) = P.accumTypes \case
+      P.ConstrainedType _ c _ -> [c]
+      _ -> []
+
     importModule = importModuleHiding []
 
+    -- todo: select imports from db and use same code as explicit imports
     importModuleHiding hideRefs mName = do
       let hiddenIdents =
             Set.fromList $
@@ -225,38 +274,40 @@ selectEnvFromImports conn (P.Module _ _ nName' decls _) = liftIO do
             E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
           }
 
+    importClass mName className = do
+      let qual = P.Qualified (P.ByModuleName mName) className
+          typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
+      typeClass <- selectTypeClass conn qual
+      type' <- selectType conn typeQual
+      let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
+      dictVal@(_, dictKind) <- fromJust <$> selectType conn dictName
+
+      let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
+          ctrMb =
+            P.Qualified (P.ByModuleName mName) <$> case dictKind of
+              P.DataType _ _ [(ctr', _)] -> Just ctr'
+              _ -> Nothing
+
+      ctrData <- ctrMb & maybe (pure Nothing) (\ctr -> selectDataConstructor conn ctr)
+      pure $ \env' ->
+        env'
+          { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)],
+            E.types =
+              E.types env'
+                <> Map.fromList
+                  [ (typeQual, fromJust type'),
+                    (dictName, dictVal)
+                  ],
+            E.dataConstructors =
+              E.dataConstructors env'
+                <> Map.fromList case (ctrMb, ctrData) of
+                  (Just ctr', Just ctrData') -> [(ctr', ctrData')]
+                  _ -> []
+          }
+
     importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
     importRef mName = \case
-      P.TypeClassRef _ className -> do
-        let qual = P.Qualified (P.ByModuleName mName) className
-            typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
-        typeClass <- selectTypeClass conn qual
-        type' <- selectType conn typeQual
-        let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
-        dictVal@(_, dictKind) <- fromJustWithErr (nName', dictName) <$> selectType conn dictName
-
-        let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
-            ctrMb =
-              P.Qualified (P.ByModuleName mName) <$> case dictKind of
-                P.DataType _ _ [(ctr', _)] -> Just ctr'
-                _ -> Nothing
-
-        ctrData <- ctrMb & maybe (pure Nothing) (\ctr -> selectDataConstructor conn ctr)
-        pure $ \env' ->
-          env'
-            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)],
-              E.types =
-                E.types env'
-                  <> Map.fromList
-                    [ (typeQual, fromJust type'),
-                      (dictName, dictVal)
-                    ],
-              E.dataConstructors =
-                E.dataConstructors env'
-                  <> Map.fromList case (ctrMb, ctrData) of
-                    (Just ctr', Just ctrData') -> [(ctr', ctrData')]
-                    _ -> []
-            }
+      P.TypeClassRef _ className -> importClass mName className
       P.TypeRef _ tyName ctrs -> do
         let qual = P.Qualified (P.ByModuleName mName) tyName
         type' <- selectType conn qual
@@ -412,7 +463,7 @@ selectClassInstance ::
 selectClassInstance conn ident = do
   SQL.query
     conn
-    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND ident = ?"
+    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?"
     (toDbQualifer ident)
     <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
 
@@ -424,6 +475,20 @@ selectModuleClassInstances conn moduleName' = do
     (SQL.Only moduleName')
     <&> fmap (SQL.fromOnly >>> deserialise)
 
+selectClassInstanceByIdents ::
+  Connection ->
+  P.Qualified (P.ProperName 'P.ClassName) ->
+  [P.Ident] ->
+  IO (Maybe NamedDict)
+selectClassInstanceByIdents conn classNameQual idents = do
+  SQL.query
+    conn
+    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND class_name = ? AND idents = ?"
+    (modName, className, A.encode idents)
+    <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
+  where
+    (modName, className) = toDbQualifer classNameQual
+
 selectValueOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe (P.ModuleName, Text))
 selectValueOperatorAlias conn modName opName = do
   SQL.query

From 15f42406a6b256443a4382cc120175d514a50186 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 4 Dec 2024 18:25:53 +0100
Subject: [PATCH 269/297] adds imports insert

---
 src/Language/PureScript/Compile.hs           |   7 +-
 src/Language/PureScript/Make/Index.hs        |  42 +++--
 src/Language/PureScript/Make/Index/Select.hs | 186 ++++++++++++++-----
 3 files changed, 169 insertions(+), 66 deletions(-)

diff --git a/src/Language/PureScript/Compile.hs b/src/Language/PureScript/Compile.hs
index 657f74d005..6d6253c8b3 100644
--- a/src/Language/PureScript/Compile.hs
+++ b/src/Language/PureScript/Compile.hs
@@ -6,7 +6,7 @@ import Database.SQLite.Simple (Connection)
 import Language.PureScript qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
-import Language.PureScript.Make.Index (addAllIndexing)
+import Language.PureScript.Make.Index (addAllIndexing, addDbConnection)
 import System.Directory (createDirectoryIfMissing)
 import Prelude
 
@@ -18,6 +18,7 @@ compile opts moduleFiles conn outputDir usePrefx = do
     foreigns <- inferForeignModules filePathMap
     liftIO $ createDirectoryIfMissing True outputDir
     let makeActions =
-          addAllIndexing conn $
-            buildMakeActions outputDir filePathMap foreigns usePrefx
+          addDbConnection conn $
+            addAllIndexing conn $
+              buildMakeActions outputDir filePathMap foreigns usePrefx
     P.make makeActions (map snd ms)
\ No newline at end of file
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index a226424730..3448f61a7c 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -15,11 +15,13 @@ module Language.PureScript.Make.Index
     insertType,
     insertDataConstructor,
     insertTypeSynonym,
+    addDbConnection,
   )
 where
 
 import Codec.Serialise (serialise)
 import Control.Concurrent.Async.Lifted (mapConcurrently_)
+import Data.Aeson qualified as A
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -40,9 +42,14 @@ import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Make.Index.Select (toDbQualifer)
 import Language.PureScript.Names (Qualified ())
 import Language.PureScript.TypeChecker.Monad (emptyCheckState)
-import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue))
+import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdInstanceKinds, tcdInstanceTypes, tcdValue))
 import Protolude hiding (moduleName)
-import Data.Aeson qualified as A
+
+addDbConnection :: Monad m => Connection -> P.MakeActions m -> P.MakeActions m
+addDbConnection conn ma =
+  ma
+    { P.getDbConnection = pure conn
+    }
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
@@ -356,6 +363,8 @@ initDb conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS imports (module_name TEXT, imported_module TEXT, imported_as TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS exports (module_name TEXT, ident TEXT, value BLOB)"
   initEnvTables conn
   addDbIndexes conn
 
@@ -390,8 +399,11 @@ indexExportedEnv moduleName env refs conn = liftIO do
   envFromModule E.dataConstructors & filter dataConstructorExportedOrDict & mapConcurrently_ (uncurry $ insertDataConstructor conn)
   envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn)
   envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
+  when (moduleName == P.ModuleName "Data.HeytingAlgebra") do
+    putErrLn $ "typeClassDicts: \n" <> intercalate "\n" (P.debugTypeClassDictionaries env)
+    putErrLn $ ("dicts exported:\n" :: Text) <> T.intercalate "\n" (fmap (P.runIdent . P.disqualify . tcdValue) dicts)
   dicts
-    & filter ((== Just moduleName) . P.getQual . tcdValue)
+    -- & filter ((== Just moduleName) . P.getQual . tcdValue)
     & mapConcurrently_ (insertNamedDict conn)
   where
     envFromModule :: (E.Environment -> Map.Map (Qualified k) v) -> [(Qualified k, v)]
@@ -431,19 +443,19 @@ indexExportedEnv moduleName env refs conn = liftIO do
       _ -> False
 
     typeOrClassExported :: (Qualified (P.ProperName 'P.TypeName), b) -> Bool
-    typeOrClassExported kv = 
-        P.isDictTypeName (P.disqualify $ fst kv)
-          || typeExported kv 
-          || typeClassExported (first (fmap P.coerceProperName) kv)
+    typeOrClassExported kv =
+      P.isDictTypeName (P.disqualify $ fst kv)
+        || typeExported kv
+        || typeClassExported (first (fmap P.coerceProperName) kv)
 
     typeExported = refMatch \k -> \case
       P.TypeRef _ typeName _ -> typeName == P.disqualify k
       _ -> False
 
     dataConstructorExportedOrDict :: (Qualified (P.ProperName 'P.ConstructorName), b) -> Bool
-    dataConstructorExportedOrDict kv = 
-        P.isDictTypeName (P.disqualify $ fst kv)
-          || dataConstructorExported kv
+    dataConstructorExportedOrDict kv =
+      P.isDictTypeName (P.disqualify $ fst kv)
+        || dataConstructorExported kv
 
     dataConstructorExported = refMatch \k -> \case
       P.TypeRef _ _ ctrs -> maybe False (elem (P.disqualify k)) ctrs
@@ -492,8 +504,8 @@ insertNamedDict :: Connection -> NamedDict -> IO ()
 insertNamedDict conn dict = do
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, idents, dict) VALUES (?, ?, ?, ?, ?, ?)"
-    (toDbQualifer (tcdValue dict) :. (clasMod, className, A.encode (tcdValue dict), serialise dict))
+    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, types, kinds, dict) VALUES (?, ?, ?, ?, ?, ?, ?)"
+    (toDbQualifer (tcdValue dict) :. (clasMod, className, A.encode (tcdInstanceTypes dict), A.encode (tcdInstanceKinds dict), serialise dict))
   where
     (clasMod, className) = toDbQualifer (tcdClassName dict)
 
@@ -504,7 +516,7 @@ initEnvTables conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT, class BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, dict BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, types TEXT, kinds TEXT, dict BLOB, debug TEXT)"
   addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
@@ -515,8 +527,8 @@ addEnvIndexes conn = do
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_synonyms_idx ON env_type_synonyms(module_name, type_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_classes_idx ON env_type_classes(module_name, class_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idx ON env_type_class_instances(module_name, instance_name)"
-  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idents_idx ON env_type_class_instances(idents)"
-  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_class_name_idx ON env_type_class_instances(class_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_idents_idx ON env_type_class_instances(idents)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_class_name_idx ON env_type_class_instances(class_name)"
 
 dropEnvTables :: Connection -> IO ()
 dropEnvTables conn = do
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 629000babb..3b57807246 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -4,7 +4,7 @@ module Language.PureScript.Make.Index.Select where
 
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
-import Control.Concurrent.Async.Lifted (forConcurrently)
+import Control.Concurrent.Async.Lifted (forConcurrently, mapConcurrently_)
 import Data.Aeson qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.List.NonEmpty qualified as NEL
@@ -18,11 +18,13 @@ import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.Operators qualified as P
 import Language.PureScript.AST.Traversals qualified as P
 import Language.PureScript.Crash (internalError)
+import Language.PureScript.Environment (TypeClassData (typeClassSuperclasses))
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
 import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
+import Language.PureScript.TypeChecker.Monad (debugTypeClassDictionaries)
 import Language.PureScript.TypeChecker.Monad qualified as P
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdValue))
 import Language.PureScript.Types qualified as P
@@ -55,16 +57,30 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
           _ -> []
 
 selectFixitiesFromModuleImports :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _) = do
+selectFixitiesFromModuleImports conn (P.Module _ _ mn decls _refs) = do
+  -- insertExports conn decls refs
+  insertImports conn mn decls 
   valueOps <- catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn))
   typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn))
   pure (valueOps, typeOps)
   where
     onImports :: (P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [a])) -> P.Declaration -> IO (Maybe (P.ModuleName, [a]))
     onImports f = \case
-      P.ImportDeclaration _ mn idt _ -> Just <$> f mn idt
+      P.ImportDeclaration _ mn' idt _ -> Just <$> f mn' idt
       _ -> pure Nothing
 
+insertImports :: Connection -> P.ModuleName -> [P.Declaration] -> IO ()
+insertImports conn mn = mapConcurrently_ (insertImport conn mn)
+
+insertImport :: Connection -> P.ModuleName -> P.Declaration -> IO ()
+insertImport conn mn = \case
+  P.ImportDeclaration _ importedModuleName _ importedAs -> do
+    SQL.execute
+      conn
+      "INSERT INTO imports (module_name, imported_module, imported_as) VALUES (?, ?, ?)"
+      (mn, importedModuleName, importedAs)
+  _ -> pure ()
+
 selectImportValueFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsFixity])
 selectImportValueFixities conn modName = \case
   P.Implicit -> selectValueFixitiesFromModule conn modName
@@ -150,7 +166,6 @@ selectNonHiddenTypeFixitiesFromModule conn modName ops = do
       "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name NOT IN (SELECT value FROM json_each(?))"
       (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
 
-
 type ClassDict =
   Map.Map
     P.QualifiedBy
@@ -159,20 +174,8 @@ type ClassDict =
         (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty NamedDict))
     )
 
-unionClassDicts :: [ClassDict] -> ClassDict
-unionClassDicts = foldl' unionClassDict Map.empty
-
-unionClassDict :: ClassDict -> ClassDict -> ClassDict
-unionClassDict = Map.unionWith (Map.unionWith (Map.unionWith (<>)))
-
-collectModuleNames :: (Ord a) => [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
-collectModuleNames = Map.toList . Map.fromListWith (<>) . fmap (fmap pure) . ordNub
-
-classDictNamedDicts :: ClassDict -> [NamedDict]
-classDictNamedDicts = concatMap NEL.toList . concatMap Map.elems . concatMap Map.elems . Map.elems
-
 selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
+selectEnvFromImports conn (P.Module _ _ mName' decls _) = liftIO do
   importFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
     P.ImportDeclaration _ mName idt _ -> do
       case idt of
@@ -181,31 +184,67 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
           edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
           pure $ foldl' (>>>) identity edits
         P.Hiding refs -> importModuleHiding refs mName
+
+    -- P.TypeInstanceDeclaration _ _ _ _ _ deps _className _types _ -> do
+    --   depFns <- forConcurrently deps \case
+    --     dep -> do
+    --       putErrLn ( "dep: " <> show (P.constraintClass dep) :: Text)
+    --       case P.constraintClass dep of
+    --         -- P.Qualified (P.ByModuleName depModuleName) depClassName ->
+    --         --   importClassAndTypes depModuleName depClassName
+    --         _ -> pure identity
+
+    -- pure (foldl' (>>>) identity depFns)
+
+    -- dict <- selectClassInstanceByIdents conn className types
+    -- pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust dict]}
     _ -> pure identity
 
-  putErrLn $ ("dicts: "  :: Text) <> show dicts
-  constraintFns <- forConcurrently typeConstraints \c ->
+  putErrLn $ ("deferredDicts: " :: Text) <> show deferredDicts
+  constraintFns <- forConcurrently (declConstraints <> typeConstraints) \c ->
     case P.constraintClass c of
       P.Qualified (P.ByModuleName mName) className ->
-        importClass mName className
+        importClassOnly mName className
       _ -> pure identity
 
-  pure $ foldl' (&) E.initEnvironment (constraintFns <> importFns)
+  let env = foldl' (&) E.initEnvironment (importFns <> constraintFns)
+  when (mName' == P.ModuleName "Data.BooleanAlgebra") do
+    putErrLn $ "Data.BooleanAlgebra: \n" <> intercalate "\n" (debugTypeClassDictionaries env)
+
+  pure env
   where
-    dicts = classDictNamedDicts $ unionClassDicts $ getDeclDicts <$> decls
+    replaceModuleAlias :: P.ModuleName -> P.ModuleName
+    replaceModuleAlias mName = fromMaybe mName $ Map.lookup mName importAliasMap
+
+    importAliasMap :: Map.Map P.ModuleName P.ModuleName
+    importAliasMap =
+      Map.fromList $
+        decls >>= \case
+          P.ImportDeclaration _ mName _ (Just alias) -> [(alias, mName)]
+          _ -> []
 
-    getDeclDicts :: P.Declaration -> ClassDict
-    getDeclDicts d = execState (onDecl d) Map.empty
+    deferredDicts = getDeclDicts =<< decls
 
-    (onDecl, _, _) = P.everywhereOnValuesM pure goExpr pure 
+    getDeclDicts :: P.Declaration -> [(P.Qualified (P.ProperName 'P.ClassName), [P.SourceType])]
 
-    goExpr :: P.Expr -> State ClassDict P.Expr
+    getDeclDicts d = execState (onDecl d) []
+
+    (onDecl, _, _) = P.everywhereOnValuesM pure goExpr pure
+
+    goExpr :: P.Expr -> State [(P.Qualified (P.ProperName 'P.ClassName), [P.SourceType])] P.Expr
     goExpr = \case
-      e@(P.TypeClassDictionary _ dict _) -> do  
-        modify (unionClassDict dict)
+      e@(P.DeferredDictionary cn tys) -> do
+        modify ((cn, tys) :)
         pure e
       e -> pure e
 
+    declConstraints :: [P.SourceConstraint]
+    declConstraints =
+      decls >>= \case
+        P.TypeClassDeclaration _ _ _ deps _ _ -> deps
+        P.TypeInstanceDeclaration _ _ _ _ _ deps _ _ _ -> deps
+        _ -> []
+
     typeConstraints :: [P.SourceConstraint]
     typeConstraints = getDeclTypeConstraints =<< decls
 
@@ -274,13 +313,31 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
             E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
           }
 
-    importClass mName className = do
+    importClassOnly :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
+    importClassOnly mName className = do
+      let qual = P.Qualified (P.ByModuleName mName) className
+      typeClass <- fromJustWithErr qual <$> selectTypeClass conn qual
+      instances <- selectClassInstancesByClassName conn qual
+      superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
+        P.Qualified (P.ByModuleName superModName) superClassName -> do
+          superModName' <- selectImportedAs' conn mName superModName
+          importClassOnly superModName' superClassName
+        _ -> pure identity
+      pure $
+        foldl' (>>>) identity superClassImports >>> \env' ->
+          env'
+            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, typeClass)],
+              E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
+            }
+
+    importClassAndTypes :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
+    importClassAndTypes mName className = do
       let qual = P.Qualified (P.ByModuleName mName) className
           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
-      typeClass <- selectTypeClass conn qual
+      typeClass <- fromJust <$> selectTypeClass conn qual
       type' <- selectType conn typeQual
       let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
-      dictVal@(_, dictKind) <- fromJust <$> selectType conn dictName
+      dictVal@(_, dictKind) <- fromJustWithErr dictName <$> selectType conn dictName
 
       let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
           ctrMb =
@@ -289,25 +346,33 @@ selectEnvFromImports conn (P.Module _ _ _ decls _) = liftIO do
               _ -> Nothing
 
       ctrData <- ctrMb & maybe (pure Nothing) (\ctr -> selectDataConstructor conn ctr)
-      pure $ \env' ->
-        env'
-          { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)],
-            E.types =
-              E.types env'
-                <> Map.fromList
-                  [ (typeQual, fromJust type'),
-                    (dictName, dictVal)
-                  ],
-            E.dataConstructors =
-              E.dataConstructors env'
-                <> Map.fromList case (ctrMb, ctrData) of
-                  (Just ctr', Just ctrData') -> [(ctr', ctrData')]
-                  _ -> []
-          }
+      superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
+        P.Qualified (P.ByModuleName superModName) superClassName -> do
+          importClassOnly (replaceModuleAlias superModName) superClassName
+        _ -> pure identity
+      instances <- selectClassInstancesByClassName conn qual
+
+      pure $
+        foldl' (>>>) identity superClassImports >>> \env' ->
+          env'
+            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, typeClass)],
+              E.types =
+                E.types env'
+                  <> Map.fromList
+                    [ (typeQual, fromJust type'),
+                      (dictName, dictVal)
+                    ],
+              E.dataConstructors =
+                E.dataConstructors env'
+                  <> Map.fromList case (ctrMb, ctrData) of
+                    (Just ctr', Just ctrData') -> [(ctr', ctrData')]
+                    _ -> [],
+              E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
+            }
 
     importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
     importRef mName = \case
-      P.TypeClassRef _ className -> importClass mName className
+      P.TypeClassRef _ className -> importClassAndTypes mName className
       P.TypeRef _ tyName ctrs -> do
         let qual = P.Qualified (P.ByModuleName mName) tyName
         type' <- selectType conn qual
@@ -489,6 +554,20 @@ selectClassInstanceByIdents conn classNameQual idents = do
   where
     (modName, className) = toDbQualifer classNameQual
 
+-- TODO: Select specific instances instead of all
+selectClassInstancesByClassName ::
+  Connection ->
+  P.Qualified (P.ProperName 'P.ClassName) ->
+  IO [NamedDict]
+selectClassInstancesByClassName conn classNameQual = do
+  SQL.query
+    conn
+    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND class_name = ?"
+    (modName, className)
+    <&> fmap (SQL.fromOnly >>> deserialise)
+  where
+    (modName, className) = toDbQualifer classNameQual
+
 selectValueOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe (P.ModuleName, Text))
 selectValueOperatorAlias conn modName opName = do
   SQL.query
@@ -505,13 +584,24 @@ selectTypeOperatorAlias conn modName opName = do
     (modName, P.runOpName opName)
     <&> head
 
+selectImportedAs' :: Connection -> P.ModuleName -> P.ModuleName -> IO  P.ModuleName
+selectImportedAs' conn modName importedModName = fromMaybe importedModName <$> selectImportedAs conn modName importedModName
+
+selectImportedAs :: Connection -> P.ModuleName -> P.ModuleName -> IO (Maybe P.ModuleName)
+selectImportedAs conn modName importedModName = do
+  SQL.query
+    conn
+    "SELECT imported_as FROM imports WHERE module_name = ? AND imported_module_name = ?"
+    (modName, importedModName)
+    <&> (head >>> fmap SQL.fromOnly >>> join)
+
 type DbQualifer a = (P.ModuleName, a)
 
 toDbQualifer :: P.Qualified a -> DbQualifer a
 toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (mn, a)
 toDbQualifer (P.Qualified (P.BySourcePos _) _) = internalError "toDbQualifer called with BySourcePos"
 
-fromJustWithErr :: (Show e) => e -> Maybe a -> a
+fromJustWithErr :: (HasCallStack) => (Show e) => e -> Maybe a -> a
 fromJustWithErr err = \case
   Just a -> a
   Nothing -> internalError $ "fromJustWithErr: " <> show err
\ No newline at end of file

From 815283ba43084133d4f70271649956118ce18bc1 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 5 Dec 2024 07:56:32 +0100
Subject: [PATCH 270/297] use exports for hidden imports

---
 src/Control/Monad/Supply.hs                  |   3 +-
 src/Language/PureScript/AST/Declarations.hs  |   9 +
 src/Language/PureScript/Make.hs              |  19 +-
 src/Language/PureScript/Make/Index/Select.hs | 313 ++++++++-----------
 src/Language/PureScript/Sugar.hs             |  25 +-
 src/Language/PureScript/Sugar/TypeClasses.hs |  96 ++++--
 6 files changed, 229 insertions(+), 236 deletions(-)

diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs
index dd447a9c39..4e851cdc67 100644
--- a/src/Control/Monad/Supply.hs
+++ b/src/Control/Monad/Supply.hs
@@ -13,9 +13,10 @@ import Control.Monad.State (StateT(..))
 import Control.Monad.Writer (MonadWriter)
 
 import Data.Functor.Identity (Identity(..))
+import Protolude (MonadIO)
 
 newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
-  deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus)
+  deriving (MonadIO, Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus)
 
 runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
 runSupplyT n = flip runStateT n . unSupplyT
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index ac122369f9..ae17eedb69 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -35,6 +35,8 @@ import Protolude.Exceptions (hush)
 import Prelude
 import Data.ByteString.Lazy qualified as Lazy
 import Language.PureScript.Types qualified as P
+import Database.SQLite.Simple.ToField (ToField (toField))
+import Database.SQLite.Simple.FromField (FromField (fromField))
 
 -- | A map of locally-bound names in scope.
 type Context = [(Ident, SourceType)]
@@ -208,6 +210,13 @@ data DeclarationRef
   | ReExportRef SourceSpan ExportSource DeclarationRef
   deriving (Show, Generic, NFData, Serialise)
 
+
+instance ToField DeclarationRef where
+  toField = toField . S.serialise
+
+instance FromField DeclarationRef where
+  fromField a = S.deserialise <$> fromField a
+
 instance Eq DeclarationRef where
   (TypeClassRef _ name) == (TypeClassRef _ name') = name == name'
   (TypeOpRef _ name) == (TypeOpRef _ name') = name == name'
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index e255ec0e2e..cac0e553a6 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -110,8 +110,7 @@ rebuildModuleWithIndexDb ::
   Maybe (Int, Int) ->
   m ExternsFile
 rebuildModuleWithIndexDb act conn exEnv m moduleIndex = do
-  env <- selectEnvFromImports conn m
-  rebuildModuleWithProvidedEnvDb emptyCheckState act conn exEnv env m moduleIndex
+  rebuildModuleWithProvidedEnvDb emptyCheckState act conn exEnv m moduleIndex
 
 rebuildModuleWithProvidedEnv ::
   forall m.
@@ -172,11 +171,10 @@ rebuildModuleWithProvidedEnvDb ::
   MakeActions m ->
   Connection ->
   Env ->
-  Environment ->
   Module ->
   Maybe (Int, Int) ->
   m ExternsFile
-rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv env m@(Module _ _ moduleName _ _) moduleIndex = do
+rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
@@ -187,7 +185,7 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv env
   --   putErrLn ( "type ops:" :: T.Text)
   --   putErrLn $ intercalate "\n" $ fmap show typeOps
   ((Module ss coms _ elaborated exps, checkSt), nextVar) <-
-    desugarAndTypeCheckDb initialCheckState withCheckStateOnError withCheckState moduleName withPrim exEnv env ops typeOps
+    desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv ops typeOps
   let env' = P.checkEnv checkSt
 
   -- desugar case declarations *after* type- and exhaustiveness checking
@@ -220,7 +218,7 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv env
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env checkSt mod' renamed docs exts
+  evalSupplyT nextVar'' $ codegen env' checkSt mod' renamed docs exts
   return exts
 
 desugarAndTypeCheck ::
@@ -260,20 +258,21 @@ desugarAndTypeCheck initialCheckState withCheckStateOnError withCheckState modul
 
 desugarAndTypeCheckDb ::
   forall m.
-  (MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  (MonadError MultipleErrors m, MonadIO m, MonadWriter MultipleErrors m) =>
   (Environment -> CheckState) ->
+  Connection ->
   (CheckState -> m ()) ->
   (CheckState -> m ()) ->
   ModuleName ->
   Module ->
   Env ->
-  Environment ->
   [(ModuleName, [ExternsFixity])] ->
   [(ModuleName, [ExternsTypeFixity])] ->
   m ((Module, CheckState), Integer)
-desugarAndTypeCheckDb initialCheckState withCheckStateOnError withCheckState moduleName withPrim exEnv env ops typeOps = runSupplyT 0 $ do
-  (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb ops typeOps env withPrim) (exEnv, mempty)
+desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv ops typeOps = runSupplyT 0 $ do
+  (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn ops typeOps withPrim) (exEnv, mempty)
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
+  env <- selectEnvFromImports conn desugared
   (checked, checkSt@(CheckState {..})) <- runStateT (catchError (typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
   lift $ withCheckState checkSt
   let usedImports' =
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 3b57807246..e57fb32edb 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -1,10 +1,11 @@
 {-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 
 module Language.PureScript.Make.Index.Select where
 
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
-import Control.Concurrent.Async.Lifted (forConcurrently, mapConcurrently_)
+import Control.Concurrent.Async.Lifted (forConcurrently, mapConcurrently_, forConcurrently_)
 import Data.Aeson qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.List.NonEmpty qualified as NEL
@@ -24,12 +25,13 @@ import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
 import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
-import Language.PureScript.TypeChecker.Monad (debugTypeClassDictionaries)
+-- import Language.PureScript.TypeChecker.Monad (debugTypeClassDictionaries)
 import Language.PureScript.TypeChecker.Monad qualified as P
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdValue))
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
+import Language.PureScript.TypeChecker.Monad (debugTypeClassDictionaries)
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImportsAndDecls conn module' = do
@@ -57,9 +59,7 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
           _ -> []
 
 selectFixitiesFromModuleImports :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModuleImports conn (P.Module _ _ mn decls _refs) = do
-  -- insertExports conn decls refs
-  insertImports conn mn decls 
+selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _refs) = do
   valueOps <- catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn))
   typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn))
   pure (valueOps, typeOps)
@@ -69,17 +69,6 @@ selectFixitiesFromModuleImports conn (P.Module _ _ mn decls _refs) = do
       P.ImportDeclaration _ mn' idt _ -> Just <$> f mn' idt
       _ -> pure Nothing
 
-insertImports :: Connection -> P.ModuleName -> [P.Declaration] -> IO ()
-insertImports conn mn = mapConcurrently_ (insertImport conn mn)
-
-insertImport :: Connection -> P.ModuleName -> P.Declaration -> IO ()
-insertImport conn mn = \case
-  P.ImportDeclaration _ importedModuleName _ importedAs -> do
-    SQL.execute
-      conn
-      "INSERT INTO imports (module_name, imported_module, imported_as) VALUES (?, ?, ?)"
-      (mn, importedModuleName, importedAs)
-  _ -> pure ()
 
 selectImportValueFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsFixity])
 selectImportValueFixities conn modName = \case
@@ -175,15 +164,15 @@ type ClassDict =
     )
 
 selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ mName' decls _) = liftIO do
+selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
+  insertExports conn modName exports
+  insertImports conn modName decls
   importFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
     P.ImportDeclaration _ mName idt _ -> do
       case idt of
         P.Implicit -> importModule mName
-        P.Explicit refs -> do
-          edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
-          pure $ foldl' (>>>) identity edits
-        P.Hiding refs -> importModuleHiding refs mName
+        P.Explicit refs -> importRefs mName refs
+        P.Hiding refs -> importModuleHiding mName refs 
 
     -- P.TypeInstanceDeclaration _ _ _ _ _ deps _className _types _ -> do
     --   depFns <- forConcurrently deps \case
@@ -200,28 +189,27 @@ selectEnvFromImports conn (P.Module _ _ mName' decls _) = liftIO do
     -- pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust dict]}
     _ -> pure identity
 
-  putErrLn $ ("deferredDicts: " :: Text) <> show deferredDicts
-  constraintFns <- forConcurrently (declConstraints <> typeConstraints) \c ->
-    case P.constraintClass c of
-      P.Qualified (P.ByModuleName mName) className ->
-        importClassOnly mName className
-      _ -> pure identity
 
-  let env = foldl' (&) E.initEnvironment (importFns <> constraintFns)
-  when (mName' == P.ModuleName "Data.BooleanAlgebra") do
+  dictFns <- forConcurrently deferredDicts \case
+    (P.Qualified (P.ByModuleName mn) className, _types) -> importClassAndTypes mn className
+    _ -> pure identity
+
+  let env = foldl' (&) E.initEnvironment (importFns <> dictFns)
+  when (modName == P.ModuleName "Data.BooleanAlgebra") do
+    putErrLn $ ("deferredDicts:\n " :: Text) <> T.intercalate "\n" (fmap (show . fst) deferredDicts)
     putErrLn $ "Data.BooleanAlgebra: \n" <> intercalate "\n" (debugTypeClassDictionaries env)
 
   pure env
   where
-    replaceModuleAlias :: P.ModuleName -> P.ModuleName
-    replaceModuleAlias mName = fromMaybe mName $ Map.lookup mName importAliasMap
+    -- replaceModuleAlias :: P.ModuleName -> P.ModuleName
+    -- replaceModuleAlias mName = fromMaybe mName $ Map.lookup mName importAliasMap
 
-    importAliasMap :: Map.Map P.ModuleName P.ModuleName
-    importAliasMap =
-      Map.fromList $
-        decls >>= \case
-          P.ImportDeclaration _ mName _ (Just alias) -> [(alias, mName)]
-          _ -> []
+    -- importAliasMap :: Map.Map P.ModuleName P.ModuleName
+    -- importAliasMap =
+    --   Map.fromList $
+    --     decls >>= \case
+    --       P.ImportDeclaration _ mName _ (Just alias) -> [(alias, mName)]
+    --       _ -> []
 
     deferredDicts = getDeclDicts =<< decls
 
@@ -238,90 +226,76 @@ selectEnvFromImports conn (P.Module _ _ mName' decls _) = liftIO do
         pure e
       e -> pure e
 
-    declConstraints :: [P.SourceConstraint]
-    declConstraints =
-      decls >>= \case
-        P.TypeClassDeclaration _ _ _ deps _ _ -> deps
-        P.TypeInstanceDeclaration _ _ _ _ _ deps _ _ _ -> deps
-        _ -> []
-
-    typeConstraints :: [P.SourceConstraint]
-    typeConstraints = getDeclTypeConstraints =<< decls
-
-    (getDeclTypeConstraints, _, _, _, _) = P.accumTypes \case
-      P.ConstrainedType _ c _ -> [c]
-      _ -> []
-
-    importModule = importModuleHiding []
-
-    -- todo: select imports from db and use same code as explicit imports
-    importModuleHiding hideRefs mName = do
-      let hiddenIdents =
-            Set.fromList $
-              hideRefs >>= \case
-                P.ValueRef _ ident -> [ident]
-                _ -> []
-
-          hiddenTypes =
-            Set.fromList $
-              hideRefs >>= \case
-                P.TypeRef _ tyName _ -> [tyName]
-                _ -> []
-
-          hiddenCtrs =
-            Set.fromList $
-              hideRefs >>= \case
-                P.TypeRef _ _ ctrs -> fold ctrs
-                _ -> []
-          hiddenTypeClasses =
-            Set.fromList $
-              hideRefs >>= \case
-                P.TypeClassRef _ className -> [className]
-                _ -> []
-
-          hiddenInstances =
-            Set.fromList $
-              hideRefs >>= \case
-                P.TypeInstanceRef _ ident _ -> [ident]
-                _ -> []
-
-      names <-
-        filter (\(ident, _) -> not $ Set.member (P.disqualify ident) hiddenIdents)
-          <$> selectModuleEnvValues conn mName
-      types <-
-        filter (\(ty, _) -> not $ Set.member (P.disqualify ty) hiddenTypes)
-          <$> selectModuleEnvTypes conn mName
-      dataConstructors <-
-        filter (\(ctr, _) -> not $ Set.member (P.disqualify ctr) hiddenCtrs)
-          <$> selectModuleDataConstructors conn mName
-      typeSynonyms <-
-        filter (\(ty, _) -> not $ Set.member (P.disqualify ty) hiddenTypes)
-          <$> selectModuleTypeSynonyms conn mName
-      typeClasses <-
-        filter (\(tc, _) -> not $ Set.member (P.disqualify tc) hiddenTypeClasses)
-          <$> selectModuleTypeClasses conn mName
-      instances <-
-        filter (\inst -> not $ Set.member (P.disqualify $ tcdValue inst) hiddenInstances)
-          <$> selectModuleClassInstances conn mName
-      pure $ \env' ->
-        env'
-          { E.names = E.names env' <> Map.fromList names,
-            E.types = E.types env' <> Map.fromList types,
-            E.dataConstructors = E.dataConstructors env' <> Map.fromList dataConstructors,
-            E.typeSynonyms = E.typeSynonyms env' <> Map.fromList typeSynonyms,
-            E.typeClasses = E.typeClasses env' <> Map.fromList typeClasses,
-            E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
-          }
 
+    importRefs mName refs = do
+        edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
+        pure $ foldl' (>>>) identity edits
+
+    importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
+    importRef mName = \case
+      P.TypeClassRef _ className -> importClassAndTypes mName className
+      P.TypeRef _ tyName ctrs -> do
+        let qual = P.Qualified (P.ByModuleName mName) tyName
+        type' <- selectType conn qual
+        ctrVals <- case ctrs of
+          Nothing -> selectTypeDataConstructors conn qual
+          Just ctrs' -> forConcurrently ctrs' \ctr -> do
+            let qual' = P.Qualified (P.ByModuleName mName) ctr
+            val <- selectDataConstructor conn qual'
+            pure (qual', fromJust val)
+        pure $ \env' ->
+          env'
+            { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
+              E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+            }
+      P.ValueRef _ ident -> do
+        let qual = P.Qualified (P.ByModuleName mName) ident
+        val <- selectEnvValue conn qual
+        pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
+      P.TypeInstanceRef _ ident _ -> do
+        let qual = P.Qualified (P.ByModuleName mName) ident
+        val <- selectClassInstance conn qual
+        pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust val]}
+      P.ModuleRef _ m -> importModule m
+      P.ReExportRef _ _ ref -> importRef mName ref
+      P.ValueOpRef _ opName -> do
+        (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
+        if isUpper $ T.head alias
+          then do
+            let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
+            val <- selectDataConstructor conn qual
+            pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJust val)]}
+          else do
+            let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
+            val <- selectEnvValue conn qual
+            pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
+      P.TypeOpRef _ opName -> do
+        (aliasModName, alias) <- fromJust <$> selectTypeOperatorAlias conn mName opName
+        let qual = P.Qualified (P.ByModuleName aliasModName) alias
+        val <- selectType conn qual
+        pure $ \env' ->
+          env'
+            { E.types = E.types env' <> Map.fromList [(qual, fromJust val)]
+            }
+
+    importModule mName = importModuleHiding mName []
+
+    importModuleHiding mName hideRefs = do
+      allRefs <- selectModuleExports conn mName
+      let refs = filter (not . flip Set.member hiddenRefSet) allRefs
+      importRefs mName refs
+      where 
+        hiddenRefSet = Set.fromList hideRefs
+      
     importClassOnly :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
     importClassOnly mName className = do
       let qual = P.Qualified (P.ByModuleName mName) className
-      typeClass <- fromJustWithErr qual <$> selectTypeClass conn qual
+      typeClass <- fromJustWithErr qual <$> selectTypeClass conn mName className
       instances <- selectClassInstancesByClassName conn qual
       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
         P.Qualified (P.ByModuleName superModName) superClassName -> do
-          superModName' <- selectImportedAs' conn mName superModName
-          importClassOnly superModName' superClassName
+          -- superModName' <- selectImportedAs' conn mName superModName
+          importClassOnly superModName superClassName
         _ -> pure identity
       pure $
         foldl' (>>>) identity superClassImports >>> \env' ->
@@ -334,7 +308,7 @@ selectEnvFromImports conn (P.Module _ _ mName' decls _) = liftIO do
     importClassAndTypes mName className = do
       let qual = P.Qualified (P.ByModuleName mName) className
           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
-      typeClass <- fromJust <$> selectTypeClass conn qual
+      typeClass <- fromJust <$> selectTypeClass conn mName className
       type' <- selectType conn typeQual
       let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
       dictVal@(_, dictKind) <- fromJustWithErr dictName <$> selectType conn dictName
@@ -348,10 +322,15 @@ selectEnvFromImports conn (P.Module _ _ mName' decls _) = liftIO do
       ctrData <- ctrMb & maybe (pure Nothing) (\ctr -> selectDataConstructor conn ctr)
       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
         P.Qualified (P.ByModuleName superModName) superClassName -> do
-          importClassOnly (replaceModuleAlias superModName) superClassName
+          importClassAndTypes superModName superClassName
         _ -> pure identity
+      when (mName == P.ModuleName "Data.HeytingAlgebra") do
+        putErrLn ("HeytingAlgebra class import: \n" <> show qual :: Text)
       instances <- selectClassInstancesByClassName conn qual
 
+      when (mName == P.ModuleName "Data.HeytingAlgebra") do
+        putErrLn ("HeytingAlgebra instances: \n" <> T.intercalate "\n\n" (fmap (show . tcdValue) instances) :: Text)
+
       pure $
         foldl' (>>>) identity superClassImports >>> \env' ->
           env'
@@ -370,52 +349,25 @@ selectEnvFromImports conn (P.Module _ _ mName' decls _) = liftIO do
               E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
             }
 
-    importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
-    importRef mName = \case
-      P.TypeClassRef _ className -> importClassAndTypes mName className
-      P.TypeRef _ tyName ctrs -> do
-        let qual = P.Qualified (P.ByModuleName mName) tyName
-        type' <- selectType conn qual
-        ctrVals <- case ctrs of
-          Nothing -> selectTypeDataConstructors conn qual
-          Just ctrs' -> forConcurrently ctrs' \ctr -> do
-            let qual' = P.Qualified (P.ByModuleName mName) ctr
-            val <- selectDataConstructor conn qual'
-            pure (qual', fromJust val)
-        pure $ \env' ->
-          env'
-            { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
-              E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
-            }
-      P.ValueRef _ ident -> do
-        let qual = P.Qualified (P.ByModuleName mName) ident
-        val <- selectEnvValue conn qual
-        pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
-      P.TypeInstanceRef _ ident _ -> do
-        let qual = P.Qualified (P.ByModuleName mName) ident
-        val <- selectClassInstance conn qual
-        pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust val]}
-      P.ModuleRef _ m -> importModule m
-      P.ReExportRef _ _ ref -> importRef mName ref
-      P.ValueOpRef _ opName -> do
-        (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
-        if isUpper $ T.head alias
-          then do
-            let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
-            val <- selectDataConstructor conn qual
-            pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJust val)]}
-          else do
-            let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
-            val <- selectEnvValue conn qual
-            pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
-      P.TypeOpRef _ opName -> do
-        (aliasModName, alias) <- fromJust <$> selectTypeOperatorAlias conn mName opName
-        let qual = P.Qualified (P.ByModuleName aliasModName) alias
-        val <- selectType conn qual
-        pure $ \env' ->
-          env'
-            { E.types = E.types env' <> Map.fromList [(qual, fromJust val)]
-            }
+selectModuleExports :: Connection -> P.ModuleName -> IO [P.DeclarationRef]
+selectModuleExports conn modName = do
+  SQL.query
+    conn
+    "SELECT value FROM exports WHERE module_name = ?"
+    (SQL.Only modName)
+    <&> fmap SQL.fromOnly
+
+insertExports :: Connection -> P.ModuleName -> Maybe [P.DeclarationRef] -> IO ()
+insertExports  conn modName = \case 
+  Nothing -> internalError "selectEnvFromImports called before desguaring module" 
+  Just refs -> forConcurrently_ refs (insertExport conn modName)
+
+insertExport :: Connection -> P.ModuleName -> P.DeclarationRef -> IO ()
+insertExport conn modName ref =
+   SQL.execute 
+     conn
+     "INSERT INTO exports (module_name, ident, value) VALUES (?, ?, ?)"  
+      (modName, (show $ P.declRefName ref) :: Text,  ref)
 
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
 selectEnvValue conn ident = do
@@ -501,17 +453,16 @@ selectModuleTypeSynonyms conn moduleName' = do
     (SQL.Only moduleName')
     <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st)))
 
-selectTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
-selectTypeClass conn ident = case Map.lookup ident P.allPrimClasses of
-  Just a -> pure $ Just a
-  Nothing ->
-    SQL.query
-      conn
-      "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
-      (modName, className)
-      <&> (fmap SQL.fromOnly . head)
-  where
-    (modName, className) = toDbQualifer ident
+selectTypeClass :: Connection -> P.ModuleName -> P.ProperName 'P.ClassName -> IO (Maybe P.TypeClassData)
+selectTypeClass conn modName className =
+  case Map.lookup (P.Qualified (P.ByModuleName modName) className) P.allPrimClasses of
+    Just a -> pure $ Just a
+    Nothing ->
+      SQL.query
+        conn
+        "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?"
+        (modName, className)
+        <&> (fmap SQL.fromOnly . head)
 
 selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
 selectModuleTypeClasses conn moduleName' = do
@@ -584,7 +535,7 @@ selectTypeOperatorAlias conn modName opName = do
     (modName, P.runOpName opName)
     <&> head
 
-selectImportedAs' :: Connection -> P.ModuleName -> P.ModuleName -> IO  P.ModuleName
+selectImportedAs' :: Connection -> P.ModuleName -> P.ModuleName -> IO P.ModuleName
 selectImportedAs' conn modName importedModName = fromMaybe importedModName <$> selectImportedAs conn modName importedModName
 
 selectImportedAs :: Connection -> P.ModuleName -> P.ModuleName -> IO (Maybe P.ModuleName)
@@ -604,4 +555,16 @@ toDbQualifer (P.Qualified (P.BySourcePos _) _) = internalError "toDbQualifer cal
 fromJustWithErr :: (HasCallStack) => (Show e) => e -> Maybe a -> a
 fromJustWithErr err = \case
   Just a -> a
-  Nothing -> internalError $ "fromJustWithErr: " <> show err
\ No newline at end of file
+  Nothing -> internalError $ "fromJustWithErr: " <> show err
+
+insertImports :: Connection -> P.ModuleName -> [P.Declaration] -> IO ()
+insertImports conn mn = mapConcurrently_ (insertImport conn mn)
+
+insertImport :: Connection -> P.ModuleName -> P.Declaration -> IO ()
+insertImport conn mn = \case
+  P.ImportDeclaration _ importedModuleName _ importedAs -> do
+    SQL.execute
+      conn
+      "INSERT INTO imports (module_name, imported_module, imported_as) VALUES (?, ?, ?)"
+      (mn, importedModuleName, importedAs)
+  _ -> pure ()
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index e4a3d38346..f6dde831d7 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -5,10 +5,7 @@ module Language.PureScript.Sugar (desugar, desugarUsingDb, module S) where
 import Control.Category ((>>>))
 import Control.Monad.Supply.Class (MonadSupply)
 import Control.Monad.Writer.Class (MonadWriter)
-import Data.Map qualified as M
 import Language.PureScript.AST (Module)
-import Language.PureScript.Environment (Environment)
-import Language.PureScript.Environment qualified as P
 import Language.PureScript.Errors (MultipleErrors)
 import Language.PureScript.Externs (ExternsFile, ExternsFixity, ExternsTypeFixity)
 import Language.PureScript.Linter.Imports (UsedImports)
@@ -25,6 +22,7 @@ import Language.PureScript.Sugar.TypeClasses as S
 import Language.PureScript.Sugar.TypeClasses.Deriving as S
 import Language.PureScript.Sugar.TypeDeclarations as S
 import Protolude
+import Database.SQLite.Simple (Connection)
 
 -- |
 -- The desugaring pipeline proceeds as follows:
@@ -74,16 +72,16 @@ desugar externs =
     >=> createBindingGroupsModule
 
 desugarUsingDb ::
-  (MonadSupply m) =>
+  (MonadSupply m, MonadIO m) =>
   (MonadWriter MultipleErrors m) =>
   (MonadError MultipleErrors m) =>
   (MonadState (Env, UsedImports) m) =>
+  Connection ->
   [(P.ModuleName, [ExternsFixity])] ->
   [(P.ModuleName, [ExternsTypeFixity])] ->
-  Environment ->
   Module ->
   m Module
-desugarUsingDb fixities typeFixities env =
+desugarUsingDb conn fixities typeFixities  =
   desugarSignedLiterals
     >>> desugarObjectConstructors
     >=> desugarDoModule
@@ -95,18 +93,5 @@ desugarUsingDb fixities typeFixities env =
     >=> rebracketFixitiesOnly (const True) fixities typeFixities
     >=> checkFixityExports
     >=> deriveInstances
-    >=> desugarTypeClassesUsingMemberMap typeClassData
+    >=> desugarTypeClassesUsingDB conn
     >=> createBindingGroupsModule
-  where
-    typeClassData =
-      P.typeClasses env
-        & M.toList
-        & mapMaybe addModuleName
-        & M.fromList
-
-addModuleName ::
-  (P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData) ->
-  Maybe ((P.ModuleName, P.ProperName 'P.ClassName), P.TypeClassData)
-addModuleName = \case
-  (P.Qualified (P.ByModuleName mn) pn, tcd) -> Just ((mn, pn), tcd)
-  _ -> Nothing
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index f02e027baf..3e367406e9 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -4,9 +4,9 @@
 --
 module Language.PureScript.Sugar.TypeClasses
   ( desugarTypeClasses
-  , desugarTypeClassesUsingMemberMap
   , typeClassMemberName
   , superClassDictionaryNames
+  , desugarTypeClassesUsingDB
   ) where
 
 import Prelude
@@ -14,7 +14,7 @@ import Prelude
 import Control.Arrow (first, second)
 import Control.Monad (unless)
 import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State (MonadState(..), StateT, evalStateT, modify)
+import Control.Monad.State (StateT, evalStateT, modify, gets, MonadIO (liftIO))
 import Control.Monad.Supply.Class (MonadSupply)
 import Data.Graph (SCC(..), stronglyConnComp)
 import Data.List (find, partition)
@@ -36,10 +36,31 @@ import Language.PureScript.PSString (mkString)
 import Language.PureScript.Sugar.CaseDeclarations (desugarCases)
 import Language.PureScript.TypeClassDictionaries (superclassName)
 import Language.PureScript.Types
+import Database.SQLite.Simple (Connection)
+import Language.PureScript.Make.Index.Select (selectTypeClass)
+import Control.Monad.State.Class (get)
 
 type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData
 
-type Desugar = StateT MemberMap
+class GetTypeClass m where
+  getTypeClass :: (ModuleName, ProperName 'ClassName) -> m (Maybe TypeClassData)
+  addTypeClass :: (ModuleName, ProperName 'ClassName) -> TypeClassData -> m ()
+
+
+instance Monad m => GetTypeClass (StateT MemberMap m) where
+  getTypeClass name = gets (M.lookup name)
+  addTypeClass name tc = modify (M.insert name tc)
+
+instance (MonadIO m) => GetTypeClass (StateT (Connection, MemberMap) m) where 
+  getTypeClass qual@(m, name) = do 
+    sync <- gets (M.lookup qual . snd) 
+    case sync of 
+      Just tc -> return (Just tc)
+      Nothing -> do 
+        (conn, _) <- get
+        liftIO (selectTypeClass conn m name)
+    
+  addTypeClass name tc = modify (second (M.insert name tc))
 
 -- |
 -- Add type synonym declarations for type class dictionary types, and value declarations for type class
@@ -50,9 +71,9 @@ desugarTypeClasses
   => [ExternsFile]
   -> Module
   -> m Module
-desugarTypeClasses externs = desugarTypeClassesUsingMemberMap 
+desugarTypeClasses externs = go
     $ M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
-  where 
+  where
   fromExternsDecl
     :: ModuleName
     -> ExternsDeclaration
@@ -60,16 +81,21 @@ desugarTypeClasses externs = desugarTypeClassesUsingMemberMap
   fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty) = Just ((mn, name), typeClass) where
     typeClass = makeTypeClassData args members implies deps tcIsEmpty
   fromExternsDecl _ _ = Nothing
-  
-desugarTypeClassesUsingMemberMap
-  :: (MonadSupply m, MonadError MultipleErrors m)
-  => MemberMap
-  -> Module
-  -> m Module
-desugarTypeClassesUsingMemberMap classes = flip evalStateT initialState . desugarModule
-  where
-  initialState :: MemberMap
-  initialState =
+
+  go
+    :: (MonadSupply m, MonadError MultipleErrors m)
+    => MemberMap
+    -> Module
+    -> m Module
+  go classes = flip evalStateT initialState . desugarModule
+    where
+    initialState :: MemberMap
+    initialState = mkInitialState classes
+
+-- desugarTypeClassesUsingDb 
+
+mkInitialState :: MemberMap -> MemberMap
+mkInitialState classes = 
     mconcat
       [ M.mapKeys (qualify C.M_Prim) primClasses
       , M.mapKeys (qualify C.M_Prim_Coerce) primCoerceClasses
@@ -81,12 +107,21 @@ desugarTypeClassesUsingMemberMap classes = flip evalStateT initialState . desuga
       , classes
       ]
 
--- TODO add desugarModuleSqlite which uses the DB instead of MemberMap to store the type class data
+desugarTypeClassesUsingDB 
+  :: (MonadIO m, MonadSupply m, MonadError MultipleErrors m)
+  => Connection
+  -> Module
+  -> m Module
+desugarTypeClassesUsingDB conn = flip evalStateT initialState . desugarModule
+  where
+  initialState :: (Connection, MemberMap)
+  initialState = (conn, mkInitialState M.empty)
 
 desugarModule
-  :: (MonadSupply m, MonadError MultipleErrors m)
+  :: forall m.
+   (MonadSupply m, MonadError MultipleErrors m, GetTypeClass m) 
   => Module
-  -> Desugar m Module
+  -> m Module
 desugarModule (Module ss coms name decls (Just exps)) = do
   let (classDecls, restDecls) = partition isTypeClassDecl decls
       classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls
@@ -94,11 +129,11 @@ desugarModule (Module ss coms name decls (Just exps)) = do
   (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps)
   return $ Module ss coms name (concat restDeclss ++ concat classDeclss) $ Just (exps ++ catMaybes restNewExpss ++ catMaybes classNewExpss)
   where
-  desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m)
-    => ModuleName
+  desugarClassDecl :: 
+     ModuleName
     -> [DeclarationRef]
     -> SCC Declaration
-    -> Desugar m (Maybe DeclarationRef, [Declaration])
+    -> m (Maybe DeclarationRef, [Declaration])
   desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d
   desugarClassDecl _ _ (CyclicSCC ds')
     | Just ds'' <- nonEmpty ds' = throwError . errorMessage' (declSourceSpan (NEL.head ds'')) $ CycleInTypeClassDeclaration (NEL.map classDeclName ds'')
@@ -208,15 +243,16 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
 --   };
 -}
 desugarDecl
-  :: (MonadSupply m, MonadError MultipleErrors m)
+  :: forall m .
+  (MonadSupply m, MonadError MultipleErrors m, GetTypeClass m)
   => ModuleName
   -> [DeclarationRef]
   -> Declaration
-  -> Desugar m (Maybe DeclarationRef, [Declaration])
+  -> m (Maybe DeclarationRef, [Declaration])
 desugarDecl mn exps = go
   where
   go d@(TypeClassDeclaration sa name args implies deps members) = do
-    modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False))
+    addTypeClass (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)
     return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
   go (TypeInstanceDeclaration sa na chainId idx name deps className tys body) = do
     name' <- desugarInstName name
@@ -243,7 +279,7 @@ desugarDecl mn exps = go
 
   -- Completes the name generation for type class instances that do not have
   -- a unique name defined in source code.
-  desugarInstName :: MonadSupply m => Either Text Ident -> Desugar m Ident
+  desugarInstName :: Either Text Ident -> m Ident
   desugarInstName = either freshIdent pure
 
   expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef
@@ -326,6 +362,7 @@ unit = srcTypeApp tyRecord srcREmpty
 typeInstanceDictionaryDeclaration
   :: forall m
    . MonadError MultipleErrors m
+  => GetTypeClass m
   => SourceAnn
   -> Ident
   -> ModuleName
@@ -333,15 +370,14 @@ typeInstanceDictionaryDeclaration
   -> Qualified (ProperName 'ClassName)
   -> [SourceType]
   -> [Declaration]
-  -> Desugar m Declaration
+  -> m Declaration
 typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls =
   rethrow (addHint (ErrorInInstance className tys)) $ do
-  m <- get
 
   -- Lookup the type arguments and member types for the type class
   TypeClassData{..} <-
-    maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $
-      M.lookup (qualify mn className) m
+    maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return =<<
+      getTypeClass (qualify mn className)
 
   -- Replace the type arguments with the appropriate types in the member types
   let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) . tuple3To2) typeClassMembers
@@ -378,7 +414,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls =
 
   where
 
-  memberToValue :: [(Ident, SourceType)] -> Declaration -> Desugar m Expr
+  memberToValue :: [(Ident, SourceType)] -> Declaration -> m Expr
   memberToValue tys' (ValueDecl (ss', _) ident _ [] [MkUnguarded val]) = do
     _ <- maybe (throwError . errorMessage' ss' $ ExtraneousClassMember ident className) return $ lookup ident tys'
     return val

From 3be413af7499ff9223cdff7efc57daf29177b1e4 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 5 Dec 2024 10:27:54 +0100
Subject: [PATCH 271/297] fixes merging of intances in env

---
 src/Language/PureScript/Make/Index.hs        |  4 --
 src/Language/PureScript/Make/Index/Select.hs | 75 +++++---------------
 src/Language/PureScript/TypeChecker/Monad.hs | 11 ++-
 3 files changed, 25 insertions(+), 65 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 3448f61a7c..c0b527a30f 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Language.PureScript.Make.Index
   ( initDb,
@@ -399,9 +398,6 @@ indexExportedEnv moduleName env refs conn = liftIO do
   envFromModule E.dataConstructors & filter dataConstructorExportedOrDict & mapConcurrently_ (uncurry $ insertDataConstructor conn)
   envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn)
   envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
-  when (moduleName == P.ModuleName "Data.HeytingAlgebra") do
-    putErrLn $ "typeClassDicts: \n" <> intercalate "\n" (P.debugTypeClassDictionaries env)
-    putErrLn $ ("dicts exported:\n" :: Text) <> T.intercalate "\n" (fmap (P.runIdent . P.disqualify . tcdValue) dicts)
   dicts
     -- & filter ((== Just moduleName) . P.getQual . tcdValue)
     & mapConcurrently_ (insertNamedDict conn)
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index e57fb32edb..bb67ddf4a8 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -5,7 +5,7 @@ module Language.PureScript.Make.Index.Select where
 
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
-import Control.Concurrent.Async.Lifted (forConcurrently, mapConcurrently_, forConcurrently_)
+import Control.Concurrent.Async.Lifted (forConcurrently, forConcurrently_, mapConcurrently_)
 import Data.Aeson qualified as A
 import Data.ByteString.Lazy qualified as Lazy
 import Data.List.NonEmpty qualified as NEL
@@ -25,13 +25,11 @@ import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
 import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
--- import Language.PureScript.TypeChecker.Monad (debugTypeClassDictionaries)
 import Language.PureScript.TypeChecker.Monad qualified as P
-import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdValue))
+import Language.PureScript.TypeClassDictionaries (NamedDict)
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
-import Language.PureScript.TypeChecker.Monad (debugTypeClassDictionaries)
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImportsAndDecls conn module' = do
@@ -69,7 +67,6 @@ selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _refs) = do
       P.ImportDeclaration _ mn' idt _ -> Just <$> f mn' idt
       _ -> pure Nothing
 
-
 selectImportValueFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsFixity])
 selectImportValueFixities conn modName = \case
   P.Implicit -> selectValueFixitiesFromModule conn modName
@@ -172,12 +169,11 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
       case idt of
         P.Implicit -> importModule mName
         P.Explicit refs -> importRefs mName refs
-        P.Hiding refs -> importModuleHiding mName refs 
+        P.Hiding refs -> importModuleHiding mName refs
 
     -- P.TypeInstanceDeclaration _ _ _ _ _ deps _className _types _ -> do
     --   depFns <- forConcurrently deps \case
     --     dep -> do
-    --       putErrLn ( "dep: " <> show (P.constraintClass dep) :: Text)
     --       case P.constraintClass dep of
     --         -- P.Qualified (P.ByModuleName depModuleName) depClassName ->
     --         --   importClassAndTypes depModuleName depClassName
@@ -189,28 +185,13 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
     -- pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust dict]}
     _ -> pure identity
 
-
   dictFns <- forConcurrently deferredDicts \case
     (P.Qualified (P.ByModuleName mn) className, _types) -> importClassAndTypes mn className
     _ -> pure identity
 
   let env = foldl' (&) E.initEnvironment (importFns <> dictFns)
-  when (modName == P.ModuleName "Data.BooleanAlgebra") do
-    putErrLn $ ("deferredDicts:\n " :: Text) <> T.intercalate "\n" (fmap (show . fst) deferredDicts)
-    putErrLn $ "Data.BooleanAlgebra: \n" <> intercalate "\n" (debugTypeClassDictionaries env)
-
   pure env
   where
-    -- replaceModuleAlias :: P.ModuleName -> P.ModuleName
-    -- replaceModuleAlias mName = fromMaybe mName $ Map.lookup mName importAliasMap
-
-    -- importAliasMap :: Map.Map P.ModuleName P.ModuleName
-    -- importAliasMap =
-    --   Map.fromList $
-    --     decls >>= \case
-    --       P.ImportDeclaration _ mName _ (Just alias) -> [(alias, mName)]
-    --       _ -> []
-
     deferredDicts = getDeclDicts =<< decls
 
     getDeclDicts :: P.Declaration -> [(P.Qualified (P.ProperName 'P.ClassName), [P.SourceType])]
@@ -226,10 +207,9 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
         pure e
       e -> pure e
 
-
     importRefs mName refs = do
-        edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
-        pure $ foldl' (>>>) identity edits
+      edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
+      pure $ foldl' (>>>) identity edits
 
     importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
     importRef mName = \case
@@ -255,7 +235,8 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
       P.TypeInstanceRef _ ident _ -> do
         let qual = P.Qualified (P.ByModuleName mName) ident
         val <- selectClassInstance conn qual
-        pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust val]}
+        pure $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap [fromJust val] (E.typeClassDictionaries env')}
+
       P.ModuleRef _ m -> importModule m
       P.ReExportRef _ _ ref -> importRef mName ref
       P.ValueOpRef _ opName -> do
@@ -284,25 +265,8 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
       allRefs <- selectModuleExports conn mName
       let refs = filter (not . flip Set.member hiddenRefSet) allRefs
       importRefs mName refs
-      where 
+      where
         hiddenRefSet = Set.fromList hideRefs
-      
-    importClassOnly :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
-    importClassOnly mName className = do
-      let qual = P.Qualified (P.ByModuleName mName) className
-      typeClass <- fromJustWithErr qual <$> selectTypeClass conn mName className
-      instances <- selectClassInstancesByClassName conn qual
-      superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
-        P.Qualified (P.ByModuleName superModName) superClassName -> do
-          -- superModName' <- selectImportedAs' conn mName superModName
-          importClassOnly superModName superClassName
-        _ -> pure identity
-      pure $
-        foldl' (>>>) identity superClassImports >>> \env' ->
-          env'
-            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, typeClass)],
-              E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
-            }
 
     importClassAndTypes :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
     importClassAndTypes mName className = do
@@ -324,13 +288,8 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
         P.Qualified (P.ByModuleName superModName) superClassName -> do
           importClassAndTypes superModName superClassName
         _ -> pure identity
-      when (mName == P.ModuleName "Data.HeytingAlgebra") do
-        putErrLn ("HeytingAlgebra class import: \n" <> show qual :: Text)
       instances <- selectClassInstancesByClassName conn qual
 
-      when (mName == P.ModuleName "Data.HeytingAlgebra") do
-        putErrLn ("HeytingAlgebra instances: \n" <> T.intercalate "\n\n" (fmap (show . tcdValue) instances) :: Text)
-
       pure $
         foldl' (>>>) identity superClassImports >>> \env' ->
           env'
@@ -346,7 +305,7 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
                   <> Map.fromList case (ctrMb, ctrData) of
                     (Just ctr', Just ctrData') -> [(ctr', ctrData')]
                     _ -> [],
-              E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap instances
+              E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
             }
 
 selectModuleExports :: Connection -> P.ModuleName -> IO [P.DeclarationRef]
@@ -358,16 +317,16 @@ selectModuleExports conn modName = do
     <&> fmap SQL.fromOnly
 
 insertExports :: Connection -> P.ModuleName -> Maybe [P.DeclarationRef] -> IO ()
-insertExports  conn modName = \case 
-  Nothing -> internalError "selectEnvFromImports called before desguaring module" 
+insertExports conn modName = \case
+  Nothing -> internalError "selectEnvFromImports called before desguaring module"
   Just refs -> forConcurrently_ refs (insertExport conn modName)
 
 insertExport :: Connection -> P.ModuleName -> P.DeclarationRef -> IO ()
 insertExport conn modName ref =
-   SQL.execute 
-     conn
-     "INSERT INTO exports (module_name, ident, value) VALUES (?, ?, ?)"  
-      (modName, (show $ P.declRefName ref) :: Text,  ref)
+  SQL.execute
+    conn
+    "INSERT INTO exports (module_name, ident, value) VALUES (?, ?, ?)"
+    (modName, (show $ P.declRefName ref) :: Text, ref)
 
 selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
 selectEnvValue conn ident = do
@@ -499,7 +458,7 @@ selectClassInstanceByIdents ::
 selectClassInstanceByIdents conn classNameQual idents = do
   SQL.query
     conn
-    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND class_name = ? AND idents = ?"
+    "SELECT dict FROM env_type_class_instances WHERE class_module = ? AND class_name = ? AND idents = ?"
     (modName, className, A.encode idents)
     <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
   where
@@ -513,7 +472,7 @@ selectClassInstancesByClassName ::
 selectClassInstancesByClassName conn classNameQual = do
   SQL.query
     conn
-    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND class_name = ?"
+    "SELECT dict FROM env_type_class_instances WHERE class_module = ? AND class_name = ?"
     (modName, className)
     <&> fmap (SQL.fromOnly >>> deserialise)
   where
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 3caa9d58db..bf21bb8f98 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -205,14 +205,18 @@ withTypeClassDictionaries
   -> m a
 withTypeClassDictionaries entries action = do
   orig <- get
-
-  let mentries = typeClassDictionariesEnvMap entries
   
-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } }
+  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = addDictsToEnvMap entries (typeClassDictionaries . checkEnv $ st) } }
   a <- action
   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
   return a
 
+addDictsToEnvMap :: [NamedDict] 
+     -> M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) 
+    ->  M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
+addDictsToEnvMap entries envMap = 
+  M.unionWith (M.unionWith (M.unionWith (<>))) envMap (typeClassDictionariesEnvMap entries)
+
 
 typeClassDictionariesEnvMap :: [NamedDict] 
   -> M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
@@ -223,6 +227,7 @@ typeClassDictionariesEnvMap entries =
         <- entries
     ]
 
+
 -- | Get the currently available map of type class dictionaries
 getTypeClassDictionaries
   :: (MonadState CheckState m)

From be1eefc5881f69242ff09516dc25a0b19253485e Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 5 Dec 2024 15:55:26 +0100
Subject: [PATCH 272/297] adds env name constraints

---
 src/Language/PureScript/Make/Index/Select.hs | 72 +++++++++++++++-----
 1 file changed, 54 insertions(+), 18 deletions(-)

diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index bb67ddf4a8..f2656e52ba 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BlockArguments #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.Make.Index.Select where
 
@@ -30,6 +31,10 @@ import Language.PureScript.TypeClassDictionaries (NamedDict)
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
+import Control.Monad.Trans.Writer (execWriter, tell)
+import Control.Monad.Writer (Writer)
+import Language.PureScript.Types (Constraint(constraintClass))
+import Control.Lens (view, Field1 (_1))
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImportsAndDecls conn module' = do
@@ -170,35 +175,57 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
         P.Implicit -> importModule mName
         P.Explicit refs -> importRefs mName refs
         P.Hiding refs -> importModuleHiding mName refs
-
-    -- P.TypeInstanceDeclaration _ _ _ _ _ deps _className _types _ -> do
-    --   depFns <- forConcurrently deps \case
-    --     dep -> do
-    --       case P.constraintClass dep of
-    --         -- P.Qualified (P.ByModuleName depModuleName) depClassName ->
-    --         --   importClassAndTypes depModuleName depClassName
-    --         _ -> pure identity
-
-    -- pure (foldl' (>>>) identity depFns)
-
-    -- dict <- selectClassInstanceByIdents conn className types
-    -- pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust dict]}
     _ -> pure identity
 
-  dictFns <- forConcurrently deferredDicts \case
+  -- when (modName == P.ModuleName "Data.Eq") do
+  --   putErrLn ( show decls :: Text)
+  --   for_ decls \case
+  --     P.TypeInstanceDeclaration _ _ _ _ name _ _ _ (P.ExplicitInstance [P.ValueDeclaration P.ValueDeclarationData {..}]) | name == Right (P.Ident "eqRowCons") -> do
+  --       putErrLn ("eqRowCons: " <> show valdeclExpression :: Text)
+  --     -- dict <- selectClassInstanceByIdents conn (P.Qualified (P.ByModuleName modName) cn) []
+  --     -- pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust dict]}
+  --     _ -> pure ()
+
+  deferredDictFns <- forConcurrently deferredDicts \case
     (P.Qualified (P.ByModuleName mn) className, _types) -> importClassAndTypes mn className
     _ -> pure identity
 
-  let env = foldl' (&) E.initEnvironment (importFns <> dictFns)
-  pure env
+  constraintsFns <- forConcurrently constraints \c -> do
+    let (classMod, className) = toDbQualifer $ constraintClass c
+    importClassAndTypes classMod className
+
+  let 
+     env = foldl' (&) E.initEnvironment importFns
+  
+  envConstraintFns <- forConcurrently (getEnvConstraints env) \c -> do
+    let (classMod, className) = toDbQualifer $ constraintClass c
+    importClassAndTypes classMod className
+
+  pure $ foldl' (&) env envConstraintFns
   where
+
+    
+    constraints :: [P.SourceConstraint]
+    constraints =  (execWriter . getDeclContraints) =<< decls 
+
+    (getDeclContraints, _, _) =  P.everywhereOnValuesTopDownM declContraint exprContraint pure 
+
+    declContraint :: P.Declaration -> Writer [P.SourceConstraint] P.Declaration
+    declContraint = pure 
+
+    exprContraint :: P.Expr -> Writer [P.SourceConstraint] P.Expr
+    exprContraint e = case e of 
+      P.TypeClassDictionary c _ _ -> tell [c] >> pure e
+      _ -> pure e
+
+
     deferredDicts = getDeclDicts =<< decls
 
     getDeclDicts :: P.Declaration -> [(P.Qualified (P.ProperName 'P.ClassName), [P.SourceType])]
 
     getDeclDicts d = execState (onDecl d) []
 
-    (onDecl, _, _) = P.everywhereOnValuesM pure goExpr pure
+    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure goExpr pure
 
     goExpr :: P.Expr -> State [(P.Qualified (P.ProperName 'P.ClassName), [P.SourceType])] P.Expr
     goExpr = \case
@@ -236,7 +263,6 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
         let qual = P.Qualified (P.ByModuleName mName) ident
         val <- selectClassInstance conn qual
         pure $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap [fromJust val] (E.typeClassDictionaries env')}
-
       P.ModuleRef _ m -> importModule m
       P.ReExportRef _ _ ref -> importRef mName ref
       P.ValueOpRef _ opName -> do
@@ -527,3 +553,13 @@ insertImport conn mn = \case
       "INSERT INTO imports (module_name, imported_module, imported_as) VALUES (?, ?, ?)"
       (mn, importedModuleName, importedAs)
   _ -> pure ()
+
+getEnvConstraints :: E.Environment -> [P.SourceConstraint]
+getEnvConstraints env = 
+  E.names env & Map.elems >>= typeConstraints . view _1
+
+typeConstraints :: P.Type a -> [P.Constraint a]
+typeConstraints = P.everythingOnTypes (<>) \case 
+  P.ConstrainedType _ c _ -> [c]
+  _ -> []
+ 

From 832d3d29e7da278b43230aba802a6284675b076d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 10 Dec 2024 12:17:35 +0100
Subject: [PATCH 273/297] value fixities importing with definition module names

---
 src/Language/PureScript/Docs/Convert.hs       |   2 +-
 src/Language/PureScript/Make.hs               |  26 +-
 src/Language/PureScript/Make/Index/Select.hs  | 273 ++++++++----------
 src/Language/PureScript/Sugar.hs              |  17 +-
 src/Language/PureScript/Sugar/Operators.hs    |   6 +-
 .../PureScript/Sugar/Operators/Binders.hs     |   4 +-
 .../PureScript/Sugar/Operators/Common.hs      |   7 +-
 .../PureScript/Sugar/Operators/Expr.hs        |   2 +
 .../PureScript/Sugar/Operators/Types.hs       |   2 +
 9 files changed, 154 insertions(+), 185 deletions(-)

diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index 6f93cbd626..747db9281f 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -297,7 +297,7 @@ partiallyDesugarWithouExterns ::
   P.Env ->
   P.Module ->
   m P.Module
-partiallyDesugarWithouExterns  fixities typeFixities env = evalSupplyT 0 . desugar'
+partiallyDesugarWithouExterns fixities typeFixities env = evalSupplyT 0 . desugar'
   where
   desugar' =
     P.desugarDoModule
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index cac0e553a6..a193122e5c 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -178,14 +178,13 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
-  (ops, typeOps) <- liftIO $ selectFixitiesFromModuleImports conn m
   -- when (moduleName == ModuleName "Data.NaturalTransformation") $ do 
   --   putErrLn ( "ops:" :: T.Text)
   --   putErrLn $ intercalate "\n" $ fmap show ops
   --   putErrLn ( "type ops:" :: T.Text)
   --   putErrLn $ intercalate "\n" $ fmap show typeOps
   ((Module ss coms _ elaborated exps, checkSt), nextVar) <-
-    desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv ops typeOps
+    desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv 
   let env' = P.checkEnv checkSt
 
   -- desugar case declarations *after* type- and exhaustiveness checking
@@ -209,14 +208,15 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
   -- a bug in the compiler, which should be reported as such.
   -- 2. We do not want to perform any extra work generating docs unless the
   -- user has asked for docs to be generated.
-  let docs = case Docs.convertModuleWithoutExterns ops typeOps exEnv env' withPrim of
-        Left errs ->
-          internalError $
-            "Failed to produce docs for "
-              ++ T.unpack (runModuleName moduleName)
-              ++ "; details:\n"
-              ++ prettyPrintMultipleErrors defaultPPEOptions errs
-        Right d -> d
+  let docs = Docs.Module moduleName (Just "TODO") [] []
+    -- case Docs.convertModuleWithoutExterns ops typeOps exEnv env' withPrim of
+    --     Left errs ->
+    --       internalError $
+    --         "Failed to produce docs for "
+    --           ++ T.unpack (runModuleName moduleName)
+    --           ++ "; details:\n"
+    --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
+    --     Right d -> d
 
   evalSupplyT nextVar'' $ codegen env' checkSt mod' renamed docs exts
   return exts
@@ -266,11 +266,9 @@ desugarAndTypeCheckDb ::
   ModuleName ->
   Module ->
   Env ->
-  [(ModuleName, [ExternsFixity])] ->
-  [(ModuleName, [ExternsTypeFixity])] ->
   m ((Module, CheckState), Integer)
-desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv ops typeOps = runSupplyT 0 $ do
-  (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn ops typeOps withPrim) (exEnv, mempty)
+desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv = runSupplyT 0 $ do
+  (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn exEnv withPrim) (exEnv, mempty)
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
   env <- selectEnvFromImports conn desugared
   (checked, checkSt@(CheckState {..})) <- runStateT (catchError (typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index f2656e52ba..889b12803f 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -1,14 +1,12 @@
 {-# LANGUAGE BlockArguments #-}
-{-# OPTIONS_GHC -Wno-unused-local-binds #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Language.PureScript.Make.Index.Select where
 
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
-import Control.Concurrent.Async.Lifted (forConcurrently, forConcurrently_, mapConcurrently_)
+import Control.Concurrent.Async.Lifted (forConcurrently, forConcurrently_, mapConcurrently, mapConcurrently_)
+import Control.Lens (Field1 (_1), Field3 (_3), view, Field2 (_2))
 import Data.Aeson qualified as A
-import Data.ByteString.Lazy qualified as Lazy
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -18,7 +16,6 @@ import Database.SQLite.Simple qualified as SQL
 import Language.PureScript.AST.Declarations (ImportDeclarationType)
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.Operators qualified as P
-import Language.PureScript.AST.Traversals qualified as P
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (TypeClassData (typeClassSuperclasses))
 import Language.PureScript.Environment qualified as E
@@ -26,19 +23,18 @@ import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
 import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
+import Language.PureScript.Sugar.Names (Exports (exportedValueOps))
+import Language.PureScript.Sugar.Names.Env qualified as P
 import Language.PureScript.TypeChecker.Monad qualified as P
 import Language.PureScript.TypeClassDictionaries (NamedDict)
+import Language.PureScript.Types (Constraint (constraintClass))
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
-import Control.Monad.Trans.Writer (execWriter, tell)
-import Control.Monad.Writer (Writer)
-import Language.PureScript.Types (Constraint(constraintClass))
-import Control.Lens (view, Field1 (_1))
-
-selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModuleImportsAndDecls conn module' = do
-  (fixitiesFromImports, typeFixitiesFromImports) <- selectFixitiesFromModuleImports conn module'
+
+selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
+selectFixitiesFromModuleImportsAndDecls conn env module' = do
+  (fixitiesFromImports, typeFixitiesFromImports) <- selectFixitiesFromModuleImports conn env module'
   let (fixitiesFromDecls, typeFixitiesFromDecls) = getModuleFixities module'
   pure ((P.getModuleName module', fixitiesFromDecls) : fixitiesFromImports, (P.getModuleName module', typeFixitiesFromDecls) : typeFixitiesFromImports)
 
@@ -61,67 +57,84 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
           P.FixityDeclaration _ fixity -> [fixity]
           _ -> []
 
-selectFixitiesFromModuleImports :: Connection -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
-selectFixitiesFromModuleImports conn (P.Module _ _ _ decls _refs) = do
-  valueOps <- catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn))
-  typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn))
-  pure (valueOps, typeOps)
+selectFixitiesFromModuleImports :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
+selectFixitiesFromModuleImports conn env (P.Module _ _ _modName decls _refs) = do
+  valueOps <- join . catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn env))
+  typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn env))
+  -- when (_modName == P.ModuleName "Data.EuclideanRing") do 
+  --   putErrText $ T.intercalate "\n\n" $ fmap show imports
+  --   putErrText $ T.intercalate "\n\n" $ fmap show valueOps
+
+  pure (groupByModule valueOps, typeOps)
   where
-    onImports :: (P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [a])) -> P.Declaration -> IO (Maybe (P.ModuleName, [a]))
+    onImports :: (P.ModuleName -> ImportDeclarationType -> IO a) -> P.Declaration -> IO (Maybe a)
     onImports f = \case
       P.ImportDeclaration _ mn' idt _ -> Just <$> f mn' idt
       _ -> pure Nothing
 
-selectImportValueFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsFixity])
-selectImportValueFixities conn modName = \case
-  P.Implicit -> selectValueFixitiesFromModule conn modName
-  P.Explicit refs | refsValueOps refs /= [] -> selectExplicitValueFixitiesFromModule conn modName (refsValueOps refs)
-  P.Hiding refs -> selectNonHiddenValueFixitiesFromModule conn modName (refsValueOps refs)
-  _ -> pure (modName, [])
 
-refsValueOps :: [P.DeclarationRef] -> [P.OpName 'P.ValueOpName]
-refsValueOps = mapMaybe refValueOp
+groupByModule :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
+groupByModule = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
 
-refValueOp :: P.DeclarationRef -> Maybe (P.OpName 'P.ValueOpName)
-refValueOp = \case
-  P.ValueOpRef _ ident -> Just ident
-  _ -> Nothing
+    -- addOr' = if _modName == P.ModuleName "Data.EuclideanRing" then (\ops -> (P.ModuleName "Nonsense", [orImport]) : ops) else identity
+    -- addOr' = if _modName == P.ModuleName "Data.EuclideanRing" then (\ops -> (P.ModuleName "Data.HeytingAlgebra", [orImport]) : ops) else identity
 
-selectValueFixitiesFromModule :: Connection -> P.ModuleName -> IO (P.ModuleName, [ExternsFixity])
-selectValueFixitiesFromModule conn modName = do
-  (modName,)
-    <$> SQL.query
-      conn
-      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ?"
-      (SQL.Only modName)
-
-selectExplicitValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
-selectExplicitValueFixitiesFromModule _ modName [] = pure (modName, [])
-selectExplicitValueFixitiesFromModule conn modName ops = do
-  (modName,)
-    <$> SQL.query
-      conn
-      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name IN (SELECT value FROM json_each(?))"
-      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
-
-selectNonHiddenValueFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.ValueOpName] -> IO (P.ModuleName, [ExternsFixity])
-selectNonHiddenValueFixitiesFromModule conn modName [] = selectValueFixitiesFromModule conn modName
-selectNonHiddenValueFixitiesFromModule conn modName ops = do
-  (modName,)
-    <$> SQL.query
-      conn
-      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name NOT IN (SELECT value FROM json_each(?))"
-      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
+selectImportValueFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, ExternsFixity)]
+selectImportValueFixities conn env modName = \case
+  P.Implicit -> selectValueFixitiesFromExports conn exports
+  P.Explicit refs -> selectValueFixitiesFromExports conn $ Map.filterWithKey (inRefs refs) exports
+  P.Hiding refs -> selectValueFixitiesFromExports conn $ Map.filterWithKey (fmap not . inRefs refs) exports
+  where
+    exports = exportedValueOps $ lookupExports modName env
+    inRefs refs opName _ = opName `elem` opRefs
+      where 
+        opRefs = refsValueOps env refs
+
+lookupExports :: P.ModuleName ->  P.Env -> Exports
+lookupExports modName env  = view _3 $ fromJust $ Map.lookup modName env
+
+lookupImports :: P.ModuleName ->  P.Env -> P.Imports
+lookupImports modName env  = view _2 $ fromJust $ Map.lookup modName env
+      
+refsValueOps ::  P.Env -> [P.DeclarationRef] -> [P.OpName 'P.ValueOpName]
+refsValueOps env = (=<<) (refValueOp env)
+
+refValueOp :: P.Env -> P.DeclarationRef -> [P.OpName 'P.ValueOpName]
+refValueOp env = \case
+  P.ValueOpRef _ ident -> pure ident
+  P.ReExportRef _ _ ref -> refValueOp env ref
+  -- P.ModuleRef _ m -> _  env $ exportedValueOps $ lookupExports m env
+  _ -> []
+
+selectValueFixitiesFromExports :: Connection -> Map (P.OpName 'P.ValueOpName) P.ExportSource -> IO [(P.ModuleName, ExternsFixity)]
+selectValueFixitiesFromExports conn = fmap catMaybes . mapConcurrently select . Map.toList
+  where
+    select (opName, P.ExportSource{..}) =  fmap (exportSourceDefinedIn, ) <$> selectImportValueFixity conn  exportSourceDefinedIn opName
 
-byteToText :: Lazy.ByteString -> Text
-byteToText = decodeUtf8 . Lazy.toStrict
+addOr :: [ExternsFixity] -> [ExternsFixity]
+addOr ops =  ExternsFixity P.Infixr 2 (P.OpName "||") (P.Qualified (P.ByModuleName $ P.ModuleName "Data.HeytingAlgebra") $ Left $ P.Ident "disj") : ops
 
-selectImportTypeFixities :: Connection -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsTypeFixity])
-selectImportTypeFixities conn modName = \case
-  P.Implicit -> selectTypeFixitiesFromModule conn modName
-  P.Explicit refs | refsTypeOps refs /= [] -> selectExplicitTypeFixitiesFromModule conn modName (refsTypeOps refs)
-  P.Hiding refs -> selectNonHiddenTypeFixitiesFromModule conn modName (refsTypeOps refs)
-  _ -> pure (modName, [])
+orImport :: ExternsFixity
+orImport =  ExternsFixity P.Infixr 2 (P.OpName "||") (P.Qualified (P.ByModuleName $ P.ModuleName "Data.HeytingAlgebra") $ Left $ P.Ident "disj")
+
+selectImportValueFixity :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe ExternsFixity)
+selectImportValueFixity conn modName opName = do
+  SQL.query
+    conn
+    "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name = ?"
+    (modName, opName)
+    <&> head
+
+selectImportTypeFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsTypeFixity])
+selectImportTypeFixities conn env modName = fmap (fmap (modName,) )\case
+  P.Implicit -> selectTypeFixitiesFromExports conn exports
+  P.Explicit refs -> selectTypeFixitiesFromExports conn $ Map.filterWithKey (inRefs refs) exports
+  P.Hiding refs -> selectTypeFixitiesFromExports conn $ Map.filterWithKey (fmap not . inRefs refs) exports
+  where
+    exports = P.exportedTypeOps $ view _3 $ fromJust $ Map.lookup modName env
+    inRefs refs opName _ = opName `elem` opRefs
+      where 
+        opRefs = refsTypeOps refs
 
 refsTypeOps :: [P.DeclarationRef] -> [P.OpName 'P.TypeOpName]
 refsTypeOps = mapMaybe refTypeOp
@@ -129,33 +142,21 @@ refsTypeOps = mapMaybe refTypeOp
 refTypeOp :: P.DeclarationRef -> Maybe (P.OpName 'P.TypeOpName)
 refTypeOp = \case
   P.TypeOpRef _ ident -> Just ident
+  P.ReExportRef _ _ ref -> refTypeOp ref
   _ -> Nothing
 
-selectTypeFixitiesFromModule :: Connection -> P.ModuleName -> IO (P.ModuleName, [ExternsTypeFixity])
-selectTypeFixitiesFromModule conn modName = do
-  (modName,)
-    <$> SQL.query
-      conn
-      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ?"
-      (SQL.Only modName)
-
-selectExplicitTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
-selectExplicitTypeFixitiesFromModule _ modName [] = pure (modName, [])
-selectExplicitTypeFixitiesFromModule conn modName ops = do
-  (modName,)
-    <$> SQL.query
-      conn
-      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name IN (SELECT value FROM json_each(?))"
-      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
-
-selectNonHiddenTypeFixitiesFromModule :: Connection -> P.ModuleName -> [P.OpName 'P.TypeOpName] -> IO (P.ModuleName, [ExternsTypeFixity])
-selectNonHiddenTypeFixitiesFromModule conn modName [] = selectTypeFixitiesFromModule conn modName
-selectNonHiddenTypeFixitiesFromModule conn modName ops = do
-  (modName,)
-    <$> SQL.query
-      conn
-      "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name NOT IN (SELECT value FROM json_each(?))"
-      (modName, decodeUtf8 $ Lazy.toStrict $ A.encode (fmap P.runOpName ops))
+selectTypeFixitiesFromExports :: Connection -> Map (P.OpName 'P.TypeOpName) P.ExportSource -> IO [ExternsTypeFixity]
+selectTypeFixitiesFromExports conn = fmap catMaybes . mapConcurrently select . Map.toList
+  where
+    select (opName, exSrc) = selectImportTypeFixity conn (P.exportSourceDefinedIn exSrc) opName
+
+selectImportTypeFixity :: Connection -> P.ModuleName -> P.OpName 'P.TypeOpName -> IO (Maybe ExternsTypeFixity)
+selectImportTypeFixity conn modName opName = do
+  SQL.query
+    conn
+    "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name = ?"
+    (modName, opName)
+    <&> head
 
 type ClassDict =
   Map.Map
@@ -177,70 +178,21 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
         P.Hiding refs -> importModuleHiding mName refs
     _ -> pure identity
 
-  -- when (modName == P.ModuleName "Data.Eq") do
-  --   putErrLn ( show decls :: Text)
-  --   for_ decls \case
-  --     P.TypeInstanceDeclaration _ _ _ _ name _ _ _ (P.ExplicitInstance [P.ValueDeclaration P.ValueDeclarationData {..}]) | name == Right (P.Ident "eqRowCons") -> do
-  --       putErrLn ("eqRowCons: " <> show valdeclExpression :: Text)
-  --     -- dict <- selectClassInstanceByIdents conn (P.Qualified (P.ByModuleName modName) cn) []
-  --     -- pure $ \env' -> env' {E.typeClassDictionaries = E.typeClassDictionaries env' <> P.typeClassDictionariesEnvMap [fromJust dict]}
-  --     _ -> pure ()
-
-  deferredDictFns <- forConcurrently deferredDicts \case
-    (P.Qualified (P.ByModuleName mn) className, _types) -> importClassAndTypes mn className
-    _ -> pure identity
-
-  constraintsFns <- forConcurrently constraints \c -> do
-    let (classMod, className) = toDbQualifer $ constraintClass c
-    importClassAndTypes classMod className
+  let env = foldl' (&) E.initEnvironment importFns
 
-  let 
-     env = foldl' (&) E.initEnvironment importFns
-  
   envConstraintFns <- forConcurrently (getEnvConstraints env) \c -> do
     let (classMod, className) = toDbQualifer $ constraintClass c
-    importClassAndTypes classMod className
+    importClass classMod className
 
   pure $ foldl' (&) env envConstraintFns
   where
-
-    
-    constraints :: [P.SourceConstraint]
-    constraints =  (execWriter . getDeclContraints) =<< decls 
-
-    (getDeclContraints, _, _) =  P.everywhereOnValuesTopDownM declContraint exprContraint pure 
-
-    declContraint :: P.Declaration -> Writer [P.SourceConstraint] P.Declaration
-    declContraint = pure 
-
-    exprContraint :: P.Expr -> Writer [P.SourceConstraint] P.Expr
-    exprContraint e = case e of 
-      P.TypeClassDictionary c _ _ -> tell [c] >> pure e
-      _ -> pure e
-
-
-    deferredDicts = getDeclDicts =<< decls
-
-    getDeclDicts :: P.Declaration -> [(P.Qualified (P.ProperName 'P.ClassName), [P.SourceType])]
-
-    getDeclDicts d = execState (onDecl d) []
-
-    (onDecl, _, _) = P.everywhereOnValuesTopDownM pure goExpr pure
-
-    goExpr :: P.Expr -> State [(P.Qualified (P.ProperName 'P.ClassName), [P.SourceType])] P.Expr
-    goExpr = \case
-      e@(P.DeferredDictionary cn tys) -> do
-        modify ((cn, tys) :)
-        pure e
-      e -> pure e
-
     importRefs mName refs = do
       edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
       pure $ foldl' (>>>) identity edits
 
     importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
     importRef mName = \case
-      P.TypeClassRef _ className -> importClassAndTypes mName className
+      P.TypeClassRef _ className -> importClass mName className
       P.TypeRef _ tyName ctrs -> do
         let qual = P.Qualified (P.ByModuleName mName) tyName
         type' <- selectType conn qual
@@ -249,7 +201,7 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
           Just ctrs' -> forConcurrently ctrs' \ctr -> do
             let qual' = P.Qualified (P.ByModuleName mName) ctr
             val <- selectDataConstructor conn qual'
-            pure (qual', fromJust val)
+            pure (qual', fromJustWithErr qual' val)
         pure $ \env' ->
           env'
             { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
@@ -258,7 +210,7 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
       P.ValueRef _ ident -> do
         let qual = P.Qualified (P.ByModuleName mName) ident
         val <- selectEnvValue conn qual
-        pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
+        pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
       P.TypeInstanceRef _ ident _ -> do
         let qual = P.Qualified (P.ByModuleName mName) ident
         val <- selectClassInstance conn qual
@@ -271,18 +223,18 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
           then do
             let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
             val <- selectDataConstructor conn qual
-            pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJust val)]}
+            pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
           else do
             let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
             val <- selectEnvValue conn qual
-            pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJust val)]}
+            pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
       P.TypeOpRef _ opName -> do
-        (aliasModName, alias) <- fromJust <$> selectTypeOperatorAlias conn mName opName
+        (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
         let qual = P.Qualified (P.ByModuleName aliasModName) alias
         val <- selectType conn qual
         pure $ \env' ->
           env'
-            { E.types = E.types env' <> Map.fromList [(qual, fromJust val)]
+            { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
             }
 
     importModule mName = importModuleHiding mName []
@@ -294,25 +246,25 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
       where
         hiddenRefSet = Set.fromList hideRefs
 
-    importClassAndTypes :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
-    importClassAndTypes mName className = do
+    importClass :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
+    importClass mName className = do
       let qual = P.Qualified (P.ByModuleName mName) className
           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
       typeClass <- fromJust <$> selectTypeClass conn mName className
       type' <- selectType conn typeQual
       let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
-      dictVal@(_, dictKind) <- fromJustWithErr dictName <$> selectType conn dictName
+      dictVal <- selectType conn dictName
 
       let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
           ctrMb =
-            P.Qualified (P.ByModuleName mName) <$> case dictKind of
-              P.DataType _ _ [(ctr', _)] -> Just ctr'
+            P.Qualified (P.ByModuleName mName) <$> case dictVal of
+              Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
               _ -> Nothing
 
       ctrData <- ctrMb & maybe (pure Nothing) (\ctr -> selectDataConstructor conn ctr)
       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
         P.Qualified (P.ByModuleName superModName) superClassName -> do
-          importClassAndTypes superModName superClassName
+          importClass superModName superClassName
         _ -> pure identity
       instances <- selectClassInstancesByClassName conn qual
 
@@ -323,9 +275,12 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
               E.types =
                 E.types env'
                   <> Map.fromList
-                    [ (typeQual, fromJust type'),
-                      (dictName, dictVal)
-                    ],
+                    ( [ (typeQual, fromJust type')
+                      ]
+                        <> case dictVal of
+                          Just val -> [(dictName, val)]
+                          _ -> []
+                    ),
               E.dataConstructors =
                 E.dataConstructors env'
                   <> Map.fromList case (ctrMb, ctrData) of
@@ -555,11 +510,11 @@ insertImport conn mn = \case
   _ -> pure ()
 
 getEnvConstraints :: E.Environment -> [P.SourceConstraint]
-getEnvConstraints env = 
+getEnvConstraints env =
   E.names env & Map.elems >>= typeConstraints . view _1
 
 typeConstraints :: P.Type a -> [P.Constraint a]
-typeConstraints = P.everythingOnTypes (<>) \case 
+typeConstraints = P.everythingOnTypes (<>) \case
   P.ConstrainedType _ c _ -> [c]
   _ -> []
- 
+
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index f6dde831d7..c9c0c6fdb8 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -7,9 +7,8 @@ import Control.Monad.Supply.Class (MonadSupply)
 import Control.Monad.Writer.Class (MonadWriter)
 import Language.PureScript.AST (Module)
 import Language.PureScript.Errors (MultipleErrors)
-import Language.PureScript.Externs (ExternsFile, ExternsFixity, ExternsTypeFixity)
+import Language.PureScript.Externs (ExternsFile)
 import Language.PureScript.Linter.Imports (UsedImports)
-import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.AdoNotation as S
 import Language.PureScript.Sugar.BindingGroups as S
 import Language.PureScript.Sugar.CaseDeclarations as S
@@ -23,6 +22,7 @@ import Language.PureScript.Sugar.TypeClasses.Deriving as S
 import Language.PureScript.Sugar.TypeDeclarations as S
 import Protolude
 import Database.SQLite.Simple (Connection)
+import Language.PureScript.Make.Index.Select (selectFixitiesFromModuleImports)
 
 -- |
 -- The desugaring pipeline proceeds as follows:
@@ -77,11 +77,10 @@ desugarUsingDb ::
   (MonadError MultipleErrors m) =>
   (MonadState (Env, UsedImports) m) =>
   Connection ->
-  [(P.ModuleName, [ExternsFixity])] ->
-  [(P.ModuleName, [ExternsTypeFixity])] ->
+  Env ->
   Module ->
   m Module
-desugarUsingDb conn fixities typeFixities  =
+desugarUsingDb conn  env =
   desugarSignedLiterals
     >>> desugarObjectConstructors
     >=> desugarDoModule
@@ -90,8 +89,14 @@ desugarUsingDb conn fixities typeFixities  =
     >>> desugarCasesModule
     >=> desugarTypeDeclarationsModule
     >=> desugarImports
-    >=> rebracketFixitiesOnly (const True) fixities typeFixities
+    >=> rebracketUsingDb
     >=> checkFixityExports
     >=> deriveInstances
     >=> desugarTypeClassesUsingDB conn
     >=> createBindingGroupsModule
+
+  where
+    rebracketUsingDb m = do 
+      (fixities, typeFixities) <- liftIO $ selectFixitiesFromModuleImports conn  env m 
+      rebracketFixitiesOnly (const True) fixities typeFixities m
+      
\ No newline at end of file
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 18f19319d1..9aa63c2dad 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -30,7 +30,7 @@ import Data.Maybe (listToMaybe, mapMaybe)
 import Data.Ord (Down (..))
 import Language.PureScript.AST
 import Language.PureScript.Constants.Libs qualified as C
-import Language.PureScript.Crash (internalError)
+import Language.PureScript.Crash (internalError, HasCallStack)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition)
 import Language.PureScript.Externs (ExternsFile (..), ExternsFixity (..), ExternsTypeFixity (..))
 import Language.PureScript.Names (Ident (..), Name (..), OpName, OpNameType (..), ProperName, ProperNameType (..), Qualified (..), QualifiedBy (..), freshIdent', pattern ByNullSourcePos)
@@ -78,6 +78,7 @@ rebracket =
 -- | rebracket that takes the fixities without the other externs fields
 rebracketFixitiesOnly ::
   forall m.
+  HasCallStack =>
   (MonadError MultipleErrors m) =>
   (MonadSupply m) =>
   (Declaration -> Bool) ->
@@ -105,6 +106,7 @@ fromExternFixities exFixities exTypeFixities  = fixities <> typeFixities
 -- operators in value declarations.
 rebracketFiltered ::
   forall m.
+  HasCallStack =>
   (MonadError MultipleErrors m) =>
   (MonadSupply m) =>
   RebracketCaller ->
@@ -117,6 +119,7 @@ rebracketFiltered !caller pred_ externs m = do
 
 rebracketFiltered' ::
   forall m.
+  HasCallStack =>
   (MonadError MultipleErrors m) =>
   (MonadSupply m) =>
   RebracketCaller ->
@@ -226,6 +229,7 @@ data RebracketCaller
 
 rebracketModule ::
   forall m.
+  HasCallStack =>
   (MonadError MultipleErrors m) =>
   (MonadSupply m) =>
   RebracketCaller ->
diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs
index 29725c711a..6f9417a798 100644
--- a/src/Language/PureScript/Sugar/Operators/Binders.hs
+++ b/src/Language/PureScript/Sugar/Operators/Binders.hs
@@ -8,9 +8,11 @@ import Language.PureScript.AST (Associativity, Binder(..), SourceSpan)
 import Language.PureScript.Errors (MultipleErrors)
 import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..))
 import Language.PureScript.Sugar.Operators.Common (matchOperators)
+import GHC.Stack (HasCallStack)
 
 matchBinderOperators
-  :: MonadError MultipleErrors m
+  :: HasCallStack
+  => MonadError MultipleErrors m
   => [[(Qualified (OpName 'ValueOpName), Associativity)]] 
   -> Binder
   -> m Binder
diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs
index 2132210f6a..0f9a354caa 100644
--- a/src/Language/PureScript/Sugar/Operators/Common.hs
+++ b/src/Language/PureScript/Sugar/Operators/Common.hs
@@ -18,7 +18,7 @@ import Text.Parsec.Pos qualified as P
 import Text.Parsec.Expr qualified as P
 
 import Language.PureScript.AST (Associativity(..), ErrorMessageHint(..), SourceSpan)
-import Language.PureScript.Crash (internalError)
+import Language.PureScript.Crash (internalError, HasCallStack)
 import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..))
 import Language.PureScript.Names (OpName, Qualified, eraseOpName)
 
@@ -62,7 +62,8 @@ opTable ops fromOp reapply =
 
 matchOperators
   :: forall m a nameType
-   . Show a
+   . HasCallStack 
+  => Show a
   => MonadError MultipleErrors m
   => (a -> Bool)
   -> (a -> Maybe (a, a, a))
@@ -145,7 +146,7 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains
     ErrorMessage
       [PositionedError (fromJust . flip M.lookup chainOpSpans =<< grp)]
 
-fromJust' :: Show a => a -> Maybe b -> b
+fromJust' :: HasCallStack => Show a => a -> Maybe b -> b
 fromJust' a m = case m of 
   Just b -> b
   Nothing -> internalError $ "mkErrors: lookup not found for: " ++ show a
diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs
index 0815eb1610..1e151397e8 100644
--- a/src/Language/PureScript/Sugar/Operators/Expr.hs
+++ b/src/Language/PureScript/Sugar/Operators/Expr.hs
@@ -12,9 +12,11 @@ import Language.PureScript.AST (Associativity, Expr(..), SourceSpan)
 import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..))
 import Language.PureScript.Sugar.Operators.Common (Chain, matchOperators, token)
 import Language.PureScript.Errors (MultipleErrors)
+import GHC.Stack (HasCallStack)
 
 matchExprOperators
   :: MonadError MultipleErrors m
+  => HasCallStack
   => [[(Qualified (OpName 'ValueOpName), Associativity)]]
   -> Expr
   -> m Expr
diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs
index 81001511cb..847de3b5a7 100644
--- a/src/Language/PureScript/Sugar/Operators/Types.hs
+++ b/src/Language/PureScript/Sugar/Operators/Types.hs
@@ -8,9 +8,11 @@ import Language.PureScript.Errors (MultipleErrors)
 import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..))
 import Language.PureScript.Sugar.Operators.Common (matchOperators)
 import Language.PureScript.Types (SourceType, Type(..), srcTypeApp)
+import GHC.Stack (HasCallStack)
 
 matchTypeOperators
   :: MonadError MultipleErrors m
+  => HasCallStack
   => SourceSpan
   -> [[(Qualified (OpName 'TypeOpName), Associativity)]]
   -> SourceType

From 63d05f720db7aad17011a6c1099e9965126aa648 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 10 Dec 2024 12:24:09 +0100
Subject: [PATCH 274/297] type fixities importing with definition module names

---
 src/Language/PureScript/Make/Index/Select.hs | 63 ++++++++------------
 1 file changed, 26 insertions(+), 37 deletions(-)

diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 889b12803f..1276889b24 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -5,7 +5,7 @@ module Language.PureScript.Make.Index.Select where
 import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
 import Control.Concurrent.Async.Lifted (forConcurrently, forConcurrently_, mapConcurrently, mapConcurrently_)
-import Control.Lens (Field1 (_1), Field3 (_3), view, Field2 (_2))
+import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view)
 import Data.Aeson qualified as A
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
@@ -59,25 +59,22 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
 
 selectFixitiesFromModuleImports :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImports conn env (P.Module _ _ _modName decls _refs) = do
-  valueOps <- join . catMaybes <$> forConcurrently decls (onImports (selectImportValueFixities conn env))
-  typeOps <- catMaybes <$> forConcurrently decls (onImports (selectImportTypeFixities conn env))
-  -- when (_modName == P.ModuleName "Data.EuclideanRing") do 
-  --   putErrText $ T.intercalate "\n\n" $ fmap show imports
-  --   putErrText $ T.intercalate "\n\n" $ fmap show valueOps
-
-  pure (groupByModule valueOps, typeOps)
+  valueOps <- onImports selectImportValueFixities
+  typeOps <- onImports selectImportTypeFixities
+  pure (valueOps, typeOps)
   where
-    onImports :: (P.ModuleName -> ImportDeclarationType -> IO a) -> P.Declaration -> IO (Maybe a)
-    onImports f = \case
+    onImports ::
+      (Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, a)]) ->
+      IO [(P.ModuleName, [a])]
+    onImports fn = groupByModule . join . catMaybes <$> forConcurrently decls (whenImportDecl (fn conn env))
+
+    whenImportDecl :: (P.ModuleName -> ImportDeclarationType -> IO a) -> P.Declaration -> IO (Maybe a)
+    whenImportDecl f = \case
       P.ImportDeclaration _ mn' idt _ -> Just <$> f mn' idt
       _ -> pure Nothing
 
-
-groupByModule :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
-groupByModule = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
-
-    -- addOr' = if _modName == P.ModuleName "Data.EuclideanRing" then (\ops -> (P.ModuleName "Nonsense", [orImport]) : ops) else identity
-    -- addOr' = if _modName == P.ModuleName "Data.EuclideanRing" then (\ops -> (P.ModuleName "Data.HeytingAlgebra", [orImport]) : ops) else identity
+    groupByModule :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
+    groupByModule = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
 
 selectImportValueFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, ExternsFixity)]
 selectImportValueFixities conn env modName = \case
@@ -87,35 +84,28 @@ selectImportValueFixities conn env modName = \case
   where
     exports = exportedValueOps $ lookupExports modName env
     inRefs refs opName _ = opName `elem` opRefs
-      where 
+      where
         opRefs = refsValueOps env refs
 
-lookupExports :: P.ModuleName ->  P.Env -> Exports
-lookupExports modName env  = view _3 $ fromJust $ Map.lookup modName env
+lookupExports :: P.ModuleName -> P.Env -> Exports
+lookupExports modName env = view _3 $ fromJust $ Map.lookup modName env
 
-lookupImports :: P.ModuleName ->  P.Env -> P.Imports
-lookupImports modName env  = view _2 $ fromJust $ Map.lookup modName env
-      
-refsValueOps ::  P.Env -> [P.DeclarationRef] -> [P.OpName 'P.ValueOpName]
+lookupImports :: P.ModuleName -> P.Env -> P.Imports
+lookupImports modName env = view _2 $ fromJust $ Map.lookup modName env
+
+refsValueOps :: P.Env -> [P.DeclarationRef] -> [P.OpName 'P.ValueOpName]
 refsValueOps env = (=<<) (refValueOp env)
 
 refValueOp :: P.Env -> P.DeclarationRef -> [P.OpName 'P.ValueOpName]
 refValueOp env = \case
   P.ValueOpRef _ ident -> pure ident
   P.ReExportRef _ _ ref -> refValueOp env ref
-  -- P.ModuleRef _ m -> _  env $ exportedValueOps $ lookupExports m env
   _ -> []
 
 selectValueFixitiesFromExports :: Connection -> Map (P.OpName 'P.ValueOpName) P.ExportSource -> IO [(P.ModuleName, ExternsFixity)]
 selectValueFixitiesFromExports conn = fmap catMaybes . mapConcurrently select . Map.toList
   where
-    select (opName, P.ExportSource{..}) =  fmap (exportSourceDefinedIn, ) <$> selectImportValueFixity conn  exportSourceDefinedIn opName
-
-addOr :: [ExternsFixity] -> [ExternsFixity]
-addOr ops =  ExternsFixity P.Infixr 2 (P.OpName "||") (P.Qualified (P.ByModuleName $ P.ModuleName "Data.HeytingAlgebra") $ Left $ P.Ident "disj") : ops
-
-orImport :: ExternsFixity
-orImport =  ExternsFixity P.Infixr 2 (P.OpName "||") (P.Qualified (P.ByModuleName $ P.ModuleName "Data.HeytingAlgebra") $ Left $ P.Ident "disj")
+    select (opName, P.ExportSource {..}) = fmap (exportSourceDefinedIn,) <$> selectImportValueFixity conn exportSourceDefinedIn opName
 
 selectImportValueFixity :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe ExternsFixity)
 selectImportValueFixity conn modName opName = do
@@ -125,15 +115,15 @@ selectImportValueFixity conn modName opName = do
     (modName, opName)
     <&> head
 
-selectImportTypeFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO (P.ModuleName, [ExternsTypeFixity])
-selectImportTypeFixities conn env modName = fmap (fmap (modName,) )\case
+selectImportTypeFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, ExternsTypeFixity)]
+selectImportTypeFixities conn env modName = \case
   P.Implicit -> selectTypeFixitiesFromExports conn exports
   P.Explicit refs -> selectTypeFixitiesFromExports conn $ Map.filterWithKey (inRefs refs) exports
   P.Hiding refs -> selectTypeFixitiesFromExports conn $ Map.filterWithKey (fmap not . inRefs refs) exports
   where
     exports = P.exportedTypeOps $ view _3 $ fromJust $ Map.lookup modName env
     inRefs refs opName _ = opName `elem` opRefs
-      where 
+      where
         opRefs = refsTypeOps refs
 
 refsTypeOps :: [P.DeclarationRef] -> [P.OpName 'P.TypeOpName]
@@ -145,10 +135,10 @@ refTypeOp = \case
   P.ReExportRef _ _ ref -> refTypeOp ref
   _ -> Nothing
 
-selectTypeFixitiesFromExports :: Connection -> Map (P.OpName 'P.TypeOpName) P.ExportSource -> IO [ExternsTypeFixity]
+selectTypeFixitiesFromExports :: Connection -> Map (P.OpName 'P.TypeOpName) P.ExportSource -> IO [(P.ModuleName, ExternsTypeFixity)]
 selectTypeFixitiesFromExports conn = fmap catMaybes . mapConcurrently select . Map.toList
   where
-    select (opName, exSrc) = selectImportTypeFixity conn (P.exportSourceDefinedIn exSrc) opName
+    select (opName, P.ExportSource {..}) = fmap (exportSourceDefinedIn,) <$> selectImportTypeFixity conn exportSourceDefinedIn opName
 
 selectImportTypeFixity :: Connection -> P.ModuleName -> P.OpName 'P.TypeOpName -> IO (Maybe ExternsTypeFixity)
 selectImportTypeFixity conn modName opName = do
@@ -517,4 +507,3 @@ typeConstraints :: P.Type a -> [P.Constraint a]
 typeConstraints = P.everythingOnTypes (<>) \case
   P.ConstrainedType _ c _ -> [c]
   _ -> []
-

From e0d6c7aeff3206f3b1c5d05dbd863a9995059cdd Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 16 Dec 2024 09:16:46 +0100
Subject: [PATCH 275/297] working but without type synonyms

---
 src/Language/PureScript/Make.hs               |   2 +-
 src/Language/PureScript/Make/Index/Select.hs  | 473 +++++++++++++++---
 src/Language/PureScript/Names.hs              |  25 +-
 src/Language/PureScript/TypeChecker.hs        |   2 +-
 .../PureScript/TypeChecker/Entailment.hs      |   2 +-
 5 files changed, 413 insertions(+), 91 deletions(-)

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index a193122e5c..bc5194efed 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -270,7 +270,7 @@ desugarAndTypeCheckDb ::
 desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv = runSupplyT 0 $ do
   (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn exEnv withPrim) (exEnv, mempty)
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-  env <- selectEnvFromImports conn desugared
+  env <- selectEnvFromImports conn exEnv' usedImports desugared
   (checked, checkSt@(CheckState {..})) <- runStateT (catchError (typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
   lift $ withCheckState checkSt
   let usedImports' =
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 1276889b24..7ed756fd93 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -1,4 +1,9 @@
 {-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-local-binds #-}
+
+{-# HLINT ignore "Redundant bracket" #-}
 
 module Language.PureScript.Make.Index.Select where
 
@@ -9,7 +14,6 @@ import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view)
 import Data.Aeson qualified as A
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
-import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple (Connection)
 import Database.SQLite.Simple qualified as SQL
@@ -21,6 +25,7 @@ import Language.PureScript.Environment (TypeClassData (typeClassSuperclasses))
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Environment qualified as P
 import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
+import Language.PureScript.Linter.Imports qualified as P
 import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
 import Language.PureScript.Sugar.Names (Exports (exportedValueOps))
@@ -88,7 +93,7 @@ selectImportValueFixities conn env modName = \case
         opRefs = refsValueOps env refs
 
 lookupExports :: P.ModuleName -> P.Env -> Exports
-lookupExports modName env = view _3 $ fromJust $ Map.lookup modName env
+lookupExports modName env = maybe P.nullExports (view _3) (Map.lookup modName env)
 
 lookupImports :: P.ModuleName -> P.Env -> P.Imports
 lookupImports modName env = view _2 $ fromJust $ Map.lookup modName env
@@ -156,92 +161,386 @@ type ClassDict =
         (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty NamedDict))
     )
 
-selectEnvFromImports :: (MonadIO m) => Connection -> P.Module -> m E.Environment
-selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
-  insertExports conn modName exports
+selectEnvFromImports :: (MonadIO m) => Connection -> P.Env -> P.UsedImports -> P.Module -> m E.Environment
+selectEnvFromImports conn exportEnv _usedImports (P.Module _ _ modName decls exportedRefs) = liftIO do
+  when (modName == P.ModuleName "Data.Identity") do
+    putErrText $ "\n\nData.Identity type imports: \n\n" <> T.intercalate "\n\n" (show <$> Map.toList (P.importedTypes imports))
+    putErrText $ "\n\nData.Identity class imports: \n\n" <> T.intercalate "\n\n" (show <$> Map.toList (P.importedTypeClasses imports))
+  insertExports conn modName exportedRefs
   insertImports conn modName decls
-  importFns :: [E.Environment -> E.Environment] <- forConcurrently decls \case
-    P.ImportDeclaration _ mName idt _ -> do
-      case idt of
-        P.Implicit -> importModule mName
-        P.Explicit refs -> importRefs mName refs
-        P.Hiding refs -> importModuleHiding mName refs
-    _ -> pure identity
-
-  let env = foldl' (&) E.initEnvironment importFns
+  importFn <-
+    ( onImportMap P.importedTypes \typeImport ->
+        do
+          let tyName = P.disqualify $ P.importName typeImport
+          type' <- selectType' conn (P.importSourceModule typeImport) tyName
+          pure $ \env' ->
+            env'
+              { E.types =
+                  E.types env'
+                    <> Map.fromList
+                      [ (P.importName typeImport, fromJust type'),
+                        (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, fromJust type')
+                      ]
+              }
+      )
+      `updateConcurrently` ( onImportMap P.importedDataConstructors \ctrImport ->
+                               do
+                                 let ctrName = P.disqualify $ P.importName ctrImport
+                                     qualified = P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName
+                                 ctr <- selectDataConstructor conn (P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName)
+                                 pure $ \env' ->
+                                   env'
+                                     { E.dataConstructors =
+                                         E.dataConstructors env'
+                                           <> Map.fromList
+                                             [ (P.importName ctrImport, fromJust ctr),
+                                               (qualified, fromJust ctr)
+                                             ]
+                                     }
+                           )
+      `updateConcurrently` ( onImportMap P.importedTypeClasses \classImport ->
+                               importClass (P.importSourceModule classImport) (P.importName classImport) (P.disqualify $ P.importName classImport)
+                           )
+      `updateConcurrently` ( onImportMap P.importedValues \valImport -> do
+                               let ident = P.disqualify $ P.importName valImport
+                               val <- selectEnvValue conn (P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident)
+                               pure $ \env' ->
+                                 env'
+                                   { E.names =
+                                       E.names env'
+                                         <> Map.fromList
+                                           [ ( P.importName valImport,
+                                               fromJustWithErr (modName, P.importSourceModule valImport, ident) val
+                                             ),
+                                             ( P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident,
+                                               fromJustWithErr (modName, P.importSourceModule valImport, ident) val
+                                             )
+                                           ]
+                                   }
+                           )
+      `updateConcurrently` ( onImportMap P.importedTypeOps \opImport -> do
+                               let opName = P.disqualify $ P.importName opImport
+                               (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn (P.importSourceModule opImport) opName
+                               type' <- selectType' conn aliasModName alias
+                               pure $ \env' ->
+                                 env'
+                                   { E.types =
+                                       E.types env'
+                                         <> Map.fromList
+                                           [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, fromJustWithErr opName type')
+                                           ]
+                                   }
+                           )
+      `updateConcurrently` ( onImportMap P.importedValueOps \opImport -> do
+                               let opName = P.disqualify $ P.importName opImport
+                               (aliasModName, alias) <- fromJustWithErr opName <$> selectValueOperatorAlias conn (P.importSourceModule opImport) opName
+                               if isUpper $ T.head alias
+                                 then do
+                                   let ctrName = P.ProperName alias
+                                       qual = P.Qualified (P.ByModuleName aliasModName) ctrName
+                                   val <- selectDataConstructor conn qual
+                                   pure $ \env' ->
+                                     env'
+                                       { E.dataConstructors =
+                                           E.dataConstructors env'
+                                             <> Map.fromList [(qual, fromJustWithErr qual val)]
+                                       }
+                                 else do
+                                   let ident = P.Ident alias
+                                       qual = P.Qualified (P.ByModuleName aliasModName) ident
+                                   val <- selectEnvValue conn qual
+                                   pure $ \env' ->
+                                     env'
+                                       { E.names =
+                                           E.names env'
+                                             <> Map.fromList [(qual, fromJustWithErr qual val)]
+                                       }
+                           )
+
+  let env = importFn E.initEnvironment
 
   envConstraintFns <- forConcurrently (getEnvConstraints env) \c -> do
     let (classMod, className) = toDbQualifer $ constraintClass c
-    importClass classMod className
+    importClass' classMod classMod className
 
   pure $ foldl' (&) env envConstraintFns
   where
-    importRefs mName refs = do
-      edits :: [E.Environment -> E.Environment] <- forConcurrently refs (importRef mName)
-      pure $ foldl' (>>>) identity edits
-
-    importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
-    importRef mName = \case
-      P.TypeClassRef _ className -> importClass mName className
-      P.TypeRef _ tyName ctrs -> do
-        let qual = P.Qualified (P.ByModuleName mName) tyName
-        type' <- selectType conn qual
-        ctrVals <- case ctrs of
-          Nothing -> selectTypeDataConstructors conn qual
-          Just ctrs' -> forConcurrently ctrs' \ctr -> do
-            let qual' = P.Qualified (P.ByModuleName mName) ctr
-            val <- selectDataConstructor conn qual'
-            pure (qual', fromJustWithErr qual' val)
-        pure $ \env' ->
-          env'
-            { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
-              E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
-            }
-      P.ValueRef _ ident -> do
-        let qual = P.Qualified (P.ByModuleName mName) ident
-        val <- selectEnvValue conn qual
-        pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-      P.TypeInstanceRef _ ident _ -> do
-        let qual = P.Qualified (P.ByModuleName mName) ident
-        val <- selectClassInstance conn qual
-        pure $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap [fromJust val] (E.typeClassDictionaries env')}
-      P.ModuleRef _ m -> importModule m
-      P.ReExportRef _ _ ref -> importRef mName ref
-      P.ValueOpRef _ opName -> do
-        (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
-        if isUpper $ T.head alias
-          then do
-            let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
-            val <- selectDataConstructor conn qual
-            pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-          else do
-            let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
-            val <- selectEnvValue conn qual
-            pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-      P.TypeOpRef _ opName -> do
-        (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
-        let qual = P.Qualified (P.ByModuleName aliasModName) alias
-        val <- selectType conn qual
-        pure $ \env' ->
-          env'
-            { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
-            }
+    -- importName :: P.ModuleName -> P.Name -> IO (E.Environment -> E.Environment)
+    -- importName mName name = _ importRef mName $  getImportSrc mName name
+    imports :: P.Imports
+    imports = lookupImports modName exportEnv
+
+    onImportMap ::
+      ( P.Imports ->
+        Map
+          (P.Qualified a)
+          [P.ImportRecord a]
+      ) ->
+      ( P.ImportRecord a ->
+        IO (P.Environment -> P.Environment)
+      ) ->
+      IO (P.Environment -> P.Environment)
+    onImportMap getImports fn =
+      pipe <$> forConcurrently (Map.toList $ getImports imports) \(_, recs) ->
+        pipe <$> forConcurrently recs fn'
+      where
+        fn' ir = if P.importSourceModule ir == modName then pure identity else fn ir
+
+    -- importValue :: P.ModuleName -> P.Qualified P.Ident -> IO (E.Environment -> E.Environment)
+    -- importValue mName = \case
+    --   P.Qualified _ ident -> do
+    --     let qual = P.Qualified (P.ByModuleName mName) ident
+    --     val <- selectEnvValue conn qual
+    --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    --   where
+    --     exports = lookupExports mName exportEnv
+
+    importClass modName' qual className = do
+      typeClass <- fromJust <$> selectTypeClass conn modName' className
+      let dictName = P.Qualified (P.ByModuleName modName') . P.dictTypeName . coerceProperName $ className
+          typeQual = P.Qualified (P.ByModuleName modName') $ coerceProperName className
+      type' <- selectType conn typeQual
+      dictVal <- selectType conn dictName
+
+      let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
+          ctrMb =
+            P.Qualified (P.ByModuleName modName') <$> case dictVal of
+              Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
+              _ -> Nothing
 
-    importModule mName = importModuleHiding mName []
+      ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
+      instances <- selectClassInstancesByClassName conn $ P.Qualified (P.ByModuleName modName') className
 
-    importModuleHiding mName hideRefs = do
-      allRefs <- selectModuleExports conn mName
-      let refs = filter (not . flip Set.member hiddenRefSet) allRefs
-      importRefs mName refs
+      superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
+        P.Qualified (P.ByModuleName superModName) superClassName -> do
+          -- TODO add check for existing class in env
+          importClass superModName (P.Qualified (P.ByModuleName superModName) superClassName) superClassName
+        _ -> pure identity
+
+      pure $
+        pipe superClassImports
+          >>> \env' ->
+            env'
+              { E.typeClasses =
+                  E.typeClasses env'
+                    <> Map.fromList
+                      [ (qual, typeClass),
+                        (P.Qualified (P.ByModuleName modName') className, typeClass)
+                      ],
+                E.types =
+                  E.types env'
+                    <> Map.fromList
+                      ( [ (typeQual, fromJust type')
+                        ]
+                          <> case dictVal of
+                            Just val -> [(dictName, val)]
+                            _ -> []
+                      ),
+                E.dataConstructors =
+                  E.dataConstructors env' <> Map.fromList case (ctrMb, ctrData) of
+                    (Just ctr', Just ctrData') -> [(ctr', ctrData')]
+                    _ -> [],
+                E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
+              }
+    importName :: P.ModuleName -> P.Qualified P.Name -> IO (E.Environment -> E.Environment)
+    importName mName (P.Qualified (P.ByModuleName _) name) = do
+      -- when (modName' /= mName) do
+      --   putErrText $ "importName called with different module names: " <> show modName' <> " and " <> show mName
+      --   putErrText $ "name: " <> show name
+      case name of
+        P.IdentName ident -> do
+          let P.ExportSource {..} = fromJustWithErr (mName, ident) $ Map.lookup ident (P.exportedValues exports)
+              qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ident
+          val <- selectEnvValue conn qual
+          let importedModuleName = getImportedModule mName ident $ P.importedValues imports
+          pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ident, fromJustWithErr ident val)]}
+        P.ValOpName opName -> do
+          let P.ExportSource {..} = fromJustWithErr (mName, opName) $ Map.lookup opName (P.exportedValueOps exports)
+          (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn exportSourceDefinedIn opName
+          if isUpper $ T.head alias
+            then do
+              let ctrName = P.ProperName alias
+                  qual = P.Qualified (P.ByModuleName aliasModName) ctrName
+              val <- selectDataConstructor conn qual
+              pure $ \env' ->
+                env'
+                  { E.dataConstructors =
+                      E.dataConstructors env'
+                        <> Map.fromList [(qual, fromJustWithErr qual val)]
+                  }
+            else do
+              let ident = P.Ident alias
+                  qual = P.Qualified (P.ByModuleName aliasModName) ident
+              val <- selectEnvValue conn qual
+              pure $ \env' ->
+                env'
+                  { E.names =
+                      E.names env'
+                        <> Map.fromList [(qual, fromJustWithErr qual val)]
+                  }
+        P.TyName tyName -> do
+          let (_, P.ExportSource {..}) = fromJust $ Map.lookup tyName (P.exportedTypes exports)
+          let qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) tyName
+          type' <- selectType conn qual
+          ctrVals <- selectTypeDataConstructors conn qual
+          let importedModuleName = getImportedModule mName tyName $ P.importedTypes imports
+          pure $ \env' ->
+            env'
+              { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) tyName, fromJust type')],
+                E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+              }
+        P.TyOpName opName -> do
+          let P.ExportSource {..} = fromJust $ Map.lookup opName (P.exportedTypeOps exports)
+          (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectTypeOperatorAlias conn exportSourceDefinedIn opName
+          let qual = P.Qualified (P.ByModuleName aliasModName) alias
+          val <- selectType conn qual
+          let importedModuleName = getImportedModule mName alias $ P.importedTypes imports
+          pure $ \env' ->
+            env'
+              { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) alias, fromJustWithErr qual val)]
+              }
+        P.TyClassName className -> do
+          let P.ExportSource {..} = fromJust $ Map.lookup className (P.exportedTypeClasses exports)
+          importClass' mName exportSourceDefinedIn className
+        P.DctorName ctrName -> do
+          let containsCtr (_, (ctrs, _)) = ctrName `elem` ctrs
+              (_, (_, P.ExportSource {..})) = fromJust $ find containsCtr $ Map.toList $ P.exportedTypes exports -- Map.find ctrName (P.exportedDataConstructors exports)
+              qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ctrName
+          val <- selectDataConstructor conn qual
+          let importedModuleName = getImportedModule mName ctrName $ P.importedDataConstructors imports
+          pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ctrName, fromJustWithErr ctrName val)]}
+        P.ModName _ -> internalError "importName called with ModName"
       where
-        hiddenRefSet = Set.fromList hideRefs
+        exports :: P.Exports
+        exports = lookupExports mName exportEnv
+    importName _ _ = pure identity
+
+    getImportedModule ::
+      (Ord a) =>
+      (Foldable f) =>
+      P.ModuleName ->
+      a ->
+      Map (P.Qualified a) (f (P.ImportRecord a)) ->
+      P.ModuleName
+    getImportedModule mName ident imports' = fromMaybe mName do
+      importRecs <- Map.lookup (P.Qualified (P.ByModuleName mName) ident) imports'
+      importRec <- head importRecs
+      pure $ P.importSourceModule importRec
+    -- imports :: P.Imports
+    -- imports = lookupImports mName exportEnv
+
+    -- case
+    -- P.IdentName ident -> do
+    --   let qual = P.Qualified (P.ByModuleName mName) ident
+    --   val <- selectEnvValue conn qual
+    --   pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    -- P.ValOpName opName -> do
+    --   (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn mName opName
+    --   if isUpper $ T.head alias
+    --     then do
+    --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
+    --       val <- selectDataConstructor conn qual
+    --       pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    --     else do
+    --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
+    --       val <- selectEnvValue conn qual
+    --       pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    -- P.TyName tyName -> do
+    --   let qual = P.Qualified (P.ByModuleName mName) tyName
+    --   type' <- selectType conn qual
+    --   ctrVals <- selectTypeDataConstructors conn qual
+    --   pure $ \env' ->
+    --     env'
+    --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual type')],
+    --         E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+    --       }
+
+    -- P.TyOpName opName -> do
+    --   (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
+    --   let qual = P.Qualified (P.ByModuleName aliasModName) alias
+    --   val <- selectType conn qual
+    --   pure $ \env' ->
+    --     env'
+    --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
+    --       }
+
+    -- P.DctorName dctorName -> do
+    --   let qual = P.Qualified (P.ByModuleName mName) dctorName
+    --   val <- selectDataConstructor conn qual
+    --   pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    -- P.TyClassName className -> do
+    --   importClass' mName className
+    -- P.ModName _ -> internalError "importName called with ModName"
+
+    -- where
+    --   exports = lookupExports mName exportEnv
+
+    -- importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
+    -- importRef mName = \case
+    --   P.TypeClassRef _ className -> importClass' mName className
+    --   P.TypeRef _ tyName ctrs -> do
+    --     let qual = P.Qualified (P.ByModuleName mName) tyName
+    --     type' <- selectType conn qual
+    --     ctrVals <- case ctrs of
+    --       Nothing -> selectTypeDataConstructors conn qual
+    --       Just ctrs' -> forConcurrently ctrs' \ctr -> do
+    --         let qual' = P.Qualified (P.ByModuleName mName) ctr
+    --         val <- selectDataConstructor conn qual'
+    --         pure (qual', fromJustWithErr qual' val)
+    --     pure $ \env' ->
+    --       env'
+    --         { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
+    --           E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+    --         }
+    --   P.ValueRef _ ident -> do
+    --     let qual = P.Qualified (P.ByModuleName mName) ident
+    --     val <- selectEnvValue conn qual
+    --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    --   P.TypeInstanceRef _ ident _ -> do
+    --     let qual = P.Qualified (P.ByModuleName mName) ident
+    --     val <- selectClassInstance conn qual
+    --     pure $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap [fromJust val] (E.typeClassDictionaries env')}
+    --   P.ModuleRef _ _ -> internalError "importRef called with ModuleRef"
+    --   P.ReExportRef _ _ ref -> importRef mName ref
+    --   P.ValueOpRef _ opName -> do
+    --     (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
+    --     if isUpper $ T.head alias
+    --       then do
+    --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
+    --         val <- selectDataConstructor conn qual
+    --         pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    --       else do
+    --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
+    --         val <- selectEnvValue conn qual
+    --         pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+    --   P.TypeOpRef _ opName -> do
+    --     (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
+    --     let qual = P.Qualified (P.ByModuleName aliasModName) alias
+    --     val <- selectType conn qual
+    --     pure $ \env' ->
+    --       env'
+    --         { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
+    --         }
+
+    -- importModule mName = importModuleHiding mName []
+
+    -- importModuleHiding mName hideRefs = do
+    --   allRefs <- selectModuleExports conn mName
+    --   let refs = filter (not . flip Set.member hiddenRefSet) allRefs
+    --   importRefs mName refs
+    --   where
+    --     hiddenRefSet = Set.fromList hideRefs
+
+    importClass' :: P.ModuleName -> P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
+    importClass' mName _modDefinedIn className = do
+      when (mName /= _modDefinedIn) do
+        putErrText $ "importClass' called with different module names: " <> show mName <> " and " <> show _modDefinedIn
+        putErrText $ "className: " <> show className
 
-    importClass :: P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
-    importClass mName className = do
       let qual = P.Qualified (P.ByModuleName mName) className
           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
-      typeClass <- fromJust <$> selectTypeClass conn mName className
       type' <- selectType conn typeQual
+      typeClass <- fromJust <$> selectTypeClass conn mName className
       let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
       dictVal <- selectType conn dictName
 
@@ -251,15 +550,16 @@ selectEnvFromImports conn (P.Module _ _ modName decls exports) = liftIO do
               Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
               _ -> Nothing
 
-      ctrData <- ctrMb & maybe (pure Nothing) (\ctr -> selectDataConstructor conn ctr)
+      ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
         P.Qualified (P.ByModuleName superModName) superClassName -> do
-          importClass superModName superClassName
+          importClass' superModName superModName superClassName
         _ -> pure identity
+
       instances <- selectClassInstancesByClassName conn qual
 
       pure $
-        foldl' (>>>) identity superClassImports >>> \env' ->
+        pipe superClassImports >>> \env' ->
           env'
             { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, typeClass)],
               E.types =
@@ -327,6 +627,9 @@ selectType conn ident = case Map.lookup ident P.allPrimTypes of
   where
     (modName, ty_name) = toDbQualifer ident
 
+selectType' :: Connection -> P.ModuleName -> P.ProperName 'P.TypeName -> IO (Maybe (P.SourceType, P.TypeKind))
+selectType' conn nMame ident = selectType conn (P.Qualified (P.ByModuleName nMame) ident)
+
 selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), (P.SourceType, P.TypeKind))]
 selectModuleEnvTypes conn moduleName' = do
   SQL.query
@@ -355,8 +658,6 @@ selectTypeDataConstructors conn ident = do
   where
     moduleName' = fromJust $ P.getQual ident
 
---   deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents)
-
 selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))]
 selectModuleDataConstructors conn moduleName' = do
   SQL.query
@@ -507,3 +808,17 @@ typeConstraints :: P.Type a -> [P.Constraint a]
 typeConstraints = P.everythingOnTypes (<>) \case
   P.ConstrainedType _ c _ -> [c]
   _ -> []
+
+pipe :: [a -> a] -> a -> a
+pipe = foldl' (>>>) identity
+
+updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c)
+updateConcurrently a b = do
+  f <- a
+  g <- b
+  pure $ f >>> g
+
+-- updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c)
+-- updateConcurrently a b = do
+--   (f, g) <- concurrently a b
+--   pure $ f >>> g
\ No newline at end of file
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index cf29011816..e3faebfbac 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -21,8 +21,9 @@ import Database.SQLite.Simple.ToField (ToField (toField))
 import GHC.Generics (Generic)
 import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos)
 import Prelude
-import Language.PureScript.Crash (internalError)
 import Protolude (isUpper)
+import Database.SQLite.Simple.Ok (Ok)
+import Data.Char (isAlphaNum)
 
 -- | A sum of the possible name types, useful for error and lint messages.
 data Name
@@ -99,14 +100,6 @@ data Ident
 instance NFData Ident
 
 instance Serialise Ident
-instance ToField Ident where
-  toField = \case 
-    Ident a -> toField a
-    _ -> internalError "unexpected InternalIdent in DB"
-    
-
-instance FromField Ident where
-  fromField a = Ident <$> fromField a
 
 unusedIdent :: Text
 unusedIdent = "$__unused"
@@ -338,4 +331,18 @@ instance FromJSONKey ModuleName where
 $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''InternalIdentData)
 $(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Ident)
 
+instance ToField Ident where
+  toField = \case 
+    Ident a -> toField a
+    ident -> toField $ A.encode ident
 
+instance FromField Ident where
+  fromField a = (decodeAlphaNumIdent =<< fromField a) <|> (decodeJsonIdent =<< fromField a)
+    where 
+      decodeAlphaNumIdent :: Text -> Ok Ident
+      decodeAlphaNumIdent txt = if all isAlphaNum $ T.unpack txt then
+        pure $ Ident txt
+      else
+        fail "Failed to decode ident"
+
+      decodeJsonIdent str = maybe (fail "Failed to decode ident") pure $ A.decode str
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 2bdce5b599..c2f0e22394 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -404,7 +404,7 @@ typeCheckAll moduleName = traverse go
         guardWith (errorMessage (DuplicateInstance dictName ss)) $
           not (M.member qualifiedDictName dictionaries)
       case M.lookup className (typeClasses env) of
-        Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"
+        Nothing -> internalError $ "typeCheckAll: Encountered unknown type class in instance declaration: " <> show moduleName <> ", " <> show className
         Just typeClass -> do
           checkInstanceArity dictName className typeClass tys
           (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys)
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 85bdfee4aa..f7a5f85a69 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -873,7 +873,7 @@ newDictionaries
   -> m [NamedDict]
 newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = do
     tcs <- gets (typeClasses . checkEnv)
-    let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs
+    let TypeClassData{..} = fromMaybe (internalError $ "newDictionaries: type class lookup failed: " <> show (name, className)) $ M.lookup className tcs
     supDicts <- join <$> zipWithM (\(Constraint ann supName supKinds supArgs _) index ->
                                       let sub = zip (map fst typeClassArguments) instanceTy in
                                       newDictionaries ((supName, index) : path)

From 299383a0c5f9f9884ef3fad633673c0e45b0e1de Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 16 Dec 2024 09:33:05 +0100
Subject: [PATCH 276/297] adds type synonyms

---
 src/Language/PureScript/Make/Index/Select.hs | 66 ++++++++++++++------
 1 file changed, 47 insertions(+), 19 deletions(-)

diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 7ed756fd93..68d67236f8 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -172,16 +172,29 @@ selectEnvFromImports conn exportEnv _usedImports (P.Module _ _ modName decls exp
     ( onImportMap P.importedTypes \typeImport ->
         do
           let tyName = P.disqualify $ P.importName typeImport
-          type' <- selectType' conn (P.importSourceModule typeImport) tyName
-          pure $ \env' ->
-            env'
-              { E.types =
-                  E.types env'
-                    <> Map.fromList
-                      [ (P.importName typeImport, fromJust type'),
-                        (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, fromJust type')
-                      ]
-              }
+          synMb <- selectTypeSynonym' conn (P.importSourceModule typeImport) tyName
+          case synMb of
+            Just syn -> do
+              pure $ \env' ->
+                env'
+                  { E.typeSynonyms =
+                      E.typeSynonyms env'
+                        <> Map.fromList
+                          [ (P.importName typeImport, syn),
+                            (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, syn)
+                          ]
+                  }
+            Nothing -> do
+              type' <- selectType' conn (P.importSourceModule typeImport) tyName
+              pure $ \env' ->
+                env'
+                  { E.types =
+                      E.types env'
+                        <> Map.fromList
+                          [ (P.importName typeImport, fromJust type'),
+                            (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, fromJust type')
+                          ]
+                  }
       )
       `updateConcurrently` ( onImportMap P.importedDataConstructors \ctrImport ->
                                do
@@ -221,15 +234,27 @@ selectEnvFromImports conn exportEnv _usedImports (P.Module _ _ modName decls exp
       `updateConcurrently` ( onImportMap P.importedTypeOps \opImport -> do
                                let opName = P.disqualify $ P.importName opImport
                                (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn (P.importSourceModule opImport) opName
-                               type' <- selectType' conn aliasModName alias
-                               pure $ \env' ->
-                                 env'
-                                   { E.types =
-                                       E.types env'
-                                         <> Map.fromList
-                                           [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, fromJustWithErr opName type')
-                                           ]
-                                   }
+                               synMb <- selectTypeSynonym' conn aliasModName alias
+                               case synMb of 
+                                  Just syn -> do
+                                    pure $ \env' ->
+                                      env'
+                                        { E.typeSynonyms =
+                                            E.typeSynonyms env'
+                                              <> Map.fromList
+                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, syn)
+                                                ]
+                                        }
+                                  Nothing -> do
+                                    type' <- selectType' conn aliasModName alias
+                                    pure $ \env' ->
+                                      env'
+                                        { E.types =
+                                            E.types env'
+                                              <> Map.fromList
+                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, fromJustWithErr opName type')
+                                                ]
+                                        }
                            )
       `updateConcurrently` ( onImportMap P.importedValueOps \opImport -> do
                                let opName = P.disqualify $ P.importName opImport
@@ -676,6 +701,9 @@ selectTypeSynonym conn ident = do
   where
     deserialiseIdents (idents, st) = (deserialise idents, st)
 
+selectTypeSynonym' :: Connection -> P.ModuleName -> P.ProperName 'P.TypeName -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
+selectTypeSynonym' conn nMame ident = selectTypeSynonym conn (P.Qualified (P.ByModuleName nMame) ident)
+
 selectModuleTypeSynonyms :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), ([(Text, Maybe P.SourceType)], P.SourceType))]
 selectModuleTypeSynonyms conn moduleName' = do
   SQL.query

From 1e7c2846dab8119c8c5771b1150042aa3dc2edad Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Dec 2024 12:42:10 +0100
Subject: [PATCH 277/297] adds GetEnv

---
 src/Language/PureScript/Environment.hs        |    4 +-
 src/Language/PureScript/Interactive.hs        |    5 +-
 src/Language/PureScript/Make.hs               |    9 +-
 src/Language/PureScript/Make/Index.hs         |   31 +-
 src/Language/PureScript/Make/Index/Select.hs  | 1263 +++++++++++------
 .../PureScript/Sugar/BindingGroups.hs         |    1 +
 src/Language/PureScript/TypeChecker.hs        |   65 +-
 .../PureScript/TypeChecker/Deriving.hs        |   41 +-
 .../PureScript/TypeChecker/Entailment.hs      |   53 +-
 .../TypeChecker/Entailment/Coercible.hs       |   11 +-
 src/Language/PureScript/TypeChecker/Kinds.hs  |  105 +-
 src/Language/PureScript/TypeChecker/Monad.hs  |  123 +-
 .../PureScript/TypeChecker/Subsumption.hs     |    5 +-
 .../PureScript/TypeChecker/TypeSearch.hs      |    9 +-
 src/Language/PureScript/TypeChecker/Types.hs  |   59 +-
 src/Language/PureScript/TypeChecker/Unify.hs  |    7 +-
 16 files changed, 1124 insertions(+), 667 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index a617e32d01..4e62155828 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -49,7 +49,7 @@ data Environment = Environment
   -- scope (ie dictionaries brought in by a constrained type).
   , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
   -- ^ Type classes
-  } deriving (Show, Generic, S.Serialise)
+  } deriving (Show, Eq, Generic, S.Serialise)
 
 instance NFData Environment
 
@@ -76,7 +76,7 @@ data TypeClassData = TypeClassData
   -- ^ A sets of arguments that can be used to infer all other arguments.
   , typeClassIsEmpty :: Bool
   -- ^ Whether or not dictionaries for this type class are necessarily empty.
-  } deriving (Show, Generic, S.Serialise)
+  } deriving (Show, Generic, Eq, S.Serialise)
 
 instance NFData TypeClassData
 
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index 5f88b079c3..061710d15f 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -42,6 +42,7 @@ import Language.PureScript.Interactive.Types        as Interactive
 import System.Directory (getCurrentDirectory)
 import System.FilePath ((</>))
 import System.FilePath.Glob (glob)
+import Language.PureScript.Make.Index.Select (runWoGetEnv, WoGetEnv)
 
 -- | Pretty-print errors
 printErrors :: MonadIO m => P.MultipleErrors -> m ()
@@ -296,8 +297,8 @@ handleKindOf print' typ = do
           let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName }
               k   = check (snd <$> P.kindOf typ') chk
 
-              check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
-              check sew = fst . runWriter . runExceptT . runStateT sew
+              check :: WoGetEnv (StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors))) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
+              check sew st' = fst $ runWriter  $ runExceptT $ flip runStateT st' $ runWoGetEnv sew
           case k of
             Left err        -> printErrors err
             Right (kind, _) -> print' . P.prettyPrintType 1024 $ kind
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index bc5194efed..d7c3e5ecb0 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -49,7 +49,7 @@ import Language.PureScript.Make.Actions as Actions
 import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult)
 import Language.PureScript.Make.BuildPlan qualified as BuildPlan
 import Language.PureScript.Make.Cache qualified as Cache
-import Language.PureScript.Make.Index.Select (getModuleFixities, selectEnvFromImports, selectFixitiesFromModuleImportsAndDecls, selectFixitiesFromModuleImports)
+import Language.PureScript.Make.Index.Select (getModuleFixities, selectFixitiesFromModuleImportsAndDecls, selectFixitiesFromModuleImports, GetEnv, runDbEnv, runWoGetEnv)
 import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
 import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName)
@@ -236,7 +236,7 @@ desugarAndTypeCheck ::
 desugarAndTypeCheck initialCheckState withCheckStateOnError withCheckState moduleName externs withPrim exEnv env = runSupplyT 0 $ do
   (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-  (checked, checkSt@(CheckState {..})) <- runStateT (catchError (typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
+  (checked, checkSt@(CheckState {..})) <- runStateT (catchError (runWoGetEnv $ typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
   lift $ withCheckState checkSt
   let usedImports' =
         foldl'
@@ -270,8 +270,9 @@ desugarAndTypeCheckDb ::
 desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv = runSupplyT 0 $ do
   (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn exEnv withPrim) (exEnv, mempty)
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-  env <- selectEnvFromImports conn exEnv' usedImports desugared
-  (checked, checkSt@(CheckState {..})) <- runStateT (catchError (typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env
+  -- env <- selectEnvFromDefinitions conn exEnv' desugared
+  let env = initEnvironment
+  (checked, checkSt@(CheckState {..})) <- runStateT (catchError (runDbEnv conn $ typeCheckModule modulesExports desugared) mergeCheckState) (initialCheckState env)
   lift $ withCheckState checkSt
   let usedImports' =
         foldl'
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index c0b527a30f..e403494c60 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -35,12 +35,11 @@ import Language.PureScript.Environment (Environment)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Externs (ExternsFile (efModuleName))
 import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), declNameType, externDeclNameType, lspNameType)
-import Language.PureScript.Lsp.Print (addDataDeclArgKind, printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType, printTypeClassKind)
+import Language.PureScript.Lsp.Print (printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType, printTypeClassKind)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Make.Index.Select (toDbQualifer)
 import Language.PureScript.Names (Qualified ())
-import Language.PureScript.TypeChecker.Monad (emptyCheckState)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdInstanceKinds, tcdInstanceTypes, tcdValue))
 import Protolude hiding (moduleName)
 
@@ -72,7 +71,7 @@ addEnvIndexing conn ma =
     }
 
 indexAstModule :: (MonadIO m) => Connection -> Environment -> P.Module -> ExternsFile -> Set P.Name -> m ()
-indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs) extern exportedNames = liftIO do
+indexAstModule conn _endEnv (P.Module _ss _comments moduleName' decls _exportRefs) extern exportedNames = liftIO do
   path <- makeAbsolute externPath
   SQL.executeNamed
     conn
@@ -103,19 +102,13 @@ indexAstModule conn endEnv (P.Module _ss _comments moduleName' decls _exportRefs
             P.DataDeclaration _ _ tyName args _ -> case getMatchingKind P.DataSig tyName of
               Just kind -> printType kind
               _ -> printDataDeclKind args
-            P.TypeSynonymDeclaration ann name args ty -> case getMatchingKind P.TypeSynonymSig name of
+            P.TypeSynonymDeclaration _ann name args _ty -> case getMatchingKind P.TypeSynonymSig name of
               Just kind -> printType kind
-              _ ->
-                let addForall ty' = foldl' (\acc v -> P.ForAll P.nullSourceAnn P.TypeVarInvisible v Nothing acc Nothing) ty' vars
-                      where
-                        vars = P.usedTypeVariables ty'
-
-                    inferSynRes =
-                      runExcept $ evalStateT (P.inferKind . addForall =<< P.inferTypeSynonym moduleName' (ann, name, args, ty)) (emptyCheckState endEnv) {P.checkCurrentModule = Just moduleName'}
-                 in case inferSynRes of
-                      Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
-                      Right (_, tyKind) ->
-                        printType $ foldr addDataDeclArgKind (void tyKind) args
+              _ -> printDataDeclKind args 
+                    -- case inferSynRes of
+                    --   Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
+                    --   Right (_, tyKind) ->
+                    --     printType $ foldr addDataDeclArgKind (void tyKind) args
             P.TypeClassDeclaration _ name args _ _ _ -> case getMatchingKind P.ClassSig (P.coerceProperName name) of
               Just kind -> printType kind
               _ -> printTypeClassKind args
@@ -500,9 +493,12 @@ insertNamedDict :: Connection -> NamedDict -> IO ()
 insertNamedDict conn dict = do
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, types, kinds, dict) VALUES (?, ?, ?, ?, ?, ?, ?)"
-    (toDbQualifer (tcdValue dict) :. (clasMod, className, A.encode (tcdInstanceTypes dict), A.encode (tcdInstanceKinds dict), serialise dict))
+    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, types, kinds, dict, debug) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
+    (toDbQualifer (tcdValue dict) :. (clasMod, className, A.encode (void <$> tcdInstanceTypes dict), A.encode (tcdInstanceKinds dict), serialise dict, debug))
   where
+    debug :: Text 
+    debug = show (void <$> tcdInstanceTypes dict)
+
     (clasMod, className) = toDbQualifer (tcdClassName dict)
 
 initEnvTables :: Connection -> IO ()
@@ -525,6 +521,7 @@ addEnvIndexes conn = do
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idx ON env_type_class_instances(module_name, instance_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_idents_idx ON env_type_class_instances(idents)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_class_name_idx ON env_type_class_instances(class_name)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_class_module_idx ON env_type_class_instances(class_module)"
 
 dropEnvTables :: Connection -> IO ()
 dropEnvTables conn = do
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 68d67236f8..eb08a2f9dc 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -11,15 +11,20 @@ import Codec.Serialise (deserialise)
 import Control.Arrow ((>>>))
 import Control.Concurrent.Async.Lifted (forConcurrently, forConcurrently_, mapConcurrently, mapConcurrently_)
 import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view)
+import Control.Monad.Writer (MonadWriter (tell), Writer, execWriter, WriterT)
+import Control.Monad.Writer.Strict qualified as Strict
 import Data.Aeson qualified as A
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple (Connection)
 import Database.SQLite.Simple qualified as SQL
 import Language.PureScript.AST.Declarations (ImportDeclarationType)
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.Operators qualified as P
+import Language.PureScript.AST.Traversals (accumTypes)
+import Language.PureScript.AST.Traversals qualified as P
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (TypeClassData (typeClassSuperclasses))
 import Language.PureScript.Environment qualified as E
@@ -28,14 +33,22 @@ import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
 import Language.PureScript.Linter.Imports qualified as P
 import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
+import Language.PureScript.Sugar.BindingGroups (usedTypeNames)
 import Language.PureScript.Sugar.Names (Exports (exportedValueOps))
 import Language.PureScript.Sugar.Names.Env qualified as P
-import Language.PureScript.TypeChecker.Monad qualified as P
+-- import Language.PureScript.TypeChecker.Monad qualified as P
 import Language.PureScript.TypeClassDictionaries (NamedDict)
+import Language.PureScript.TypeClassDictionaries qualified as P
 import Language.PureScript.Types (Constraint (constraintClass))
 import Language.PureScript.Types qualified as P
 import Protolude hiding (moduleName)
 import Protolude.Partial (fromJust)
+import Control.Monad.Supply (SupplyT)
+import Control.Monad.Supply.Class (MonadSupply (fresh, peek))
+import Control.Monad.Trans.Class (MonadTrans)
+import Control.Monad.Identity (IdentityT)
+import Control.Monad.Trans.Maybe (MaybeT)
+
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImportsAndDecls conn env module' = do
@@ -161,448 +174,680 @@ type ClassDict =
         (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty NamedDict))
     )
 
-selectEnvFromImports :: (MonadIO m) => Connection -> P.Env -> P.UsedImports -> P.Module -> m E.Environment
-selectEnvFromImports conn exportEnv _usedImports (P.Module _ _ modName decls exportedRefs) = liftIO do
-  when (modName == P.ModuleName "Data.Identity") do
-    putErrText $ "\n\nData.Identity type imports: \n\n" <> T.intercalate "\n\n" (show <$> Map.toList (P.importedTypes imports))
-    putErrText $ "\n\nData.Identity class imports: \n\n" <> T.intercalate "\n\n" (show <$> Map.toList (P.importedTypeClasses imports))
-  insertExports conn modName exportedRefs
-  insertImports conn modName decls
-  importFn <-
-    ( onImportMap P.importedTypes \typeImport ->
-        do
-          let tyName = P.disqualify $ P.importName typeImport
-          synMb <- selectTypeSynonym' conn (P.importSourceModule typeImport) tyName
-          case synMb of
-            Just syn -> do
-              pure $ \env' ->
-                env'
-                  { E.typeSynonyms =
-                      E.typeSynonyms env'
-                        <> Map.fromList
-                          [ (P.importName typeImport, syn),
-                            (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, syn)
-                          ]
-                  }
-            Nothing -> do
-              type' <- selectType' conn (P.importSourceModule typeImport) tyName
-              pure $ \env' ->
-                env'
-                  { E.types =
-                      E.types env'
-                        <> Map.fromList
-                          [ (P.importName typeImport, fromJust type'),
-                            (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, fromJust type')
-                          ]
-                  }
-      )
-      `updateConcurrently` ( onImportMap P.importedDataConstructors \ctrImport ->
-                               do
-                                 let ctrName = P.disqualify $ P.importName ctrImport
-                                     qualified = P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName
-                                 ctr <- selectDataConstructor conn (P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName)
-                                 pure $ \env' ->
-                                   env'
-                                     { E.dataConstructors =
-                                         E.dataConstructors env'
-                                           <> Map.fromList
-                                             [ (P.importName ctrImport, fromJust ctr),
-                                               (qualified, fromJust ctr)
-                                             ]
-                                     }
-                           )
-      `updateConcurrently` ( onImportMap P.importedTypeClasses \classImport ->
-                               importClass (P.importSourceModule classImport) (P.importName classImport) (P.disqualify $ P.importName classImport)
-                           )
-      `updateConcurrently` ( onImportMap P.importedValues \valImport -> do
-                               let ident = P.disqualify $ P.importName valImport
-                               val <- selectEnvValue conn (P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident)
-                               pure $ \env' ->
-                                 env'
-                                   { E.names =
-                                       E.names env'
-                                         <> Map.fromList
-                                           [ ( P.importName valImport,
-                                               fromJustWithErr (modName, P.importSourceModule valImport, ident) val
-                                             ),
-                                             ( P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident,
-                                               fromJustWithErr (modName, P.importSourceModule valImport, ident) val
-                                             )
-                                           ]
-                                   }
-                           )
-      `updateConcurrently` ( onImportMap P.importedTypeOps \opImport -> do
-                               let opName = P.disqualify $ P.importName opImport
-                               (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn (P.importSourceModule opImport) opName
-                               synMb <- selectTypeSynonym' conn aliasModName alias
-                               case synMb of 
-                                  Just syn -> do
-                                    pure $ \env' ->
-                                      env'
-                                        { E.typeSynonyms =
-                                            E.typeSynonyms env'
-                                              <> Map.fromList
-                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, syn)
-                                                ]
-                                        }
-                                  Nothing -> do
-                                    type' <- selectType' conn aliasModName alias
-                                    pure $ \env' ->
-                                      env'
-                                        { E.types =
-                                            E.types env'
-                                              <> Map.fromList
-                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, fromJustWithErr opName type')
-                                                ]
-                                        }
-                           )
-      `updateConcurrently` ( onImportMap P.importedValueOps \opImport -> do
-                               let opName = P.disqualify $ P.importName opImport
-                               (aliasModName, alias) <- fromJustWithErr opName <$> selectValueOperatorAlias conn (P.importSourceModule opImport) opName
-                               if isUpper $ T.head alias
-                                 then do
-                                   let ctrName = P.ProperName alias
-                                       qual = P.Qualified (P.ByModuleName aliasModName) ctrName
-                                   val <- selectDataConstructor conn qual
-                                   pure $ \env' ->
-                                     env'
-                                       { E.dataConstructors =
-                                           E.dataConstructors env'
-                                             <> Map.fromList [(qual, fromJustWithErr qual val)]
-                                       }
-                                 else do
-                                   let ident = P.Ident alias
-                                       qual = P.Qualified (P.ByModuleName aliasModName) ident
-                                   val <- selectEnvValue conn qual
-                                   pure $ \env' ->
-                                     env'
-                                       { E.names =
-                                           E.names env'
-                                             <> Map.fromList [(qual, fromJustWithErr qual val)]
-                                       }
-                           )
-
-  let env = importFn E.initEnvironment
-
-  envConstraintFns <- forConcurrently (getEnvConstraints env) \c -> do
-    let (classMod, className) = toDbQualifer $ constraintClass c
-    importClass' classMod classMod className
-
-  pure $ foldl' (&) env envConstraintFns
+-- selectEnvFromDefinitions :: forall m. (MonadIO m) => Connection -> P.Env -> P.Module -> m E.Environment
+-- selectEnvFromDefinitions conn _exportEnv (P.Module _ _ modName decls _) = liftIO do
+--   -- when (modName == P.ModuleName "Data.BooleanAlgebra") do
+--   --   putErrText "de"
+--   --   putErrText "\n"
+--   --   putErrText $ T.intercalate "\n\n" (show <$> decls)
+--   updates <- catMaybes <$> forConcurrently usedNames (import' E.initEnvironment)
+--   let env = pipe (fmap snd updates) E.initEnvironment
+--   addEnvTypes env
+--   where
+--     addEnvTypes :: E.Environment -> IO E.Environment
+--     addEnvTypes env = do
+--       let toImport = getTypesToImportFromEnv env
+--       updates <- catMaybes <$> forConcurrently (Set.toList $ getTypesToImportFromEnv env) (import' env)
+--       putErrText $ show modName
+--       when (modName == P.ModuleName "Data.Show") do
+--         putErrText "\n"
+--         putErrText $ T.pack $ intercalate "\n" (show <$> Set.toList toImport)
+--         putErrText "\n"
+--         -- putErrText $ T.pack $ intercalate "\n" (P.debugTypeClassDictionaries env)
+--         putErrText "\n\n"
+--         putErrText ("updates: " <> show (length updates))
+--         putErrText (T.intercalate "\n" $ fmap (show . fst) updates)
+
+--       let newEnv = pipe (fmap snd updates) env
+--       case updates of
+--         [] -> pure env
+--         _ 
+--           | newEnv /= env -> 
+--             addEnvTypes $ pipe (fmap snd updates) env
+--           | otherwise ->  pure env
+
+--     usedNames = Set.toList $ Set.unions $ getUsedNames <$> decls
+
+--     import' :: E.Environment -> P.Qualified ToImport -> IO (Maybe (P.Qualified ToImport, E.Environment -> E.Environment))
+--     import' env ti@(P.Qualified (P.ByModuleName mName) name) | mName /= modName = fmap (ti,) <$> do
+--       case name of
+--         TiIdent ident -> do
+--           let qual = P.Qualified (P.ByModuleName mName) ident
+--           if Map.member qual (E.names env)
+--             then pure Nothing
+--             else do
+--               val <- selectEnvValue conn qual
+--               pure $ Just $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--         TiType tyName -> do
+--           let qual = P.Qualified (P.ByModuleName mName) tyName
+--           if Map.member qual (E.types env) || Map.member qual (E.typeSynonyms env)
+--             then pure Nothing
+--             else do
+--               type' <- selectType conn qual
+--               pure $ Just $ \env' -> env' {E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual type')]}
+--         TiDctor ctrName -> do
+--           let qual = P.Qualified (P.ByModuleName mName) ctrName
+--           if Map.member qual (E.dataConstructors env)
+--             then pure Nothing
+--             else do
+--               val <- selectDataConstructor conn qual
+--               pure $ Just $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJust val)]}
+--         TiClass className -> do
+--           let qual = P.Qualified (P.ByModuleName mName) className
+--           if Map.member qual (E.typeClasses env)
+--             then pure Nothing
+--             else do
+--               typeClass <- selectTypeClass conn mName className
+--               pure $ Just $ \env' -> env' {E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)]}
+--         TiDeferredDictionary className -> do
+--           let qual = P.Qualified (P.ByModuleName mName) className
+--           instances <- selectClassInstancesByClassName conn qual
+
+--           let dictInEnv _d =
+--                 Map.lookup (P.ByModuleName mName) (E.typeClassDictionaries env)
+--                   & maybe False (Map.member qual)
+--                   -- & maybe False (Map.member (P.tcdValue d))
+
+--           when (modName == P.ModuleName "Data.Show") do
+--             putErrText $ T.pack $ intercalate "\n" (P.debugTypeClassDictionaries env)
+--             putErrText $ "instances: "
+--             for_ instances \i -> do 
+--               putErrText $ show i
+--               putErrText $ show $ dictInEnv i
+
+
+--           if all dictInEnv instances
+--               then pure Nothing
+--               else pure $ Just $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')}
+--     import' _ _ = pure Nothing
+
+getTypesToImportFromEnv :: P.Environment -> Set (P.Qualified ToImport)
+getTypesToImportFromEnv env =
+  nameImports
+    <> typeImports
+    <> ctrImports
+    <> synonymImports
+    <> dictImports
+    <> classImports
   where
-    -- importName :: P.ModuleName -> P.Name -> IO (E.Environment -> E.Environment)
-    -- importName mName name = _ importRef mName $  getImportSrc mName name
-    imports :: P.Imports
-    imports = lookupImports modName exportEnv
-
-    onImportMap ::
-      ( P.Imports ->
-        Map
-          (P.Qualified a)
-          [P.ImportRecord a]
-      ) ->
-      ( P.ImportRecord a ->
-        IO (P.Environment -> P.Environment)
-      ) ->
-      IO (P.Environment -> P.Environment)
-    onImportMap getImports fn =
-      pipe <$> forConcurrently (Map.toList $ getImports imports) \(_, recs) ->
-        pipe <$> forConcurrently recs fn'
-      where
-        fn' ir = if P.importSourceModule ir == modName then pure identity else fn ir
-
-    -- importValue :: P.ModuleName -> P.Qualified P.Ident -> IO (E.Environment -> E.Environment)
-    -- importValue mName = \case
-    --   P.Qualified _ ident -> do
-    --     let qual = P.Qualified (P.ByModuleName mName) ident
-    --     val <- selectEnvValue conn qual
-    --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    --   where
-    --     exports = lookupExports mName exportEnv
-
-    importClass modName' qual className = do
-      typeClass <- fromJust <$> selectTypeClass conn modName' className
-      let dictName = P.Qualified (P.ByModuleName modName') . P.dictTypeName . coerceProperName $ className
-          typeQual = P.Qualified (P.ByModuleName modName') $ coerceProperName className
-      type' <- selectType conn typeQual
-      dictVal <- selectType conn dictName
-
-      let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
-          ctrMb =
-            P.Qualified (P.ByModuleName modName') <$> case dictVal of
-              Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
-              _ -> Nothing
-
-      ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
-      instances <- selectClassInstancesByClassName conn $ P.Qualified (P.ByModuleName modName') className
-
-      superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
-        P.Qualified (P.ByModuleName superModName) superClassName -> do
-          -- TODO add check for existing class in env
-          importClass superModName (P.Qualified (P.ByModuleName superModName) superClassName) superClassName
-        _ -> pure identity
-
-      pure $
-        pipe superClassImports
-          >>> \env' ->
-            env'
-              { E.typeClasses =
-                  E.typeClasses env'
-                    <> Map.fromList
-                      [ (qual, typeClass),
-                        (P.Qualified (P.ByModuleName modName') className, typeClass)
-                      ],
-                E.types =
-                  E.types env'
-                    <> Map.fromList
-                      ( [ (typeQual, fromJust type')
-                        ]
-                          <> case dictVal of
-                            Just val -> [(dictName, val)]
-                            _ -> []
-                      ),
-                E.dataConstructors =
-                  E.dataConstructors env' <> Map.fromList case (ctrMb, ctrData) of
-                    (Just ctr', Just ctrData') -> [(ctr', ctrData')]
-                    _ -> [],
-                E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
-              }
-    importName :: P.ModuleName -> P.Qualified P.Name -> IO (E.Environment -> E.Environment)
-    importName mName (P.Qualified (P.ByModuleName _) name) = do
-      -- when (modName' /= mName) do
-      --   putErrText $ "importName called with different module names: " <> show modName' <> " and " <> show mName
-      --   putErrText $ "name: " <> show name
-      case name of
-        P.IdentName ident -> do
-          let P.ExportSource {..} = fromJustWithErr (mName, ident) $ Map.lookup ident (P.exportedValues exports)
-              qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ident
-          val <- selectEnvValue conn qual
-          let importedModuleName = getImportedModule mName ident $ P.importedValues imports
-          pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ident, fromJustWithErr ident val)]}
-        P.ValOpName opName -> do
-          let P.ExportSource {..} = fromJustWithErr (mName, opName) $ Map.lookup opName (P.exportedValueOps exports)
-          (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn exportSourceDefinedIn opName
-          if isUpper $ T.head alias
-            then do
-              let ctrName = P.ProperName alias
-                  qual = P.Qualified (P.ByModuleName aliasModName) ctrName
-              val <- selectDataConstructor conn qual
-              pure $ \env' ->
-                env'
-                  { E.dataConstructors =
-                      E.dataConstructors env'
-                        <> Map.fromList [(qual, fromJustWithErr qual val)]
-                  }
-            else do
-              let ident = P.Ident alias
-                  qual = P.Qualified (P.ByModuleName aliasModName) ident
-              val <- selectEnvValue conn qual
-              pure $ \env' ->
-                env'
-                  { E.names =
-                      E.names env'
-                        <> Map.fromList [(qual, fromJustWithErr qual val)]
-                  }
-        P.TyName tyName -> do
-          let (_, P.ExportSource {..}) = fromJust $ Map.lookup tyName (P.exportedTypes exports)
-          let qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) tyName
-          type' <- selectType conn qual
-          ctrVals <- selectTypeDataConstructors conn qual
-          let importedModuleName = getImportedModule mName tyName $ P.importedTypes imports
-          pure $ \env' ->
-            env'
-              { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) tyName, fromJust type')],
-                E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
-              }
-        P.TyOpName opName -> do
-          let P.ExportSource {..} = fromJust $ Map.lookup opName (P.exportedTypeOps exports)
-          (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectTypeOperatorAlias conn exportSourceDefinedIn opName
-          let qual = P.Qualified (P.ByModuleName aliasModName) alias
-          val <- selectType conn qual
-          let importedModuleName = getImportedModule mName alias $ P.importedTypes imports
-          pure $ \env' ->
-            env'
-              { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) alias, fromJustWithErr qual val)]
-              }
-        P.TyClassName className -> do
-          let P.ExportSource {..} = fromJust $ Map.lookup className (P.exportedTypeClasses exports)
-          importClass' mName exportSourceDefinedIn className
-        P.DctorName ctrName -> do
-          let containsCtr (_, (ctrs, _)) = ctrName `elem` ctrs
-              (_, (_, P.ExportSource {..})) = fromJust $ find containsCtr $ Map.toList $ P.exportedTypes exports -- Map.find ctrName (P.exportedDataConstructors exports)
-              qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ctrName
-          val <- selectDataConstructor conn qual
-          let importedModuleName = getImportedModule mName ctrName $ P.importedDataConstructors imports
-          pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ctrName, fromJustWithErr ctrName val)]}
-        P.ModName _ -> internalError "importName called with ModName"
-      where
-        exports :: P.Exports
-        exports = lookupExports mName exportEnv
-    importName _ _ = pure identity
-
-    getImportedModule ::
-      (Ord a) =>
-      (Foldable f) =>
-      P.ModuleName ->
-      a ->
-      Map (P.Qualified a) (f (P.ImportRecord a)) ->
-      P.ModuleName
-    getImportedModule mName ident imports' = fromMaybe mName do
-      importRecs <- Map.lookup (P.Qualified (P.ByModuleName mName) ident) imports'
-      importRec <- head importRecs
-      pure $ P.importSourceModule importRec
-    -- imports :: P.Imports
-    -- imports = lookupImports mName exportEnv
-
-    -- case
-    -- P.IdentName ident -> do
-    --   let qual = P.Qualified (P.ByModuleName mName) ident
-    --   val <- selectEnvValue conn qual
-    --   pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    -- P.ValOpName opName -> do
-    --   (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn mName opName
-    --   if isUpper $ T.head alias
-    --     then do
-    --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
-    --       val <- selectDataConstructor conn qual
-    --       pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    --     else do
-    --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
-    --       val <- selectEnvValue conn qual
-    --       pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    -- P.TyName tyName -> do
-    --   let qual = P.Qualified (P.ByModuleName mName) tyName
-    --   type' <- selectType conn qual
-    --   ctrVals <- selectTypeDataConstructors conn qual
-    --   pure $ \env' ->
-    --     env'
-    --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual type')],
-    --         E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
-    --       }
-
-    -- P.TyOpName opName -> do
-    --   (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
-    --   let qual = P.Qualified (P.ByModuleName aliasModName) alias
-    --   val <- selectType conn qual
-    --   pure $ \env' ->
-    --     env'
-    --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
-    --       }
-
-    -- P.DctorName dctorName -> do
-    --   let qual = P.Qualified (P.ByModuleName mName) dctorName
-    --   val <- selectDataConstructor conn qual
-    --   pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    -- P.TyClassName className -> do
-    --   importClass' mName className
-    -- P.ModName _ -> internalError "importName called with ModName"
-
-    -- where
-    --   exports = lookupExports mName exportEnv
-
-    -- importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
-    -- importRef mName = \case
-    --   P.TypeClassRef _ className -> importClass' mName className
-    --   P.TypeRef _ tyName ctrs -> do
-    --     let qual = P.Qualified (P.ByModuleName mName) tyName
-    --     type' <- selectType conn qual
-    --     ctrVals <- case ctrs of
-    --       Nothing -> selectTypeDataConstructors conn qual
-    --       Just ctrs' -> forConcurrently ctrs' \ctr -> do
-    --         let qual' = P.Qualified (P.ByModuleName mName) ctr
-    --         val <- selectDataConstructor conn qual'
-    --         pure (qual', fromJustWithErr qual' val)
-    --     pure $ \env' ->
-    --       env'
-    --         { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
-    --           E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
-    --         }
-    --   P.ValueRef _ ident -> do
-    --     let qual = P.Qualified (P.ByModuleName mName) ident
-    --     val <- selectEnvValue conn qual
-    --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    --   P.TypeInstanceRef _ ident _ -> do
-    --     let qual = P.Qualified (P.ByModuleName mName) ident
-    --     val <- selectClassInstance conn qual
-    --     pure $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap [fromJust val] (E.typeClassDictionaries env')}
-    --   P.ModuleRef _ _ -> internalError "importRef called with ModuleRef"
-    --   P.ReExportRef _ _ ref -> importRef mName ref
-    --   P.ValueOpRef _ opName -> do
-    --     (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
-    --     if isUpper $ T.head alias
-    --       then do
-    --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
-    --         val <- selectDataConstructor conn qual
-    --         pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    --       else do
-    --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
-    --         val <- selectEnvValue conn qual
-    --         pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
-    --   P.TypeOpRef _ opName -> do
-    --     (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
-    --     let qual = P.Qualified (P.ByModuleName aliasModName) alias
-    --     val <- selectType conn qual
-    --     pure $ \env' ->
-    --       env'
-    --         { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
-    --         }
-
-    -- importModule mName = importModuleHiding mName []
-
-    -- importModuleHiding mName hideRefs = do
-    --   allRefs <- selectModuleExports conn mName
-    --   let refs = filter (not . flip Set.member hiddenRefSet) allRefs
-    --   importRefs mName refs
-    --   where
-    --     hiddenRefSet = Set.fromList hideRefs
-
-    importClass' :: P.ModuleName -> P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
-    importClass' mName _modDefinedIn className = do
-      when (mName /= _modDefinedIn) do
-        putErrText $ "importClass' called with different module names: " <> show mName <> " and " <> show _modDefinedIn
-        putErrText $ "className: " <> show className
-
-      let qual = P.Qualified (P.ByModuleName mName) className
-          typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
-      type' <- selectType conn typeQual
-      typeClass <- fromJust <$> selectTypeClass conn mName className
-      let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
-      dictVal <- selectType conn dictName
-
-      let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
-          ctrMb =
-            P.Qualified (P.ByModuleName mName) <$> case dictVal of
-              Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
-              _ -> Nothing
-
-      ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
-      superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
-        P.Qualified (P.ByModuleName superModName) superClassName -> do
-          importClass' superModName superModName superClassName
-        _ -> pure identity
-
-      instances <- selectClassInstancesByClassName conn qual
-
-      pure $
-        pipe superClassImports >>> \env' ->
-          env'
-            { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, typeClass)],
-              E.types =
-                E.types env'
-                  <> Map.fromList
-                    ( [ (typeQual, fromJust type')
-                      ]
-                        <> case dictVal of
-                          Just val -> [(dictName, val)]
-                          _ -> []
-                    ),
-              E.dataConstructors =
-                E.dataConstructors env'
-                  <> Map.fromList case (ctrMb, ctrData) of
-                    (Just ctr', Just ctrData') -> [(ctr', ctrData')]
-                    _ -> [],
-              E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
-            }
+    nameImports =
+      E.names env
+        & Map.elems
+        <&> (typesToImport . view _1)
+        & Set.unions
+
+    typeImports =
+      E.types env
+        & Map.elems
+        <&> (typesToImport . view _1)
+        & Set.unions
+
+    ctrImports =
+      E.dataConstructors env
+        & Map.elems
+        <&> (typesToImport . view _3)
+        & Set.unions
+
+    synonymImports =
+      E.typeSynonyms env
+        & Map.elems
+        <&> (typesToImport . view _2)
+        & Set.unions
+
+    dictImports =
+      E.typeClassDictionaries env
+        & Map.elems
+          >>= Map.elems
+          >>= (fmap (Set.unions . fmap namedDictImports) . Map.elems)
+        & Set.unions
+
+    classImports =
+      E.typeClasses env
+        & Map.elems
+        <&> typeClassImports
+        & Set.unions
+
+namedDictImports :: NamedDict -> Set (P.Qualified ToImport)
+namedDictImports dict = P.tcdDependencies dict & maybe Set.empty (Set.unions . fmap (Set.unions . fmap typesToImport . P.constraintArgs))
+
+typeClassImports :: P.TypeClassData -> Set (P.Qualified ToImport)
+typeClassImports tcd =
+  P.typeClassSuperclasses tcd
+    <&> constraintImports
+    & Set.unions
+
+typeClassDataTypes :: P.TypeClassData -> [P.SourceType]
+typeClassDataTypes tcd = P.typeClassSuperclasses tcd >>= P.constraintArgs
+
+getUsedNames :: P.Declaration -> Set (P.Qualified ToImport)
+getUsedNames d = getUsedValueNames d <> getDeclTypesToImport d
+
+getUsedValueNames :: P.Declaration -> Set (P.Qualified ToImport)
+getUsedValueNames = execWriter . handleDecl
+  where
+    (handleDecl, _, _) = P.everywhereOnValuesM onDecl onExpr pure
+
+    onDecl :: P.Declaration -> Writer (Set (P.Qualified ToImport)) P.Declaration
+    onDecl d = do
+      case d of
+        P.TypeInstanceDeclaration _ _ _ _ _ deps cl _ _ ->
+          tell $
+            Set.fromList [fmap TiClass cl, TiType . P.coerceProperName <$> cl] <> Set.unions (constraintImports <$> deps)
+        _ -> pure ()
+      pure d
+
+    onExpr :: P.Expr -> Writer (Set (P.Qualified ToImport)) P.Expr
+    onExpr e = do
+      case e of
+        P.Var _ qn -> tell $ Set.singleton $ fmap TiIdent qn
+        P.Constructor _ qn -> tell $ Set.singleton $ fmap TiDctor qn
+        P.DeferredDictionary cn@(P.Qualified qb cn') _types ->
+          tell $
+            Set.fromList
+              [ fmap TiClass cn,
+                TiType . P.coerceProperName <$> cn,
+                P.Qualified qb $ TiDeferredDictionary cn'
+              ]
+        P.DerivedInstancePlaceholder cn _ ->
+          tell $
+            Set.fromList
+              [ fmap TiClass cn,
+                TiType . P.coerceProperName <$> cn
+              ]
+        _ -> pure ()
+      pure e
+
+getDeclTypesToImport :: P.Declaration -> Set (P.Qualified ToImport)
+getDeclTypesToImport = declTypeNames
+  where
+    (declTypeNames, _, _, _, _) = P.accumTypes $ P.everythingOnTypes (<>) \case
+      P.TypeConstructor _ tyName -> Set.singleton $ fmap TiType tyName
+      P.ConstrainedType _ c _ -> constraintImports c
+        where
+          (P.Qualified qb cl) = P.constraintClass c
+      _ -> Set.empty
+
+constraintImports :: P.SourceConstraint -> Set (P.Qualified ToImport)
+constraintImports c =
+  Set.fromList
+    [ TiClass <$> P.constraintClass c,
+      TiType . P.coerceProperName <$> P.constraintClass c,
+      P.Qualified qb $ TiDeferredDictionary cl
+    ]
+  where
+    (P.Qualified qb cl) = P.constraintClass c
+
+typesToImport :: P.SourceType -> Set (P.Qualified ToImport)
+typesToImport = P.everythingOnTypes (<>) \case
+  P.TypeConstructor _ tyName -> Set.singleton $ fmap TiType tyName
+  P.ConstrainedType _ c _ ->
+    Set.fromList
+      [ TiClass <$> P.constraintClass c,
+        TiType . P.coerceProperName <$> P.constraintClass c,
+        P.Qualified qb $ TiDeferredDictionary cl
+      ]
+    where
+      (P.Qualified qb cl) = P.constraintClass c
+  _ -> Set.empty
+
+data ToImport
+  = TiIdent P.Ident
+  | TiType (P.ProperName 'P.TypeName)
+  | TiDctor (P.ProperName 'P.ConstructorName)
+  | TiClass (P.ProperName 'P.ClassName)
+  | TiDeferredDictionary (P.ProperName 'P.ClassName)
+  deriving (Show, Eq, Ord)
+
+-- (handleDecl, _, _) = P.everywhereOnValuesM onDecl onExpr pure
+
+-- -- onDecl :: P.Declaration -> Writer (Set (P.Qualified P.ProperName)) P.Declaration
+-- onDecl d = do
+--   let (declTypeNames, _, _, _, _) = P.accumTypes (P.everythingOnTypes (<>) _)
+--   tell $ Set.map (fmap P.coerceProperName) $ declTypeNames d
+--   pure d
+-- onExpr = pure
+
+-- selectEnvFromImports :: (MonadIO m) => Connection -> P.Env -> P.UsedImports -> P.Module -> m E.Environment
+-- selectEnvFromImports conn exportEnv _usedImports (P.Module _ _ modName decls exportedRefs) = liftIO do
+--   insertExports conn modName exportedRefs
+--   insertImports conn modName decls
+--   importFn <-
+--     ( onImportMap P.importedTypes \typeImport ->
+--         do
+--           let tyName = P.disqualify $ P.importName typeImport
+--           synMb <- selectTypeSynonym' conn (P.importSourceModule typeImport) tyName
+--           case synMb of
+--             Just syn -> do
+--               pure $ \env' ->
+--                 env'
+--                   { E.typeSynonyms =
+--                       E.typeSynonyms env'
+--                         <> Map.fromList
+--                           [ (P.importName typeImport, syn),
+--                             (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, syn)
+--                           ]
+--                   }
+--             Nothing -> do
+--               type' <- selectType' conn (P.importSourceModule typeImport) tyName
+--               pure $ \env' ->
+--                 env'
+--                   { E.types =
+--                       E.types env'
+--                         <> Map.fromList
+--                           [ (P.importName typeImport, fromJust type'),
+--                             (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, fromJust type')
+--                           ]
+--                   }
+--       )
+--       `updateConcurrently` ( onImportMap P.importedDataConstructors \ctrImport ->
+--                                do
+--                                  let ctrName = P.disqualify $ P.importName ctrImport
+--                                      qualified = P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName
+--                                  ctr <- selectDataConstructor conn (P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName)
+--                                  pure $ \env' ->
+--                                    env'
+--                                      { E.dataConstructors =
+--                                          E.dataConstructors env'
+--                                            <> Map.fromList
+--                                              [ (P.importName ctrImport, fromJust ctr),
+--                                                (qualified, fromJust ctr)
+--                                              ]
+--                                      }
+--                            )
+--       `updateConcurrently` ( onImportMap P.importedTypeClasses \classImport ->
+--                                importClass (P.importSourceModule classImport) (P.importName classImport) (P.disqualify $ P.importName classImport)
+--                            )
+--       `updateConcurrently` ( onImportMap P.importedValues \valImport -> do
+--                                let ident = P.disqualify $ P.importName valImport
+--                                val <- selectEnvValue conn (P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident)
+--                                pure $ \env' ->
+--                                  env'
+--                                    { E.names =
+--                                        E.names env'
+--                                          <> Map.fromList
+--                                            [ ( P.importName valImport,
+--                                                fromJustWithErr (modName, P.importSourceModule valImport, ident) val
+--                                              ),
+--                                              ( P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident,
+--                                                fromJustWithErr (modName, P.importSourceModule valImport, ident) val
+--                                              )
+--                                            ]
+--                                    }
+--                            )
+--       `updateConcurrently` ( onImportMap P.importedTypeOps \opImport -> do
+--                                let opName = P.disqualify $ P.importName opImport
+--                                (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn (P.importSourceModule opImport) opName
+--                                synMb <- selectTypeSynonym' conn aliasModName alias
+--                                case synMb of
+--                                  Just syn -> do
+--                                    pure $ \env' ->
+--                                      env'
+--                                        { E.typeSynonyms =
+--                                            E.typeSynonyms env'
+--                                              <> Map.fromList
+--                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, syn),
+--                                                  (P.Qualified (P.ByModuleName aliasModName) alias, syn)
+--                                                ]
+--                                        }
+--                                  Nothing -> do
+--                                    type' <- selectType' conn aliasModName alias
+--                                    pure $ \env' ->
+--                                      env'
+--                                        { E.types =
+--                                            E.types env'
+--                                              <> Map.fromList
+--                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, fromJustWithErr opName type'),
+--                                                  (P.Qualified (P.ByModuleName aliasModName) alias, fromJustWithErr opName type')
+--                                                ]
+--                                        }
+--                            )
+--       `updateConcurrently` ( onImportMap P.importedValueOps \opImport -> do
+--                                let opName = P.disqualify $ P.importName opImport
+--                                (aliasModName, alias) <- fromJustWithErr opName <$> selectValueOperatorAlias conn (P.importSourceModule opImport) opName
+--                                if isUpper $ T.head alias
+--                                  then do
+--                                    let ctrName = P.ProperName alias
+--                                        qual = P.Qualified (P.ByModuleName aliasModName) ctrName
+--                                    val <- selectDataConstructor conn qual
+--                                    pure $ \env' ->
+--                                      env'
+--                                        { E.dataConstructors =
+--                                            E.dataConstructors env'
+--                                              <> Map.fromList [(qual, fromJustWithErr qual val)]
+--                                        }
+--                                  else do
+--                                    let ident = P.Ident alias
+--                                        qual = P.Qualified (P.ByModuleName aliasModName) ident
+--                                    val <- selectEnvValue conn qual
+--                                    pure $ \env' ->
+--                                      env'
+--                                        { E.names =
+--                                            E.names env'
+--                                              <> Map.fromList [(qual, fromJustWithErr qual val)]
+--                                        }
+--                            )
+
+--   let env = importFn E.initEnvironment
+
+--   envConstraintFns <- forConcurrently (getEnvConstraints env) \c -> do
+--     let (classMod, className) = toDbQualifer $ constraintClass c
+--     importClass' classMod classMod className
+
+--   pure $ foldl' (&) env envConstraintFns
+--   where
+--     -- importName :: P.ModuleName -> P.Name -> IO (E.Environment -> E.Environment)
+--     -- importName mName name = _ importRef mName $  getImportSrc mName name
+--     imports :: P.Imports
+--     imports = lookupImports modName exportEnv
+
+--     onImportMap ::
+--       ( P.Imports ->
+--         Map
+--           (P.Qualified a)
+--           [P.ImportRecord a]
+--       ) ->
+--       ( P.ImportRecord a ->
+--         IO (P.Environment -> P.Environment)
+--       ) ->
+--       IO (P.Environment -> P.Environment)
+--     onImportMap getImports fn =
+--       pipe <$> forConcurrently (Map.toList $ getImports imports) \(_, recs) ->
+--         pipe <$> forConcurrently recs fn'
+--       where
+--         fn' ir = if P.importSourceModule ir == modName then pure identity else fn ir
+
+--     -- importValue :: P.ModuleName -> P.Qualified P.Ident -> IO (E.Environment -> E.Environment)
+--     -- importValue mName = \case
+--     --   P.Qualified _ ident -> do
+--     --     let qual = P.Qualified (P.ByModuleName mName) ident
+--     --     val <- selectEnvValue conn qual
+--     --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     --   where
+--     --     exports = lookupExports mName exportEnv
+
+--     importClass modName' qual className = do
+--       typeClass <- fromJust <$> selectTypeClass conn modName' className
+--       let dictName = P.Qualified (P.ByModuleName modName') . P.dictTypeName . coerceProperName $ className
+--           typeQual = P.Qualified (P.ByModuleName modName') $ coerceProperName className
+--       type' <- selectType conn typeQual
+--       dictVal <- selectType conn dictName
+
+--       let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
+--           ctrMb =
+--             P.Qualified (P.ByModuleName modName') <$> case dictVal of
+--               Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
+--               _ -> Nothing
+
+--       ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
+--       instances <- selectClassInstancesByClassName conn $ P.Qualified (P.ByModuleName modName') className
+
+--       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
+--         P.Qualified (P.ByModuleName superModName) superClassName -> do
+--           -- TODO add check for existing class in env
+--           importClass superModName (P.Qualified (P.ByModuleName superModName) superClassName) superClassName
+--         _ -> pure identity
+
+--       pure $
+--         pipe superClassImports
+--           >>> \env' ->
+--             env'
+--               { E.typeClasses =
+--                   E.typeClasses env'
+--                     <> Map.fromList
+--                       [ (qual, typeClass),
+--                         (P.Qualified (P.ByModuleName modName') className, typeClass)
+--                       ],
+--                 E.types =
+--                   E.types env'
+--                     <> Map.fromList
+--                       ( [ (typeQual, fromJust type')
+--                         ]
+--                           <> case dictVal of
+--                             Just val -> [(dictName, val)]
+--                             _ -> []
+--                       ),
+--                 E.dataConstructors =
+--                   E.dataConstructors env' <> Map.fromList case (ctrMb, ctrData) of
+--                     (Just ctr', Just ctrData') -> [(ctr', ctrData')]
+--                     _ -> [],
+--                 E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
+--               }
+--     importName :: P.ModuleName -> P.Qualified P.Name -> IO (E.Environment -> E.Environment)
+--     importName mName (P.Qualified (P.ByModuleName _) name) = do
+--       -- when (modName' /= mName) do
+--       --   putErrText $ "importName called with different module names: " <> show modName' <> " and " <> show mName
+--       --   putErrText $ "name: " <> show name
+--       case name of
+--         P.IdentName ident -> do
+--           let P.ExportSource {..} = fromJustWithErr (mName, ident) $ Map.lookup ident (P.exportedValues exports)
+--               qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ident
+--           val <- selectEnvValue conn qual
+--           let importedModuleName = getImportedModule mName ident $ P.importedValues imports
+--           pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ident, fromJustWithErr ident val)]}
+--         P.ValOpName opName -> do
+--           let P.ExportSource {..} = fromJustWithErr (mName, opName) $ Map.lookup opName (P.exportedValueOps exports)
+--           (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn exportSourceDefinedIn opName
+--           if isUpper $ T.head alias
+--             then do
+--               let ctrName = P.ProperName alias
+--                   qual = P.Qualified (P.ByModuleName aliasModName) ctrName
+--               val <- selectDataConstructor conn qual
+--               pure $ \env' ->
+--                 env'
+--                   { E.dataConstructors =
+--                       E.dataConstructors env'
+--                         <> Map.fromList [(qual, fromJustWithErr qual val)]
+--                   }
+--             else do
+--               let ident = P.Ident alias
+--                   qual = P.Qualified (P.ByModuleName aliasModName) ident
+--               val <- selectEnvValue conn qual
+--               pure $ \env' ->
+--                 env'
+--                   { E.names =
+--                       E.names env'
+--                         <> Map.fromList [(qual, fromJustWithErr qual val)]
+--                   }
+--         P.TyName tyName -> do
+--           let (_, P.ExportSource {..}) = fromJust $ Map.lookup tyName (P.exportedTypes exports)
+--           let qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) tyName
+--           type' <- selectType conn qual
+--           ctrVals <- selectTypeDataConstructors conn qual
+--           let importedModuleName = getImportedModule mName tyName $ P.importedTypes imports
+--           pure $ \env' ->
+--             env'
+--               { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) tyName, fromJust type')],
+--                 E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+--               }
+--         P.TyOpName opName -> do
+--           let P.ExportSource {..} = fromJust $ Map.lookup opName (P.exportedTypeOps exports)
+--           (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectTypeOperatorAlias conn exportSourceDefinedIn opName
+--           let qual = P.Qualified (P.ByModuleName aliasModName) alias
+--           val <- selectType conn qual
+--           let importedModuleName = getImportedModule mName alias $ P.importedTypes imports
+--           pure $ \env' ->
+--             env'
+--               { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) alias, fromJustWithErr qual val)]
+--               }
+--         P.TyClassName className -> do
+--           let P.ExportSource {..} = fromJust $ Map.lookup className (P.exportedTypeClasses exports)
+--           importClass' mName exportSourceDefinedIn className
+--         P.DctorName ctrName -> do
+--           let containsCtr (_, (ctrs, _)) = ctrName `elem` ctrs
+--               (_, (_, P.ExportSource {..})) = fromJust $ find containsCtr $ Map.toList $ P.exportedTypes exports -- Map.find ctrName (P.exportedDataConstructors exports)
+--               qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ctrName
+--           val <- selectDataConstructor conn qual
+--           let importedModuleName = getImportedModule mName ctrName $ P.importedDataConstructors imports
+--           pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ctrName, fromJustWithErr ctrName val)]}
+--         P.ModName _ -> internalError "importName called with ModName"
+--       where
+--         exports :: P.Exports
+--         exports = lookupExports mName exportEnv
+--     importName _ _ = pure identity
+
+--     getImportedModule ::
+--       (Ord a) =>
+--       (Foldable f) =>
+--       P.ModuleName ->
+--       a ->
+--       Map (P.Qualified a) (f (P.ImportRecord a)) ->
+--       P.ModuleName
+--     getImportedModule mName ident imports' = fromMaybe mName do
+--       importRecs <- Map.lookup (P.Qualified (P.ByModuleName mName) ident) imports'
+--       importRec <- head importRecs
+--       pure $ P.importSourceModule importRec
+--     -- imports :: P.Imports
+--     -- imports = lookupImports mName exportEnv
+
+--     -- case
+--     -- P.IdentName ident -> do
+--     --   let qual = P.Qualified (P.ByModuleName mName) ident
+--     --   val <- selectEnvValue conn qual
+--     --   pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     -- P.ValOpName opName -> do
+--     --   (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn mName opName
+--     --   if isUpper $ T.head alias
+--     --     then do
+--     --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
+--     --       val <- selectDataConstructor conn qual
+--     --       pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     --     else do
+--     --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
+--     --       val <- selectEnvValue conn qual
+--     --       pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     -- P.TyName tyName -> do
+--     --   let qual = P.Qualified (P.ByModuleName mName) tyName
+--     --   type' <- selectType conn qual
+--     --   ctrVals <- selectTypeDataConstructors conn qual
+--     --   pure $ \env' ->
+--     --     env'
+--     --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual type')],
+--     --         E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+--     --       }
+
+--     -- P.TyOpName opName -> do
+--     --   (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
+--     --   let qual = P.Qualified (P.ByModuleName aliasModName) alias
+--     --   val <- selectType conn qual
+--     --   pure $ \env' ->
+--     --     env'
+--     --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
+--     --       }
+
+--     -- P.DctorName dctorName -> do
+--     --   let qual = P.Qualified (P.ByModuleName mName) dctorName
+--     --   val <- selectDataConstructor conn qual
+--     --   pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     -- P.TyClassName className -> do
+--     --   importClass' mName className
+--     -- P.ModName _ -> internalError "importName called with ModName"
+
+--     -- where
+--     --   exports = lookupExports mName exportEnv
+
+--     -- importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
+--     -- importRef mName = \case
+--     --   P.TypeClassRef _ className -> importClass' mName className
+--     --   P.TypeRef _ tyName ctrs -> do
+--     --     let qual = P.Qualified (P.ByModuleName mName) tyName
+--     --     type' <- selectType conn qual
+--     --     ctrVals <- case ctrs of
+--     --       Nothing -> selectTypeDataConstructors conn qual
+--     --       Just ctrs' -> forConcurrently ctrs' \ctr -> do
+--     --         let qual' = P.Qualified (P.ByModuleName mName) ctr
+--     --         val <- selectDataConstructor conn qual'
+--     --         pure (qual', fromJustWithErr qual' val)
+--     --     pure $ \env' ->
+--     --       env'
+--     --         { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
+--     --           E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
+--     --         }
+--     --   P.ValueRef _ ident -> do
+--     --     let qual = P.Qualified (P.ByModuleName mName) ident
+--     --     val <- selectEnvValue conn qual
+--     --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     --   P.TypeInstanceRef _ ident _ -> do
+--     --     let qual = P.Qualified (P.ByModuleName mName) ident
+--     --     val <- selectClassInstance conn qual
+--     --     pure $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap [fromJust val] (E.typeClassDictionaries env')}
+--     --   P.ModuleRef _ _ -> internalError "importRef called with ModuleRef"
+--     --   P.ReExportRef _ _ ref -> importRef mName ref
+--     --   P.ValueOpRef _ opName -> do
+--     --     (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
+--     --     if isUpper $ T.head alias
+--     --       then do
+--     --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
+--     --         val <- selectDataConstructor conn qual
+--     --         pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     --       else do
+--     --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
+--     --         val <- selectEnvValue conn qual
+--     --         pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
+--     --   P.TypeOpRef _ opName -> do
+--     --     (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
+--     --     let qual = P.Qualified (P.ByModuleName aliasModName) alias
+--     --     val <- selectType conn qual
+--     --     pure $ \env' ->
+--     --       env'
+--     --         { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
+--     --         }
+
+--     -- importModule mName = importModuleHiding mName []
+
+--     -- importModuleHiding mName hideRefs = do
+--     --   allRefs <- selectModuleExports conn mName
+--     --   let refs = filter (not . flip Set.member hiddenRefSet) allRefs
+--     --   importRefs mName refs
+--     --   where
+--     --     hiddenRefSet = Set.fromList hideRefs
+
+--     importClass' :: P.ModuleName -> P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
+--     importClass' mName _modDefinedIn className = do
+--       when (mName /= _modDefinedIn) do
+--         putErrText $ "importClass' called with different module names: " <> show mName <> " and " <> show _modDefinedIn
+--         putErrText $ "className: " <> show className
+
+--       let qual = P.Qualified (P.ByModuleName mName) className
+--           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
+--       type' <- selectType conn typeQual
+--       typeClass <- fromJust <$> selectTypeClass conn mName className
+--       let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
+--       dictVal <- selectType conn dictName
+
+--       let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
+--           ctrMb =
+--             P.Qualified (P.ByModuleName mName) <$> case dictVal of
+--               Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
+--               _ -> Nothing
+
+--       ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
+--       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
+--         P.Qualified (P.ByModuleName superModName) superClassName -> do
+--           importClass' superModName superModName superClassName
+--         _ -> pure identity
+
+--       instances <- selectClassInstancesByClassName conn qual
+
+--       pure $
+--         pipe superClassImports >>> \env' ->
+--           env'
+--             { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, typeClass)],
+--               E.types =
+--                 E.types env'
+--                   <> Map.fromList
+--                     ( [ (typeQual, fromJust type')
+--                       ]
+--                         <> case dictVal of
+--                           Just val -> [(dictName, val)]
+--                           _ -> []
+--                     ),
+--               E.dataConstructors =
+--                 E.dataConstructors env'
+--                   <> Map.fromList case (ctrMb, ctrData) of
+--                     (Just ctr', Just ctrData') -> [(ctr', ctrData')]
+--                     _ -> [],
+--               E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
+--             }
 
 selectModuleExports :: Connection -> P.ModuleName -> IO [P.DeclarationRef]
 selectModuleExports conn modName = do
@@ -723,6 +968,11 @@ selectTypeClass conn modName className =
         (modName, className)
         <&> (fmap SQL.fromOnly . head)
 
+selectTypeClass' :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
+selectTypeClass' conn = \case 
+   P.Qualified (P.ByModuleName modName) className -> selectTypeClass conn modName className
+   _ -> pure Nothing 
+
 selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
 selectModuleTypeClasses conn moduleName' = do
   SQL.query
@@ -731,16 +981,28 @@ selectModuleTypeClasses conn moduleName' = do
     (SQL.Only moduleName')
     <&> fmap (first (P.Qualified (P.ByModuleName moduleName')))
 
-selectClassInstance ::
+selectAllClassInstances :: 
+  Connection -> 
+  IO [NamedDict]
+selectAllClassInstances conn  = do
+  SQL.query_
+    conn
+    "SELECT dict FROM env_type_class_instances"
+    <&> (fmap (SQL.fromOnly >>> deserialise))
+
+selectClassInstances ::
   Connection ->
-  P.Qualified P.Ident ->
-  IO (Maybe NamedDict)
-selectClassInstance conn ident = do
+  P.Qualified (P.ProperName 'P.ClassName) ->
+  [P.Type ()] ->
+  IO [NamedDict]
+selectClassInstances conn classNameQual types = do
   SQL.query
     conn
-    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?"
-    (toDbQualifer ident)
-    <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
+    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND class_name = ? AND types = ?"
+    (modName, className, A.encode types)
+    <&> (fmap (SQL.fromOnly >>> deserialise))
+  where
+    (modName, className) = toDbQualifer classNameQual
 
 selectModuleClassInstances :: Connection -> P.ModuleName -> IO [NamedDict]
 selectModuleClassInstances conn moduleName' = do
@@ -840,6 +1102,8 @@ typeConstraints = P.everythingOnTypes (<>) \case
 pipe :: [a -> a] -> a -> a
 pipe = foldl' (>>>) identity
 
+-- pipeSet = pipe . Set.toList
+
 updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c)
 updateConcurrently a b = do
   f <- a
@@ -849,4 +1113,103 @@ updateConcurrently a b = do
 -- updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c)
 -- updateConcurrently a b = do
 --   (f, g) <- concurrently a b
---   pure $ f >>> g
\ No newline at end of file
+--   pure $ f >>> g
+
+-- xx = [TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))]
+
+-- xx = [TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Type.Proxy")) (ProperName {runProperName = "Proxy"}))) (TypeVar    "a")]
+-- xx = [TypeConstructor    (Qualified (ByModuleName (ModuleName "Data.Unit")) (ProperName {runProperName = "Unit"}))]
+-- xx = [TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim.RowList")) (ProperName {runProperName = "Nil"})),TypeVar    "row",REmpty
+-- xx = [TypeApp    (TypeApp    (TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim.RowList")) (ProperName {runProperName = "Cons"}))) (TypeVar    "key")) (TypeVar    "focus")) (TypeVar    "rowlistTail"),TypeVar    "row",TypeVar    [TypeApp    (TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeVar    "a")) (TypeVar    "b")]
+-- xx = [TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (TypeVar    "row")]
+
+class GetEnv m where 
+  getName :: P.Qualified P.Ident -> m (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
+  getType :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe (P.SourceType, P.TypeKind))
+  getDataConstructor :: P.Qualified (P.ProperName 'P.ConstructorName) -> m (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
+  getTypeSynonym :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
+  getTypeClass :: P.Qualified (P.ProperName 'P.ClassName) -> m (Maybe P.TypeClassData)
+  getTypeClassDictionaries :: m [NamedDict]
+  getTypeClassDictionary :: P.Qualified (P.ProperName 'P.ClassName) -> m (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty P.NamedDict))
+
+
+instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where 
+  getName = lift . getName
+  getType = lift . getType
+  getDataConstructor = lift . getDataConstructor
+  getTypeSynonym = lift . getTypeSynonym
+  getTypeClass = lift . getTypeClass
+  getTypeClassDictionaries = lift getTypeClassDictionaries
+  getTypeClassDictionary = lift . getTypeClassDictionary
+
+instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where 
+  getName = lift . getName
+  getType = lift . getType
+  getDataConstructor = lift . getDataConstructor
+  getTypeSynonym = lift . getTypeSynonym
+  getTypeClass = lift . getTypeClass
+  getTypeClassDictionaries = lift getTypeClassDictionaries
+  getTypeClassDictionary = lift . getTypeClassDictionary
+instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where 
+  getName = lift . getName
+  getType = lift . getType
+  getDataConstructor = lift . getDataConstructor
+  getTypeSynonym = lift . getTypeSynonym
+  getTypeClass = lift . getTypeClass
+  getTypeClassDictionaries = lift getTypeClassDictionaries
+  getTypeClassDictionary = lift . getTypeClassDictionary
+
+newtype DbEnv m a = DbEnv (ReaderT Connection m a)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadError e, MonadWriter w, MonadTrans)
+
+instance MonadSupply m => MonadSupply (DbEnv m)
+
+
+runDbEnv :: Connection -> DbEnv m a -> m a
+runDbEnv conn (DbEnv m) = runReaderT m conn
+
+instance (MonadIO m) => GetEnv (DbEnv m) where
+  getName ident = DbEnv $ do
+    conn <- ask
+    liftIO $ selectEnvValue conn ident
+  getType ty = DbEnv $ do
+    conn <- ask
+    liftIO $ selectType conn ty
+  getDataConstructor ctr = DbEnv $ do
+    conn <- ask
+    liftIO $ selectDataConstructor conn ctr
+  getTypeSynonym syn = DbEnv $ do
+    conn <- ask
+    liftIO $ selectTypeSynonym conn syn
+  getTypeClass cls = DbEnv $ do
+    conn <- ask
+    liftIO $ selectTypeClass' conn cls
+  getTypeClassDictionaries = DbEnv $ do
+    conn <- ask
+    liftIO $ selectAllClassInstances conn
+
+
+  getTypeClassDictionary cls = DbEnv $ do
+    conn <- ask
+    liftIO $ key <$> selectClassInstancesByClassName conn cls
+    where 
+      key = Map.fromListWith (<>) . fmap (\d -> (P.tcdValue d, pure d))
+
+newtype WoGetEnv m a = WoGetEnv (m a)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadError e, MonadWriter w)
+
+runWoGetEnv :: WoGetEnv m a -> m a
+runWoGetEnv (WoGetEnv m) = m
+
+instance MonadSupply m => MonadSupply (WoGetEnv m) where 
+  fresh = WoGetEnv fresh
+  peek = WoGetEnv peek
+
+instance Monad m => GetEnv (WoGetEnv m) where 
+  getName _ = pure Nothing
+  getType _ = pure Nothing
+  getDataConstructor _ = pure Nothing
+  getTypeSynonym _ = pure Nothing
+  getTypeClass _ = pure Nothing
+  getTypeClassDictionaries = pure []
+  getTypeClassDictionary _ = pure Map.empty
\ No newline at end of file
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 730c1ef80a..5d024cafc1 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -6,6 +6,7 @@ module Language.PureScript.Sugar.BindingGroups
   ( createBindingGroups
   , createBindingGroupsModule
   , collapseBindingGroups
+  , usedIdents
   , usedTypeNames
   ) where
 
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index c2f0e22394..dbaa974963 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -48,6 +48,7 @@ import Language.PureScript.TypeChecker.Unify (varIfUnknown)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes)
 import Language.PureScript.Types qualified as P
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 addDataType
   :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
@@ -124,13 +125,13 @@ addTypeSynonym moduleName name args ty kind = do
                , typeSynonyms = M.insert qualName (args, ty) (typeSynonyms env) }
 
 valueIsNotDefined
-  :: (MonadState CheckState m, MonadError MultipleErrors m)
+  :: (MonadState CheckState m, MonadError MultipleErrors m, GetEnv m)
   => ModuleName
   -> Ident
   -> m ()
 valueIsNotDefined moduleName name = do
-  env <- getEnv
-  case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of
+  nameMb <- lookupName (Qualified (ByModuleName moduleName) name)
+  case nameMb of
     Just _ -> throwError . errorMessage $ RedefinedIdent name
     Nothing -> return ()
 
@@ -252,7 +253,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms
 --
 typeCheckAll
   :: forall m
-   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => ModuleName
   -> [Declaration]
   -> m [Declaration]
@@ -403,34 +404,32 @@ typeCheckAll moduleName = traverse go
       flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries ->
         guardWith (errorMessage (DuplicateInstance dictName ss)) $
           not (M.member qualifiedDictName dictionaries)
-      case M.lookup className (typeClasses env) of
-        Nothing -> internalError $ "typeCheckAll: Encountered unknown type class in instance declaration: " <> show moduleName <> ", " <> show className
-        Just typeClass -> do
-          checkInstanceArity dictName className typeClass tys
-          (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys)
-          tys'' <- traverse replaceAllTypeSynonyms tys'
-          zipWithM_ (checkTypeClassInstance typeClass) [0..] tys''
-          let nonOrphanModules = findNonOrphanModules className typeClass tys''
-          checkOrphanInstance dictName className tys'' nonOrphanModules
-          let chainId = Just ch
-          checkOverlappingInstance ss chainId dictName vars className typeClass tys'' nonOrphanModules
-          _ <- traverseTypeInstanceBody checkInstanceMembers body
-          deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps'
-          let 
-              srcType = srcInstanceType ss vars className tys''
-              dict =
-                TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $
-                  if isPlainIdent dictName then Nothing else Just srcType
-                  
-          addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict)
-          let 
-            kind = M.lookup (coerceProperName <$> className) (types env)
-
-          addIdeClassName (Just $ fromMaybe moduleName $ getQual className) ss
-            ( ProperName $ (("typeCheckAll: " <> T.pack (show tys'') <> " : ") <>) $ runProperName $ disqualify className) 
-            $ maybe P.srcTypeWildcard fst kind
-
-          return d
+      typeClass <- lookupTypeClassUnsafe className
+      checkInstanceArity dictName className typeClass tys
+      (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys)
+      tys'' <- traverse replaceAllTypeSynonyms tys'
+      zipWithM_ (checkTypeClassInstance typeClass) [0..] tys''
+      let nonOrphanModules = findNonOrphanModules className typeClass tys''
+      checkOrphanInstance dictName className tys'' nonOrphanModules
+      let chainId = Just ch
+      checkOverlappingInstance ss chainId dictName vars className typeClass tys'' nonOrphanModules
+      _ <- traverseTypeInstanceBody checkInstanceMembers body
+      deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps'
+      let 
+          srcType = srcInstanceType ss vars className tys''
+          dict =
+            TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $
+              if isPlainIdent dictName then Nothing else Just srcType
+              
+      addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict)
+      let 
+        kind = M.lookup (coerceProperName <$> className) (types env)
+
+      addIdeClassName (Just $ fromMaybe moduleName $ getQual className) ss
+        ( ProperName $ (("typeCheckAll: " <> T.pack (show tys'') <> " : ") <>) $ runProperName $ disqualify className) 
+        $ maybe P.srcTypeWildcard fst kind
+
+      return d
 
   checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m ()
   checkInstanceArity dictName className typeClass tys = do
@@ -598,7 +597,7 @@ checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
 --
 typeCheckModule
   :: forall m
-   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => M.Map ModuleName Exports
   -> Module
   -> m Module
diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs
index 8d5dcde9b6..57ce007594 100644
--- a/src/Language/PureScript/TypeChecker/Deriving.hs
+++ b/src/Language/PureScript/TypeChecker/Deriving.hs
@@ -24,14 +24,15 @@ import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>))
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError)
 import Language.PureScript.Label (Label(..))
-import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify)
+import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify)
 import Language.PureScript.PSString (PSString, mkString)
 import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames)
 import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts)
-import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule)
+import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule, lookupTypeClassOrThrow, lookupTypeClassMb, lookupTypeClassDictionariesForClass)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, SourceType, Type(..), completeBinderList, eqType, everythingOnTypes, replaceAllTypeVars, srcTypeVar, usedTypeVariables)
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 -- | Extract the name of the newtype appearing in the last type argument of
 -- a derived newtype instance.
@@ -48,6 +49,7 @@ extractNewtypeName mn
 deriveInstance
   :: forall m
    . MonadError MultipleErrors m
+  => GetEnv m
   => MonadState CheckState m
   => MonadSupply m
   => MonadWriter MultipleErrors m
@@ -57,13 +59,10 @@ deriveInstance
   -> m Expr
 deriveInstance instType className strategy = do
   mn <- unsafeCheckCurrentModule
-  env <- getEnv
   instUtc@UnwrappedTypeConstructor{ utcArgs = tys } <- maybe (internalCompilerError "invalid instance type") pure $ unwrapTypeConstructor instType
   let ctorName = coerceProperName <$> utcQTyCon instUtc
 
-  TypeClassData{..} <-
-    note (errorMessage . UnknownName $ fmap TyClassName className) $
-      className `M.lookup` typeClasses env
+  TypeClassData{..} <- lookupTypeClassOrThrow className
 
   case strategy of
     KnownClassStrategy -> let
@@ -111,6 +110,7 @@ deriveNewtypeInstance
    . MonadError MultipleErrors m
   => MonadState CheckState m
   => MonadWriter MultipleErrors m
+  => GetEnv m
   => Qualified (ProperName 'ClassName)
   -> [SourceType]
   -> UnwrappedTypeConstructor
@@ -151,11 +151,12 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs
 
     verifySuperclasses :: m ()
     verifySuperclasses = do
-      env <- getEnv
-      for_ (M.lookup className (typeClasses env)) $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } ->
+      typeClass <- lookupTypeClassMb className
+      for_ typeClass $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } ->
         for_ superclasses $ \Constraint{..} -> do
           let constraintClass' = qualify (internalError "verifySuperclasses: unknown class module") constraintClass
-          for_ (M.lookup constraintClass (typeClasses env)) $ \TypeClassData{ typeClassDependencies = deps } ->
+          conTypeClass <- lookupTypeClassMb constraintClass
+          for_ conTypeClass $ \TypeClassData{ typeClassDependencies = deps } ->
             -- We need to check whether the newtype is mentioned, because of classes like MonadWriter
             -- with its Monoid superclass constraint.
             when (not (null args) && any ((fst (last args) `elem`) . usedTypeVariables) constraintArgs) $ do
@@ -171,20 +172,23 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs
                   -- check, since the superclass might have multiple type arguments, so overlaps might still
                   -- be possible, so we warn again.
                   for_ (extractNewtypeName mn tys) $ \nm -> do
-                    unless (hasNewtypeSuperclassInstance constraintClass' nm (typeClassDictionaries env)) $
+                    consDicts <- lookupTypeClassDictionariesForClass (ByModuleName (fst constraintClass')) constraintClass
+                    newtypeDicts <- lookupTypeClassDictionariesForClass (ByModuleName (fst nm)) constraintClass
+                    unless (hasNewtypeSuperclassInstance constraintClass' nm (consDicts <> newtypeDicts)) $
                       tell . errorMessage $ MissingNewtypeSuperclassInstance constraintClass className tys
                 else tell . errorMessage $ UnverifiableSuperclassInstance constraintClass className tys
 
     -- Note that this check doesn't actually verify that the superclass is
     -- newtype-derived; see #3168. The whole verifySuperclasses feature
     -- is pretty sketchy, and could use a thorough review and probably rewrite.
-    hasNewtypeSuperclassInstance (suModule, suClass) nt@(newtypeModule, _) dicts =
-      let su = Qualified (ByModuleName suModule) suClass
+    hasNewtypeSuperclassInstance (suModule, _) nt@(newtypeModule, _) dicts =
+      let getDictNewtypeNames mn' = 
+            toList . extractNewtypeName mn' . tcdInstanceTypes
+              <=< foldMap toList . M.elems
           lookIn mn'
             = elem nt
-            . (toList . extractNewtypeName mn' . tcdInstanceTypes
-                <=< foldMap toList . M.elems
-                <=< toList . (M.lookup su <=< M.lookup (ByModuleName mn')))
+            . (getDictNewtypeNames mn'
+                <=< toList . Just)
             $ dicts
       in lookIn suModule || lookIn newtypeModule
 
@@ -439,6 +443,7 @@ validateParamsInTypeConstructors
   :: forall c m
    . MonadError MultipleErrors m
   => MonadState CheckState m
+  => GetEnv m
   => Qualified (ProperName 'ClassName)
   -> UnwrappedTypeConstructor
   -> Bool
@@ -645,7 +650,7 @@ mkTraversal mn isBi te@TraversalExprs{..} getContraversalExprs (TraversalOps @_
 
 deriveFunctor
   :: forall m
-   . MonadError MultipleErrors m
+   . (MonadError MultipleErrors m, GetEnv m)
   => MonadState CheckState m
   => MonadSupply m
   => Maybe Bool -- does left parameter exist, and is it contravariant?
@@ -691,7 +696,7 @@ applyWhen cond f = if cond then f else identity
 
 deriveFoldable
   :: forall m
-   . MonadError MultipleErrors m
+   . (MonadError MultipleErrors m, GetEnv m)
   => MonadState CheckState m
   => MonadSupply m
   => Bool -- is there a left parameter (are we deriving Bifoldable)?
@@ -788,7 +793,7 @@ foldMapOps = TraversalOps { visitExpr = toConst, .. }
 
 deriveTraversable
   :: forall m
-   . MonadError MultipleErrors m
+   . (MonadError MultipleErrors m, GetEnv m)
   => MonadState CheckState m
   => MonadSupply m
   => Bool -- is there a left parameter (are we deriving Bitraversable)?
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index f7a5f85a69..71842f84a3 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -44,7 +44,7 @@ import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName
 import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds)
 import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation)
 import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds')
-import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint, lookupTypeClassMb)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, substituteType, unifyTypes)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..), superclassName)
@@ -53,6 +53,7 @@ import Language.PureScript.Label (Label(..))
 import Language.PureScript.PSString (PSString, mkString, decodeString)
 import Language.PureScript.Constants.Libs qualified as C
 import Language.PureScript.Constants.Prim qualified as C
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 -- | Describes what sort of dictionary to generate for type class instances
 data Evidence
@@ -113,7 +114,7 @@ combineContexts = M.unionWith (M.unionWith (M.unionWith (<>)))
 -- | Replace type class dictionary placeholders with inferred type class dictionaries
 replaceTypeClassDictionaries
   :: forall m
-   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m, GetEnv m)
   => Bool
   -> Expr
   -> m (Expr, [(Ident, InstanceContext, SourceConstraint)])
@@ -181,7 +182,7 @@ instance Monoid t => Monoid (Matched t) where
 -- return a type class dictionary reference.
 entails
   :: forall m
-   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m)
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m, GetEnv m)
   => SolverOptions
   -- ^ Solver options
   -> SourceConstraint
@@ -196,32 +197,32 @@ entails SolverOptions{..} constraint context hints =
   where
     forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict]
     forClassNameM env ctx cn@C.Coercible kinds args =
-      fromMaybe (forClassName env ctx cn kinds args) <$>
+      fromMaybe (forClassName  ctx cn kinds args) <$>
         solveCoercible env ctx kinds args
-    forClassNameM env ctx cn kinds args =
-      pure $ forClassName env ctx cn kinds args
+    forClassNameM _env ctx cn kinds args =
+      pure $ forClassName ctx cn kinds args
 
-    forClassName :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> [TypeClassDict]
-    forClassName _ ctx cn@C.Warn _ [msg] =
+    forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> [TypeClassDict]
+    forClassName  ctx cn@C.Warn _ [msg] =
       -- Prefer a warning dictionary in scope if there is one available.
       -- This allows us to defer a warning by propagating the constraint.
       findDicts ctx cn ByNullSourcePos ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing Nothing]
-    forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts
-    forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts
-    forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts
-    forClassName _ _ C.SymbolCons _ args | Just dicts <- solveSymbolCons args = dicts
-    forClassName _ _ C.IntAdd _ args | Just dicts <- solveIntAdd args = dicts
-    forClassName _ ctx C.IntCompare _ args | Just dicts <- solveIntCompare ctx args = dicts
-    forClassName _ _ C.IntMul _ args | Just dicts <- solveIntMul args = dicts
-    forClassName _ _ C.IntToString _ args | Just dicts <- solveIntToString args = dicts
-    forClassName _ _ C.Reflectable _ args | Just dicts <- solveReflectable args = dicts
-    forClassName _ _ C.RowUnion kinds args | Just dicts <- solveUnion kinds args = dicts
-    forClassName _ _ C.RowNub kinds args | Just dicts <- solveNub kinds args = dicts
-    forClassName _ _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts
-    forClassName _ _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts
-    forClassName _ _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts
-    forClassName _ ctx cn@(Qualified (ByModuleName mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys)))
-    forClassName _ _ _ _ _ = internalError "forClassName: expected qualified class name"
+    forClassName _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts
+    forClassName _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts
+    forClassName _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts
+    forClassName _ C.SymbolCons _ args | Just dicts <- solveSymbolCons args = dicts
+    forClassName _ C.IntAdd _ args | Just dicts <- solveIntAdd args = dicts
+    forClassName  ctx C.IntCompare _ args | Just dicts <- solveIntCompare ctx args = dicts
+    forClassName _ C.IntMul _ args | Just dicts <- solveIntMul args = dicts
+    forClassName _ C.IntToString _ args | Just dicts <- solveIntToString args = dicts
+    forClassName _ C.Reflectable _ args | Just dicts <- solveReflectable args = dicts
+    forClassName _ C.RowUnion kinds args | Just dicts <- solveUnion kinds args = dicts
+    forClassName _ C.RowNub kinds args | Just dicts <- solveNub kinds args = dicts
+    forClassName _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts
+    forClassName _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts
+    forClassName _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts
+    forClassName  ctx cn@(Qualified (ByModuleName mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys)))
+    forClassName _ _ _ _ = internalError "forClassName: expected qualified class name"
 
     ctorModules :: SourceType -> Maybe ModuleName
     ctorModules (TypeConstructor _ (Qualified (ByModuleName mn) _)) = Just mn
@@ -250,15 +251,15 @@ entails SolverOptions{..} constraint context hints =
             inferred <- lift get
             -- We need information about functional dependencies, so we have to look up the class
             -- name in the environment:
+            typeClass <- lift . lift $ lookupTypeClassMb className'
             env <- lift . lift $ gets checkEnv
-            let classesInScope = typeClasses env
             TypeClassData
               { typeClassArguments
               , typeClassDependencies
               , typeClassIsEmpty
               , typeClassCoveringSets
               , typeClassMembers 
-              } <- case M.lookup className' classesInScope of
+              } <- case typeClass of
                 Nothing -> throwError . errorMessage $ UnknownClass className'
                 Just tcd -> pure tcd
 
diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
index 8abaac31ca..491e75d565 100644
--- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
@@ -47,6 +47,7 @@ import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind,
 import Language.PureScript.Roles (Role(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes)
 import Language.PureScript.Constants.Prim qualified as Prim
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 -- | State of the given constraints solver.
 data GivenSolverState =
@@ -118,7 +119,7 @@ initialGivenSolverState =
 -- 3c. Otherwise canonicalization can succeed with derived constraints which we
 -- add to the unsolved queue and then go back to 1.
 solveGivens
-  :: MonadError MultipleErrors m
+  :: (MonadError MultipleErrors m, GetEnv m)
   => MonadState CheckState m
   => Environment
   -> StateT GivenSolverState m ()
@@ -206,7 +207,7 @@ initialWantedSolverState givens a b =
 -- interact the latter with the former, we would report an insoluble
 -- @Coercible Boolean Char@.
 solveWanteds
-  :: MonadError MultipleErrors m
+  :: (MonadError MultipleErrors m, GetEnv m)
   => MonadWriter [ErrorMessageHint] m
   => MonadState CheckState m
   => Environment
@@ -271,7 +272,7 @@ solveWanteds env = go (0 :: Int) where
 -- @Coercible (D \@k) (D \@k)@ constraint which could be trivially solved by
 -- reflexivity instead of having to saturate the type constructors.
 unify
-  :: MonadError MultipleErrors m
+  :: (MonadError MultipleErrors m, GetEnv m)
   => MonadState CheckState m
   => (SourceType, SourceType)
   -> m (SourceType, SourceType, SourceType)
@@ -478,7 +479,7 @@ data Canonicalized
 -- | Canonicalization takes a wanted constraint and try to reduce it to a set of
 -- simpler constraints whose satisfaction will imply the goal.
 canon
-  :: MonadError MultipleErrors m
+  :: (MonadError MultipleErrors m, GetEnv m)
   => MonadWriter [ErrorMessageHint] m
   => MonadState CheckState m
   => Environment
@@ -578,7 +579,7 @@ canonUnsaturatedHigherKindedType env a b
 -- yield a constraint @Coercible r s@ and constraints on the types for each
 -- label in both rows. Labels exclusive to one row yield a failure.
 canonRow
-  :: MonadError MultipleErrors m
+  :: (MonadError MultipleErrors m, GetEnv  m)
   => MonadState CheckState m
   => SourceType
   -> SourceType
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index ed88dc1975..2292c0cf48 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -52,11 +52,12 @@ import Language.PureScript.Crash (HasCallStack, internalError)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Errors
 import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified)
-import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, addIdeType, addIdeTypeNameQual, addIdeClassNameQual)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, addIdeType, addIdeTypeNameQual, lookupType, lookupTypeMb)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.Types
 import Language.PureScript.Pretty.Types (prettyPrintType)
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType
 generalizeUnknowns unks ty =
@@ -155,7 +156,7 @@ unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join)
     pure $ (lvl, (u, ty)) : rest
 
 inferKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> m (SourceType, SourceType)
 inferKind = \tyToInfer ->
@@ -169,27 +170,25 @@ inferKind = \tyToInfer ->
     pure (ty, kind)
   go = \case
     ty@(TypeConstructor ann v) -> do
-      env <- getEnv
-      case M.lookup v (E.types env) of
-        Nothing ->
-          throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
-        Just (kind, E.LocalTypeVariable) -> do
+      k <- lookupType (fst ann) v
+      case k of
+        (kind, E.LocalTypeVariable) -> do
           kind' <- apply kind
           addIdeTypeNameQual (fst ann) v (kind' $> ann)
           pure (ty, kind' $> ann)
-        Just (kind, _) -> do
-          let className = coerceProperName <$> v
-          case M.lookup className (E.typeClasses env) of 
-            Just _ -> addIdeClassNameQual (fst ann) className (kind $> ann)
-            Nothing -> addIdeTypeNameQual (fst ann) v (kind $> ann)
+        (kind, _) -> do
+          -- let className = coerceProperName <$> v
+          -- case M.lookup className (E.typeClasses env) of 
+          --   Just _ -> addIdeClassNameQual (fst ann) className (kind $> ann)
+          --   Nothing -> addIdeTypeNameQual (fst ann) v (kind $> ann)
           pure (ty, kind $> ann)
     ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do
-      env <- getEnv
-      con' <- case M.lookup (coerceProperName <$> v) (E.types env) of
-        Nothing ->
-          throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v
-        Just _ ->
+      kindMb <- lookupTypeMb (coerceProperName <$> v)
+      con' <- case kindMb of 
+        Just _ -> do
           checkConstraint con
+        Nothing ->
+            throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v
       ty' <- checkIsSaturatedType ty
       con'' <- applyConstraint con'
       let kind = E.kindType $> ann'
@@ -253,7 +252,7 @@ inferKind = \tyToInfer ->
       internalError $ "inferKind: Unimplemented case \n" <> prettyPrintType 100 ty
 
 inferAppKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceAnn
   -> (SourceType, SourceType)
   -> SourceType
@@ -286,7 +285,7 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of
     _ -> pure True
 
 cannotApplyTypeToType
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> SourceType
   -> m a
@@ -296,7 +295,7 @@ cannotApplyTypeToType fn arg = do
   internalCompilerError . T.pack $ "Cannot apply type to type: " <> debugType (srcTypeApp fn arg)
 
 cannotApplyKindToType
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> SourceType
   -> m a
@@ -307,7 +306,7 @@ cannotApplyKindToType poly arg = do
   internalCompilerError . T.pack $ "Cannot apply kind to type: " <> debugType (srcKindApp poly arg)
 
 checkKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> SourceType
   -> m SourceType
@@ -321,13 +320,13 @@ checkKind = checkKind' False
 -- error.
 --
 checkIsSaturatedType
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> m SourceType
 checkIsSaturatedType ty = checkKind' True ty E.kindType
 
 checkKind'
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => Bool
   -> SourceType
   -> SourceType
@@ -342,7 +341,7 @@ checkKind' requireSynonymsToExpand ty kind2 = do
         instantiateKind (ty', kind1') kind2'
 
 instantiateKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => (SourceType, SourceType)
   -> SourceType
   -> m SourceType
@@ -360,7 +359,7 @@ instantiateKind (ty, kind1) kind2 = case kind1 of
     _ -> False
 
 subsumesKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> SourceType
   -> m ()
@@ -391,7 +390,7 @@ subsumesKind = go
       unifyKinds a b
 
 unifyKinds
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> SourceType
   -> m ()
@@ -404,7 +403,7 @@ unifyKinds = unifyKindsWithFailure $ \w1 w2 ->
 -- | local position context. This is useful when invoking kind unification
 -- | outside of kind checker internals.
 unifyKinds'
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> SourceType
   -> m ()
@@ -415,7 +414,7 @@ unifyKinds' = unifyKindsWithFailure $ \w1 w2 ->
 
 -- | Check the kind of a type, failing if it is not of kind *.
 checkTypeKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> SourceType
   -> m ()
@@ -423,7 +422,7 @@ checkTypeKind ty kind =
   unifyKindsWithFailure (\_ _ -> throwError . errorMessage $ ExpectedType ty kind) kind E.kindType
 
 unifyKindsWithFailure
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => (SourceType -> SourceType -> m ())
   -> SourceType
   -> SourceType
@@ -475,7 +474,7 @@ unifyKindsWithFailure onFailure = go
       onFailure (rowFromList w1) (rowFromList w2)
 
 solveUnknown
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => Unknown
   -> SourceType
   -> m ()
@@ -523,7 +522,7 @@ promoteKind u2 ty = do
       pure ty'
 
 elaborateKind
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> m SourceType
 elaborateKind = \case
@@ -532,12 +531,8 @@ elaborateKind = \case
   TypeLevelInt ann _ ->
     pure $ E.tyInt $> ann
   TypeConstructor ann v -> do
-    env <- getEnv
-    case M.lookup v (E.types env) of
-      Nothing ->
-        throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v
-      Just (kind, _) ->
-        ($> ann) <$> apply kind
+    (kind, _) <- lookupType (fst ann) v
+    ($> ann) <$> apply kind
   TypeVar ann a -> do
     moduleName <- unsafeCheckCurrentModule
     kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName a)
@@ -599,7 +594,7 @@ checkEscapedSkolems ty =
     errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty'
 
 kindOfWithUnknowns
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> m (([(Unknown, SourceType)], SourceType), SourceType)
 kindOfWithUnknowns ty = do
@@ -609,14 +604,14 @@ kindOfWithUnknowns ty = do
 
 -- | Infer the kind of a single type
 kindOf
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> m (SourceType, SourceType)
 kindOf = fmap (first snd) . kindOfWithScopedVars
 
 -- | Infer the kind of a single type, returning the kinds of any scoped type variables
 kindOfWithScopedVars
-  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m)
   => SourceType
   -> m (([(Text, SourceType)], SourceType), SourceType)
 kindOfWithScopedVars ty = do
@@ -640,7 +635,7 @@ type DataDeclarationResult =
   )
 
 kindOfData
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> DataDeclarationArgs
   -> m DataDeclarationResult
@@ -648,7 +643,7 @@ kindOfData moduleName dataDecl =
   head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] []
 
 inferDataDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> DataDeclarationArgs
   -> m [(DataConstructorDeclaration, SourceType)]
@@ -668,7 +663,7 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do
         fmap (fmap (addVisibility visibility . mkForAll ctorBinders)) . inferDataConstructor tyCtor'
 
 inferDataConstructor
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => SourceType
   -> DataConstructorDeclaration
   -> m (DataConstructorDeclaration, SourceType)
@@ -692,7 +687,7 @@ type TypeDeclarationResult =
   )
 
 kindOfTypeSynonym
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> TypeDeclarationArgs
   -> m TypeDeclarationResult
@@ -700,7 +695,7 @@ kindOfTypeSynonym moduleName typeDecl =
   head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] []
 
 inferTypeSynonym
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> TypeDeclarationArgs
   -> m SourceType
@@ -809,7 +804,7 @@ type ClassDeclarationResult =
   )
 
 kindOfClass
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> ClassDeclarationArgs
   -> m ClassDeclarationResult
@@ -817,7 +812,7 @@ kindOfClass moduleName clsDecl =
   head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl]
 
 inferClassDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> ClassDeclarationArgs
   -> m ([(Text, SourceType)], [SourceConstraint], [Declaration])
@@ -833,7 +828,7 @@ inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) =
         <*> for decls checkClassMemberDeclaration
 
 checkClassMemberDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => Declaration
   -> m Declaration
 checkClassMemberDeclaration = \case
@@ -858,7 +853,7 @@ mapTypeDeclaration f = \case
     other
 
 checkConstraint
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => SourceConstraint
   -> m SourceConstraint
 checkConstraint (Constraint ann clsName kinds args dat) = do
@@ -892,7 +887,7 @@ type InstanceDeclarationResult =
   )
 
 checkInstanceDeclaration
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> InstanceDeclarationArgs
   -> m InstanceDeclarationResult
@@ -913,7 +908,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do
     pure (allConstraints, allKinds, allArgs, varKinds)
 
 checkKindDeclaration
-  :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> SourceType
   -> m SourceType
@@ -948,19 +943,19 @@ checkKindDeclaration _ ty = do
     other -> pure other
 
 existingSignatureOrFreshKind
-  :: forall m. MonadState CheckState m
+  :: forall m. (MonadState CheckState m, GetEnv m)
   => ModuleName
   -> SourceSpan
   -> ProperName 'TypeName
   -> m SourceType
 existingSignatureOrFreshKind moduleName ss name = do
-  env <- getEnv
-  case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of
+  tyMb <- lookupTypeMb (Qualified (ByModuleName moduleName) name)
+  case tyMb of
     Nothing -> freshKind ss
     Just (kind, _) -> pure kind
 
 kindsOfAll
-  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m)
+  :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModuleName
   -> [TypeDeclarationArgs]
   -> [DataDeclarationArgs]
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index bf21bb8f98..4917ee75bd 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -20,9 +20,9 @@ import Data.Text (Text, isPrefixOf, unpack)
 import Data.List.NonEmpty qualified as NEL
 
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..))
-import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition, DeclarationRef)
-import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName)
+import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), DataDeclType)
+import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition, DeclarationRef, errorMessage')
+import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, Name (TyClassName, TyName))
 import Language.PureScript.Pretty.Types (prettyPrintType)
 import Language.PureScript.Pretty.Values (prettyPrintValue)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
@@ -32,6 +32,8 @@ import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtif
 import Protolude (whenM, isJust)
 import Language.PureScript.AST.Binders (Binder)
 import Language.PureScript.AST.Declarations (Declaration, Expr (..))
+import Language.PureScript.Make.Index.Select (GetEnv (getName, getType, getTypeClass, getDataConstructor, getTypeClassDictionary))
+import Language.PureScript.Make.Index.Select qualified as Select
 
 newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown)
   deriving (Eq, Show)
@@ -227,12 +229,14 @@ typeClassDictionariesEnvMap entries =
         <- entries
     ]
 
-
 -- | Get the currently available map of type class dictionaries
 getTypeClassDictionaries
-  :: (MonadState CheckState m)
+  :: (MonadState CheckState m, GetEnv m)
   => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv
+getTypeClassDictionaries = do 
+  envDicts <- gets $ typeClassDictionaries . checkEnv
+  dbDicts <- Select.getTypeClassDictionaries 
+  pure $ addDictsToEnvMap dbDicts envDicts
 
 -- | Lookup type class dictionaries in a module.
 lookupTypeClassDictionaries
@@ -243,11 +247,16 @@ lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeCl
 
 -- | Lookup type class dictionaries in a module.
 lookupTypeClassDictionariesForClass
-  :: (MonadState CheckState m)
+  :: (MonadState CheckState m, GetEnv m)
   => QualifiedBy
   -> Qualified (ProperName 'ClassName)
   -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
-lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn
+lookupTypeClassDictionariesForClass mn cn = do
+  inDb <- getTypeClassDictionary cn
+  inEnv <- getInEnv
+  pure $ inDb <> inEnv
+  where 
+    getInEnv = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn
 
 -- | Temporarily bind a collection of names to local variables
 bindLocalVariables
@@ -284,31 +293,44 @@ preservingNames action = do
   modifyEnv $ \e -> e { names = orig }
   return a
 
+lookupName 
+  :: (MonadState CheckState m, GetEnv m)
+  => Qualified Ident 
+  -> m (Maybe (SourceType, NameKind, NameVisibility))
+lookupName qual = do
+  env <- getEnv
+  case M.lookup qual (names env) of
+    Nothing -> do 
+      getName qual
+    n -> return n
+
 -- | Lookup the type of a value by name in the @Environment@
 lookupVariable
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m)
   => Qualified Ident
   -> m SourceType
 lookupVariable qual = do
-  env <- getEnv
-  case M.lookup qual (names env) of
+  nameMb <- lookupName qual
+  case nameMb of
     Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
     Just (ty, _, _) -> return ty
+    
+
 
 -- | Lookup the visibility of a value by name in the @Environment@
 getVisibility
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m)
   => Qualified Ident
   -> m NameVisibility
 getVisibility qual = do
-  env <- getEnv
-  case M.lookup qual (names env) of
+  nameMb <- lookupName qual
+  case nameMb of
     Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual)
     Just (_, _, vis) -> return vis
 
 -- | Assert that a name is visible
 checkVisibility
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m)
   => Qualified Ident
   -> m ()
 checkVisibility name@(Qualified _ var) = do
@@ -317,22 +339,89 @@ checkVisibility name@(Qualified _ var) = do
     Undefined -> throwError . errorMessage $ CycleInDeclaration var
     _ -> return ()
 
+lookupTypeMb 
+  :: (MonadState CheckState m, GetEnv m)
+  => Qualified (ProperName 'TypeName) 
+  -> m (Maybe (SourceType, TypeKind))
+lookupTypeMb qual = do
+  env <- getEnv
+  case M.lookup qual (types env) of
+    Nothing -> do 
+      getType qual
+    ty -> return ty
+
+lookupType :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m) => SourceSpan -> Qualified (ProperName 'TypeName) -> m (SourceType, TypeKind)
+lookupType span' v = 
+  lookupTypeMb v >>= \case 
+    Nothing -> throwError . errorMessage' span' $ UnknownName $ fmap TyName v
+    Just ty -> return ty
+
 -- | Lookup the kind of a type by name in the @Environment@
 lookupTypeVariable
-  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m)
   => ModuleName
   -> Qualified (ProperName 'TypeName)
   -> m SourceType
 lookupTypeVariable currentModule (Qualified qb name) = do
   env <- getEnv
   case M.lookup (Qualified qb' name) (types env) of
-    Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
+    Nothing -> do 
+      ty <- getType (Qualified qb' name)
+      case ty of 
+        Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
+        Just (k, _) -> return k
     Just (k, _) -> return k
   where
   qb' = ByModuleName $ case qb of
     ByModuleName m -> m
     BySourcePos _ -> currentModule
 
+lookupConstructorMb 
+  :: (MonadState CheckState m, GetEnv m)
+  => Qualified (ProperName 'ConstructorName)
+  -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
+lookupConstructorMb name = do
+  env <- getEnv
+  case M.lookup name (dataConstructors env) of
+    Nothing -> do 
+      getDataConstructor name 
+    ctr -> return ctr
+
+lookupConstructorUnsafe 
+  :: ( MonadState CheckState m, GetEnv m)
+  => Qualified (ProperName 'ConstructorName)
+  -> m (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
+lookupConstructorUnsafe name = lookupConstructorMb name >>= \case 
+  Nothing -> internalError $ "lookupConstructorUnsafe: Encountered unknown constructor in: " <> show name
+  Just ctr -> return ctr
+
+lookupTypeClassMb 
+  :: (MonadState CheckState m, GetEnv m)
+  => Qualified (ProperName 'ClassName)
+  -> m (Maybe TypeClassData)
+lookupTypeClassMb name = do
+  env <- getEnv
+  case M.lookup name (typeClasses env) of
+    Nothing -> do 
+      getTypeClass name
+    tc -> return tc
+
+lookupTypeClassUnsafe 
+  :: (MonadState CheckState m, GetEnv m)
+  => Qualified (ProperName 'ClassName)
+  -> m TypeClassData
+lookupTypeClassUnsafe name = lookupTypeClassMb name >>= \case
+  Nothing -> internalError $ "lookupTypeClassUnsafe: Encountered unknown type class in: " <> show name
+  Just tc -> return tc
+  
+lookupTypeClassOrThrow 
+  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m)
+  => Qualified (ProperName 'ClassName)
+  -> m TypeClassData
+lookupTypeClassOrThrow name = lookupTypeClassMb name >>= \case
+  Nothing -> throwError . errorMessage $ UnknownName $ fmap TyClassName name
+  Just tc -> return tc
+
 -- | Get the current @Environment@
 getEnv :: (MonadState CheckState m) => m Environment
 getEnv = gets checkEnv
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 26da5e980f..6e60f3ac4f 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -24,6 +24,7 @@ import Language.PureScript.TypeChecker.Monad (CheckState, getHints, getTypeClass
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize)
 import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, unifyTypes)
 import Language.PureScript.Types (RowListItem(..), SourceType, Type(..), eqType, isREmpty, replaceTypeVars, rowFromList)
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 -- | Subsumption can operate in two modes:
 --
@@ -59,7 +60,7 @@ defaultCoercion SNoElaborate = ()
 
 -- | Check that one type subsumes another, rethrowing errors to provide a better error message
 subsumes
-  :: (MonadError MultipleErrors m, MonadState CheckState m)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => SourceType
   -> SourceType
   -> m (Expr -> Expr)
@@ -69,7 +70,7 @@ subsumes ty1 ty2 =
 
 -- | Check that one type subsumes another
 subsumes'
-  :: (MonadError MultipleErrors m, MonadState CheckState m)
+  :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m)
   => ModeSing mode
   -> SourceType
   -> SourceType
diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs
index 6158f48a82..4365201888 100644
--- a/src/Language/PureScript/TypeChecker/TypeSearch.hs
+++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs
@@ -22,6 +22,7 @@ import Language.PureScript.Pretty.Types            as P
 import Language.PureScript.TypeChecker.Skolems     as Skolem
 import Language.PureScript.TypeChecker.Synonyms    as P
 import Language.PureScript.Types                   as P
+import Language.PureScript.Make.Index.Select (runWoGetEnv)
 
 checkInEnvironment
   :: Environment
@@ -61,14 +62,14 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do
 
   let dummyExpression = P.Var nullSourceSpan (P.Qualified P.ByNullSourcePos (P.Ident "x"))
 
-  elab <- subsumes envT' userT'
+  elab <- runWoGetEnv $ subsumes envT' userT' -- TODO add DB
   subst <- gets TC.checkSubstitution
   let expP = P.overTypes (P.substituteType subst) (elab dummyExpression)
 
   -- Now check that any unsolved constraints have not become impossible
   (traverse_ . traverse_) (\(_, context, constraint) -> do
     let constraint' = P.mapConstraintArgs (map (P.substituteType subst)) constraint
-    flip evalStateT Map.empty . evalWriterT $
+    runWoGetEnv $ flip evalStateT Map.empty . evalWriterT $  -- TODO add DB
       Entailment.entails
         (Entailment.SolverOptions
           { solverShouldGeneralize = True
@@ -76,7 +77,7 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do
           }) constraint' context []) unsolved
 
   -- Finally, check any constraints which were found during elaboration
-  Entailment.replaceTypeClassDictionaries (isJust unsolved) expP
+  runWoGetEnv $ Entailment.replaceTypeClassDictionaries (isJust unsolved) expP -- TODO add DB
 
 accessorSearch
   :: Maybe [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)]
@@ -96,7 +97,7 @@ accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment e
   rowType <- freshTypeWithKind (P.kindRow P.kindType)
   resultType <- freshTypeWithKind P.kindType
   let recordFunction = srcTypeApp (srcTypeApp tyFunction (srcTypeApp tyRecord rowType)) resultType
-  _ <- subsumes recordFunction userT'
+  _ <- runWoGetEnv $ subsumes recordFunction userT' -- TODO add DB
   subst <- gets TC.checkSubstitution
   let solvedRow = toRowPair <$> fst (rowToList (substituteType subst rowType))
   tcS <- get
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index f59ba189ad..01c0a8dbd7 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -64,6 +64,7 @@ import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, replaceTypeWild
 import Language.PureScript.Types
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.PSString (PSString)
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 data BindingGroupType
   = RecursiveBindingGroup
@@ -86,7 +87,7 @@ lookupTypeClass name =
 -- | Infer the types of multiple mutually-recursive values, and return elaborated values including
 -- type class dictionaries and type annotations.
 typesOf
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => BindingGroupType
   -> ModuleName
   -> [((SourceAnn, Ident), Expr)]
@@ -265,7 +266,7 @@ data SplitBindingGroup = SplitBindingGroup
 -- This function also generates fresh unification variables for the types of
 -- declarations without type annotations, returned in the 'UntypedData' structure.
 typeDictionaryForBindingGroup
-  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Maybe ModuleName
   -> [((SourceAnn, Ident), Expr)]
   -> m SplitBindingGroup
@@ -302,7 +303,7 @@ typeDictionaryForBindingGroup moduleName vals = do
 
 -- | Check the type annotation of a typed value in a binding group.
 checkTypedBindingGroupElement
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => ModuleName
   -> ((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool))
   -- ^ The identifier we are trying to define, along with the expression and its type annotation
@@ -321,7 +322,7 @@ checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do
 
 -- | Infer a type for a value in a binding group which lacks an annotation.
 typeForBindingGroupElement
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => ((SourceAnn, Ident), (Expr, SourceType))
   -- ^ The identifier we are trying to define, along with the expression and its assigned type
   -- (at this point, this should be a unification variable)
@@ -341,7 +342,7 @@ typeForBindingGroupElement (ident, (val, ty)) dict = do
 -- This is necessary during type checking to avoid unifying a polymorphic type with a
 -- unification variable.
 instantiatePolyTypeWithUnknowns
-  :: (MonadState CheckState m, MonadError MultipleErrors m)
+  :: (MonadState CheckState m, MonadError MultipleErrors m, GetEnv m)
   => Expr
   -> SourceType
   -> m (Expr, SourceType)
@@ -366,7 +367,7 @@ instantiatePolyTypeWithUnknownsUntilVisible val (ForAll _ TypeVarInvisible ident
   instantiatePolyTypeWithUnknownsUntilVisible val $ replaceTypeVars ident u ty
 instantiatePolyTypeWithUnknownsUntilVisible val ty = return (val, ty)
 
-instantiateConstraint :: MonadState CheckState m => Expr -> Type SourceAnn -> m (Expr, Type SourceAnn)
+instantiateConstraint :: (MonadState CheckState m, GetEnv m) => Expr -> Type SourceAnn -> m (Expr, Type SourceAnn)
 instantiateConstraint val (ConstrainedType _ con ty) = do
   dicts <- getTypeClassDictionaries
   hints <- getHints
@@ -381,13 +382,13 @@ insertUnkName' _ _ = internalCompilerError "type is not TUnknown"
 -- | Infer a type for a value, rethrowing any error to provide a more useful error message
 -- | and add the inferred type to the IDE artifacts if necessary.
 infer
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -> m TypedValue'
 infer val = withErrorMessageHint (ErrorInferringType val) $ inferAndAddToIde val
 
 
-inferAndAddToIde  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+inferAndAddToIde  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -> m TypedValue'
 inferAndAddToIde = infer' >=> addTypedValueToIde
@@ -400,7 +401,7 @@ addTypedValueToIde tv@(TypedValue' _ expr ty) = do
 -- | Infer a type for a value
 infer'
   :: forall m
-   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -> m TypedValue'
 infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue' True v tyInt
@@ -521,8 +522,8 @@ infer' (Var ss var) = do
       return $ TypedValue' True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty'
     _ -> return $ TypedValue' True (Var ss var) ty
 infer' v@(Constructor _ c) = do
-  env <- getEnv
-  case M.lookup c (dataConstructors env) of
+  ctrMb <- lookupConstructorMb c
+  case ctrMb of
     Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c
     Just (_, _, ty, _) -> TypedValue' True v <$> (introduceSkolemScope <=< replaceAllTypeSynonyms $ ty)
 infer' (Case vals binders) = do
@@ -572,7 +573,7 @@ inferProperties
   :: ( MonadSupply m
      , MonadState CheckState m
      , MonadError MultipleErrors m
-     , MonadWriter MultipleErrors m
+     , MonadWriter MultipleErrors m, GetEnv m
      )
   => [(PSString, Expr)]
   -> m [(PSString, (Expr, SourceType))]
@@ -584,7 +585,7 @@ inferWithinRecord
   :: ( MonadSupply m
      , MonadState CheckState m
      , MonadError MultipleErrors m
-     , MonadWriter MultipleErrors m
+     , MonadWriter MultipleErrors m, GetEnv m
      )
   => Expr
   -> m (Expr, SourceType)
@@ -606,7 +607,7 @@ propertyShouldInstantiate = \case
   _ -> False
 
 inferLetBinding
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => [Declaration]
   -> [Declaration]
   -> Expr
@@ -648,7 +649,7 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
 
 inferBinder 
   :: forall m
-   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => SourceType
   -> Binder
   -> m (M.Map Ident (SourceSpan, SourceType))
@@ -662,7 +663,7 @@ inferBinder val binder = do
 -- | Infer the types of variables brought into scope by a binder
 inferBinder'
   :: forall m
-   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => SourceType
   -> Binder
   -> m (M.Map Ident (SourceSpan, SourceType))
@@ -674,8 +675,8 @@ inferBinder' val (LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val t
 inferBinder' val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty
 inferBinder' val (VarBinder ss name) = return $ M.singleton name (ss, val)
 inferBinder' val (ConstructorBinder ss ctor binders) = do
-  env <- getEnv
-  case M.lookup ctor (dataConstructors env) of
+  ctrMb <-  lookupConstructorMb ctor
+  case ctrMb of
     Just (_, _, ty, _) -> do
       (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty
       fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
@@ -742,7 +743,7 @@ binderRequiresMonotype _ = True
 
 -- | Instantiate polytypes only when necessitated by a binder.
 instantiateForBinders
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => [Expr]
   -> [CaseAlternative]
   -> m ([Expr], [SourceType])
@@ -759,7 +760,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
 -- Check the types of the return values in a set of binders in a case statement
 --
 checkBinders
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => [SourceType]
   -> SourceType
   -> [CaseAlternative]
@@ -775,7 +776,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
   return $ r : rs
 
 checkGuardedRhs
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => GuardedExpr
   -> SourceType
   -> m GuardedExpr
@@ -799,13 +800,13 @@ checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do
 -- Check the type of a value, rethrowing errors to provide a better error message
 --
 check
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -> SourceType
   -> m TypedValue'
 check val ty = withErrorMessageHint' val (ErrorCheckingType val ty) $ checkAndAddToIde val ty
 
-checkAndAddToIde :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) 
+checkAndAddToIde :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr -> SourceType -> m TypedValue'
 checkAndAddToIde val ty = do
   tv <- check' val ty
@@ -815,7 +816,7 @@ checkAndAddToIde val ty = do
 --
 check'
   :: forall m
-   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+   . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -> SourceType
   -> m TypedValue'
@@ -942,8 +943,8 @@ check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val
   val' <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest))
   return $ TypedValue' True (Accessor prop val') ty
 check' v@(Constructor _ c) ty = do
-  env <- getEnv
-  case M.lookup c (dataConstructors env) of
+  ctrMb <- lookupConstructorMb c
+  case ctrMb of
     Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c
     Just (_, _, ty1, _) -> do
       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
@@ -971,7 +972,7 @@ check' val ty = do
 -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
 --
 checkProperties
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -> [(PSString, Expr)]
   -> SourceType
@@ -1018,7 +1019,7 @@ checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where
 -- * The elaborated expression for the function application (since we might need to
 --   insert type class dictionaries, etc.)
 checkFunctionApplication
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -- ^ The function expression
   -> SourceType
@@ -1035,7 +1036,7 @@ checkFunctionApplication fn fnTy arg = withErrorMessageHint' fn (ErrorInApplicat
 
 -- | Check the type of a function application
 checkFunctionApplication'
-  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => Expr
   -> SourceType
   -> Expr
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index e4f1040ebf..d2d349685d 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -33,6 +33,7 @@ import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, un
 import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize)
 import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown)
+import Language.PureScript.Make.Index.Select (GetEnv)
 
 -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible.
 freshType :: (MonadState CheckState m) => m SourceType
@@ -61,7 +62,7 @@ freshTypeWithKind kind = state $ \st -> do
   (srcTUnknown t, st')
 
 -- | Update the substitution to solve a type constraint
-solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m ()
+solveType :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => Int -> SourceType -> m ()
 solveType u t = rethrow (onErrorMessages withoutPosition) $ do
   -- We strip the position so that any errors get rethrown with the position of
   -- the original unification constraint. Otherwise errors may arise from arbitrary
@@ -106,7 +107,7 @@ unknownsInType t = everythingOnTypes (.) go t []
   go _ = id
 
 -- | Unify two types, updating the current substitution
-unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m ()
+unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => SourceType -> SourceType -> m ()
 unifyTypes t1 t2 = do
   sub <- gets checkSubstitution
   withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2)
@@ -160,7 +161,7 @@ unifyTypes t1 t2 = do
 --
 -- Common labels are identified and unified. Remaining labels and types are unified with a
 -- trailing row unification variable, if appropriate.
-unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m ()
+unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => SourceType -> SourceType -> m ()
 unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where
   unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2
 

From b9624a7f082907a7a1a3cb224f9f10dcbd8ab826 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 19 Dec 2024 17:37:03 +0100
Subject: [PATCH 278/297] remove checkExhaustiveExpr env

---
 src/Language/PureScript/Environment.hs        |   6 +-
 src/Language/PureScript/Errors.hs             |   6 +-
 src/Language/PureScript/Linter/Exhaustive.hs  | 376 +++++++++---------
 src/Language/PureScript/Make/Index/Select.hs  |  20 +-
 src/Language/PureScript/TypeChecker.hs        |  41 +-
 .../PureScript/TypeChecker/Entailment.hs      |   7 +-
 src/Language/PureScript/TypeChecker/Monad.hs  |   7 +-
 src/Language/PureScript/TypeChecker/Types.hs  |  16 +-
 8 files changed, 259 insertions(+), 220 deletions(-)

diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 4e62155828..1943bdb179 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -22,7 +22,7 @@ import Data.Text qualified as T
 import Data.List.NonEmpty qualified as NEL
 
 import Language.PureScript.AST.SourcePos (nullSourceAnn)
-import Language.PureScript.Crash (internalError)
+import Language.PureScript.Crash (internalError, HasCallStack)
 import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName)
 import Language.PureScript.Roles (Role(..))
 import Language.PureScript.TypeClassDictionaries (NamedDict)
@@ -699,9 +699,9 @@ primTypeErrorClasses =
     ]
 
 -- | Finds information about data constructors from the current environment.
-lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
+lookupConstructor :: HasCallStack => Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
 lookupConstructor env ctor =
-  fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env
+  fromMaybe (internalError $ "Data constructor not found: " <> show ctor) $ ctor `M.lookup` dataConstructors env
 
 -- | Finds information about values from the current environment.
 lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 6185c5750f..2b3848959b 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -81,7 +81,7 @@ data SimpleErrorMessage
   | OrphanTypeDeclaration Ident
   | OrphanKindDeclaration (ProperName 'TypeName)
   | OrphanRoleDeclaration (ProperName 'TypeName)
-  | RedefinedIdent Ident
+  | RedefinedIdent Ident Text
   | OverlappingNamesInLet Ident
   | UnknownName (Qualified Name)
   | UnknownImport ModuleName Name
@@ -774,8 +774,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
       line $ "The kind declaration for " <> markCode (runProperName nm) <> " should be followed by its definition."
     renderSimpleErrorMessage (OrphanRoleDeclaration nm) =
       line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition."
-    renderSimpleErrorMessage (RedefinedIdent name) =
-      line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times"
+    renderSimpleErrorMessage (RedefinedIdent name text) =
+      line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" <> text
     renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.S_bind, C.S_discard ] =
       line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude"
     renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)))) =
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 697fefe8a0..5b7cf16a26 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -3,35 +3,34 @@
 -- The algorithm analyses the clauses of a definition one by one from top
 -- to bottom, where in each step it has the cases already missing (uncovered),
 -- and it generates the new set of missing cases.
---
 module Language.PureScript.Linter.Exhaustive
-  ( checkExhaustiveExpr
-  ) where
-
-import Prelude
-import Protolude (ordNub)
+  ( checkExhaustiveExpr,
+  )
+where
 
-import Control.Applicative (Applicative(..))
+import Control.Applicative (Applicative (..))
 import Control.Arrow (first, second)
-import Control.Monad (unless)
-import Control.Monad.Writer.Class (MonadWriter(..))
-
-import Data.List (foldl', sortOn)
+import Control.Monad (unless, join)
+import Control.Monad.Writer.Class (MonadWriter (..))
+import Data.Functor ((<&>))
+import Data.List (sortOn)
 import Data.Maybe (fromMaybe)
-import Data.Map qualified as M
 import Data.Text qualified as T
-
-import Language.PureScript.AST.Binders (Binder(..))
-import Language.PureScript.AST.Declarations (CaseAlternative(..), Expr(..), Guard(..), GuardedExpr(..), pattern MkUnguarded, isTrueExpr)
-import Language.PureScript.AST.Literals (Literal(..))
+import Language.PureScript.AST.Binders (Binder (..))
+import Language.PureScript.AST.Declarations (CaseAlternative (..), Expr (..), Guard (..), GuardedExpr (..), isTrueExpr, pattern MkUnguarded)
+import Language.PureScript.AST.Literals (Literal (..))
 import Language.PureScript.AST.Traversals (everywhereOnValuesM)
+import Language.PureScript.Constants.Prim qualified as C
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (DataDeclType, Environment(..), TypeKind(..))
-import Language.PureScript.Errors (MultipleErrors, pattern NullSourceAnn, SimpleErrorMessage(..), SourceSpan, errorMessage')
+import Language.PureScript.Environment (TypeKind (..))
+import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), SourceSpan, errorMessage', pattern NullSourceAnn)
+import Language.PureScript.Make.Index.Select (GetEnv)
 import Language.PureScript.Names as P
 import Language.PureScript.Pretty.Values (prettyPrintBinderAtom)
+import Language.PureScript.TypeChecker.Monad (CheckState, lookupConstructorMb, lookupTypeMb)
 import Language.PureScript.Types as P
-import Language.PureScript.Constants.Prim qualified as C
+import Protolude (MonadState, ifM, ordNub, foldlM)
+import Prelude
 
 -- | There are two modes of failure for the redundancy check:
 --
@@ -43,55 +42,49 @@ data RedundancyError = Incomplete | Unknown
 
 -- |
 -- Qualifies a propername from a given qualified propername and a default module name
---
-qualifyName
-  :: ProperName a
-  -> ModuleName
-  -> Qualified (ProperName b)
-  -> Qualified (ProperName a)
+qualifyName ::
+  ProperName a ->
+  ModuleName ->
+  Qualified (ProperName b) ->
+  Qualified (ProperName a)
 qualifyName n defmn qn = Qualified (ByModuleName mn) n
   where
-  (mn, _) = qualify defmn qn
+    (mn, _) = qualify defmn qn
 
 -- |
--- Given an environment and a datatype or newtype name,
+-- Given  a datatype or newtype name,
 -- this function returns the associated data constructors if it is the case of a datatype
 -- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)
 --        - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])
---
-getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [SourceType])]
-getConstructors env defmn n = extractConstructors lnte
-  where
-
-  extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])]
-  extractConstructors (Just (_, DataType _ _ pt)) = pt
-  extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
+getConstructors :: forall m. (MonadState CheckState m, GetEnv m) => ModuleName -> Qualified (ProperName 'ConstructorName) -> m [(ProperName 'ConstructorName, [SourceType])]
+getConstructors defmn n = do
+  qpn <- getConsDataName n
+  lnte <- lookupTypeMb qpn
 
-  lnte :: Maybe (SourceType, TypeKind)
-  lnte = M.lookup qpn (types env)
-
-  qpn :: Qualified (ProperName 'TypeName)
-  qpn = getConsDataName n
+  pure $ extractConstructors lnte
+  where
+    extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])]
+    extractConstructors (Just (_, DataType _ _ pt)) = pt
+    extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
 
-  getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName)
-  getConsDataName con =
-    case getConsInfo con of
-      Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName."
-      Just (_, pm, _, _) -> qualifyName pm defmn con
+    getConsDataName :: Qualified (ProperName 'ConstructorName) -> m (Qualified (ProperName 'TypeName))
+    getConsDataName con =
+      lookupConstructorMb con <&> \case
+        Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName."
+        Just (_, pm, _, _) -> qualifyName pm defmn con
 
-  getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
-  getConsInfo con = M.lookup con (dataConstructors env)
+-- getConsInfo :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
+-- getConsInfo con = M.lookup con (dataConstructors env)
 
 -- |
 -- Replicates a wildcard binder
---
 initialize :: Int -> [Binder]
 initialize l = replicate l NullBinder
 
 -- |
 -- Applies a function over two lists of tuples that may lack elements
---
-genericMerge :: Ord a =>
+genericMerge ::
+  (Ord a) =>
   (a -> Maybe b -> Maybe c -> d) ->
   [(a, b)] ->
   [(a, c)] ->
@@ -99,7 +92,7 @@ genericMerge :: Ord a =>
 genericMerge _ [] [] = []
 genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs
 genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs
-genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
+genericMerge f bsl@((s, b) : bs) bsr@((s', b') : bs')
   | s < s' = f s (Just b) Nothing : genericMerge f bs bsr
   | s > s' = f s' Nothing (Just b') : genericMerge f bsl bs'
   | otherwise = f s (Just b) (Just b') : genericMerge f bs bs'
@@ -107,49 +100,49 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
 -- |
 -- Find the uncovered set between two binders:
 -- the first binder is the case we are trying to cover, the second one is the matching binder
---
-missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool)
-missingCasesSingle _ _ _ NullBinder = ([], return True)
-missingCasesSingle _ _ _ (VarBinder _ _) = ([], return True)
-missingCasesSingle env mn (VarBinder _ _) b = missingCasesSingle env mn NullBinder b
-missingCasesSingle env mn br (NamedBinder _ _ bl) = missingCasesSingle env mn br bl
-missingCasesSingle env mn NullBinder cb@(ConstructorBinder ss con _) =
-  (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True)
-  where
-  allPatterns = map (\(p, t) -> ConstructorBinder ss (qualifyName p mn con) (initialize $ length t))
-                  $ getConstructors env mn con
-missingCasesSingle env mn cb@(ConstructorBinder ss con bs) (ConstructorBinder _ con' bs')
-  | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder ss con) bs'', pr)
-  | otherwise = ([cb], return False)
-missingCasesSingle env mn NullBinder (LiteralBinder ss (ObjectLiteral bs)) =
-  (map (LiteralBinder ss . ObjectLiteral . zip (map fst bs)) allMisses, pr)
-  where
-  (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)
-missingCasesSingle env mn (LiteralBinder _ (ObjectLiteral bs)) (LiteralBinder ss (ObjectLiteral bs')) =
-  (map (LiteralBinder ss . ObjectLiteral . zip sortedNames) allMisses, pr)
+missingCasesSingle :: (MonadState CheckState m, GetEnv m) => ModuleName -> Binder -> Binder -> m ([Binder], Either RedundancyError Bool)
+missingCasesSingle _ _ NullBinder = pure ([], return True)
+missingCasesSingle _ _ (VarBinder _ _) = pure ([], return True)
+missingCasesSingle mn (VarBinder _ _) b = missingCasesSingle mn NullBinder b
+missingCasesSingle mn br (NamedBinder _ _ bl) = missingCasesSingle mn br bl
+missingCasesSingle mn NullBinder cb@(ConstructorBinder ss con _) = do
+  ctrs <- getConstructors mn con
+  let allPatterns =
+        map (\(p, t) -> ConstructorBinder ss (qualifyName p mn con) (initialize $ length t)) ctrs
+  binders <- join <$> traverse (\cp -> fst <$> missingCasesSingle mn cp cb) allPatterns
+  return (binders, return True)
+missingCasesSingle mn cb@(ConstructorBinder ss con bs) (ConstructorBinder _ con' bs')
+  | con == con' = do
+      (bs'', pr) <- missingCasesMultiple mn bs bs'
+      pure (map (ConstructorBinder ss con) bs'', pr)
+  | otherwise = return ([cb], return False)
+missingCasesSingle mn NullBinder (LiteralBinder ss (ObjectLiteral bs)) = do
+  (allMisses, pr) <- missingCasesMultiple mn (initialize $ length bs) (map snd bs)
+  pure (map (LiteralBinder ss . ObjectLiteral . zip (map fst bs)) allMisses, pr)
+missingCasesSingle mn (LiteralBinder _ (ObjectLiteral bs)) (LiteralBinder ss (ObjectLiteral bs')) = do
+  (allMisses, pr) <- uncurry (missingCasesMultiple mn) (unzip binders)
+  return (map (LiteralBinder ss . ObjectLiteral . zip sortedNames) allMisses, pr)
   where
-  (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)
+    sortNames = sortOn fst
 
-  sortNames = sortOn fst
+    (sbs, sbs') = (sortNames bs, sortNames bs')
 
-  (sbs, sbs') = (sortNames bs, sortNames bs')
+    compB :: a -> Maybe a -> Maybe a -> (a, a)
+    compB e b b' = (fm b, fm b')
+      where
+        fm = fromMaybe e
 
-  compB :: a -> Maybe a -> Maybe a -> (a, a)
-  compB e b b' = (fm b, fm b')
-    where
-    fm = fromMaybe e
+    compBS :: b -> a -> Maybe b -> Maybe b -> (a, (b, b))
+    compBS e s b b' = (s, compB e b b')
 
-  compBS :: b -> a -> Maybe b -> Maybe b -> (a, (b, b))
-  compBS e s b b' = (s, compB e b b')
-
-  (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
-missingCasesSingle _ _ NullBinder (LiteralBinder ss (BooleanLiteral b)) = ([LiteralBinder ss . BooleanLiteral $ not b], return True)
-missingCasesSingle _ _ (LiteralBinder ss (BooleanLiteral bl)) (LiteralBinder _ (BooleanLiteral br))
-  | bl == br = ([], return True)
-  | otherwise = ([LiteralBinder ss $ BooleanLiteral bl], return False)
-missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb
-missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb
-missingCasesSingle _ _ b _ = ([b], Left Unknown)
+    (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'
+missingCasesSingle _ NullBinder (LiteralBinder ss (BooleanLiteral b)) = return ([LiteralBinder ss . BooleanLiteral $ not b], return True)
+missingCasesSingle _ (LiteralBinder ss (BooleanLiteral bl)) (LiteralBinder _ (BooleanLiteral br))
+  | bl == br = return ([], return True)
+  | otherwise = return ([LiteralBinder ss $ BooleanLiteral bl], return False)
+missingCasesSingle mn b (PositionedBinder _ _ cb) = missingCasesSingle mn b cb
+missingCasesSingle mn b (TypedBinder _ cb) = missingCasesSingle mn b cb
+missingCasesSingle _ b _ = return ([b], Left Unknown)
 
 -- |
 -- Returns the uncovered set of binders
@@ -176,15 +169,14 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)
 --       Up to now, we've decided to use `x` just because we expect to generate uncovered cases which might be
 --       redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker
 --       (which ought to be available soon), or increase the complexity of the algorithm.
---
-missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
-missingCasesMultiple env mn = go
+missingCasesMultiple :: (MonadState CheckState m, GetEnv m) => ModuleName -> [Binder] -> [Binder] -> m ([[Binder]], Either RedundancyError Bool)
+missingCasesMultiple mn = go
   where
-  go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2)
-    where
-    (miss1, pr1) = missingCasesSingle env mn x y
-    (miss2, pr2) = go xs ys
-  go _ _ = ([], pure True)
+    go (x : xs) (y : ys) = do
+      (miss1, pr1) <- missingCasesSingle mn x y
+      (miss2, pr2) <- go xs ys
+      pure (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2)
+    go _ _ = pure ([], pure True)
 
 -- |
 -- Guard handling
@@ -199,111 +191,127 @@ missingCasesMultiple env mn = go
 --
 -- The function below say whether or not a guard has an `otherwise` expression
 -- It is considered that `otherwise` is defined in Prelude
---
-isExhaustiveGuard :: Environment -> ModuleName -> [GuardedExpr] -> Bool
-isExhaustiveGuard _ _ [MkUnguarded _] = True
-isExhaustiveGuard env moduleName gs   =
-  any (\(GuardedExpr grd _) -> isExhaustive grd) gs
+isExhaustiveGuard :: forall m. (GetEnv m, MonadState CheckState m) => ModuleName -> [GuardedExpr] -> m Bool
+isExhaustiveGuard _ [MkUnguarded _] = pure True
+isExhaustiveGuard moduleName gs =
+  anyM (\(GuardedExpr grd _) -> isExhaustive grd) gs
   where
-    isExhaustive :: [Guard] -> Bool
-    isExhaustive = all checkGuard
+    isExhaustive :: [Guard] -> m Bool
+    isExhaustive = allM checkGuard
 
-    checkGuard :: Guard -> Bool
-    checkGuard (ConditionGuard cond)   = isTrueExpr cond
-    checkGuard (PatternGuard binder _) =
-      case missingCasesMultiple env moduleName [NullBinder] [binder] of
+    checkGuard :: Guard -> m Bool
+    checkGuard (ConditionGuard cond) = pure $ isTrueExpr cond
+    checkGuard (PatternGuard binder _) = do
+      missing <- missingCasesSingle moduleName NullBinder binder
+      pure $ case missing of
         ([], _) -> True -- there are no missing pattern for this guard
-        _       -> False
+        _ -> False
+
+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+anyM _ [] = pure False
+anyM f (x : xs) = do
+  b <- f x
+  if b then pure True else anyM f xs
+
+allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+allM _ [] = pure True
+allM f (x : xs) = do
+  b <- f x
+  if b then allM f xs else pure False
 
 -- |
 -- Returns the uncovered set of case alternatives
---
-missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool)
-missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)
+missingCases :: (GetEnv m, MonadState CheckState m) => ModuleName -> [Binder] -> CaseAlternative -> m ([[Binder]], Either RedundancyError Bool)
+missingCases mn uncovered ca = missingCasesMultiple mn uncovered (caseAlternativeBinders ca)
 
-missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool)
-missingAlternative env mn ca uncovered
-  | isExhaustiveGuard env mn (caseAlternativeResult ca) = mcases
-  | otherwise = ([uncovered], snd mcases)
-  where
-  mcases = missingCases env mn uncovered ca
+missingAlternative :: (GetEnv m, MonadState CheckState m) => ModuleName -> CaseAlternative -> [Binder] -> m ([[Binder]], Either RedundancyError Bool)
+missingAlternative mn ca uncovered = do
+  mcases <- missingCases mn uncovered ca
+  ifM (isExhaustiveGuard mn (caseAlternativeResult ca)) (pure mcases) (pure ([uncovered], snd mcases))
 
 -- |
 -- Main exhaustivity checking function
 -- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument),
 -- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
 -- Then, returns the uncovered set of case alternatives.
---
-checkExhaustive
-  :: forall m
-   . MonadWriter MultipleErrors m
-   => SourceSpan
-   -> Environment
-   -> ModuleName
-   -> Int
-   -> [CaseAlternative]
-   -> Expr
-   -> m Expr
-checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas
+checkExhaustive ::
+  forall m.
+  (MonadWriter MultipleErrors m, GetEnv m, MonadState CheckState m) =>
+  SourceSpan ->
+  ModuleName ->
+  Int ->
+  [CaseAlternative] ->
+  Expr ->
+  m Expr
+checkExhaustive ss mn numArgs cas expr = makeResult . first ordNub =<< foldlM step ([initialize numArgs], (pure True, [])) cas
   where
-  step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
-  step (uncovered, (nec, redundant)) ca =
-    let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)
-        (missed', approx) = splitAt 10000 (ordNub (concat missed))
-        cond = or <$> sequenceA pr
-    in (missed', ( if null approx
-                     then liftA2 (&&) cond nec
-                     else Left Incomplete
-                 , if and cond
-                     then redundant
-                     else caseAlternativeBinders ca : redundant
-                 )
-       )
+    step ::
+      ([[Binder]], (Either RedundancyError Bool, [[Binder]])) ->
+      CaseAlternative ->
+      m ([[Binder]], (Either RedundancyError Bool, [[Binder]]))
+    step (uncovered, (nec, redundant)) ca = do 
+      (missed, pr) <- unzip <$> traverse (missingAlternative mn ca) uncovered
+      let (missed', approx) = splitAt 10000 (ordNub (concat missed))
+          cond = or <$> sequenceA pr
+
+      -- let (missed, pr) = unzip (map (missingAlternative mn ca) uncovered)
+      --     (missed', approx) = splitAt 10000 (ordNub (concat missed))
+      --     cond = or <$> sequenceA pr
+      pure ( missed',
+            ( if null approx
+                then liftA2 (&&) cond nec
+                else Left Incomplete,
+              if and cond
+                then redundant
+                else caseAlternativeBinders ca : redundant
+            )
+          )
 
-  makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr
-  makeResult (bss, (rr, bss')) =
-    do unless (null bss') tellRedundant
-       case rr of
-         Left Incomplete -> tellIncomplete
-         _ -> return ()
-       return $ if null bss
-         then expr
-         else addPartialConstraint (second null (splitAt 5 bss)) expr
-    where
-      tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
-      tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck
+    makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr
+    makeResult (bss, (rr, bss')) =
+      do
+        unless (null bss') tellRedundant
+        case rr of
+          Left Incomplete -> tellIncomplete
+          _ -> return ()
+        return $
+          if null bss
+            then expr
+            else addPartialConstraint (second null (splitAt 5 bss)) expr
+      where
+        tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
+        tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck
 
-  -- We add a Partial constraint by annotating the expression to have type `Partial => _`.
-  --
-  -- The binder information is provided so that it can be embedded in the constraint,
-  -- and then included in the error message.
-  addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr
-  addPartialConstraint (bss, complete) e =
-    TypedValue True e $
-      srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) $ TypeWildcard NullSourceAnn IgnoredWildcard
-    where
-      constraintData :: ConstraintData
-      constraintData =
-        PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete
+    -- We add a Partial constraint by annotating the expression to have type `Partial => _`.
+    --
+    -- The binder information is provided so that it can be embedded in the constraint,
+    -- and then included in the error message.
+    addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr
+    addPartialConstraint (bss, complete) e =
+      TypedValue True e $
+        srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) $
+          TypeWildcard NullSourceAnn IgnoredWildcard
+      where
+        constraintData :: ConstraintData
+        constraintData =
+          PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete
 
 -- |
 -- Exhaustivity checking
---
-checkExhaustiveExpr
-  :: forall m
-   . MonadWriter MultipleErrors m
-   => SourceSpan
-   -> Environment
-   -> ModuleName
-   -> Expr
-   -> m Expr
-checkExhaustiveExpr ss env mn = onExpr'
+checkExhaustiveExpr ::
+  forall m.
+  (MonadWriter MultipleErrors m, GetEnv m, MonadState CheckState m) =>
+  SourceSpan ->
+  ModuleName ->
+  Expr ->
+  m Expr
+checkExhaustiveExpr ss mn = onExpr'
   where
-  (_, onExpr', _) = everywhereOnValuesM pure onExpr pure
+    (_, onExpr', _) = everywhereOnValuesM pure onExpr pure
 
-  onExpr :: Expr -> m Expr
-  onExpr e = case e of
-    Case es cas ->
-      checkExhaustive ss env mn (length es) cas e
-    _ ->
-      pure e
+    onExpr :: Expr -> m Expr
+    onExpr e = case e of
+      Case es cas ->
+        checkExhaustive ss mn (length es) cas e
+      _ ->
+        pure e
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index eb08a2f9dc..cd046b289e 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -1090,6 +1090,14 @@ insertImport conn mn = \case
       (mn, importedModuleName, importedAs)
   _ -> pure ()
 
+deleteModuleEnvImpl :: P.ModuleName -> Connection -> IO ()
+deleteModuleEnvImpl moduleName conn = do
+  SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
+
 getEnvConstraints :: E.Environment -> [P.SourceConstraint]
 getEnvConstraints env =
   E.names env & Map.elems >>= typeConstraints . view _1
@@ -1110,6 +1118,8 @@ updateConcurrently a b = do
   g <- b
   pure $ f >>> g
 
+
+
 -- updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c)
 -- updateConcurrently a b = do
 --   (f, g) <- concurrently a b
@@ -1131,6 +1141,7 @@ class GetEnv m where
   getTypeClass :: P.Qualified (P.ProperName 'P.ClassName) -> m (Maybe P.TypeClassData)
   getTypeClassDictionaries :: m [NamedDict]
   getTypeClassDictionary :: P.Qualified (P.ProperName 'P.ClassName) -> m (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty P.NamedDict))
+  deleteModuleEnv :: P.ModuleName -> m ()
 
 
 instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where 
@@ -1141,6 +1152,7 @@ instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where
   getTypeClass = lift . getTypeClass
   getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
+  deleteModuleEnv = lift . deleteModuleEnv
 
 instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where 
   getName = lift . getName
@@ -1150,6 +1162,7 @@ instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where
   getTypeClass = lift . getTypeClass
   getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
+  deleteModuleEnv = lift . deleteModuleEnv
 instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where 
   getName = lift . getName
   getType = lift . getType
@@ -1158,6 +1171,7 @@ instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where
   getTypeClass = lift . getTypeClass
   getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
+  deleteModuleEnv = lift . deleteModuleEnv
 
 newtype DbEnv m a = DbEnv (ReaderT Connection m a)
   deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadError e, MonadWriter w, MonadTrans)
@@ -1187,6 +1201,9 @@ instance (MonadIO m) => GetEnv (DbEnv m) where
   getTypeClassDictionaries = DbEnv $ do
     conn <- ask
     liftIO $ selectAllClassInstances conn
+  deleteModuleEnv modName = DbEnv $ do
+    conn <- ask
+    liftIO $ deleteModuleEnvImpl modName conn
 
 
   getTypeClassDictionary cls = DbEnv $ do
@@ -1212,4 +1229,5 @@ instance Monad m => GetEnv (WoGetEnv m) where
   getTypeSynonym _ = pure Nothing
   getTypeClass _ = pure Nothing
   getTypeClassDictionaries = pure []
-  getTypeClassDictionary _ = pure Map.empty
\ No newline at end of file
+  getTypeClassDictionary _ = pure Map.empty
+  deleteModuleEnv _ = pure ()
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index dbaa974963..25eb52cedf 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -48,7 +48,7 @@ import Language.PureScript.TypeChecker.Unify (varIfUnknown)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes)
 import Language.PureScript.Types qualified as P
-import Language.PureScript.Make.Index.Select (GetEnv)
+import Language.PureScript.Make.Index.Select (GetEnv (deleteModuleEnv, getTypeClass))
 
 addDataType
   :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
@@ -132,7 +132,7 @@ valueIsNotDefined
 valueIsNotDefined moduleName name = do
   nameMb <- lookupName (Qualified (ByModuleName moduleName) name)
   case nameMb of
-    Just _ -> throwError . errorMessage $ RedefinedIdent name
+    Just found -> throwError . errorMessage $ RedefinedIdent name $ " valueIsNotDefined: " <> T.pack (show (name, found))
     Nothing -> return ()
 
 addValue
@@ -148,7 +148,7 @@ addValue moduleName name ty nameKind = do
 
 addTypeClass
   :: forall m
-   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+   . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m)
   => ModuleName
   -> Qualified (ProperName 'ClassName)
   -> [(Text, Maybe SourceType)]
@@ -172,18 +172,26 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do
 
     mkNewClass :: m TypeClassData
     mkNewClass = do
-      env <- getEnv
       implies' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms implies
-      let ctIsEmpty = null classMembers && all (typeClassIsEmpty . findSuperClass env) implies'
+      ctIsEmpty <- if null classMembers
+         then allM (fmap typeClassIsEmpty . findSuperClass) implies'
+         else pure False 
       pure $ makeTypeClassData args classMembers implies' dependencies ctIsEmpty
       where
-      findSuperClass env c = case M.lookup (constraintClass c) (typeClasses env) of
-        Just tcd -> tcd
-        Nothing -> internalError "Unknown super class in TypeClassDeclaration"
+      findSuperClass c = lookupTypeClassUnsafe $ constraintClass c
+        --  case M.lookup (constraintClass c) (typeClasses env) of
+        -- Just tcd -> tcd
+        -- Nothing -> internalError "Unknown super class in TypeClassDeclaration"
 
     toPair (TypeDeclaration (TypeDeclarationData _ ident ty)) = (ident, ty)
     toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
 
+allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+allM _ [] = pure True
+allM f (x:xs) = do
+  b <- f x
+  if b then allM f xs else pure False
+
 addTypeClassDictionaries
   :: (MonadState CheckState m)
   => QualifiedBy
@@ -334,10 +342,9 @@ typeCheckAll moduleName = traverse go
   go TypeDeclaration{} =
     internalError "Type declarations should have been removed before typeCheckAlld"
   go d@(ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do
-    env <- getEnv
     let declHint = if isPlainIdent name then addHint (ErrorInValueDeclaration name) else id
     warnAndRethrow (declHint . addHint (positionedError ss)) $ do
-      val' <- checkExhaustiveExpr ss env moduleName val
+      val' <- checkExhaustiveExpr ss moduleName val
       valueIsNotDefined moduleName name
       typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case
         [(_, (val'', ty))] -> do
@@ -349,11 +356,10 @@ typeCheckAll moduleName = traverse go
   go ValueDeclaration{} = internalError "Binders were not desugared"
   go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared"
   go (BindingGroupDeclaration vals) = do
-    env <- getEnv
     let sss = fmap (\(((ss, _), _), _, _) -> ss) vals
     warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, ident), _, _) -> ident) vals)) . addHint (PositionedError sss)) $ do
       for_ vals $ \((_, ident), _, _) -> valueIsNotDefined moduleName ident
-      vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss env moduleName expr) vals
+      vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss moduleName expr) vals
       tys <- typesOf RecursiveBindingGroup moduleName $ fmap (\(sai, _, ty) -> (sai, ty)) vals'
       vals'' <- forM [ (sai, val, nameKind, ty)
                      | (sai@(_, name), nameKind, _) <- vals'
@@ -374,15 +380,17 @@ typeCheckAll moduleName = traverse go
       return d
   go d@(ExternDeclaration (ss, _) name ty) = do
     warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do
-      env <- getEnv
       (elabTy, kind) <- withFreshSubstitution $ do
         ((unks, ty'), kind) <- kindOfWithUnknowns ty
         ty'' <- varIfUnknown unks ty'
         pure (ty'', kind)
       checkTypeKind elabTy kind
-      case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of
-        Just _ -> throwError . errorMessage $ RedefinedIdent name
-        Nothing -> putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) })
+      nameMb <- lookupName (Qualified (ByModuleName moduleName) name)
+      case nameMb of
+        Just _ -> throwError . errorMessage $ RedefinedIdent name $ " typeCheckAll: " <> T.pack (show (Qualified (ByModuleName moduleName) name))
+        Nothing -> do 
+          env <- getEnv
+          putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) })
     return d
   go d@FixityDeclaration{} = return d
   go d@ImportDeclaration{} = return d
@@ -605,6 +613,7 @@ typeCheckModule _ (Module _ _ _ _ Nothing) =
   internalError "exports should have been elaborated before typeCheckModule"
 typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) =
   warnAndRethrow (addHint (ErrorInModule mn)) $ do
+    deleteModuleEnv mn
     let (decls', imports) = partitionEithers $ fromImportDecl <$> decls
     for_ imports $ \((modSS,_), mName, idType, _, _) -> do 
       addIdeModule modSS mName
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 71842f84a3..f8357c8bb9 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -44,7 +44,7 @@ import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName
 import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds)
 import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation)
 import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds')
-import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint, lookupTypeClassMb)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint, lookupTypeClassMb, lookupTypeClassUnsafe)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, substituteType, unifyTypes)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..), superclassName)
@@ -867,14 +867,13 @@ matches deps TypeClassDictionaryInScope{..} tys =
 -- | Add a dictionary for the constraint to the scope, and dictionaries
 -- for all implied superclass instances.
 newDictionaries
-  :: MonadState CheckState m
+  :: (MonadState CheckState m, GetEnv m)
   => [(Qualified (ProperName 'ClassName), Integer)]
   -> Qualified Ident
   -> SourceConstraint
   -> m [NamedDict]
 newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = do
-    tcs <- gets (typeClasses . checkEnv)
-    let TypeClassData{..} = fromMaybe (internalError $ "newDictionaries: type class lookup failed: " <> show (name, className)) $ M.lookup className tcs
+    TypeClassData{..} <- lookupTypeClassUnsafe className
     supDicts <- join <$> zipWithM (\(Constraint ann supName supKinds supArgs _) index ->
                                       let sub = zip (map fst typeClassArguments) instanceTy in
                                       newDictionaries ((supName, index) : path)
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 4917ee75bd..2ea40f477c 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -384,7 +384,12 @@ lookupConstructorMb name = do
   env <- getEnv
   case M.lookup name (dataConstructors env) of
     Nothing -> do 
-      getDataConstructor name 
+      ctrMb <- getDataConstructor name 
+      case ctrMb of 
+        Nothing -> return Nothing
+        Just ctr -> do 
+          modifyEnv (\env' -> env' { dataConstructors = M.insert name ctr (dataConstructors env') })
+          return $ Just ctr
     ctr -> return ctr
 
 lookupConstructorUnsafe 
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 01c0a8dbd7..ea2f901052 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -51,7 +51,7 @@ import Language.PureScript.AST
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment
 import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU)
-import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent)
+import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent)
 import Language.PureScript.TypeChecker.Deriving (deriveInstance)
 import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries)
 import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds)
@@ -78,11 +78,11 @@ data TypedValue' = TypedValue' Bool Expr SourceType
 tvToExpr :: TypedValue' -> Expr
 tvToExpr (TypedValue' c e t) = TypedValue c e t
 
--- | Lookup data about a type class in the @Environment@
-lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData
-lookupTypeClass name =
-  let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name
-   in gets (findClass . typeClasses . checkEnv)
+-- -- | Lookup data about a type class in the @Environment@
+-- lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData
+-- lookupTypeClass name =
+--   let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name
+--    in gets (findClass . typeClasses . checkEnv)
 
 -- | Infer the types of multiple mutually-recursive values, and return elaborated values including
 -- type class dictionaries and type annotations.
@@ -126,7 +126,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
         -- ambiguous types to be inferred if they can be solved by some functional
         -- dependency.
         conData <- forM unsolved $ \(_, _, con) -> do
-          TypeClassData{ typeClassDependencies } <- lookupTypeClass $ constraintClass con
+          TypeClassData{ typeClassDependencies } <- lookupTypeClassUnsafe $ constraintClass con
           let
             -- The set of unknowns mentioned in each argument.
             unknownsForArg :: [S.Set Int]
@@ -840,7 +840,7 @@ check' val (ForAll ann vis ident mbK ty _) = do
   val' <- tvToExpr <$> check skVal sk
   return $ TypedValue' True val' (ForAll ann vis ident mbK ty (Just scope))
 check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName className)) _ _ _) ty) = do
-  TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls
+  TypeClassData{ typeClassIsEmpty } <- lookupTypeClassUnsafe cls
   -- An empty class dictionary is never used; see code in `TypeChecker.Entailment`
   -- that wraps empty dictionary solutions in `Unused`.
   dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> className)

From b25fbca191c1749a77623eb70c019d5194a636d7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 20 Dec 2024 10:25:40 +0100
Subject: [PATCH 279/297] uses GetEnv in Coercible

---
 src/Language/PureScript/Linter/Exhaustive.hs  |   3 +-
 src/Language/PureScript/Make/Index/Select.hs  |   9 +
 .../PureScript/TypeChecker/Entailment.hs      |  23 +-
 .../TypeChecker/Entailment/Coercible.hs       | 314 ++++++++++--------
 src/Language/PureScript/TypeChecker/Monad.hs  |   5 +
 src/Language/PureScript/TypeChecker/Roles.hs  |  22 +-
 6 files changed, 213 insertions(+), 163 deletions(-)

diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index 5b7cf16a26..b5551107f7 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -60,12 +60,11 @@ getConstructors :: forall m. (MonadState CheckState m, GetEnv m) => ModuleName -
 getConstructors defmn n = do
   qpn <- getConsDataName n
   lnte <- lookupTypeMb qpn
-
   pure $ extractConstructors lnte
   where
     extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])]
     extractConstructors (Just (_, DataType _ _ pt)) = pt
-    extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"
+    extractConstructors other = internalError $ "Data name not in the scope of the current environment in extractConstructors: " ++ show other 
 
     getConsDataName :: Qualified (ProperName 'ConstructorName) -> m (Qualified (ProperName 'TypeName))
     getConsDataName con =
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index cd046b289e..f870cbeef0 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -1153,6 +1153,15 @@ instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where
   getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
   deleteModuleEnv = lift . deleteModuleEnv
+instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where 
+  getName = lift . getName
+  getType = lift . getType
+  getDataConstructor = lift . getDataConstructor
+  getTypeSynonym = lift . getTypeSynonym
+  getTypeClass = lift . getTypeClass
+  getTypeClassDictionaries = lift getTypeClassDictionaries
+  getTypeClassDictionary = lift . getTypeClassDictionary
+  deleteModuleEnv = lift . deleteModuleEnv
 
 instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where 
   getName = lift . getName
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index f8357c8bb9..b5bdbc0d5d 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -38,7 +38,7 @@ import Data.List.NonEmpty qualified as NEL
 import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Literal(..), pattern NullSourceSpan, everywhereOnValuesTopDownM, nullSourceSpan, everythingOnValues)
 import Language.PureScript.AST.Declarations (UnknownsHint(..))
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString)
+import Language.PureScript.Environment (FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow)
 import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual)
 import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds)
@@ -195,11 +195,11 @@ entails
 entails SolverOptions{..} constraint context hints =
   overConstraintArgsAll (lift . lift . traverse replaceAllTypeSynonyms) constraint >>= solve
   where
-    forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict]
-    forClassNameM env ctx cn@C.Coercible kinds args =
+    forClassNameM ::  InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict]
+    forClassNameM  ctx cn@C.Coercible kinds args =
       fromMaybe (forClassName  ctx cn kinds args) <$>
-        solveCoercible env ctx kinds args
-    forClassNameM _env ctx cn kinds args =
+        solveCoercible ctx kinds args
+    forClassNameM  ctx cn kinds args =
       pure $ forClassName ctx cn kinds args
 
     forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> [TypeClassDict]
@@ -252,7 +252,6 @@ entails SolverOptions{..} constraint context hints =
             -- We need information about functional dependencies, so we have to look up the class
             -- name in the environment:
             typeClass <- lift . lift $ lookupTypeClassMb className'
-            env <- lift . lift $ gets checkEnv
             TypeClassData
               { typeClassArguments
               , typeClassDependencies
@@ -263,7 +262,7 @@ entails SolverOptions{..} constraint context hints =
                 Nothing -> throwError . errorMessage $ UnknownClass className'
                 Just tcd -> pure tcd
 
-            dicts <- lift . lift $ forClassNameM env (combineContexts context inferred) className' kinds'' tys''
+            dicts <- lift . lift $ forClassNameM (combineContexts context inferred) className' kinds'' tys''
 
             let (catMaybes -> ambiguous, instances) = partitionEithers $ do
                   chain :: NonEmpty TypeClassDict <-
@@ -471,15 +470,15 @@ entails SolverOptions{..} constraint context hints =
         subclassDictionaryValue dict className index =
           App (Accessor (mkString (superclassName className index)) dict) valUndefined
 
-    solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict])
-    solveCoercible env ctx kinds [a, b] = do
+    solveCoercible :: InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict])
+    solveCoercible ctx kinds [a, b] = do
       let coercibleDictsInScope = findDicts ctx C.Coercible ByNullSourcePos
           givens = flip mapMaybe coercibleDictsInScope $ \case
             dict | [a', b'] <- tcdInstanceTypes dict -> Just (a', b')
                  | otherwise -> Nothing
-      GivenSolverState{ inertGivens } <- execStateT (solveGivens env) $
+      GivenSolverState{ inertGivens } <- execStateT solveGivens $
         initialGivenSolverState givens
-      (WantedSolverState{ inertWanteds }, hints') <- runWriterT . execStateT (solveWanteds env) $
+      (WantedSolverState{ inertWanteds }, hints') <- runWriterT . execStateT solveWanteds $
         initialWantedSolverState inertGivens a b
       -- Solving fails when there's irreducible wanteds left.
       --
@@ -492,7 +491,7 @@ entails SolverOptions{..} constraint context hints =
         [] -> pure $ Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing Nothing]
         (k, a', b') : _ | a' == b && b' == a -> throwError $ insoluble k b' a'
         (k, a', b') : _ -> throwError $ insoluble k a' b'
-    solveCoercible _ _ _ _ = pure Nothing
+    solveCoercible _ _ _ = pure Nothing
 
     solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict]
     solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope Nothing 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing Nothing]
diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
index 491e75d565..6afa4103f3 100644
--- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
@@ -15,7 +15,7 @@ module Language.PureScript.TypeChecker.Entailment.Coercible
 
 import Prelude hiding (interact)
 
-import Control.Applicative ((<|>), empty)
+import Control.Applicative ((<|>), empty, Applicative (liftA2))
 import Control.Arrow ((&&&))
 import Control.Monad ((<=<), guard, unless, when)
 import Control.Monad.Error.Class (MonadError, catchError, throwError)
@@ -23,7 +23,7 @@ import Control.Monad.State (MonadState, StateT, get, gets, modify, put)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
-import Control.Monad.Writer.Strict (MonadWriter, Writer, execWriter, runWriter, runWriterT, tell)
+import Control.Monad.Writer.Strict (MonadWriter, runWriterT, tell, execWriterT)
 import Data.Either (partitionEithers)
 import Data.Foldable (fold, foldl', for_, toList)
 import Data.Functor (($>))
@@ -36,11 +36,11 @@ import Data.Map qualified as M
 import Data.Set qualified as S
 
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds)
+import Language.PureScript.Environment (DataDeclType(..), TypeKind(..), unapplyKinds)
 import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..))
 import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName)
 import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds')
-import Language.PureScript.TypeChecker.Monad (CheckState(..))
+import Language.PureScript.TypeChecker.Monad (CheckState(..), lookupTypeMb, lookupTypeUnsafe)
 import Language.PureScript.TypeChecker.Roles (lookupRoles)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, substituteType)
@@ -48,6 +48,7 @@ import Language.PureScript.Roles (Role(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes)
 import Language.PureScript.Constants.Prim qualified as Prim
 import Language.PureScript.Make.Index.Select (GetEnv)
+import Control.Monad.Trans.Writer.Strict (WriterT)
 
 -- | State of the given constraints solver.
 data GivenSolverState =
@@ -119,30 +120,33 @@ initialGivenSolverState =
 -- 3c. Otherwise canonicalization can succeed with derived constraints which we
 -- add to the unsolved queue and then go back to 1.
 solveGivens
-  :: (MonadError MultipleErrors m, GetEnv m)
+  :: forall m
+  .  (MonadError MultipleErrors m, GetEnv m)
   => MonadState CheckState m
-  => Environment
-  -> StateT GivenSolverState m ()
-solveGivens env = go (0 :: Int) where
+  => (StateT GivenSolverState m ())
+solveGivens = go (0 :: Int) where
+  go :: Int -> StateT GivenSolverState m ()
   go n = do
-    when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
+    when (n > 1000) $ throwError $ errorMessage PossiblyInfiniteCoercibleInstance
     gets unsolvedGivens >>= \case
       [] -> pure ()
       given : unsolved -> do
         (k, a, b) <- lift $ unify given
         GivenSolverState{..} <- get
-        lift (fst <$> runWriterT (canon env Nothing k a b `catchError` recover)) >>= \case
-          Irreducible -> case interact env (a, b) inertGivens of
-            Just (Simplified (a', b')) ->
-              put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. }
-            Just Discharged ->
-              put $ GivenSolverState { unsolvedGivens = unsolved, .. }
-            Nothing -> do
-              let (kickedOut, kept) = partitionEithers $ kicksOut env (a, b) <$> inertGivens
-              put $ GivenSolverState
-                { inertGivens = (k, a, b) : kept
-                , unsolvedGivens = kickedOut <> unsolved
-                }
+        lift (fst <$> runWriterT (canon Nothing k a b `catchError` recover)) >>= \case
+          Irreducible -> do 
+            i <- lift $ interact (a, b) inertGivens
+            case i of
+              Just (Simplified (a', b')) ->
+                put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. }
+              Just Discharged ->
+                put $ GivenSolverState { unsolvedGivens = unsolved, .. }
+              Nothing -> do
+                (kickedOut, kept) <- partitionEithers <$> traverse (lift . kicksOut  (a, b)) inertGivens
+                put $ GivenSolverState
+                  { inertGivens = (k, a, b) : kept
+                  , unsolvedGivens = kickedOut <> unsolved
+                  }
           Canonicalized deriveds ->
             put $ GivenSolverState { unsolvedGivens = toList deriveds <> unsolved, .. }
         go (n + 1)
@@ -207,12 +211,12 @@ initialWantedSolverState givens a b =
 -- interact the latter with the former, we would report an insoluble
 -- @Coercible Boolean Char@.
 solveWanteds
-  :: (MonadError MultipleErrors m, GetEnv m)
+  :: forall m. 
+  (MonadError MultipleErrors m, GetEnv m, MonadState CheckState m)
   => MonadWriter [ErrorMessageHint] m
-  => MonadState CheckState m
-  => Environment
-  -> StateT WantedSolverState m ()
-solveWanteds env = go (0 :: Int) where
+  => StateT WantedSolverState m ()
+solveWanteds = go (0 :: Int) where
+  go :: Int -> StateT WantedSolverState m ()
   go n = do
     when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance
     gets unsolvedWanteds >>= \case
@@ -220,8 +224,8 @@ solveWanteds env = go (0 :: Int) where
       wanted : unsolved -> do
         (k, a, b) <- lift $ unify wanted
         WantedSolverState{..} <- get
-        lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case
-          Irreducible -> case interact env (a, b) inertGivens of
+        lift (canon  (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case
+          Irreducible -> lift (interact (a, b) inertGivens) >>= \case
             Just (Simplified (a', b')) ->
               put $ WantedSolverState { unsolvedWanteds = (a', b') : unsolved, .. }
             Just Discharged ->
@@ -235,8 +239,8 @@ solveWanteds env = go (0 :: Int) where
           Canonicalized deriveds ->
             put $ WantedSolverState { unsolvedWanteds = toList deriveds <> unsolved, .. }
         go (n + 1)
-  recover wanted givens errors =
-    case interact env wanted givens of
+  recover wanted givens errors = do 
+     interact wanted givens  >>= \case
       Nothing -> throwError errors
       Just (Simplified wanted') -> pure . Canonicalized $ S.singleton wanted'
       Just Discharged -> pure $ Canonicalized mempty
@@ -297,17 +301,20 @@ data Interaction
 
 -- | Interact an irreducible constraint with an inert set of givens.
 interact
-  :: Environment
-  -> (SourceType, SourceType)
+  :: (GetEnv m, MonadState CheckState m)
+  => (SourceType, SourceType)
   -> [(SourceType, SourceType, SourceType)]
-  -> Maybe Interaction
-interact env irred = go where
-  go [] = Nothing
-  go (inert : _)
-    | canDischarge inert irred = Just Discharged
-    | Just derived <- interactSameTyVar inert irred = Just $ Simplified derived
-    | Just derived <- interactDiffTyVar env inert irred = Just $ Simplified derived
-  go (_ : inerts) = go inerts
+  -> m (Maybe Interaction)
+interact irred = go where
+  go [] = pure Nothing
+  go (inert : inserts) 
+    | canDischarge inert irred =  pure $ Just Discharged
+    | Just derived <- interactSameTyVar inert irred = pure $ Just $ Simplified derived
+    | otherwise = 
+        interactDiffTyVar inert irred >>= \case
+          Just s -> pure $ Just $ Simplified s
+          _ -> go inserts
+
 
 -- | A given constraint of the form @Coercible a b@ can discharge constraints
 -- of the form @Coercible a b@ and @Coercible b a@.
@@ -362,27 +369,32 @@ interactSameTyVar (_, tv1, ty1) (tv2, ty2)
 -- the non canonical given @Coercible b (D b)@ it would give @Coercible a (D b)@,
 -- which would keep interacting indefinitely with the given.
 interactDiffTyVar
-  :: Environment
-  -> (SourceType, SourceType, SourceType)
+  :: (GetEnv m, MonadState CheckState m)
+  =>  (SourceType, SourceType, SourceType)
   -> (SourceType, SourceType)
-  -> Maybe (SourceType, SourceType)
-interactDiffTyVar env (_, tv1, ty1) (tv2, ty2)
+  -> m (Maybe (SourceType, SourceType))
+interactDiffTyVar (_, tv1, ty1) (tv2, ty2)
   | tv1 /= tv2 && isCanonicalTyVarEq (tv2, ty2)
-  , (ty2', Any True) <- runWriter $ rewrite env (tv1, ty1) ty2
-  = Just (tv2, ty2')
-  | otherwise = Nothing
+  =  do 
+    rewriteRes <- runWriterT $ rewrite (tv1, ty1) ty2
+    case rewriteRes of
+      (ty2', Any True) -> pure $
+           Just (tv2, ty2')
+      _ -> pure Nothing
+  | otherwise = pure Nothing
 
 -- | A canonical constraint of the form @Coercible tv1 ty1@ can rewrite the
 -- right hand side of an irreducible constraint of the form @Coercible tv2 ty2@
 -- by substituting @ty1@ for every occurrence of @tv1@ at representational and
 -- phantom role in @ty2@. Nominal occurrences are left untouched.
-rewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Writer Any SourceType
-rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where
+rewrite :: (GetEnv m, MonadState CheckState m) => (SourceType, SourceType) -> SourceType -> WriterT Any m SourceType
+rewrite (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where
   go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1
   go ty2 | (Skolem{}, _, xs) <- unapplyTypes ty2, not $ null xs =
     rewriteTyVarApp go ty2
          | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do
-    rewriteTyConApp go (lookupRoles env tyName) ty2
+    roles <- lookupRoles tyName
+    rewriteTyConApp go roles ty2
   go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k
   go (ForAll sa vis tv k ty scope) = ForAll sa vis tv k <$> go ty <*> pure scope
   go (ConstrainedType sa Constraint{..} ty) | s1 `S.notMember` foldMap skolems constraintArgs =
@@ -390,7 +402,7 @@ rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where
   go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest
   go (KindedType sa ty k) = KindedType sa <$> go ty <*> pure k
   go ty2 = pure ty2
-rewrite _ _ = pure
+rewrite _ = pure
 
 -- | Rewrite the head of a type application of the form @tv a_0 .. a_n@.
 rewriteTyVarApp
@@ -422,8 +434,8 @@ rewriteTyConApp f = go where
     KindApp sa <$> go roles ty <*> pure k
   go _ ty = pure ty
 
-canRewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Bool
-canRewrite env irred = getAny . execWriter . rewrite env irred
+canRewrite :: (MonadState CheckState m, GetEnv m ) => (SourceType, SourceType) -> SourceType -> m Bool
+canRewrite irred =  fmap getAny . execWriterT . rewrite  irred
 
 -- | An irreducible given constraint must kick out of the inert set any
 -- constraint it can rewrite when it becomes inert, otherwise solving would be
@@ -442,14 +454,16 @@ canRewrite env irred = getAny . execWriter . rewrite env irred
 -- not be able to rewrite it to @Coercible a (g b)@ and discharge the wanted,
 -- but inverting the givens would work.
 kicksOut
-  :: Environment
-  -> (SourceType, SourceType)
+  :: (GetEnv m, MonadState CheckState m)
+  => (SourceType, SourceType)
   -> (SourceType, SourceType, SourceType)
-  -> Either (SourceType, SourceType) (SourceType, SourceType, SourceType)
-kicksOut env irred (_, tv2, ty2)
-  | isCanonicalTyVarEq (tv2, ty2) && canRewrite env irred ty2
-  = Left (tv2, ty2)
-kicksOut _ _ inert = Right inert
+  ->m ( Either (SourceType, SourceType) (SourceType, SourceType, SourceType))
+kicksOut irred inert@(_, tv2, ty2)
+  | isCanonicalTyVarEq (tv2, ty2) 
+  = do 
+    cr <- canRewrite irred ty2
+    pure $ if cr then Left (tv2, ty2) else Right inert 
+kicksOut _ inert = pure $ Right inert
 
 -- | A constraint of the form @Coercible tv ty@ is canonical when @tv@ does not
 -- occur in @ty@. Non canonical constraints do not interact to prevent loops.
@@ -482,16 +496,15 @@ canon
   :: (MonadError MultipleErrors m, GetEnv m)
   => MonadWriter [ErrorMessageHint] m
   => MonadState CheckState m
-  => Environment
-  -> Maybe [(SourceType, SourceType, SourceType)]
+  => Maybe [(SourceType, SourceType, SourceType)]
   -> SourceType
   -> SourceType
   -> SourceType
   -> m Canonicalized
-canon env givens k a b =
+canon  givens k a b =
   maybe (throwError $ insoluble k a b) pure <=< runMaybeT $
         canonRefl a b
-    <|> canonUnsaturatedHigherKindedType env a b
+    <|> canonUnsaturatedHigherKindedType  a b
     <|> canonRow a b
     -- We unwrap newtypes before trying the decomposition rules because it let
     -- us solve more constraints.
@@ -510,11 +523,11 @@ canon env givens k a b =
     -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@
     -- which we can then decompose to @Coercible a b@ and discharge with the
     -- given.
-    <|> canonNewtypeLeft env a b
-    <|> canonNewtypeRight env a b
-    <|> canonDecomposition env a b
-    <|> canonDecompositionFailure env k a b
-    <|> canonNewtypeDecomposition env givens a b
+    <|> canonNewtypeLeft  a b
+    <|> canonNewtypeRight  a b
+    <|> canonDecomposition  a b
+    <|> canonDecompositionFailure  k a b
+    <|> canonNewtypeDecomposition  givens a b
     <|> canonNewtypeDecompositionFailure a b
     <|> canonTypeVars a b
     <|> canonTypeVarLeft a b
@@ -553,25 +566,30 @@ canonRefl a b =
 canonUnsaturatedHigherKindedType
   :: MonadError MultipleErrors m
   => MonadState CheckState m
-  => Environment
-  -> SourceType
+  => GetEnv m
+  => SourceType
   -> SourceType
   -> MaybeT m Canonicalized
-canonUnsaturatedHigherKindedType env a b
+canonUnsaturatedHigherKindedType  a b
   | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a
-  , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env)
-  , (aks, _) <- unapplyKinds ak
-  , length axs < length aks = do
-      ak' <- lift $ do
-        let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak
-            instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps
-        unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs
-        pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak'
-      let (aks', _) = unapplyKinds ak'
-      tys <- traverse freshTypeWithKind $ drop (length axs) aks'
-      let a' = foldl' srcTypeApp a tys
-          b' = foldl' srcTypeApp b tys
-      pure . Canonicalized $ S.singleton (a', b')
+   = do
+      (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") <$> lookupTypeMb aTyName
+      let (aks, _) = unapplyKinds ak
+      if length axs < length aks
+        then do
+          ak' <- lift $ do
+            let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak
+                instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps
+            unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs
+            pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak'
+          let (aks', _) = unapplyKinds ak'
+          tys <- traverse freshTypeWithKind $ drop (length axs) aks'
+          let a' = foldl' srcTypeApp a tys
+              b' = foldl' srcTypeApp b tys
+          pure . Canonicalized $ S.singleton (a', b')
+        else empty
+      
+
   | otherwise = empty
 
 -- | Constraints of the form
@@ -629,23 +647,18 @@ data UnwrapNewtypeError
 -- | Unwraps a newtype and yields its underlying type with the newtype arguments
 -- substituted in (e.g. @N[D/a] = D@ given @newtype N a = N a@ and @data D = D@).
 unwrapNewtype
-  :: MonadState CheckState m
+  :: (MonadState CheckState m, GetEnv m)
   => MonadWriter [ErrorMessageHint] m
-  => Environment
-  -> SourceType
+  => SourceType
   -> m (Either UnwrapNewtypeError SourceType)
-unwrapNewtype env = go (0 :: Int) where
+unwrapNewtype = go (0 :: Int) where
   go n ty = runExceptT $ do
     when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain
     (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports
     case unapplyTypes ty of
-      (TypeConstructor _ newtypeName, ks, xs)
-        | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <-
-            lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName ks
-        -- We refuse to unwrap newtypes over polytypes because we don't know how
-        -- to canonicalize them yet and we'd rather try to make progress with
-        -- another rule.
-        , isMonoType wrappedTy -> do
+      (TypeConstructor _ newtypeName, ks, xs) -> do
+        lookupNewtypeConstructorInScope  currentModuleName currentModuleImports newtypeName ks >>= \case 
+          Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) | isMonoType wrappedTy -> do 
             unless inScope $ do
               tell [MissingConstructorImportForCoercible newtypeCtorName]
               throwError CannotUnwrapConstructor
@@ -654,6 +667,7 @@ unwrapNewtype env = go (0 :: Int) where
             ExceptT (go (n + 1) wrappedTySub) `catchError` \case
               CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain
               CannotUnwrapConstructor -> pure wrappedTySub
+          _ -> throwError CannotUnwrapConstructor
       _ -> throwError CannotUnwrapConstructor
   addConstructorImportForCoercible fromModuleName newtypeCtorName = modify $ \st ->
     st { checkConstructorImportsForCoercible = S.insert (fromModuleName, newtypeCtorName) $ checkConstructorImportsForCoercible st }
@@ -661,23 +675,28 @@ unwrapNewtype env = go (0 :: Int) where
 -- | Looks up a given name and, if it names a newtype, returns the names of the
 -- type's parameters, the type the newtype wraps and the names of the type's
 -- fields.
-lookupNewtypeConstructor
-  :: Environment
-  -> Qualified (ProperName 'TypeName)
+lookupNewtypeConstructor 
+  :: GetEnv m 
+  => MonadState CheckState m
+  => Qualified (ProperName 'TypeName)
   -> [SourceType]
-  -> Maybe ([Text], ProperName 'ConstructorName, SourceType)
-lookupNewtypeConstructor env qualifiedNewtypeName ks = do
-  (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env)
-  let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk
-      instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs ks
-  pure (map (\(name, _, _) -> name) tvs, ctorName, replaceAllTypeVars instantiatedKinds wrappedTy)
+  -> m (Maybe ([Text], ProperName 'ConstructorName, SourceType))
+lookupNewtypeConstructor qualifiedNewtypeName ks = do
+  nt <- lookupTypeUnsafe qualifiedNewtypeName
+  case nt of 
+    (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) -> do 
+      let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk
+          instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs ks
+      pure $ Just (map (\(name, _, _) -> name) tvs, ctorName, replaceAllTypeVars instantiatedKinds wrappedTy)
+    _ -> internalError "lookupNewtypeConstructor: not a newtype"
 
 -- | Behaves like 'lookupNewtypeConstructor' but also returns whether the
 -- newtype constructor is in scope and the module from which it is imported, or
 -- 'Nothing' if it is defined in the current module.
 lookupNewtypeConstructorInScope
-  :: Environment
-  -> Maybe ModuleName
+  :: GetEnv m 
+  => MonadState CheckState m 
+  => Maybe ModuleName
   -> [ ( SourceAnn
        , ModuleName
        , ImportDeclarationType
@@ -687,16 +706,19 @@ lookupNewtypeConstructorInScope
      ]
   -> Qualified (ProperName 'TypeName)
   -> [SourceType]
-  -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType)
-lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do
+  -> m (Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType))
+lookupNewtypeConstructorInScope currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do
   let fromModule = find isNewtypeCtorImported currentModuleImports
       fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule
       asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule
       isDefinedInCurrentModule = toMaybeModuleName newtypeModuleName == currentModuleName
       isImported = isJust fromModule
       inScope = isDefinedInCurrentModule || isImported
-  (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks
-  pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy)
+  ntCtr <- lookupNewtypeConstructor qualifiedNewtypeName ks
+  pure $ case ntCtr of
+    Nothing -> Nothing
+    Just (tvs, ctorName, wrappedTy) ->
+      pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy)
   where
   isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) =
     case M.lookup newtypeName exportedTypes of
@@ -714,13 +736,13 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali
 -- @Coercible a b@ if unwrapping the newtype yields @a@.
 canonNewtypeLeft
   :: MonadState CheckState m
+  => GetEnv m
   => MonadWriter [ErrorMessageHint] m
-  => Environment
-  -> SourceType
+  => SourceType
   -> SourceType
   -> MaybeT m Canonicalized
-canonNewtypeLeft env a b =
-  unwrapNewtype env a >>= \case
+canonNewtypeLeft a b =
+  unwrapNewtype a >>= \case
     Left CannotUnwrapInfiniteNewtypeChain -> empty
     Left CannotUnwrapConstructor -> empty
     Right a' -> pure . Canonicalized $ S.singleton (a', b)
@@ -729,13 +751,13 @@ canonNewtypeLeft env a b =
 -- @Coercible a b@ if unwrapping the newtype yields @b@.
 canonNewtypeRight
   :: MonadState CheckState m
+  => GetEnv m
   => MonadWriter [ErrorMessageHint] m
-  => Environment
-  -> SourceType
+  => SourceType
   -> SourceType
   -> MaybeT m Canonicalized
-canonNewtypeRight env =
-  flip $ canonNewtypeLeft env
+canonNewtypeRight =
+  flip canonNewtypeLeft 
 
 -- | Decomposes constraints of the form @Coercible (D a_0 .. a_n) (D b_0 .. b_n)@
 -- into constraints on their representational arguments, ignoring phantom
@@ -751,14 +773,14 @@ canonNewtypeRight env =
 -- We can decompose @Coercible (D a b d) (D a c e)@ into @Coercible b c@, but
 -- decomposing @Coercible (D a c d) (D b c d)@ would fail.
 decompose
-  :: MonadError MultipleErrors m
-  => Environment
-  -> Qualified (ProperName 'TypeName)
+  :: (MonadError MultipleErrors m, GetEnv m, MonadState CheckState m)
+  => Qualified (ProperName 'TypeName)
   -> [SourceType]
   -> [SourceType]
   -> m Canonicalized
-decompose env tyName axs bxs = do
-  let roles = lookupRoles env tyName
+decompose tyName axs bxs = do
+  roles <- lookupRoles tyName
+  let
       f role ax bx = case role of
         Nominal
           -- If we had first-class equality constraints, we'd just
@@ -781,16 +803,19 @@ decompose env tyName axs bxs = do
 -- @D@ is not a newtype, yield constraints on their arguments.
 canonDecomposition
   :: MonadError MultipleErrors m
-  => Environment
-  -> SourceType
+  => GetEnv m 
+  => MonadState CheckState m
+  => SourceType
   -> SourceType
   -> MaybeT m Canonicalized
-canonDecomposition env a b
+canonDecomposition a b
   | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a
   , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b
   , aTyName == bTyName
-  , Nothing <- lookupNewtypeConstructor env aTyName [] =
-      decompose env aTyName axs bxs
+  = do 
+    lookupNewtypeConstructor aTyName [] >>= \case
+      Just _ -> empty
+      _ -> decompose aTyName axs bxs
   | otherwise = empty
 
 -- | Constraints of the form @Coercible (D1 a_0 .. a_n) (D2 b_0 .. b_n)@, where
@@ -798,18 +823,21 @@ canonDecomposition env a b
 -- newtypes, are insoluble.
 canonDecompositionFailure
   :: MonadError MultipleErrors m
-  => Environment
-  -> SourceType
+  => GetEnv m
+  => MonadState CheckState m
+  => SourceType
   -> SourceType
   -> SourceType
   -> MaybeT m Canonicalized
-canonDecompositionFailure env k a b
+canonDecompositionFailure k a b
   | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a
   , (TypeConstructor _ bTyName, _, _) <- unapplyTypes b
-  , aTyName /= bTyName
-  , Nothing <- lookupNewtypeConstructor env aTyName []
-  , Nothing <- lookupNewtypeConstructor env bTyName [] =
-      throwError $ insoluble k a b
+  , aTyName /= bTyName = 
+  -- , Nothing <- lookupNewtypeConstructor aTyName []
+  -- , Nothing <- lookupNewtypeConstructor bTyName [] =
+    liftA2 (,) (lookupNewtypeConstructor aTyName []) (lookupNewtypeConstructor bTyName []) >>= \case
+      (Nothing, Nothing) -> throwError $ insoluble k a b
+      _ -> empty
   | otherwise = empty
 
 -- | Wanted constraints of the form @Coercible (N a_0 .. a_n) (N b_0 .. b_n)@,
@@ -846,21 +874,19 @@ canonDecompositionFailure env k a b
 -- @Coercible (Const a a) (Const a b)@ to @Coercible a b@ we would not be able
 -- to discharge it with the given.
 canonNewtypeDecomposition
-  :: MonadError MultipleErrors m
-  => Environment
-  -> Maybe [(SourceType, SourceType, SourceType)]
+  :: (MonadError MultipleErrors m, GetEnv m, MonadState CheckState m)
+  => Maybe [(SourceType, SourceType, SourceType)]
   -> SourceType
   -> SourceType
   -> MaybeT m Canonicalized
-canonNewtypeDecomposition env (Just givens) a b
+canonNewtypeDecomposition (Just givens) a b
   | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a
   , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b
-  , aTyName == bTyName
-  , Just _ <- lookupNewtypeConstructor env aTyName [] = do
+  , aTyName == bTyName = do
       let givensCanDischarge = any (\given -> canDischarge given (a, b)) givens
       guard $ not givensCanDischarge
-      decompose env aTyName axs bxs
-canonNewtypeDecomposition _ _ _ _ = empty
+      lift $ decompose aTyName axs bxs
+canonNewtypeDecomposition _ _ _ = empty
 
 -- | Constraints of the form @Coercible (N1 a_0 .. a_n) (N2 b_0 .. b_n)@, where
 -- @N1@ and @N2@ are different type constructors and either of them is a
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 2ea40f477c..ab440ccc5d 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -356,6 +356,11 @@ lookupType span' v =
     Nothing -> throwError . errorMessage' span' $ UnknownName $ fmap TyName v
     Just ty -> return ty
 
+lookupTypeUnsafe :: (MonadState CheckState m, GetEnv m) => Qualified (ProperName 'TypeName) -> m (SourceType, TypeKind)
+lookupTypeUnsafe qual = lookupTypeMb qual >>= \case 
+  Nothing -> internalError $ "lookupTypeUnsafe: Encountered unknown type in: " <> show qual
+  Just ty -> return ty
+
 -- | Lookup the kind of a type by name in the @Environment@
 lookupTypeVariable
   :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m)
diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs
index 7b38a317b7..c76563dd71 100644
--- a/src/Language/PureScript/TypeChecker/Roles.hs
+++ b/src/Language/PureScript/TypeChecker/Roles.hs
@@ -29,6 +29,8 @@ import Language.PureScript.Errors (DataConstructorDeclaration(..), MultipleError
 import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..))
 import Language.PureScript.Roles (Role(..))
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), freeTypeVariables, unapplyTypes)
+import Language.PureScript.Make.Index.Select (GetEnv)
+import Language.PureScript.TypeChecker.Monad (CheckState, lookupTypeMb)
 
 -- |
 -- A map of a type's formal parameter names to their roles. This type's
@@ -78,11 +80,21 @@ updateRoleEnv qualTyName roles' roleEnv =
 -- returns an empty list.
 --
 lookupRoles
-  :: Environment
-  -> Qualified (ProperName 'TypeName)
-  -> [Role]
-lookupRoles env tyName =
-  fromMaybe [] $ M.lookup tyName (types env) >>= typeKindRoles . snd
+  :: (GetEnv m, MonadState CheckState m)
+  => Qualified (ProperName 'TypeName)
+  -> m [Role]
+lookupRoles tyName = do 
+  tysMb <- lookupTypeMb tyName 
+  case tysMb of
+    Nothing -> pure []
+    Just ty -> 
+      pure $ fromMaybe [] $ typeKindRoles $ snd ty
+
+
+
+      -- fromMaybe (pure []) $ typeKindRoles . snd <$> M.lookup tyName tys
+ 
+  -- fromMaybe (pure []) $ M.lookup tyName (types env) >>= typeKindRoles . snd
 
 -- |
 -- Compares the inferred roles to the explicitly declared roles and ensures

From 91bb2e03f4d05c1d352340bf6a6de93c848f6b2d Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 20 Dec 2024 11:03:29 +0100
Subject: [PATCH 280/297] use db for type synonyms

---
 src/Language/PureScript/TypeChecker.hs        |   8 +-
 .../PureScript/TypeChecker/Deriving.hs        |   3 +-
 src/Language/PureScript/TypeChecker/Monad.hs  |  12 ++
 .../PureScript/TypeChecker/Synonyms.hs        | 123 +++++++++---------
 .../PureScript/TypeChecker/TypeSearch.hs      |   4 +-
 5 files changed, 84 insertions(+), 66 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 25eb52cedf..9b31f605ab 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -51,7 +51,7 @@ import Language.PureScript.Types qualified as P
 import Language.PureScript.Make.Index.Select (GetEnv (deleteModuleEnv, getTypeClass))
 
 addDataType
-  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => ModuleName
   -> DataDeclType
   -> ProperName 'TypeName
@@ -72,7 +72,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
       addDataConstructor moduleName dtype name dctor fields polyType
 
 addDataConstructor
-  :: (MonadState CheckState m, MonadError MultipleErrors m)
+  :: (MonadState CheckState m, MonadError MultipleErrors m, GetEnv m)
   => ModuleName
   -> DataDeclType
   -> ProperName 'TypeName
@@ -107,7 +107,7 @@ checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles)
       _ -> internalError "Unsupported role declaration"
 
 addTypeSynonym
-  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => ModuleName
   -> ProperName 'TypeName
   -> [(Text, Maybe SourceType)]
@@ -239,7 +239,7 @@ checkTypeClassInstance cls i = check where
 -- Check that type synonyms are fully-applied in a type
 --
 checkTypeSynonyms
-  :: (MonadState CheckState m, MonadError MultipleErrors m)
+  :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m)
   => SourceType
   -> m ()
 checkTypeSynonyms = void . replaceAllTypeSynonyms
diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs
index 57ce007594..613ec6e85d 100644
--- a/src/Language/PureScript/TypeChecker/Deriving.hs
+++ b/src/Language/PureScript/TypeChecker/Deriving.hs
@@ -211,7 +211,7 @@ lookupTypeInfo UnwrappedTypeConstructor{..} = do
 
 deriveEq
   :: forall m
-   . MonadError MultipleErrors m
+   . (MonadError MultipleErrors m, GetEnv m)
   => MonadState CheckState m
   => MonadSupply m
   => UnwrappedTypeConstructor
@@ -273,6 +273,7 @@ deriveEq1 = pure [(Libs.S_eq1, mkRef Libs.I_eq)]
 deriveOrd
   :: forall m
    . MonadError MultipleErrors m
+  => GetEnv m
   => MonadState CheckState m
   => MonadSupply m
   => UnwrappedTypeConstructor
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index ab440ccc5d..a502cab86c 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -361,6 +361,18 @@ lookupTypeUnsafe qual = lookupTypeMb qual >>= \case
   Nothing -> internalError $ "lookupTypeUnsafe: Encountered unknown type in: " <> show qual
   Just ty -> return ty
 
+
+lookupSynonymMb 
+  :: (MonadState CheckState m, GetEnv m)
+  => Qualified (ProperName 'TypeName) 
+  -> m (Maybe ([(Text, Maybe SourceType)], SourceType))
+lookupSynonymMb qual = do
+  env <- getEnv
+  case M.lookup qual (typeSynonyms env) of
+    Nothing -> do 
+      Select.getTypeSynonym qual
+    syn -> return syn
+
 -- | Lookup the kind of a type by name in the @Environment@
 lookupTypeVariable
   :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m)
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 1c17474f1e..7d25bb0845 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -2,79 +2,84 @@
 
 -- |
 -- Functions for replacing fully applied type synonyms
---
 module Language.PureScript.TypeChecker.Synonyms
-  ( SynonymMap
-  , KindMap
-  , replaceAllTypeSynonyms
-  ) where
+  ( SynonymMap,
+    KindMap,
+    replaceAllTypeSynonyms,
+  )
+where
 
-import Prelude
-
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.State (MonadState, StateT (runStateT), modify)
-import Data.Maybe (fromMaybe)
+import Control.Monad.Error.Class (MonadError (..))
+import Control.Monad.State (MonadState)
 import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import Language.PureScript.Environment (Environment(..), TypeKind)
-import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage')
-import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified)
-import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, addIdeSynonym)
-import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars)
-import Control.Monad.Except (Except, runExcept)
-import Data.Foldable (for_)
+import Language.PureScript.Environment (TypeKind)
+import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), SourceSpan, errorMessage')
+import Language.PureScript.Make.Index.Select (GetEnv)
+import Language.PureScript.Names (ProperName, ProperNameType (..), Qualified)
+import Language.PureScript.TypeChecker.Monad (CheckState, lookupSynonymMb, lookupTypeMb)
+import Language.PureScript.Types (SourceType, Type (..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars)
+import Prelude
 
 -- | Type synonym information (arguments with kinds, aliased type), indexed by name
 type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType)
 
 type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
 
-replaceAllTypeSynonyms'
-  :: SynonymMap
-  -> KindMap
-  -> SourceType
-  -> Either MultipleErrors (SourceType, [(SourceType, SourceType)])
-replaceAllTypeSynonyms' syns kinds  ty = runExcept $ runStateT (everywhereOnTypesTopDownM try ty) []
-  where
-  try :: SourceType -> StateT [(SourceType, SourceType)] (Except MultipleErrors) SourceType
-  try t = do
-    res <- go (fst $ getAnnForType t) 0 [] [] t
-    case res of
-      Just t' -> do
-        modify ((t, t') :)
-        pure t'
-      Nothing ->
-        pure t
-
-  go ::
-    SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType ->
-    StateT [(SourceType, SourceType)] (Except MultipleErrors) (Maybe SourceType)
-  go ss c kargs args (TypeConstructor _ ctor)
-    | Just (synArgs, body) <- M.lookup ctor syns
-    , c == length synArgs
-    , kindArgs <- lookupKindArgs ctor
-    , length kargs == length kindArgs
-    = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
-      in Just <$> try repl
-    | Just (synArgs, _) <- M.lookup ctor syns
-    , length synArgs > c
-    = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
-  go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
-  go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
-  go _ _ _ _ _ = return Nothing
+-- replaceAllTypeSynonyms'
+--   :: SynonymMap
+--   -> KindMap
+--   -> SourceType
+--   -> Either MultipleErrors SourceType
+-- replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try
+--   where
+--   try :: SourceType -> Either MultipleErrors SourceType
+--   try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
 
-  lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text]
-  lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds
+--   go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType)
+--   go ss c kargs args (TypeConstructor _ ctor)
+--     | Just (synArgs, body) <- M.lookup ctor syns
+--     , c == length synArgs
+--     , kindArgs <- lookupKindArgs ctor
+--     , length kargs == length kindArgs
+--     = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
+--       in Just <$> try repl
+--     | Just (synArgs, _) <- M.lookup ctor syns
+--     , length synArgs > c
+--     = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
+--   go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
+--   go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
+--   go _ _ _ _ _ = return Nothing
 
+--   lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text]
+--   lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds
 
 -- | Replace fully applied type synonyms
-replaceAllTypeSynonyms :: forall e m. (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType
-replaceAllTypeSynonyms d = do
-  env <- getEnv
-  either throwError trackUsedSynonym $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d
+replaceAllTypeSynonyms :: forall e m. (e ~ MultipleErrors, MonadState CheckState m, GetEnv m, MonadError e m) => SourceType -> m SourceType
+replaceAllTypeSynonyms = everywhereOnTypesTopDownM try
   where
-    trackUsedSynonym (found, syns) = do
-      for_ syns $ uncurry addIdeSynonym
-      pure found
+    try :: SourceType -> m SourceType
+    try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
 
+    go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> m (Maybe SourceType)
+    go ss c kargs args (TypeConstructor _ ctor) =
+      lookupSynonymMb ctor >>= \case
+        Just (synArgs, body)
+          | c == length synArgs -> do
+             kindArgs <- lookupKindArgs ctor
+             if length kargs == length kindArgs  then 
+              let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
+               in Just <$> try repl
+             else pure Nothing
+          | length synArgs > c ->
+              throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
+        _ -> return Nothing
+    go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
+    go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
+    go _ _ _ _ _ = return Nothing
 
+    lookupKindArgs :: Qualified (ProperName 'TypeName) -> m [Text]
+    lookupKindArgs ctor = do
+      k <- lookupTypeMb ctor
+      pure $ fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< k
diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs
index 4365201888..6758c86f4f 100644
--- a/src/Language/PureScript/TypeChecker/TypeSearch.hs
+++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs
@@ -54,7 +54,7 @@ checkSubsume
 checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do
   let initializeSkolems =
         Skolem.introduceSkolemScope
-        <=< P.replaceAllTypeSynonyms
+        <=< (runWoGetEnv . P.replaceAllTypeSynonyms)
         <=< P.replaceTypeWildcards
 
   userT' <- initializeSkolems userT
@@ -89,7 +89,7 @@ accessorSearch
 accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment env st $ do
   let initializeSkolems =
         Skolem.introduceSkolemScope
-        <=< P.replaceAllTypeSynonyms
+        <=< (runWoGetEnv . P.replaceAllTypeSynonyms)
         <=< P.replaceTypeWildcards
 
   userT' <- initializeSkolems userT

From 52c61119fc54c4512a63f99cee19752918d0ef51 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 20 Dec 2024 11:18:19 +0100
Subject: [PATCH 281/297] simple purs building

---
 .../TypeChecker/Entailment/Coercible.hs       |  2 +-
 .../PureScript/TypeChecker/Synonyms.hs        | 32 ++-----------------
 2 files changed, 3 insertions(+), 31 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
index 6afa4103f3..e0a121713a 100644
--- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs
@@ -688,7 +688,7 @@ lookupNewtypeConstructor qualifiedNewtypeName ks = do
       let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk
           instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs ks
       pure $ Just (map (\(name, _, _) -> name) tvs, ctorName, replaceAllTypeVars instantiatedKinds wrappedTy)
-    _ -> internalError "lookupNewtypeConstructor: not a newtype"
+    _ -> pure Nothing
 
 -- | Behaves like 'lookupNewtypeConstructor' but also returns whether the
 -- newtype constructor is in scope and the module from which it is imported, or
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 7d25bb0845..c07ad51fda 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -27,34 +27,6 @@ type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Source
 
 type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
 
--- replaceAllTypeSynonyms'
---   :: SynonymMap
---   -> KindMap
---   -> SourceType
---   -> Either MultipleErrors SourceType
--- replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try
---   where
---   try :: SourceType -> Either MultipleErrors SourceType
---   try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
-
---   go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType)
---   go ss c kargs args (TypeConstructor _ ctor)
---     | Just (synArgs, body) <- M.lookup ctor syns
---     , c == length synArgs
---     , kindArgs <- lookupKindArgs ctor
---     , length kargs == length kindArgs
---     = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
---       in Just <$> try repl
---     | Just (synArgs, _) <- M.lookup ctor syns
---     , length synArgs > c
---     = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
---   go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
---   go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
---   go _ _ _ _ _ = return Nothing
-
---   lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text]
---   lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds
-
 -- | Replace fully applied type synonyms
 replaceAllTypeSynonyms :: forall e m. (e ~ MultipleErrors, MonadState CheckState m, GetEnv m, MonadError e m) => SourceType -> m SourceType
 replaceAllTypeSynonyms = everywhereOnTypesTopDownM try
@@ -63,12 +35,12 @@ replaceAllTypeSynonyms = everywhereOnTypesTopDownM try
     try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t
 
     go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> m (Maybe SourceType)
-    go ss c kargs args (TypeConstructor _ ctor) =
+    go ss c kargs args (TypeConstructor _ ctor) = do
       lookupSynonymMb ctor >>= \case
         Just (synArgs, body)
           | c == length synArgs -> do
              kindArgs <- lookupKindArgs ctor
-             if length kargs == length kindArgs  then 
+             if length kargs == length kindArgs  then
               let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
                in Just <$> try repl
              else pure Nothing

From ef80b1082e9db70826d9b41e97ab2f050118b1b7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 27 Dec 2024 10:29:46 +0100
Subject: [PATCH 282/297] adds db env to corefn desugaring

---
 src/Language/PureScript/AST/Literals.hs      |   2 +-
 src/Language/PureScript/CoreFn/Desugar.hs    | 151 +++++++++++--------
 src/Language/PureScript/Make.hs              |  13 +-
 src/Language/PureScript/Make/Index/Select.hs |   2 +
 src/Language/PureScript/Sugar.hs             |   2 +-
 5 files changed, 103 insertions(+), 67 deletions(-)

diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index 5d4db34d5c..1a0e3611c7 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -39,4 +39,4 @@ data Literal a
   -- An object literal
   --
   | ObjectLiteral [(PSString, a)]
-  deriving (Eq, Ord, Show, Functor, Generic,  S.Serialise, NFData)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic,  S.Serialise, NFData)
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 34bf08f1f3..bf119ab00e 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -1,9 +1,9 @@
+{-# LANGUAGE BlockArguments #-}
 module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
 
 import Prelude
-import Protolude (ordNub, orEmpty)
+import Protolude (ordNub, orEmpty, (<&>), join, for)
 
-import Control.Arrow (second)
 
 import Data.Function (on)
 import Data.Maybe (mapMaybe)
@@ -21,26 +21,27 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..),
 import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..))
 import Language.PureScript.CoreFn.Module (Module(..))
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue)
+import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupValue)
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual)
 import Language.PureScript.PSString (PSString)
 import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..))
 import Language.PureScript.AST qualified as A
 import Language.PureScript.Constants.Prim qualified as C
+import Language.PureScript.Make.Index.Select (GetEnv (getDataConstructor))
 
 -- | Desugars a module from AST to CoreFn representation.
-moduleToCoreFn :: Environment -> A.Module -> Module Ann
+moduleToCoreFn :: forall m. (Monad m, GetEnv m) => Environment -> A.Module -> m (Module Ann)
 moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =
   internalError "Module exports were not elaborated before moduleToCoreFn"
-moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
+moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = do
   let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls)
       imports' = dedupeImports imports
       exps' = ordNub $ concatMap exportToCoreFn exps
       reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps)
       externs = ordNub $ mapMaybe externToCoreFn decls
-      decls' = concatMap declToCoreFn decls
-  in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls'
+  decls' <- join <$> traverse declToCoreFn decls
+  pure $ Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls'
   where
   -- Creates a map from a module name to the re-export references defined in
   -- that module.
@@ -62,8 +63,8 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
   ssA ss = (ss, [], Nothing)
 
   -- Desugars member declarations from AST to CoreFn representation.
-  declToCoreFn :: A.Declaration -> [Bind Ann]
-  declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) =
+  declToCoreFn :: A.Declaration -> m [Bind Ann]
+  declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = pure 
     [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $
       Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))]
     where
@@ -71,27 +72,39 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
   declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) =
     error $ "Found newtype with multiple constructors: " ++ show d
   declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) =
-    flip fmap ctors $ \ctorDecl ->
+    for ctors $ \ctorDecl -> do
       let
         ctor = A.dataCtorName ctorDecl
-        (_, _, _, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor)
-      in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields
+      (_, _, _, fields) <- lookupConstructor' (Qualified (ByModuleName mn) ctor)
+      return $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields
   declToCoreFn (A.DataBindingGroupDeclaration ds) =
-    concatMap declToCoreFn ds
-  declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) =
-    [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
-  declToCoreFn (A.BindingGroupDeclaration ds) =
-    [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds]
-  declToCoreFn _ = []
+    concat <$> traverse declToCoreFn ds
+  declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do 
+    cfn <- exprToCoreFn ss com Nothing e
+    pure [NonRec (ssA ss) name cfn]
+  declToCoreFn (A.BindingGroupDeclaration ds) = do 
+    exprs <- traverse (\(((ss, com), name), _, e) -> ((ssA ss, name),) <$>  exprToCoreFn ss com Nothing e) ds
+    pure  [Rec . NEL.toList $ exprs]
+  --       concatMap declToCoreFn ds
+  -- declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) =
+  --   [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
+  -- declToCoreFn (A.BindingGroupDeclaration ds) =
+  --   [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds]
+
+  declToCoreFn _ = return []
 
   -- Desugars expressions from AST to CoreFn representation.
-  exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann
-  exprToCoreFn _ com _ (A.Literal ss lit) =
-    Literal (ss, com, Nothing) (fmap (exprToCoreFn ss com Nothing) lit)
+  exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> m (Expr Ann)
+  exprToCoreFn _ com _ (A.Literal ss lit) = do 
+    cfs <- traverse (exprToCoreFn ss com Nothing) lit
+    pure $ Literal (ss, com, Nothing) cfs
+
   exprToCoreFn ss com _ (A.Accessor name v) =
-    Accessor (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v)
-  exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
-    ObjectUpdate (ss, com, Nothing) (exprToCoreFn ss [] Nothing obj) (ty >>= unchangedRecordFields (fmap fst vs)) $ fmap (second (exprToCoreFn ss [] Nothing)) vs
+    Accessor (ss, com, Nothing) name <$> exprToCoreFn ss [] Nothing v
+  exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = do
+    cfn <- exprToCoreFn ss [] Nothing obj
+    cfns <- traverse (\(ps, expr) -> (ps,) <$> exprToCoreFn ss [] Nothing expr) vs
+    pure $ ObjectUpdate (ss, com, Nothing) cfn (ty >>= unchangedRecordFields (fmap fst vs)) cfns
     where
     -- Return the unchanged labels of a closed record, or Nothing for other types or open records.
     unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString]
@@ -104,14 +117,14 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
         collect _ = Nothing
     unchangedRecordFields _ _ = Nothing
   exprToCoreFn ss com _ (A.Abs (A.VarBinder _ name) v) =
-    Abs (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v)
+    Abs (ss, com, Nothing) name <$> exprToCoreFn ss [] Nothing v
   exprToCoreFn _ _ _ (A.Abs _ _) =
     internalError "Abs with Binder argument was not desugared before exprToCoreFn mn"
-  exprToCoreFn ss com _ (A.App v1 v2) =
-    App (ss, com, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2'
+  exprToCoreFn ss com _ (A.App v1 v2) = do
+    v1' <- exprToCoreFn ss [] Nothing v1
+    v2' <- exprToCoreFn ss [] Nothing v2
+    pure $ App (ss, com, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2'
     where
-    v1' = exprToCoreFn ss [] Nothing v1
-    v2' = exprToCoreFn ss [] Nothing v2
     isDictCtor = \case
       A.Constructor _ (Qualified _ name) -> isDictTypeName name
       _ -> False
@@ -122,57 +135,67 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
       A.Unused{}             -> True
       _                      -> False
   exprToCoreFn ss com _ (A.Unused _) =
-    Var (ss, com, Nothing) C.I_undefined
+    return $ Var (ss, com, Nothing) C.I_undefined
   exprToCoreFn _ com _ (A.Var ss ident) =
-    Var (ss, com, getValueMeta ident) ident
-  exprToCoreFn ss com _ (A.IfThenElse v1 v2 v3) =
-    Case (ss, com, Nothing) [exprToCoreFn ss [] Nothing v1]
+    return $ Var (ss, com, getValueMeta ident) ident
+  exprToCoreFn ss com _ (A.IfThenElse v1 v2 v3) = do 
+    if' <- exprToCoreFn ss [] Nothing v1
+    then' <- exprToCoreFn ss [] Nothing v2
+    else' <- exprToCoreFn ss [] Nothing v3
+    return $ Case (ss, com, Nothing) [if']
       [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True]
-                        (Right $ exprToCoreFn ss [] Nothing v2)
+                        (Right then')
       , CaseAlternative [NullBinder (ssAnn ss)]
-                        (Right $ exprToCoreFn ss [] Nothing v3) ]
-  exprToCoreFn _ com _ (A.Constructor ss name) =
-    Var (ss, com, Just $ getConstructorMeta name) $ fmap properToIdent name
+                        (Right else')]
+  exprToCoreFn _ com _ (A.Constructor ss name) = do
+    meta <- getConstructorMeta name
+    return $ Var (ss, com, Just meta) $ fmap properToIdent name
   exprToCoreFn ss com _ (A.Case vs alts) =
-    Case (ss, com, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts)
+    Case (ss, com, Nothing) <$> traverse (exprToCoreFn ss [] Nothing) vs <*> traverse (altToCoreFn ss) alts
   exprToCoreFn ss com _ (A.TypedValue _ v ty) =
     exprToCoreFn ss com (Just ty) v
-  exprToCoreFn ss com _ (A.Let w ds v) =
-    Let (ss, com, getLetMeta w) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v)
+  exprToCoreFn ss com _ (A.Let w ds v) = do 
+    ds' <- join <$> traverse declToCoreFn ds
+    Let (ss, com, getLetMeta w) ds' <$> exprToCoreFn ss [] Nothing v
   exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
     exprToCoreFn ss (com ++ com1) ty v
   exprToCoreFn _ _ _ e =
     error $ "Unexpected value in exprToCoreFn mn: " ++ show e
 
   -- Desugars case alternatives from AST to CoreFn representation.
-  altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
-  altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)
+  altToCoreFn :: SourceSpan -> A.CaseAlternative -> m (CaseAlternative Ann)
+  altToCoreFn ss (A.CaseAlternative bs vs) = do 
+    bs' <- traverse (binderToCoreFn ss []) bs
+    res <- go vs
+    return $ CaseAlternative bs' res
     where
-    go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
+    go :: [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann))
     go [A.MkUnguarded e]
-      = Right (exprToCoreFn ss [] Nothing e)
+      = Right <$> exprToCoreFn ss [] Nothing e
     go gs
-      = Left [ (exprToCoreFn ss [] Nothing cond, exprToCoreFn ss [] Nothing e)
-             | A.GuardedExpr g e <- gs
-             , let cond = guardToExpr g
-             ]
+      = Left <$> for gs \(A.GuardedExpr g e)-> do 
+        g' <- exprToCoreFn ss [] Nothing (guardToExpr g)
+        e' <- exprToCoreFn ss [] Nothing e
+        return (g', e')
 
+    guardToExpr :: [A.Guard] -> A.Expr
     guardToExpr [A.ConditionGuard cond] = cond
     guardToExpr _ = internalError "Guard not correctly desugared"
 
   -- Desugars case binders from AST to CoreFn representation.
-  binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann
-  binderToCoreFn _ com (A.LiteralBinder ss lit) =
-    LiteralBinder (ss, com, Nothing) (fmap (binderToCoreFn ss com) lit)
+  binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> m (Binder Ann)
+  binderToCoreFn _ com (A.LiteralBinder ss lit) = 
+    LiteralBinder (ss, com, Nothing) <$> traverse (binderToCoreFn ss com) lit
   binderToCoreFn ss com A.NullBinder =
-    NullBinder (ss, com, Nothing)
+    return $ NullBinder (ss, com, Nothing)
   binderToCoreFn _ com (A.VarBinder ss name) =
-    VarBinder (ss, com, Nothing) name
-  binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) =
-    let (_, tctor, _, _) = lookupConstructor env dctor
-    in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs)
+     return $ VarBinder (ss, com, Nothing) name
+  binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = do
+    (_, tctor, _, _) <- lookupConstructor' dctor
+    meta <- getConstructorMeta dctor
+    ConstructorBinder (ss, com, Just meta) (Qualified mn' tctor) dctor <$> traverse (binderToCoreFn ss []) bs
   binderToCoreFn _ com (A.NamedBinder ss name b) =
-    NamedBinder (ss, com, Nothing) name (binderToCoreFn ss [] b)
+    NamedBinder (ss, com, Nothing) name <$> binderToCoreFn ss [] b
   binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
     binderToCoreFn ss (com ++ com1) b
   binderToCoreFn ss com (A.TypedBinder _ b) =
@@ -197,9 +220,9 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
       _ -> Nothing
 
   -- Gets metadata for data constructors.
-  getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta
+  getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> m Meta
   getConstructorMeta ctor =
-    case lookupConstructor env ctor of
+    lookupConstructor' ctor <&> \case
       (Newtype, _, _, _) -> IsNewtype
       dc@(Data, _, _, fields) ->
         let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
@@ -217,6 +240,16 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
     typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
     typeConstructor _ = internalError "Invalid argument to typeConstructor"
 
+  lookupConstructor' :: Qualified (ProperName 'ConstructorName) -> m (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
+  lookupConstructor' name =   case M.lookup name (dataConstructors env) of
+    Nothing -> do 
+      ctrMb <- getDataConstructor name 
+      case ctrMb of 
+        Nothing -> internalError $ "Constructor " ++ show name ++ " not found in environment"
+        Just ctr -> return  ctr
+    Just ctr -> return ctr
+
+
 -- | Find module names from qualified references to values. This is used to
 -- ensure instances are imported from any module that is referenced by the
 -- current module, not just from those that are imported explicitly (#667).
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index d7c3e5ecb0..7d0f1f4b8c 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -49,7 +49,7 @@ import Language.PureScript.Make.Actions as Actions
 import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult)
 import Language.PureScript.Make.BuildPlan qualified as BuildPlan
 import Language.PureScript.Make.Cache qualified as Cache
-import Language.PureScript.Make.Index.Select (getModuleFixities, selectFixitiesFromModuleImportsAndDecls, selectFixitiesFromModuleImports, GetEnv, runDbEnv, runWoGetEnv)
+import Language.PureScript.Make.Index.Select (getModuleFixities, selectFixitiesFromModuleImportsAndDecls, selectFixitiesFromModuleImports, GetEnv (deleteModuleEnv), runDbEnv, runWoGetEnv)
 import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
 import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName)
@@ -140,7 +140,8 @@ rebuildModuleWithProvidedEnv initialCheckState MakeActions {..} exEnv env extern
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
 
-      corefn = CF.moduleToCoreFn env' mod'
+  corefn <- runWoGetEnv $ CF.moduleToCoreFn env' mod'
+  let 
       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
       exts = moduleToExternsFile mod' env' renamedIdents
@@ -196,7 +197,8 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
 
-      corefn = CF.moduleToCoreFn env' mod'
+  corefn <- runDbEnv conn $ CF.moduleToCoreFn env' mod'
+  let 
       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
       exts = moduleToExternsFile mod' env' renamedIdents
@@ -268,6 +270,7 @@ desugarAndTypeCheckDb ::
   Env ->
   m ((Module, CheckState), Integer)
 desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv = runSupplyT 0 $ do
+  runDbEnv conn $ deleteModuleEnv moduleName
   (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn exEnv withPrim) (exEnv, mempty)
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
   -- env <- selectEnvFromDefinitions conn exEnv' desugared
@@ -431,9 +434,7 @@ make ma@MakeActions {..} ms = do
             (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do
               -- Eventlog markers for profiling; see debug/eventlog.js
               liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start"
-              -- Force the externs and warnings to avoid retaining excess module
-              -- data after the module is finished compiling.
-              extsAndWarnings <- evaluate . force <=< listen $ do
+              extsAndWarnings <- listen $ do
                 rebuildModuleWithIndexDb ma conn env m (Just (idx, cnt))
               liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
               return extsAndWarnings
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index f870cbeef0..e7867362be 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -78,6 +78,8 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
 selectFixitiesFromModuleImports :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImports conn env (P.Module _ _ _modName decls _refs) = do
   valueOps <- onImports selectImportValueFixities
+  when (_modName == P.ModuleName "Data.NonEmpty") do 
+    putErrText $ "valueOps: " <> show valueOps
   typeOps <- onImports selectImportTypeFixities
   pure (valueOps, typeOps)
   where
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index c9c0c6fdb8..387e93c8e9 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -80,7 +80,7 @@ desugarUsingDb ::
   Env ->
   Module ->
   m Module
-desugarUsingDb conn  env =
+desugarUsingDb conn env = do 
   desugarSignedLiterals
     >>> desugarObjectConstructors
     >=> desugarDoModule

From 98bcacc509301b3123a5e5c1c069c1acdb7deaed Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 27 Dec 2024 14:26:10 +0100
Subject: [PATCH 283/297] dont store ide imports

---
 src/Language/PureScript/CoreFn/Desugar.hs    | 12 ++--
 src/Language/PureScript/Make/Index/Select.hs | 17 +++---
 src/Language/PureScript/Renamer.hs           | 63 ++++++++++----------
 src/Language/PureScript/TypeChecker.hs       |  9 ---
 4 files changed, 47 insertions(+), 54 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index bf119ab00e..4e398d879e 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -85,12 +85,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = do
   declToCoreFn (A.BindingGroupDeclaration ds) = do 
     exprs <- traverse (\(((ss, com), name), _, e) -> ((ssA ss, name),) <$>  exprToCoreFn ss com Nothing e) ds
     pure  [Rec . NEL.toList $ exprs]
-  --       concatMap declToCoreFn ds
-  -- declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) =
-  --   [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
-  -- declToCoreFn (A.BindingGroupDeclaration ds) =
-  --   [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds]
-
+  
   declToCoreFn _ = return []
 
   -- Desugars expressions from AST to CoreFn representation.
@@ -104,6 +99,9 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = do
   exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = do
     cfn <- exprToCoreFn ss [] Nothing obj
     cfns <- traverse (\(ps, expr) -> (ps,) <$> exprToCoreFn ss [] Nothing expr) vs
+
+    -- ObjectUpdate (ss, com, Nothing) (exprToCoreFn ss [] Nothing obj) (ty >>= unchangedRecordFields (fmap fst vs)) $ fmap (second (exprToCoreFn ss [] Nothing)) vs
+
     pure $ ObjectUpdate (ss, com, Nothing) cfn (ty >>= unchangedRecordFields (fmap fst vs)) cfns
     where
     -- Return the unchanged labels of a closed record, or Nothing for other types or open records.
@@ -155,7 +153,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = do
   exprToCoreFn ss com _ (A.TypedValue _ v ty) =
     exprToCoreFn ss com (Just ty) v
   exprToCoreFn ss com _ (A.Let w ds v) = do 
-    ds' <- join <$> traverse declToCoreFn ds
+    ds' <- concat <$> traverse declToCoreFn ds
     Let (ss, com, getLetMeta w) ds' <$> exprToCoreFn ss [] Nothing v
   exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
     exprToCoreFn ss (com ++ com1) ty v
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index e7867362be..b782ba8bc7 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -78,23 +78,26 @@ getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTy
 selectFixitiesFromModuleImports :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
 selectFixitiesFromModuleImports conn env (P.Module _ _ _modName decls _refs) = do
   valueOps <- onImports selectImportValueFixities
-  when (_modName == P.ModuleName "Data.NonEmpty") do 
-    putErrText $ "valueOps: " <> show valueOps
+  -- when (_modName == P.ModuleName "Data.NonEmpty") do 
+  -- putErrText $ show _modName
+  -- putErrText $ "valueOps: " <> show valueOps
   typeOps <- onImports selectImportTypeFixities
   pure (valueOps, typeOps)
   where
-    onImports ::
+    onImports :: Ord a =>
       (Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, a)]) ->
       IO [(P.ModuleName, [a])]
     onImports fn = groupByModule . join . catMaybes <$> forConcurrently decls (whenImportDecl (fn conn env))
 
-    whenImportDecl :: (P.ModuleName -> ImportDeclarationType -> IO a) -> P.Declaration -> IO (Maybe a)
+    whenImportDecl :: (P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, a)]) -> P.Declaration -> IO (Maybe [(P.ModuleName, a)])
     whenImportDecl f = \case
-      P.ImportDeclaration _ mn' idt _ -> Just <$> f mn' idt
+      P.ImportDeclaration _ mn' idt importedAs -> Just  <$> f mn' idt
+        where 
+          addImportedAs (mn'', a) = (fromMaybe mn'' importedAs, a)
       _ -> pure Nothing
 
-    groupByModule :: [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
-    groupByModule = Map.toList . Map.fromListWith (<>) . fmap (fmap pure)
+    groupByModule :: Ord a => [(P.ModuleName, a)] -> [(P.ModuleName, [a])]
+    groupByModule = Map.toList . fmap ordNub . Map.fromListWith (<>) . fmap (fmap pure)
 
 selectImportValueFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, ExternsFixity)]
 selectImportValueFixities conn env modName = \case
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index aff42ca288..548634d3b4 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -16,7 +16,7 @@ import Data.Set qualified as S
 import Data.Text qualified as T
 
 import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), Expr(..), Literal(..), Module(..))
-import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent, showIdent)
+import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent)
 import Language.PureScript.Traversals (eitherM, pairM, sndM)
 
 -- |
@@ -87,13 +87,14 @@ updateScope ident =
 -- |
 -- Finds the new name to use for an ident.
 --
-lookupIdent :: Ident -> Rename Ident
-lookupIdent UnusedIdent = return UnusedIdent
-lookupIdent name = do
+lookupIdent :: a -> Ident -> Rename Ident
+lookupIdent _ UnusedIdent = return UnusedIdent
+lookupIdent _modName name = do
   name' <- gets $ M.lookup name . rsBoundNames
   case name' of
     Just name'' -> return name''
-    Nothing -> error $ "Rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'"
+    Nothing -> pure name
+      --  error $ "In " ++ show modName ++ " rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'"
 
 
 -- |
@@ -102,10 +103,10 @@ lookupIdent name = do
 -- externs files as well.
 --
 renameInModule :: Module Ann -> (M.Map Ident Ident, Module Ann)
-renameInModule m@(Module _ _ _ _ _ exports _ foreigns decls) = (rsBoundNames, m { moduleExports, moduleDecls })
+renameInModule m@(Module _ _ name _ _ exports _ foreigns decls) = (rsBoundNames, m { moduleExports, moduleDecls })
   where
   ((moduleDecls, moduleExports), RenameState{..}) = runRename foreigns $
-    (,) <$> renameInDecls decls <*> traverse lookupIdent exports
+    (,) <$> renameInDecls decls <*> traverse (lookupIdent name) exports
 
 -- |
 -- Renames within a list of declarations. The list is processed in three
@@ -152,38 +153,38 @@ renameInDecls =
 
   renameValuesInDecl :: Bind Ann -> Rename (Bind Ann)
   renameValuesInDecl = \case
-    NonRec a name val -> NonRec a name <$> renameInValue val
+    NonRec a name val -> NonRec a name <$> renameInValue name val
     Rec ds -> Rec <$> traverse updateValues ds
     where
     updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
-    updateValues (aname, val) = (aname, ) <$> renameInValue val
+    updateValues (aname, val) = (aname, ) <$> renameInValue (snd aname) val
 
 -- |
 -- Renames within a value.
 --
-renameInValue :: Expr Ann -> Rename (Expr Ann)
-renameInValue (Literal ann l) =
-  Literal ann <$> renameInLiteral renameInValue l
-renameInValue c@Constructor{} = return c
-renameInValue (Accessor ann prop v) =
-  Accessor ann prop <$> renameInValue v
-renameInValue (ObjectUpdate ann obj copy vs) =
-  (\obj' -> ObjectUpdate ann obj' copy) <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs
-renameInValue (Abs ann name v) =
-  newScope $ Abs ann <$> updateScope name <*> renameInValue v
-renameInValue (App ann v1 v2) =
-  App ann <$> renameInValue v1 <*> renameInValue v2
-renameInValue (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) =
+renameInValue :: Ident -> Expr Ann -> Rename (Expr Ann)
+renameInValue declName (Literal ann l) =
+  Literal ann <$> renameInLiteral (renameInValue declName) l
+renameInValue _ c@Constructor{} = return c
+renameInValue declName (Accessor ann prop v) =
+  Accessor ann prop <$> renameInValue declName v
+renameInValue declName (ObjectUpdate ann obj copy vs) =
+  (\obj' -> ObjectUpdate ann obj' copy) <$> renameInValue declName obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue declName v) vs
+renameInValue declName (Abs ann name v) =
+  newScope $ Abs ann <$> updateScope name <*> renameInValue declName v
+renameInValue declName (App ann v1 v2) =
+  App ann <$> renameInValue declName v1 <*> renameInValue declName v2
+renameInValue declName (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) =
   -- This should only rename identifiers local to the current module: either
   -- they aren't qualified, or they are but they have a name that should not
   -- have appeared in a module's externs, so they must be from this module's
   -- top-level scope.
-  Var ann . Qualified qb <$> lookupIdent name
-renameInValue v@Var{} = return v
-renameInValue (Case ann vs alts) =
-  newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts
-renameInValue (Let ann ds v) =
-  newScope $ Let ann <$> renameInDecls ds <*> renameInValue v
+  Var ann . Qualified qb <$> lookupIdent (declName, qb) name
+renameInValue _ v@Var{} = return v
+renameInValue declName (Case ann vs alts) =
+  newScope $ Case ann <$> traverse (renameInValue declName) vs <*> traverse (renameInCaseAlternative declName) alts
+renameInValue declName (Let ann ds v) =
+  newScope $ Let ann <$> renameInDecls ds <*> renameInValue declName v
 
 -- |
 -- Renames within literals.
@@ -196,10 +197,10 @@ renameInLiteral _ l = return l
 -- |
 -- Renames within case alternatives.
 --
-renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)
-renameInCaseAlternative (CaseAlternative bs v) = newScope $
+renameInCaseAlternative :: Ident -> CaseAlternative Ann -> Rename (CaseAlternative Ann)
+renameInCaseAlternative  name (CaseAlternative bs v) = newScope $
   CaseAlternative <$> traverse renameInBinder bs
-                  <*> eitherM (traverse (pairM renameInValue renameInValue)) renameInValue v
+                  <*> eitherM (traverse (pairM (renameInValue name) (renameInValue name))) (renameInValue name) v
 
 -- |
 -- Renames within binders.
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 9b31f605ab..05dc205823 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -615,15 +615,6 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) =
   warnAndRethrow (addHint (ErrorInModule mn)) $ do
     deleteModuleEnv mn
     let (decls', imports) = partitionEithers $ fromImportDecl <$> decls
-    for_ imports $ \((modSS,_), mName, idType, _, _) -> do 
-      addIdeModule modSS mName
-      let 
-        refs = 
-          case idType of 
-            Explicit refs' -> refs'
-            Hiding refs' -> refs'
-            _ -> []
-      for_ refs (addIdeImport mName)
     modify (\s -> s { checkCurrentModule = Just mn, checkCurrentModuleImports = imports })
     decls'' <- typeCheckAll mn $ ignoreWildcardsUnderCompleteTypeSignatures <$> decls'
     checkSuperClassesAreExported <- getSuperClassExportCheck

From 96daaf98903e89d615dcab63d40fcb69dbdb51e3 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 27 Dec 2024 14:34:46 +0100
Subject: [PATCH 284/297] remove comments

---
 src/Language/PureScript/Make/Index/Select.hs | 555 -------------------
 1 file changed, 555 deletions(-)

diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index b782ba8bc7..e1d1a6eb00 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -179,93 +179,6 @@ type ClassDict =
         (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty NamedDict))
     )
 
--- selectEnvFromDefinitions :: forall m. (MonadIO m) => Connection -> P.Env -> P.Module -> m E.Environment
--- selectEnvFromDefinitions conn _exportEnv (P.Module _ _ modName decls _) = liftIO do
---   -- when (modName == P.ModuleName "Data.BooleanAlgebra") do
---   --   putErrText "de"
---   --   putErrText "\n"
---   --   putErrText $ T.intercalate "\n\n" (show <$> decls)
---   updates <- catMaybes <$> forConcurrently usedNames (import' E.initEnvironment)
---   let env = pipe (fmap snd updates) E.initEnvironment
---   addEnvTypes env
---   where
---     addEnvTypes :: E.Environment -> IO E.Environment
---     addEnvTypes env = do
---       let toImport = getTypesToImportFromEnv env
---       updates <- catMaybes <$> forConcurrently (Set.toList $ getTypesToImportFromEnv env) (import' env)
---       putErrText $ show modName
---       when (modName == P.ModuleName "Data.Show") do
---         putErrText "\n"
---         putErrText $ T.pack $ intercalate "\n" (show <$> Set.toList toImport)
---         putErrText "\n"
---         -- putErrText $ T.pack $ intercalate "\n" (P.debugTypeClassDictionaries env)
---         putErrText "\n\n"
---         putErrText ("updates: " <> show (length updates))
---         putErrText (T.intercalate "\n" $ fmap (show . fst) updates)
-
---       let newEnv = pipe (fmap snd updates) env
---       case updates of
---         [] -> pure env
---         _ 
---           | newEnv /= env -> 
---             addEnvTypes $ pipe (fmap snd updates) env
---           | otherwise ->  pure env
-
---     usedNames = Set.toList $ Set.unions $ getUsedNames <$> decls
-
---     import' :: E.Environment -> P.Qualified ToImport -> IO (Maybe (P.Qualified ToImport, E.Environment -> E.Environment))
---     import' env ti@(P.Qualified (P.ByModuleName mName) name) | mName /= modName = fmap (ti,) <$> do
---       case name of
---         TiIdent ident -> do
---           let qual = P.Qualified (P.ByModuleName mName) ident
---           if Map.member qual (E.names env)
---             then pure Nothing
---             else do
---               val <- selectEnvValue conn qual
---               pure $ Just $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---         TiType tyName -> do
---           let qual = P.Qualified (P.ByModuleName mName) tyName
---           if Map.member qual (E.types env) || Map.member qual (E.typeSynonyms env)
---             then pure Nothing
---             else do
---               type' <- selectType conn qual
---               pure $ Just $ \env' -> env' {E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual type')]}
---         TiDctor ctrName -> do
---           let qual = P.Qualified (P.ByModuleName mName) ctrName
---           if Map.member qual (E.dataConstructors env)
---             then pure Nothing
---             else do
---               val <- selectDataConstructor conn qual
---               pure $ Just $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJust val)]}
---         TiClass className -> do
---           let qual = P.Qualified (P.ByModuleName mName) className
---           if Map.member qual (E.typeClasses env)
---             then pure Nothing
---             else do
---               typeClass <- selectTypeClass conn mName className
---               pure $ Just $ \env' -> env' {E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, fromJust typeClass)]}
---         TiDeferredDictionary className -> do
---           let qual = P.Qualified (P.ByModuleName mName) className
---           instances <- selectClassInstancesByClassName conn qual
-
---           let dictInEnv _d =
---                 Map.lookup (P.ByModuleName mName) (E.typeClassDictionaries env)
---                   & maybe False (Map.member qual)
---                   -- & maybe False (Map.member (P.tcdValue d))
-
---           when (modName == P.ModuleName "Data.Show") do
---             putErrText $ T.pack $ intercalate "\n" (P.debugTypeClassDictionaries env)
---             putErrText $ "instances: "
---             for_ instances \i -> do 
---               putErrText $ show i
---               putErrText $ show $ dictInEnv i
-
-
---           if all dictInEnv instances
---               then pure Nothing
---               else pure $ Just $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')}
---     import' _ _ = pure Nothing
-
 getTypesToImportFromEnv :: P.Environment -> Set (P.Qualified ToImport)
 getTypesToImportFromEnv env =
   nameImports
@@ -403,457 +316,6 @@ data ToImport
   | TiDeferredDictionary (P.ProperName 'P.ClassName)
   deriving (Show, Eq, Ord)
 
--- (handleDecl, _, _) = P.everywhereOnValuesM onDecl onExpr pure
-
--- -- onDecl :: P.Declaration -> Writer (Set (P.Qualified P.ProperName)) P.Declaration
--- onDecl d = do
---   let (declTypeNames, _, _, _, _) = P.accumTypes (P.everythingOnTypes (<>) _)
---   tell $ Set.map (fmap P.coerceProperName) $ declTypeNames d
---   pure d
--- onExpr = pure
-
--- selectEnvFromImports :: (MonadIO m) => Connection -> P.Env -> P.UsedImports -> P.Module -> m E.Environment
--- selectEnvFromImports conn exportEnv _usedImports (P.Module _ _ modName decls exportedRefs) = liftIO do
---   insertExports conn modName exportedRefs
---   insertImports conn modName decls
---   importFn <-
---     ( onImportMap P.importedTypes \typeImport ->
---         do
---           let tyName = P.disqualify $ P.importName typeImport
---           synMb <- selectTypeSynonym' conn (P.importSourceModule typeImport) tyName
---           case synMb of
---             Just syn -> do
---               pure $ \env' ->
---                 env'
---                   { E.typeSynonyms =
---                       E.typeSynonyms env'
---                         <> Map.fromList
---                           [ (P.importName typeImport, syn),
---                             (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, syn)
---                           ]
---                   }
---             Nothing -> do
---               type' <- selectType' conn (P.importSourceModule typeImport) tyName
---               pure $ \env' ->
---                 env'
---                   { E.types =
---                       E.types env'
---                         <> Map.fromList
---                           [ (P.importName typeImport, fromJust type'),
---                             (P.Qualified (P.ByModuleName $ P.importSourceModule typeImport) tyName, fromJust type')
---                           ]
---                   }
---       )
---       `updateConcurrently` ( onImportMap P.importedDataConstructors \ctrImport ->
---                                do
---                                  let ctrName = P.disqualify $ P.importName ctrImport
---                                      qualified = P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName
---                                  ctr <- selectDataConstructor conn (P.Qualified (P.ByModuleName $ P.importSourceModule ctrImport) ctrName)
---                                  pure $ \env' ->
---                                    env'
---                                      { E.dataConstructors =
---                                          E.dataConstructors env'
---                                            <> Map.fromList
---                                              [ (P.importName ctrImport, fromJust ctr),
---                                                (qualified, fromJust ctr)
---                                              ]
---                                      }
---                            )
---       `updateConcurrently` ( onImportMap P.importedTypeClasses \classImport ->
---                                importClass (P.importSourceModule classImport) (P.importName classImport) (P.disqualify $ P.importName classImport)
---                            )
---       `updateConcurrently` ( onImportMap P.importedValues \valImport -> do
---                                let ident = P.disqualify $ P.importName valImport
---                                val <- selectEnvValue conn (P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident)
---                                pure $ \env' ->
---                                  env'
---                                    { E.names =
---                                        E.names env'
---                                          <> Map.fromList
---                                            [ ( P.importName valImport,
---                                                fromJustWithErr (modName, P.importSourceModule valImport, ident) val
---                                              ),
---                                              ( P.Qualified (P.ByModuleName $ P.importSourceModule valImport) ident,
---                                                fromJustWithErr (modName, P.importSourceModule valImport, ident) val
---                                              )
---                                            ]
---                                    }
---                            )
---       `updateConcurrently` ( onImportMap P.importedTypeOps \opImport -> do
---                                let opName = P.disqualify $ P.importName opImport
---                                (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn (P.importSourceModule opImport) opName
---                                synMb <- selectTypeSynonym' conn aliasModName alias
---                                case synMb of
---                                  Just syn -> do
---                                    pure $ \env' ->
---                                      env'
---                                        { E.typeSynonyms =
---                                            E.typeSynonyms env'
---                                              <> Map.fromList
---                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, syn),
---                                                  (P.Qualified (P.ByModuleName aliasModName) alias, syn)
---                                                ]
---                                        }
---                                  Nothing -> do
---                                    type' <- selectType' conn aliasModName alias
---                                    pure $ \env' ->
---                                      env'
---                                        { E.types =
---                                            E.types env'
---                                              <> Map.fromList
---                                                [ (P.Qualified (P.ByModuleName (P.importSourceModule opImport)) alias, fromJustWithErr opName type'),
---                                                  (P.Qualified (P.ByModuleName aliasModName) alias, fromJustWithErr opName type')
---                                                ]
---                                        }
---                            )
---       `updateConcurrently` ( onImportMap P.importedValueOps \opImport -> do
---                                let opName = P.disqualify $ P.importName opImport
---                                (aliasModName, alias) <- fromJustWithErr opName <$> selectValueOperatorAlias conn (P.importSourceModule opImport) opName
---                                if isUpper $ T.head alias
---                                  then do
---                                    let ctrName = P.ProperName alias
---                                        qual = P.Qualified (P.ByModuleName aliasModName) ctrName
---                                    val <- selectDataConstructor conn qual
---                                    pure $ \env' ->
---                                      env'
---                                        { E.dataConstructors =
---                                            E.dataConstructors env'
---                                              <> Map.fromList [(qual, fromJustWithErr qual val)]
---                                        }
---                                  else do
---                                    let ident = P.Ident alias
---                                        qual = P.Qualified (P.ByModuleName aliasModName) ident
---                                    val <- selectEnvValue conn qual
---                                    pure $ \env' ->
---                                      env'
---                                        { E.names =
---                                            E.names env'
---                                              <> Map.fromList [(qual, fromJustWithErr qual val)]
---                                        }
---                            )
-
---   let env = importFn E.initEnvironment
-
---   envConstraintFns <- forConcurrently (getEnvConstraints env) \c -> do
---     let (classMod, className) = toDbQualifer $ constraintClass c
---     importClass' classMod classMod className
-
---   pure $ foldl' (&) env envConstraintFns
---   where
---     -- importName :: P.ModuleName -> P.Name -> IO (E.Environment -> E.Environment)
---     -- importName mName name = _ importRef mName $  getImportSrc mName name
---     imports :: P.Imports
---     imports = lookupImports modName exportEnv
-
---     onImportMap ::
---       ( P.Imports ->
---         Map
---           (P.Qualified a)
---           [P.ImportRecord a]
---       ) ->
---       ( P.ImportRecord a ->
---         IO (P.Environment -> P.Environment)
---       ) ->
---       IO (P.Environment -> P.Environment)
---     onImportMap getImports fn =
---       pipe <$> forConcurrently (Map.toList $ getImports imports) \(_, recs) ->
---         pipe <$> forConcurrently recs fn'
---       where
---         fn' ir = if P.importSourceModule ir == modName then pure identity else fn ir
-
---     -- importValue :: P.ModuleName -> P.Qualified P.Ident -> IO (E.Environment -> E.Environment)
---     -- importValue mName = \case
---     --   P.Qualified _ ident -> do
---     --     let qual = P.Qualified (P.ByModuleName mName) ident
---     --     val <- selectEnvValue conn qual
---     --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     --   where
---     --     exports = lookupExports mName exportEnv
-
---     importClass modName' qual className = do
---       typeClass <- fromJust <$> selectTypeClass conn modName' className
---       let dictName = P.Qualified (P.ByModuleName modName') . P.dictTypeName . coerceProperName $ className
---           typeQual = P.Qualified (P.ByModuleName modName') $ coerceProperName className
---       type' <- selectType conn typeQual
---       dictVal <- selectType conn dictName
-
---       let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
---           ctrMb =
---             P.Qualified (P.ByModuleName modName') <$> case dictVal of
---               Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
---               _ -> Nothing
-
---       ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
---       instances <- selectClassInstancesByClassName conn $ P.Qualified (P.ByModuleName modName') className
-
---       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
---         P.Qualified (P.ByModuleName superModName) superClassName -> do
---           -- TODO add check for existing class in env
---           importClass superModName (P.Qualified (P.ByModuleName superModName) superClassName) superClassName
---         _ -> pure identity
-
---       pure $
---         pipe superClassImports
---           >>> \env' ->
---             env'
---               { E.typeClasses =
---                   E.typeClasses env'
---                     <> Map.fromList
---                       [ (qual, typeClass),
---                         (P.Qualified (P.ByModuleName modName') className, typeClass)
---                       ],
---                 E.types =
---                   E.types env'
---                     <> Map.fromList
---                       ( [ (typeQual, fromJust type')
---                         ]
---                           <> case dictVal of
---                             Just val -> [(dictName, val)]
---                             _ -> []
---                       ),
---                 E.dataConstructors =
---                   E.dataConstructors env' <> Map.fromList case (ctrMb, ctrData) of
---                     (Just ctr', Just ctrData') -> [(ctr', ctrData')]
---                     _ -> [],
---                 E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
---               }
---     importName :: P.ModuleName -> P.Qualified P.Name -> IO (E.Environment -> E.Environment)
---     importName mName (P.Qualified (P.ByModuleName _) name) = do
---       -- when (modName' /= mName) do
---       --   putErrText $ "importName called with different module names: " <> show modName' <> " and " <> show mName
---       --   putErrText $ "name: " <> show name
---       case name of
---         P.IdentName ident -> do
---           let P.ExportSource {..} = fromJustWithErr (mName, ident) $ Map.lookup ident (P.exportedValues exports)
---               qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ident
---           val <- selectEnvValue conn qual
---           let importedModuleName = getImportedModule mName ident $ P.importedValues imports
---           pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ident, fromJustWithErr ident val)]}
---         P.ValOpName opName -> do
---           let P.ExportSource {..} = fromJustWithErr (mName, opName) $ Map.lookup opName (P.exportedValueOps exports)
---           (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn exportSourceDefinedIn opName
---           if isUpper $ T.head alias
---             then do
---               let ctrName = P.ProperName alias
---                   qual = P.Qualified (P.ByModuleName aliasModName) ctrName
---               val <- selectDataConstructor conn qual
---               pure $ \env' ->
---                 env'
---                   { E.dataConstructors =
---                       E.dataConstructors env'
---                         <> Map.fromList [(qual, fromJustWithErr qual val)]
---                   }
---             else do
---               let ident = P.Ident alias
---                   qual = P.Qualified (P.ByModuleName aliasModName) ident
---               val <- selectEnvValue conn qual
---               pure $ \env' ->
---                 env'
---                   { E.names =
---                       E.names env'
---                         <> Map.fromList [(qual, fromJustWithErr qual val)]
---                   }
---         P.TyName tyName -> do
---           let (_, P.ExportSource {..}) = fromJust $ Map.lookup tyName (P.exportedTypes exports)
---           let qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) tyName
---           type' <- selectType conn qual
---           ctrVals <- selectTypeDataConstructors conn qual
---           let importedModuleName = getImportedModule mName tyName $ P.importedTypes imports
---           pure $ \env' ->
---             env'
---               { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) tyName, fromJust type')],
---                 E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
---               }
---         P.TyOpName opName -> do
---           let P.ExportSource {..} = fromJust $ Map.lookup opName (P.exportedTypeOps exports)
---           (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectTypeOperatorAlias conn exportSourceDefinedIn opName
---           let qual = P.Qualified (P.ByModuleName aliasModName) alias
---           val <- selectType conn qual
---           let importedModuleName = getImportedModule mName alias $ P.importedTypes imports
---           pure $ \env' ->
---             env'
---               { E.types = E.types env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) alias, fromJustWithErr qual val)]
---               }
---         P.TyClassName className -> do
---           let P.ExportSource {..} = fromJust $ Map.lookup className (P.exportedTypeClasses exports)
---           importClass' mName exportSourceDefinedIn className
---         P.DctorName ctrName -> do
---           let containsCtr (_, (ctrs, _)) = ctrName `elem` ctrs
---               (_, (_, P.ExportSource {..})) = fromJust $ find containsCtr $ Map.toList $ P.exportedTypes exports -- Map.find ctrName (P.exportedDataConstructors exports)
---               qual = P.Qualified (P.ByModuleName exportSourceDefinedIn) ctrName
---           val <- selectDataConstructor conn qual
---           let importedModuleName = getImportedModule mName ctrName $ P.importedDataConstructors imports
---           pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(P.Qualified (P.ByModuleName importedModuleName) ctrName, fromJustWithErr ctrName val)]}
---         P.ModName _ -> internalError "importName called with ModName"
---       where
---         exports :: P.Exports
---         exports = lookupExports mName exportEnv
---     importName _ _ = pure identity
-
---     getImportedModule ::
---       (Ord a) =>
---       (Foldable f) =>
---       P.ModuleName ->
---       a ->
---       Map (P.Qualified a) (f (P.ImportRecord a)) ->
---       P.ModuleName
---     getImportedModule mName ident imports' = fromMaybe mName do
---       importRecs <- Map.lookup (P.Qualified (P.ByModuleName mName) ident) imports'
---       importRec <- head importRecs
---       pure $ P.importSourceModule importRec
---     -- imports :: P.Imports
---     -- imports = lookupImports mName exportEnv
-
---     -- case
---     -- P.IdentName ident -> do
---     --   let qual = P.Qualified (P.ByModuleName mName) ident
---     --   val <- selectEnvValue conn qual
---     --   pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     -- P.ValOpName opName -> do
---     --   (aliasModName, alias) <- fromJustWithErr (mName, opName) <$> selectValueOperatorAlias conn mName opName
---     --   if isUpper $ T.head alias
---     --     then do
---     --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
---     --       val <- selectDataConstructor conn qual
---     --       pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     --     else do
---     --       let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
---     --       val <- selectEnvValue conn qual
---     --       pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     -- P.TyName tyName -> do
---     --   let qual = P.Qualified (P.ByModuleName mName) tyName
---     --   type' <- selectType conn qual
---     --   ctrVals <- selectTypeDataConstructors conn qual
---     --   pure $ \env' ->
---     --     env'
---     --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual type')],
---     --         E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
---     --       }
-
---     -- P.TyOpName opName -> do
---     --   (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
---     --   let qual = P.Qualified (P.ByModuleName aliasModName) alias
---     --   val <- selectType conn qual
---     --   pure $ \env' ->
---     --     env'
---     --       { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
---     --       }
-
---     -- P.DctorName dctorName -> do
---     --   let qual = P.Qualified (P.ByModuleName mName) dctorName
---     --   val <- selectDataConstructor conn qual
---     --   pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     -- P.TyClassName className -> do
---     --   importClass' mName className
---     -- P.ModName _ -> internalError "importName called with ModName"
-
---     -- where
---     --   exports = lookupExports mName exportEnv
-
---     -- importRef :: P.ModuleName -> P.DeclarationRef -> IO (E.Environment -> E.Environment)
---     -- importRef mName = \case
---     --   P.TypeClassRef _ className -> importClass' mName className
---     --   P.TypeRef _ tyName ctrs -> do
---     --     let qual = P.Qualified (P.ByModuleName mName) tyName
---     --     type' <- selectType conn qual
---     --     ctrVals <- case ctrs of
---     --       Nothing -> selectTypeDataConstructors conn qual
---     --       Just ctrs' -> forConcurrently ctrs' \ctr -> do
---     --         let qual' = P.Qualified (P.ByModuleName mName) ctr
---     --         val <- selectDataConstructor conn qual'
---     --         pure (qual', fromJustWithErr qual' val)
---     --     pure $ \env' ->
---     --       env'
---     --         { E.types = E.types env' <> Map.fromList [(qual, fromJust type')],
---     --           E.dataConstructors = E.dataConstructors env' <> Map.fromList ctrVals
---     --         }
---     --   P.ValueRef _ ident -> do
---     --     let qual = P.Qualified (P.ByModuleName mName) ident
---     --     val <- selectEnvValue conn qual
---     --     pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     --   P.TypeInstanceRef _ ident _ -> do
---     --     let qual = P.Qualified (P.ByModuleName mName) ident
---     --     val <- selectClassInstance conn qual
---     --     pure $ \env' -> env' {E.typeClassDictionaries = P.addDictsToEnvMap [fromJust val] (E.typeClassDictionaries env')}
---     --   P.ModuleRef _ _ -> internalError "importRef called with ModuleRef"
---     --   P.ReExportRef _ _ ref -> importRef mName ref
---     --   P.ValueOpRef _ opName -> do
---     --     (aliasModName, alias) <- fromJust <$> selectValueOperatorAlias conn mName opName
---     --     if isUpper $ T.head alias
---     --       then do
---     --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.ProperName alias)
---     --         val <- selectDataConstructor conn qual
---     --         pure $ \env' -> env' {E.dataConstructors = E.dataConstructors env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     --       else do
---     --         let qual = P.Qualified (P.ByModuleName aliasModName) (P.Ident alias)
---     --         val <- selectEnvValue conn qual
---     --         pure $ \env' -> env' {E.names = E.names env' <> Map.fromList [(qual, fromJustWithErr qual val)]}
---     --   P.TypeOpRef _ opName -> do
---     --     (aliasModName, alias) <- fromJustWithErr opName <$> selectTypeOperatorAlias conn mName opName
---     --     let qual = P.Qualified (P.ByModuleName aliasModName) alias
---     --     val <- selectType conn qual
---     --     pure $ \env' ->
---     --       env'
---     --         { E.types = E.types env' <> Map.fromList [(qual, fromJustWithErr qual val)]
---     --         }
-
---     -- importModule mName = importModuleHiding mName []
-
---     -- importModuleHiding mName hideRefs = do
---     --   allRefs <- selectModuleExports conn mName
---     --   let refs = filter (not . flip Set.member hiddenRefSet) allRefs
---     --   importRefs mName refs
---     --   where
---     --     hiddenRefSet = Set.fromList hideRefs
-
---     importClass' :: P.ModuleName -> P.ModuleName -> P.ProperName 'P.ClassName -> IO (E.Environment -> E.Environment)
---     importClass' mName _modDefinedIn className = do
---       when (mName /= _modDefinedIn) do
---         putErrText $ "importClass' called with different module names: " <> show mName <> " and " <> show _modDefinedIn
---         putErrText $ "className: " <> show className
-
---       let qual = P.Qualified (P.ByModuleName mName) className
---           typeQual = P.Qualified (P.ByModuleName mName) $ coerceProperName className
---       type' <- selectType conn typeQual
---       typeClass <- fromJust <$> selectTypeClass conn mName className
---       let dictName = P.Qualified (P.ByModuleName mName) . P.dictTypeName . coerceProperName $ className
---       dictVal <- selectType conn dictName
-
---       let ctrMb :: Maybe (P.Qualified (P.ProperName 'P.ConstructorName))
---           ctrMb =
---             P.Qualified (P.ByModuleName mName) <$> case dictVal of
---               Just (_, P.DataType _ _ [(ctr', _)]) -> Just ctr'
---               _ -> Nothing
-
---       ctrData <- ctrMb & maybe (pure Nothing) (selectDataConstructor conn)
---       superClassImports <- forConcurrently (typeClassSuperclasses typeClass) \super -> case P.constraintClass super of
---         P.Qualified (P.ByModuleName superModName) superClassName -> do
---           importClass' superModName superModName superClassName
---         _ -> pure identity
-
---       instances <- selectClassInstancesByClassName conn qual
-
---       pure $
---         pipe superClassImports >>> \env' ->
---           env'
---             { E.typeClasses = E.typeClasses env' <> Map.fromList [(qual, typeClass)],
---               E.types =
---                 E.types env'
---                   <> Map.fromList
---                     ( [ (typeQual, fromJust type')
---                       ]
---                         <> case dictVal of
---                           Just val -> [(dictName, val)]
---                           _ -> []
---                     ),
---               E.dataConstructors =
---                 E.dataConstructors env'
---                   <> Map.fromList case (ctrMb, ctrData) of
---                     (Just ctr', Just ctrData') -> [(ctr', ctrData')]
---                     _ -> [],
---               E.typeClassDictionaries = P.addDictsToEnvMap instances (E.typeClassDictionaries env')
---             }
-
 selectModuleExports :: Connection -> P.ModuleName -> IO [P.DeclarationRef]
 selectModuleExports conn modName = do
   SQL.query
@@ -1115,29 +577,12 @@ typeConstraints = P.everythingOnTypes (<>) \case
 pipe :: [a -> a] -> a -> a
 pipe = foldl' (>>>) identity
 
--- pipeSet = pipe . Set.toList
-
 updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c)
 updateConcurrently a b = do
   f <- a
   g <- b
   pure $ f >>> g
 
-
-
--- updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c)
--- updateConcurrently a b = do
---   (f, g) <- concurrently a b
---   pure $ f >>> g
-
--- xx = [TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Int"}))]
-
--- xx = [TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Type.Proxy")) (ProperName {runProperName = "Proxy"}))) (TypeVar    "a")]
--- xx = [TypeConstructor    (Qualified (ByModuleName (ModuleName "Data.Unit")) (ProperName {runProperName = "Unit"}))]
--- xx = [TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim.RowList")) (ProperName {runProperName = "Nil"})),TypeVar    "row",REmpty
--- xx = [TypeApp    (TypeApp    (TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim.RowList")) (ProperName {runProperName = "Cons"}))) (TypeVar    "key")) (TypeVar    "focus")) (TypeVar    "rowlistTail"),TypeVar    "row",TypeVar    [TypeApp    (TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Function"}))) (TypeVar    "a")) (TypeVar    "b")]
--- xx = [TypeApp    (TypeConstructor    (Qualified (ByModuleName (ModuleName "Prim")) (ProperName {runProperName = "Record"}))) (TypeVar    "row")]
-
 class GetEnv m where 
   getName :: P.Qualified P.Ident -> m (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
   getType :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe (P.SourceType, P.TypeKind))

From e6810b110b5baa75bd39f9c13c8f1cb2173add0f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 27 Dec 2024 16:32:09 +0100
Subject: [PATCH 285/297] allow ' in decoded idents

---
 src/Language/PureScript/Names.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index e3faebfbac..32e1633d4f 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -340,9 +340,9 @@ instance FromField Ident where
   fromField a = (decodeAlphaNumIdent =<< fromField a) <|> (decodeJsonIdent =<< fromField a)
     where 
       decodeAlphaNumIdent :: Text -> Ok Ident
-      decodeAlphaNumIdent txt = if all isAlphaNum $ T.unpack txt then
+      decodeAlphaNumIdent txt = if all (\c -> isAlphaNum c || c == '\'') $ T.unpack txt then
         pure $ Ident txt
       else
-        fail "Failed to decode ident"
+        fail $ "Failed to decode alphanum ident: " <> show txt
 
-      decodeJsonIdent str = maybe (fail "Failed to decode ident") pure $ A.decode str
+      decodeJsonIdent str = maybe (fail $ "Failed to decode json ident: " <> show str) pure $ A.decode str

From 4fe0b4e4c2b30813fd9721132e4948e7a1b683d4 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 27 Dec 2024 16:33:30 +0100
Subject: [PATCH 286/297] moves selection of type class instances to entailment

---
 src/Language/PureScript/Make/Index/Select.hs      | 10 +++++-----
 src/Language/PureScript/TypeChecker/Deriving.hs   |  7 ++++---
 src/Language/PureScript/TypeChecker/Entailment.hs |  9 +++++----
 src/Language/PureScript/TypeChecker/Monad.hs      | 11 ++++++++---
 4 files changed, 22 insertions(+), 15 deletions(-)

diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index e1d1a6eb00..f86c4dda2c 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -4,6 +4,7 @@
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
 
 {-# HLINT ignore "Redundant bracket" #-}
+{-# LANGUAGE InstanceSigs #-}
 
 module Language.PureScript.Make.Index.Select where
 
@@ -590,7 +591,7 @@ class GetEnv m where
   getTypeSynonym :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
   getTypeClass :: P.Qualified (P.ProperName 'P.ClassName) -> m (Maybe P.TypeClassData)
   getTypeClassDictionaries :: m [NamedDict]
-  getTypeClassDictionary :: P.Qualified (P.ProperName 'P.ClassName) -> m (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty P.NamedDict))
+  getTypeClassDictionary :: P.Qualified (P.ProperName 'P.ClassName) -> m [NamedDict]
   deleteModuleEnv :: P.ModuleName -> m ()
 
 
@@ -667,9 +668,8 @@ instance (MonadIO m) => GetEnv (DbEnv m) where
 
   getTypeClassDictionary cls = DbEnv $ do
     conn <- ask
-    liftIO $ key <$> selectClassInstancesByClassName conn cls
-    where 
-      key = Map.fromListWith (<>) . fmap (\d -> (P.tcdValue d, pure d))
+    liftIO $ selectClassInstancesByClassName conn cls
+
 
 newtype WoGetEnv m a = WoGetEnv (m a)
   deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadError e, MonadWriter w)
@@ -688,5 +688,5 @@ instance Monad m => GetEnv (WoGetEnv m) where
   getTypeSynonym _ = pure Nothing
   getTypeClass _ = pure Nothing
   getTypeClassDictionaries = pure []
-  getTypeClassDictionary _ = pure Map.empty
+  getTypeClassDictionary _ = pure []
   deleteModuleEnv _ = pure ()
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs
index 613ec6e85d..ad6cd23413 100644
--- a/src/Language/PureScript/TypeChecker/Deriving.hs
+++ b/src/Language/PureScript/TypeChecker/Deriving.hs
@@ -28,11 +28,11 @@ import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName
 import Language.PureScript.PSString (PSString, mkString)
 import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames)
 import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts)
-import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule, lookupTypeClassOrThrow, lookupTypeClassMb, lookupTypeClassDictionariesForClass)
+import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule, lookupTypeClassOrThrow, lookupTypeClassMb, lookupTypeClassDictionariesForClass, addDictsToEnvMap)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, SourceType, Type(..), completeBinderList, eqType, everythingOnTypes, replaceAllTypeVars, srcTypeVar, usedTypeVariables)
-import Language.PureScript.Make.Index.Select (GetEnv)
+import Language.PureScript.Make.Index.Select (GetEnv (getTypeClassDictionary))
 
 -- | Extract the name of the newtype appearing in the last type argument of
 -- a derived newtype instance.
@@ -462,7 +462,8 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con
       (True, _)         -> Left $ kindType -:> kindType
   ctors <- traverse (traverse $ traverse replaceAllTypeSynonyms) tiCtors
   tcds <- getTypeClassDictionaries
-  let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf tcds tiArgSubst (maybe That These mbLParam param) False) ctors
+  classTcds <- getTypeClassDictionary derivingClass
+  let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf (addDictsToEnvMap classTcds tcds) tiArgSubst (maybe That These mbLParam param) False) ctors
   let relatedClasses = [monoClass, biClass] ++ ([contraClass, proClass] <*> (contravariantClasses <$> toList contravarianceSupport))
   for_ (nonEmpty $ ordNub problemSpans) $ \sss ->
     throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass relatedClasses (isJust contravarianceSupport)
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index b5bdbc0d5d..9a2389cc5a 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -44,7 +44,7 @@ import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName
 import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds)
 import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation)
 import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds')
-import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint, lookupTypeClassMb, lookupTypeClassUnsafe)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint, lookupTypeClassMb, lookupTypeClassUnsafe, addDictsToEnvMap)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, substituteType, unifyTypes)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..), superclassName)
@@ -53,7 +53,7 @@ import Language.PureScript.Label (Label(..))
 import Language.PureScript.PSString (PSString, mkString, decodeString)
 import Language.PureScript.Constants.Libs qualified as C
 import Language.PureScript.Constants.Prim qualified as C
-import Language.PureScript.Make.Index.Select (GetEnv)
+import Language.PureScript.Make.Index.Select (GetEnv (getTypeClassDictionary))
 
 -- | Describes what sort of dictionary to generate for type class instances
 data Evidence
@@ -246,7 +246,8 @@ entails SolverOptions{..} constraint context hints =
             latestSubst <- lift . lift $ gets checkSubstitution
             let kinds'' = map (substituteType latestSubst) kinds'
                 tys'' = map (substituteType latestSubst) tys'
-
+            
+            fromDb <- lift . lift $ getTypeClassDictionary className'
             -- Get the inferred constraint context so far, and merge it with the global context
             inferred <- lift get
             -- We need information about functional dependencies, so we have to look up the class
@@ -262,7 +263,7 @@ entails SolverOptions{..} constraint context hints =
                 Nothing -> throwError . errorMessage $ UnknownClass className'
                 Just tcd -> pure tcd
 
-            dicts <- lift . lift $ forClassNameM (combineContexts context inferred) className' kinds'' tys''
+            dicts <- lift . lift $ forClassNameM (addDictsToEnvMap fromDb $ combineContexts context inferred) className' kinds'' tys''
 
             let (catMaybes -> ambiguous, instances) = partitionEithers $ do
                   chain :: NonEmpty TypeClassDict <-
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index a502cab86c..04bc61f2ba 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+{-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 -- |
 -- Monads for type checking and type inference and associated data types
@@ -235,8 +238,9 @@ getTypeClassDictionaries
   => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
 getTypeClassDictionaries = do 
   envDicts <- gets $ typeClassDictionaries . checkEnv
-  dbDicts <- Select.getTypeClassDictionaries 
-  pure $ addDictsToEnvMap dbDicts envDicts
+  -- dbDicts <- Select.getTypeClassDictionaries 
+  pure envDicts
+   --   $ addDictsToEnvMap dbDicts envDicts
 
 -- | Lookup type class dictionaries in a module.
 lookupTypeClassDictionaries
@@ -252,11 +256,12 @@ lookupTypeClassDictionariesForClass
   -> Qualified (ProperName 'ClassName)
   -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
 lookupTypeClassDictionariesForClass mn cn = do
-  inDb <- getTypeClassDictionary cn
+  inDb <- key <$> getTypeClassDictionary cn
   inEnv <- getInEnv
   pure $ inDb <> inEnv
   where 
     getInEnv = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn
+    key = M.fromList . fmap \a -> (tcdValue a, pure a)
 
 -- | Temporarily bind a collection of names to local variables
 bindLocalVariables

From e7e59a698b3236b544549507c677ff8b3a970d27 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 30 Dec 2024 12:21:10 +0100
Subject: [PATCH 287/297] only fetch dicts when needed

---
 src/Language/PureScript/TypeChecker/Monad.hs | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 04bc61f2ba..55d20ccee1 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -236,10 +236,7 @@ typeClassDictionariesEnvMap entries =
 getTypeClassDictionaries
   :: (MonadState CheckState m, GetEnv m)
   => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
-getTypeClassDictionaries = do 
-  envDicts <- gets $ typeClassDictionaries . checkEnv
-  -- dbDicts <- Select.getTypeClassDictionaries 
-  pure envDicts
+getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv
    --   $ addDictsToEnvMap dbDicts envDicts
 
 -- | Lookup type class dictionaries in a module.
@@ -256,11 +253,14 @@ lookupTypeClassDictionariesForClass
   -> Qualified (ProperName 'ClassName)
   -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
 lookupTypeClassDictionariesForClass mn cn = do
-  inDb <- key <$> getTypeClassDictionary cn
-  inEnv <- getInEnv
-  pure $ inDb <> inEnv
+  dicts <- lookupTypeClassDictionaries mn
+  case M.lookup cn dicts of 
+    Just d -> pure  d
+    Nothing -> do 
+      inDb <- getTypeClassDictionary cn
+      modifyEnv $ \env -> env { typeClassDictionaries =  addDictsToEnvMap inDb (typeClassDictionaries env) }
+      pure $ key inDb 
   where 
-    getInEnv = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn
     key = M.fromList . fmap \a -> (tcdValue a, pure a)
 
 -- | Temporarily bind a collection of names to local variables

From dae4bdd26676784eaad2b811d18edf79c958ca00 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 30 Dec 2024 12:21:31 +0100
Subject: [PATCH 288/297] force eval

---
 src/Language/PureScript/Make.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 7d0f1f4b8c..4142ca75f9 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -434,7 +434,9 @@ make ma@MakeActions {..} ms = do
             (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do
               -- Eventlog markers for profiling; see debug/eventlog.js
               liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start"
-              extsAndWarnings <- listen $ do
+              -- Force the externs and warnings to avoid retaining excess module
+              -- data after the module is finished compiling.
+              extsAndWarnings <- evaluate . force <=< listen $ do
                 rebuildModuleWithIndexDb ma conn env m (Just (idx, cnt))
               liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
               return extsAndWarnings

From dc22b3a708d488fd3867f4219dd803ce267f0467 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 30 Dec 2024 12:21:43 +0100
Subject: [PATCH 289/297] delete class instances when deleting env

---
 src/Language/PureScript/Make/Index.hs        |  9 ++++++++-
 src/Language/PureScript/Make/Index/Select.hs | 10 +---------
 2 files changed, 9 insertions(+), 10 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index e403494c60..7dad3cae4b 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -419,6 +419,7 @@ indexExportedEnv moduleName env refs conn = liftIO do
       SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
 
     refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool
     refMatch f (k, _) = maybe True (any (f k)) refs
@@ -487,7 +488,13 @@ insertTypeClass conn ident tcd = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)"
-    (toDbQualifer ident :. SQL.Only tcd)
+    ((clasMod, className) :. SQL.Only tcd)
+  -- SQL.execute
+  --   conn
+  --   "DELETE FROM env_type_class_instances WHERE class_name = ?"
+  --   (SQL.Only clasMod)
+  where 
+    (clasMod, className) = toDbQualifer ident
 
 insertNamedDict :: Connection -> NamedDict -> IO ()
 insertNamedDict conn dict = do
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index f86c4dda2c..0c706c6c3c 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -565,6 +565,7 @@ deleteModuleEnvImpl moduleName conn = do
   SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
   SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
   SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
 
 getEnvConstraints :: E.Environment -> [P.SourceConstraint]
 getEnvConstraints env =
@@ -590,7 +591,6 @@ class GetEnv m where
   getDataConstructor :: P.Qualified (P.ProperName 'P.ConstructorName) -> m (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
   getTypeSynonym :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
   getTypeClass :: P.Qualified (P.ProperName 'P.ClassName) -> m (Maybe P.TypeClassData)
-  getTypeClassDictionaries :: m [NamedDict]
   getTypeClassDictionary :: P.Qualified (P.ProperName 'P.ClassName) -> m [NamedDict]
   deleteModuleEnv :: P.ModuleName -> m ()
 
@@ -601,7 +601,6 @@ instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where
   getDataConstructor = lift . getDataConstructor
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
-  getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
   deleteModuleEnv = lift . deleteModuleEnv
 instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where 
@@ -610,7 +609,6 @@ instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where
   getDataConstructor = lift . getDataConstructor
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
-  getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
   deleteModuleEnv = lift . deleteModuleEnv
 
@@ -620,7 +618,6 @@ instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where
   getDataConstructor = lift . getDataConstructor
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
-  getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
   deleteModuleEnv = lift . deleteModuleEnv
 instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where 
@@ -629,7 +626,6 @@ instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where
   getDataConstructor = lift . getDataConstructor
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
-  getTypeClassDictionaries = lift getTypeClassDictionaries
   getTypeClassDictionary = lift . getTypeClassDictionary
   deleteModuleEnv = lift . deleteModuleEnv
 
@@ -658,9 +654,6 @@ instance (MonadIO m) => GetEnv (DbEnv m) where
   getTypeClass cls = DbEnv $ do
     conn <- ask
     liftIO $ selectTypeClass' conn cls
-  getTypeClassDictionaries = DbEnv $ do
-    conn <- ask
-    liftIO $ selectAllClassInstances conn
   deleteModuleEnv modName = DbEnv $ do
     conn <- ask
     liftIO $ deleteModuleEnvImpl modName conn
@@ -687,6 +680,5 @@ instance Monad m => GetEnv (WoGetEnv m) where
   getDataConstructor _ = pure Nothing
   getTypeSynonym _ = pure Nothing
   getTypeClass _ = pure Nothing
-  getTypeClassDictionaries = pure []
   getTypeClassDictionary _ = pure []
   deleteModuleEnv _ = pure ()
\ No newline at end of file

From 7662cb733f3e23c2f5a1027d4f989eb87163a6b5 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 30 Dec 2024 14:36:46 +0100
Subject: [PATCH 290/297] store more env in memory

---
 src/Language/PureScript/Make/Index/Select.hs | 63 ++++++++++++--------
 src/Language/PureScript/TypeChecker.hs       | 34 +++++++----
 src/Language/PureScript/TypeChecker/Monad.hs | 19 ++++--
 3 files changed, 77 insertions(+), 39 deletions(-)

diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 0c706c6c3c..c72d03e8b6 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -472,29 +472,6 @@ selectClassInstances conn classNameQual types = do
   where
     (modName, className) = toDbQualifer classNameQual
 
-selectModuleClassInstances :: Connection -> P.ModuleName -> IO [NamedDict]
-selectModuleClassInstances conn moduleName' = do
-  SQL.query
-    conn
-    "SELECT dict FROM env_type_class_instances WHERE module_name = ?"
-    (SQL.Only moduleName')
-    <&> fmap (SQL.fromOnly >>> deserialise)
-
-selectClassInstanceByIdents ::
-  Connection ->
-  P.Qualified (P.ProperName 'P.ClassName) ->
-  [P.Ident] ->
-  IO (Maybe NamedDict)
-selectClassInstanceByIdents conn classNameQual idents = do
-  SQL.query
-    conn
-    "SELECT dict FROM env_type_class_instances WHERE class_module = ? AND class_name = ? AND idents = ?"
-    (modName, className, A.encode idents)
-    <&> (head >>> fmap (SQL.fromOnly >>> deserialise))
-  where
-    (modName, className) = toDbQualifer classNameQual
-
--- TODO: Select specific instances instead of all
 selectClassInstancesByClassName ::
   Connection ->
   P.Qualified (P.ProperName 'P.ClassName) ->
@@ -508,6 +485,18 @@ selectClassInstancesByClassName conn classNameQual = do
   where
     (modName, className) = toDbQualifer classNameQual
 
+selectDoesClassInstanceExist ::
+  Connection ->
+  P.Qualified P.Ident ->
+  IO Bool
+selectDoesClassInstanceExist conn ident  = do
+  SQL.query
+    conn
+    "SELECT EXISTS (SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND ident = ?)"
+    (toDbQualifer ident)
+    <&> head
+    <&> maybe False SQL.fromOnly
+
 selectValueOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe (P.ModuleName, Text))
 selectValueOperatorAlias conn modName opName = do
   SQL.query
@@ -592,7 +581,10 @@ class GetEnv m where
   getTypeSynonym :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
   getTypeClass :: P.Qualified (P.ProperName 'P.ClassName) -> m (Maybe P.TypeClassData)
   getTypeClassDictionary :: P.Qualified (P.ProperName 'P.ClassName) -> m [NamedDict]
+  hasTypeClassInEnv :: P.Qualified P.Ident -> m Bool
+  hasEnv :: m Bool
   deleteModuleEnv :: P.ModuleName -> m ()
+  logGetEnv :: Text -> m ()
 
 
 instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where 
@@ -602,7 +594,10 @@ instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
   getTypeClassDictionary = lift . getTypeClassDictionary
+  hasTypeClassInEnv = lift . hasTypeClassInEnv
   deleteModuleEnv = lift . deleteModuleEnv
+  logGetEnv = lift . logGetEnv
+  hasEnv = lift hasEnv
 instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where 
   getName = lift . getName
   getType = lift . getType
@@ -610,7 +605,10 @@ instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
   getTypeClassDictionary = lift . getTypeClassDictionary
+  hasTypeClassInEnv = lift . hasTypeClassInEnv
   deleteModuleEnv = lift . deleteModuleEnv
+  logGetEnv = lift . logGetEnv
+  hasEnv = lift hasEnv
 
 instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where 
   getName = lift . getName
@@ -619,7 +617,10 @@ instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
   getTypeClassDictionary = lift . getTypeClassDictionary
+  hasTypeClassInEnv = lift . hasTypeClassInEnv
   deleteModuleEnv = lift . deleteModuleEnv
+  logGetEnv = lift . logGetEnv
+  hasEnv = lift hasEnv
 instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where 
   getName = lift . getName
   getType = lift . getType
@@ -627,7 +628,10 @@ instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where
   getTypeSynonym = lift . getTypeSynonym
   getTypeClass = lift . getTypeClass
   getTypeClassDictionary = lift . getTypeClassDictionary
+  hasTypeClassInEnv = lift . hasTypeClassInEnv
   deleteModuleEnv = lift . deleteModuleEnv
+  logGetEnv = lift . logGetEnv
+  hasEnv = lift hasEnv
 
 newtype DbEnv m a = DbEnv (ReaderT Connection m a)
   deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadError e, MonadWriter w, MonadTrans)
@@ -657,6 +661,13 @@ instance (MonadIO m) => GetEnv (DbEnv m) where
   deleteModuleEnv modName = DbEnv $ do
     conn <- ask
     liftIO $ deleteModuleEnvImpl modName conn
+  hasTypeClassInEnv ident = DbEnv $ do
+    conn <- ask
+    liftIO $ selectDoesClassInstanceExist conn ident
+  logGetEnv msg = DbEnv $ do
+    liftIO $ putErrText msg
+
+  hasEnv = pure True
 
 
   getTypeClassDictionary cls = DbEnv $ do
@@ -681,4 +692,8 @@ instance Monad m => GetEnv (WoGetEnv m) where
   getTypeSynonym _ = pure Nothing
   getTypeClass _ = pure Nothing
   getTypeClassDictionary _ = pure []
-  deleteModuleEnv _ = pure ()
\ No newline at end of file
+  hasTypeClassInEnv _ = pure False
+  deleteModuleEnv _ = pure ()
+  logGetEnv _ = pure ()
+  
+  hasEnv = pure False
\ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 05dc205823..a26d8c7a74 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -9,10 +9,10 @@ module Language.PureScript.TypeChecker
   ) where
 
 import Prelude
-import Protolude (headMay, maybeToLeft, ordNub)
+import Protolude (headMay, maybeToLeft, ordNub, ifM, whenM)
 
 import Control.Lens ((^..), _2)
-import Control.Monad (when, unless, void, forM, zipWithM_)
+import Control.Monad (when, unless, void, forM, zipWithM_, (>=>))
 import Control.Monad.Error.Class (MonadError(..))
 import Control.Monad.State.Class (MonadState(..), modify, gets)
 import Control.Monad.Supply.Class (MonadSupply)
@@ -48,7 +48,7 @@ import Language.PureScript.TypeChecker.Unify (varIfUnknown)
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
 import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes)
 import Language.PureScript.Types qualified as P
-import Language.PureScript.Make.Index.Select (GetEnv (deleteModuleEnv, getTypeClass))
+import Language.PureScript.Make.Index.Select (GetEnv (deleteModuleEnv, getTypeClass, logGetEnv, hasEnv, hasTypeClassInEnv, getType))
 
 addDataType
   :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
@@ -265,8 +265,17 @@ typeCheckAll
   => ModuleName
   -> [Declaration]
   -> m [Declaration]
-typeCheckAll moduleName = traverse go
+typeCheckAll moduleName = traverse (logDecl >=> go >=> logDone)
   where
+  logDecl :: Declaration -> m Declaration
+  logDecl d = do 
+    logGetEnv ("TypeChecking: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d))
+    return d
+
+  logDone :: Declaration -> m Declaration
+  logDone d = do 
+    logGetEnv ("TypeChecked: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d))
+    return d
   go :: Declaration -> m Declaration
   go d@(DataDeclaration sa@(ss, _) dtype name args dctors) = do
     warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do
@@ -407,11 +416,16 @@ typeCheckAll moduleName = traverse go
   go (TypeInstanceDeclaration _ _ _ _ (Left _) _ _ _ _) = internalError "typeCheckAll: type class instance generated name should have been desugared"
   go d@(TypeInstanceDeclaration sa@(ss, _) _ ch idx (Right dictName) deps className tys body) =
     rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do
-      env <- getEnv
       let qualifiedDictName = Qualified (ByModuleName moduleName) dictName
-      flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries ->
-        guardWith (errorMessage (DuplicateInstance dictName ss)) $
-          not (M.member qualifiedDictName dictionaries)
+      ifM hasEnv 
+        (do 
+          whenM (hasTypeClassInEnv qualifiedDictName) $ throwError . errorMessage $ DuplicateInstance dictName ss
+        )
+        (do 
+            env <- getEnv
+            flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries ->
+              guardWith (errorMessage (DuplicateInstance dictName ss)) $
+                  not (M.member qualifiedDictName dictionaries))
       typeClass <- lookupTypeClassUnsafe className
       checkInstanceArity dictName className typeClass tys
       (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys)
@@ -430,8 +444,8 @@ typeCheckAll moduleName = traverse go
               if isPlainIdent dictName then Nothing else Just srcType
               
       addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict)
-      let 
-        kind = M.lookup (coerceProperName <$> className) (types env)
+      
+      kind <- lookupTypeMb (coerceProperName <$> className)
 
       addIdeClassName (Just $ fromMaybe moduleName $ getQual className) ss
         ( ProperName $ (("typeCheckAll: " <> T.pack (show tys'') <> " : ") <>) $ runProperName $ disqualify className) 
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 55d20ccee1..ed71d575c1 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -32,7 +32,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary
 import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
 import Text.PrettyPrint.Boxes (render)
 import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, insertTypeSynonym, insertModule, insertImport)
-import Protolude (whenM, isJust)
+import Protolude (whenM, isJust, (&))
 import Language.PureScript.AST.Binders (Binder)
 import Language.PureScript.AST.Declarations (Declaration, Expr (..))
 import Language.PureScript.Make.Index.Select (GetEnv (getName, getType, getTypeClass, getDataConstructor, getTypeClassDictionary))
@@ -306,7 +306,10 @@ lookupName qual = do
   env <- getEnv
   case M.lookup qual (names env) of
     Nothing -> do 
-      getName qual
+      nameMb <- getName qual
+      nameMb & maybe (return ()) \name -> 
+        modifyEnv (\env' -> env' { names = M.insert qual name (names env') })
+      return nameMb
     n -> return n
 
 -- | Lookup the type of a value by name in the @Environment@
@@ -352,7 +355,9 @@ lookupTypeMb qual = do
   env <- getEnv
   case M.lookup qual (types env) of
     Nothing -> do 
-      getType qual
+      tyMb <- getType qual
+      tyMb & maybe (return ()) \ty -> modifyEnv (\env' -> env' { types = M.insert qual ty (types env') })
+      return tyMb
     ty -> return ty
 
 lookupType :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m) => SourceSpan -> Qualified (ProperName 'TypeName) -> m (SourceType, TypeKind)
@@ -375,7 +380,9 @@ lookupSynonymMb qual = do
   env <- getEnv
   case M.lookup qual (typeSynonyms env) of
     Nothing -> do 
-      Select.getTypeSynonym qual
+      sybMb <- Select.getTypeSynonym qual
+      sybMb & maybe (return ()) \syb -> modifyEnv (\env' -> env' { typeSynonyms = M.insert qual syb (typeSynonyms env') })
+      return sybMb
     syn -> return syn
 
 -- | Lookup the kind of a type by name in the @Environment@
@@ -391,7 +398,9 @@ lookupTypeVariable currentModule (Qualified qb name) = do
       ty <- getType (Qualified qb' name)
       case ty of 
         Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
-        Just (k, _) -> return k
+        Just kind@(k, _) -> do 
+          modifyEnv (\env' -> env' { types = M.insert (Qualified qb' name) kind (types env') })
+          return k
     Just (k, _) -> return k
   where
   qb' = ByModuleName $ case qb of

From 28b261cd2494d6057f938ba2a15da080e5b2c3f7 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Wed, 1 Jan 2025 07:17:12 +0100
Subject: [PATCH 291/297] fix selectDoesClassInstanceExist

---
 src/Language/PureScript/Make/Index.hs          | 18 ++++++++----------
 src/Language/PureScript/Make/Index/Select.hs   |  6 +++---
 .../PureScript/TypeChecker/Synonyms.hs         | 11 ++++++-----
 3 files changed, 17 insertions(+), 18 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 7dad3cae4b..109c429a1e 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -20,7 +20,6 @@ where
 
 import Codec.Serialise (serialise)
 import Control.Concurrent.Async.Lifted (mapConcurrently_)
-import Data.Aeson qualified as A
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -40,7 +39,7 @@ import Language.PureScript.Lsp.ServerConfig (ServerConfig)
 import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName)
 import Language.PureScript.Make.Index.Select (toDbQualifer)
 import Language.PureScript.Names (Qualified ())
-import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdInstanceKinds, tcdInstanceTypes, tcdValue))
+import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue))
 import Protolude hiding (moduleName)
 
 addDbConnection :: Monad m => Connection -> P.MakeActions m -> P.MakeActions m
@@ -480,8 +479,11 @@ insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(
 insertTypeSynonym conn ident (idents, st) = do
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type) VALUES (?, ?, ?, ?)"
-    (toDbQualifer ident :. (serialise idents, st))
+    "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type, debug) VALUES (?, ?, ?, ?, ?)"
+    (toDbQualifer ident :. (serialise idents, st, debug))
+  where
+    debug :: Text
+    debug = show (idents, st)
 
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
 insertTypeClass conn ident tcd = do
@@ -500,12 +502,9 @@ insertNamedDict :: Connection -> NamedDict -> IO ()
 insertNamedDict conn dict = do
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, types, kinds, dict, debug) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
-    (toDbQualifer (tcdValue dict) :. (clasMod, className, A.encode (void <$> tcdInstanceTypes dict), A.encode (tcdInstanceKinds dict), serialise dict, debug))
+    "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, dict) VALUES (?, ?, ?, ?, ?)"
+    (toDbQualifer (tcdValue dict) :. (clasMod, className, serialise dict))
   where
-    debug :: Text 
-    debug = show (void <$> tcdInstanceTypes dict)
-
     (clasMod, className) = toDbQualifer (tcdClassName dict)
 
 initEnvTables :: Connection -> IO ()
@@ -526,7 +525,6 @@ addEnvIndexes conn = do
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_synonyms_idx ON env_type_synonyms(module_name, type_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_classes_idx ON env_type_classes(module_name, class_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idx ON env_type_class_instances(module_name, instance_name)"
-  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_idents_idx ON env_type_class_instances(idents)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_class_name_idx ON env_type_class_instances(class_name)"
   SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_class_module_idx ON env_type_class_instances(class_module)"
 
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index c72d03e8b6..4862f3fb92 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -405,11 +405,11 @@ selectModuleDataConstructors conn moduleName' = do
     <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents)))
 
 selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType))
-selectTypeSynonym conn ident = do
+selectTypeSynonym conn tyName = do
   SQL.query
     conn
     "SELECT idents, source_type FROM env_type_synonyms WHERE module_name = ? AND type_name = ?"
-    (toDbQualifer ident)
+    (toDbQualifer tyName)
     <&> (head >>> fmap deserialiseIdents)
   where
     deserialiseIdents (idents, st) = (deserialise idents, st)
@@ -492,7 +492,7 @@ selectDoesClassInstanceExist ::
 selectDoesClassInstanceExist conn ident  = do
   SQL.query
     conn
-    "SELECT EXISTS (SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND ident = ?)"
+    "SELECT EXISTS (SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?)"
     (toDbQualifer ident)
     <&> head
     <&> maybe False SQL.fromOnly
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index c07ad51fda..7f5e606c9e 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -39,11 +39,12 @@ replaceAllTypeSynonyms = everywhereOnTypesTopDownM try
       lookupSynonymMb ctor >>= \case
         Just (synArgs, body)
           | c == length synArgs -> do
-             kindArgs <- lookupKindArgs ctor
-             if length kargs == length kindArgs  then
-              let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
-               in Just <$> try repl
-             else pure Nothing
+              kindArgs <- lookupKindArgs ctor
+              if length kargs == length kindArgs
+                then
+                  let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body
+                   in Just <$> try repl
+                else pure Nothing
           | length synArgs > c ->
               throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
         _ -> return Nothing

From aae15d7e92f7584c8ac30bdc6da8c0473a504d3f Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 2 Jan 2025 11:09:22 +0100
Subject: [PATCH 292/297] stop indexing that was leaking memory

---
 src/Language/PureScript/Make/Index.hs        | 24 ++++++++++++--------
 src/Language/PureScript/Make/Index/Select.hs | 10 +++++---
 src/Language/PureScript/TypeChecker.hs       | 20 ++++++++--------
 3 files changed, 32 insertions(+), 22 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 109c429a1e..3152402aa1 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -19,7 +19,7 @@ module Language.PureScript.Make.Index
 where
 
 import Codec.Serialise (serialise)
-import Control.Concurrent.Async.Lifted (mapConcurrently_)
+import Control.Concurrent.Async.Lifted (mapConcurrently_, forConcurrently_)
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -50,9 +50,9 @@ addDbConnection conn ma =
 
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
-  addAstModuleIndexing conn $
-    addEnvIndexing conn $
-      addExternIndexing conn ma
+  -- addAstModuleIndexing conn $
+    addEnvIndexing conn ma 
+      -- addExternIndexing conn ma
 
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
@@ -65,7 +65,7 @@ addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions
 addEnvIndexing conn ma =
   ma
     { P.codegen = \prevEnv checkSt astM@(P.Module _ _ _ _ refs) m docs ext -> do
-        lift (indexExportedEnv (P.getModuleName astM) (P.checkEnv checkSt) refs conn)
+        lift (indexExportedEnv astM (P.checkEnv checkSt) refs conn)
         P.codegen ma prevEnv checkSt astM m docs ext
     }
 
@@ -352,8 +352,6 @@ initDb conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS export_environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT references ast_modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS imports (module_name TEXT, imported_module TEXT, imported_as TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS exports (module_name TEXT, ident TEXT, value BLOB)"
   initEnvTables conn
@@ -382,9 +380,10 @@ dropTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
   dropEnvTables conn
 
-indexExportedEnv :: (MonadIO m) => P.ModuleName -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
-indexExportedEnv moduleName env refs conn = liftIO do
+indexExportedEnv :: (MonadIO m) => P.Module -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
+indexExportedEnv module' env refs conn = liftIO do
   deleteModuleEnv
+  forConcurrently_ (P.getModuleDeclarations module') (indexFixity conn moduleName)
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
   envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn)
   envFromModule E.dataConstructors & filter dataConstructorExportedOrDict & mapConcurrently_ (uncurry $ insertDataConstructor conn)
@@ -394,6 +393,7 @@ indexExportedEnv moduleName env refs conn = liftIO do
     -- & filter ((== Just moduleName) . P.getQual . tcdValue)
     & mapConcurrently_ (insertNamedDict conn)
   where
+    moduleName = P.getModuleName module'
     envFromModule :: (E.Environment -> Map.Map (Qualified k) v) -> [(Qualified k, v)]
     envFromModule f = f env & Map.toList & filter ((== Just moduleName) . P.getQual . fst)
 
@@ -419,6 +419,9 @@ indexExportedEnv moduleName env refs conn = liftIO do
       SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM type_operators WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM value_operators WHERE module_name = ?" (SQL.Only moduleName)
+      
 
     refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool
     refMatch f (k, _) = maybe True (any (f k)) refs
@@ -509,12 +512,15 @@ insertNamedDict conn dict = do
 
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
+  
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, type_name TEXT, source_type BLOB, type_kind TEXT, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT, class BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, types TEXT, kinds TEXT, dict BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
   addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 4862f3fb92..974a9024ab 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -490,12 +490,16 @@ selectDoesClassInstanceExist ::
   P.Qualified P.Ident ->
   IO Bool
 selectDoesClassInstanceExist conn ident  = do
-  SQL.query
+  res <- SQL.query
     conn
     "SELECT EXISTS (SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?)"
     (toDbQualifer ident)
-    <&> head
-    <&> maybe False SQL.fromOnly
+  putErrText $ "selectDoesClassInstanceExist: " <> show ((toDbQualifer ident), res)
+  res 
+    & head
+    & maybe False SQL.fromOnly
+    & return
+
 
 selectValueOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe (P.ModuleName, Text))
 selectValueOperatorAlias conn modName opName = do
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index a26d8c7a74..5813950143 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -265,17 +265,17 @@ typeCheckAll
   => ModuleName
   -> [Declaration]
   -> m [Declaration]
-typeCheckAll moduleName = traverse (logDecl >=> go >=> logDone)
+typeCheckAll moduleName = traverse go -- (logDecl >=> go >=> logDone)
   where
-  logDecl :: Declaration -> m Declaration
-  logDecl d = do 
-    logGetEnv ("TypeChecking: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d))
-    return d
-
-  logDone :: Declaration -> m Declaration
-  logDone d = do 
-    logGetEnv ("TypeChecked: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d))
-    return d
+  -- logDecl :: Declaration -> m Declaration
+  -- logDecl d = do 
+  --   logGetEnv ("TypeChecking: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d))
+  --   return d
+
+  -- logDone :: Declaration -> m Declaration
+  -- logDone d = do 
+  --   logGetEnv ("TypeChecked: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d))
+  --   return d
   go :: Declaration -> m Declaration
   go d@(DataDeclaration sa@(ss, _) dtype name args dctors) = do
     warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do

From f828eab851facef9377b131f87a1d971ffc29149 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Thu, 2 Jan 2025 17:34:14 +0100
Subject: [PATCH 293/297] complex project building without errors

---
 .gitignore                                   |  2 +
 src/Language/PureScript/Make.hs              | 16 +++-----
 src/Language/PureScript/Make/Index.hs        | 40 +++++++++-----------
 src/Language/PureScript/Make/Index/Select.hs |  3 --
 src/Language/PureScript/TypeChecker.hs       |  5 ++-
 src/Language/PureScript/TypeChecker/Kinds.hs | 13 ++-----
 6 files changed, 31 insertions(+), 48 deletions(-)

diff --git a/.gitignore b/.gitignore
index 0454beffcb..4a35fe051b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -38,3 +38,5 @@ TAGS
 *.ps
 *.svg
 tests/purs/make/
+
+.codegpt
\ No newline at end of file
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 4142ca75f9..1d7d4c85fd 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -61,7 +61,6 @@ import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 import Prelude
 import Language.PureScript.Docs.Types qualified as Docs
-import Protolude (Print(putErrLn))
 
 -- | Rebuild a single module.
 --
@@ -179,11 +178,7 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
-  -- when (moduleName == ModuleName "Data.NaturalTransformation") $ do 
-  --   putErrLn ( "ops:" :: T.Text)
-  --   putErrLn $ intercalate "\n" $ fmap show ops
-  --   putErrLn ( "type ops:" :: T.Text)
-  --   putErrLn $ intercalate "\n" $ fmap show typeOps
+
   ((Module ss coms _ elaborated exps, checkSt), nextVar) <-
     desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv 
   let env' = P.checkEnv checkSt
@@ -197,6 +192,7 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
 
+
   corefn <- runDbEnv conn $ CF.moduleToCoreFn env' mod'
   let 
       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
@@ -219,7 +215,6 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
     --           ++ "; details:\n"
     --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
     --     Right d -> d
-
   evalSupplyT nextVar'' $ codegen env' checkSt mod' renamed docs exts
   return exts
 
@@ -269,14 +264,13 @@ desugarAndTypeCheckDb ::
   Module ->
   Env ->
   m ((Module, CheckState), Integer)
-desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv = runSupplyT 0 $ do
+desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError _withCheckState moduleName withPrim exEnv = runSupplyT 0 $ do
   runDbEnv conn $ deleteModuleEnv moduleName
   (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn exEnv withPrim) (exEnv, mempty)
   let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
   -- env <- selectEnvFromDefinitions conn exEnv' desugared
   let env = initEnvironment
   (checked, checkSt@(CheckState {..})) <- runStateT (catchError (runDbEnv conn $ typeCheckModule modulesExports desugared) mergeCheckState) (initialCheckState env)
-  lift $ withCheckState checkSt
   let usedImports' =
         foldl'
           ( flip $ \(fromModuleName, newtypeCtorName) ->
@@ -319,8 +313,8 @@ make ma@MakeActions {..} ms = do
   -- This is to ensure that modules complete fully before moving on, to avoid
   -- holding excess memory during compilation from modules that were paused
   -- by the Haskell runtime.
-  capabilities <- getNumCapabilities
-  let concurrency = max 1 capabilities
+  -- capabilities <- getNumCapabilities
+  let concurrency = 1 --  max 1 capabilities
   lock <- C.newQSem concurrency
 
   let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index 3152402aa1..d8b01d0954 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -1,10 +1,9 @@
 {-# LANGUAGE BlockArguments #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Make.Index
   ( initDb,
     addAllIndexing,
-    addAstModuleIndexing,
-    addExternIndexing,
     indexAstModuleFromExtern,
     indexAstDeclFromExternDecl,
     dropTables,
@@ -19,7 +18,7 @@ module Language.PureScript.Make.Index
 where
 
 import Codec.Serialise (serialise)
-import Control.Concurrent.Async.Lifted (mapConcurrently_, forConcurrently_)
+import Control.Concurrent.Async.Lifted (forConcurrently_, mapConcurrently_)
 import Data.List (partition)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@@ -42,7 +41,7 @@ import Language.PureScript.Names (Qualified ())
 import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue))
 import Protolude hiding (moduleName)
 
-addDbConnection :: Monad m => Connection -> P.MakeActions m -> P.MakeActions m
+addDbConnection :: (Monad m) => Connection -> P.MakeActions m -> P.MakeActions m
 addDbConnection conn ma =
   ma
     { P.getDbConnection = pure conn
@@ -51,8 +50,9 @@ addDbConnection conn ma =
 addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAllIndexing conn ma =
   -- addAstModuleIndexing conn $
-    addEnvIndexing conn ma 
-      -- addExternIndexing conn ma
+  addEnvIndexing conn ma
+
+-- addExternIndexing conn ma
 
 addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addAstModuleIndexing conn ma =
@@ -103,11 +103,11 @@ indexAstModule conn _endEnv (P.Module _ss _comments moduleName' decls _exportRef
               _ -> printDataDeclKind args
             P.TypeSynonymDeclaration _ann name args _ty -> case getMatchingKind P.TypeSynonymSig name of
               Just kind -> printType kind
-              _ -> printDataDeclKind args 
-                    -- case inferSynRes of
-                    --   Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
-                    --   Right (_, tyKind) ->
-                    --     printType $ foldr addDataDeclArgKind (void tyKind) args
+              _ -> printDataDeclKind args
+            -- case inferSynRes of
+            --   Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err)
+            --   Right (_, tyKind) ->
+            --     printType $ foldr addDataDeclArgKind (void tyKind) args
             P.TypeClassDeclaration _ name args _ _ _ -> case getMatchingKind P.ClassSig (P.coerceProperName name) of
               Just kind -> printType kind
               _ -> printTypeClassKind args
@@ -190,9 +190,9 @@ indexFixity conn moduleName' = \case
           "INSERT INTO value_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \
           \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)"
       )
-      [ ":module_name" := P.runModuleName moduleName',
+      [ ":module_name" := moduleName',
         ":op_name" := P.runOpName op,
-        ":alias_module_name" := P.runModuleName val_mod,
+        ":alias_module_name" := val_mod,
         ":alias" := either P.runIdent P.runProperName name,
         ":associativity" := P.showAssoc assoc,
         ":precedence" := prec
@@ -204,9 +204,9 @@ indexFixity conn moduleName' = \case
           "INSERT INTO type_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \
           \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)"
       )
-      [ ":module_name" := P.runModuleName moduleName',
+      [ ":module_name" := moduleName',
         ":op_name" := P.runOpName op,
-        ":alias_module_name" := P.runModuleName ty_mod,
+        ":alias_module_name" := ty_mod,
         ":alias" := name,
         ":associativity" := P.showAssoc assoc,
         ":precedence" := prec
@@ -421,7 +421,6 @@ indexExportedEnv module' env refs conn = liftIO do
       SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM type_operators WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM value_operators WHERE module_name = ?" (SQL.Only moduleName)
-      
 
     refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool
     refMatch f (k, _) = maybe True (any (f k)) refs
@@ -486,7 +485,7 @@ insertTypeSynonym conn ident (idents, st) = do
     (toDbQualifer ident :. (serialise idents, st, debug))
   where
     debug :: Text
-    debug = show (idents, st)
+    debug = "show (idents, st)"
 
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
 insertTypeClass conn ident tcd = do
@@ -494,11 +493,7 @@ insertTypeClass conn ident tcd = do
     conn
     "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)"
     ((clasMod, className) :. SQL.Only tcd)
-  -- SQL.execute
-  --   conn
-  --   "DELETE FROM env_type_class_instances WHERE class_name = ?"
-  --   (SQL.Only clasMod)
-  where 
+  where
     (clasMod, className) = toDbQualifer ident
 
 insertNamedDict :: Connection -> NamedDict -> IO ()
@@ -512,7 +507,6 @@ insertNamedDict conn dict = do
 
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
-  
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, type_name TEXT, source_type BLOB, type_kind TEXT, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 974a9024ab..16c600430d 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -2,9 +2,7 @@
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-local-binds #-}
-
 {-# HLINT ignore "Redundant bracket" #-}
-{-# LANGUAGE InstanceSigs #-}
 
 module Language.PureScript.Make.Index.Select where
 
@@ -494,7 +492,6 @@ selectDoesClassInstanceExist conn ident  = do
     conn
     "SELECT EXISTS (SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?)"
     (toDbQualifer ident)
-  putErrText $ "selectDoesClassInstanceExist: " <> show ((toDbQualifer ident), res)
   res 
     & head
     & maybe False SQL.fromOnly
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 5813950143..31fc5267a5 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -87,7 +87,7 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do
   putEnv $ env { dataConstructors = M.insert (Qualified (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
 
 checkRoleDeclaration
-  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => ModuleName
   -> RoleDeclarationData
   -> m ()
@@ -95,7 +95,8 @@ checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles)
   warnAndRethrow (addHint (ErrorInRoleDeclaration name) . addHint (positionedError ss)) $ do
     env <- getEnv
     let qualName = Qualified (ByModuleName moduleName) name
-    case M.lookup qualName (types env) of
+    kindAndData <- lookupTypeMb qualName
+    case kindAndData of
       Just (kind, DataType dtype args dctors) -> do
         checkRoleDeclarationArity name declaredRoles (length args)
         checkRoles args declaredRoles
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 2292c0cf48..628fef1a7a 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -43,7 +43,7 @@ import Data.Functor (($>))
 import Data.IntSet qualified as IS
 import Data.List (nubBy, sortOn, (\\))
 import Data.Map qualified as M
-import Data.Maybe (fromJust, fromMaybe)
+import Data.Maybe (fromJust, fromMaybe, isJust)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Traversable (for)
@@ -52,7 +52,7 @@ import Language.PureScript.Crash (HasCallStack, internalError)
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Errors
 import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified)
-import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, addIdeType, addIdeTypeNameQual, lookupType, lookupTypeMb)
+import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, lookupType, lookupTypeMb, lookupSynonymMb)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize)
 import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
 import Language.PureScript.Types
@@ -162,19 +162,14 @@ inferKind
 inferKind = \tyToInfer ->
   withErrorMessageHint (ErrorInferringKind tyToInfer)
     . rethrowWithPosition (fst $ getAnnForType tyToInfer)
-    $ addTypeKindToIde
-    =<< go tyToInfer
+    $ go tyToInfer
   where
-  addTypeKindToIde (ty, kind)  = do 
-    addIdeType ty kind 
-    pure (ty, kind)
   go = \case
     ty@(TypeConstructor ann v) -> do
       k <- lookupType (fst ann) v
       case k of
         (kind, E.LocalTypeVariable) -> do
           kind' <- apply kind
-          addIdeTypeNameQual (fst ann) v (kind' $> ann)
           pure (ty, kind' $> ann)
         (kind, _) -> do
           -- let className = coerceProperName <$> v
@@ -279,7 +274,7 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of
     cannotApplyTypeToType fn arg
   where
   requiresSynonymsToExpand = \case
-    TypeConstructor _ v -> M.notMember v . E.typeSynonyms <$> getEnv
+    TypeConstructor _ v -> isJust <$> lookupSynonymMb v
     TypeApp _ l _ -> requiresSynonymsToExpand l
     KindApp _ l _ -> requiresSynonymsToExpand l
     _ -> pure True

From 336a1eb1e93da9ef07bc9b726826daf638318174 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 3 Jan 2025 05:44:51 +0100
Subject: [PATCH 294/297] adds modules to db

---
 src/Language/PureScript/Make.hs              |  4 +-
 src/Language/PureScript/Make/Actions.hs      |  7 ++++
 src/Language/PureScript/Make/BuildPlan.hs    |  8 ++++
 src/Language/PureScript/Make/Index.hs        | 43 ++++++++++++--------
 src/Language/PureScript/Make/Index/Select.hs |  8 +---
 5 files changed, 45 insertions(+), 25 deletions(-)

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 1d7d4c85fd..994e2d4768 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -313,8 +313,8 @@ make ma@MakeActions {..} ms = do
   -- This is to ensure that modules complete fully before moving on, to avoid
   -- holding excess memory during compilation from modules that were paused
   -- by the Haskell runtime.
-  -- capabilities <- getNumCapabilities
-  let concurrency = 1 --  max 1 capabilities
+  capabilities <- getNumCapabilities
+  let concurrency = max 1 capabilities
   lock <- C.newQSem concurrency
 
   let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 98f6bf0de7..465a07bb04 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -63,6 +63,7 @@ import Prelude
 import Database.SQLite.Simple (Connection)
 import Language.PureScript.DB (mkConnection)
 
+
 -- | Determines when to rebuild a module
 data RebuildPolicy
   = -- | Never rebuild this module
@@ -274,13 +275,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
     codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
     codegen _prevEnv _endEnv _m m docs exts = do
+
       let mn = CF.moduleName m
       lift $ writeCborFile (outputFilename mn externsFileName) exts
+
       codegenTargets <- lift $ asks optionsCodegenTargets
       when (S.member CoreFn codegenTargets) $ do
         let coreFnFile = targetFilename mn CoreFn
             json = CFJ.moduleToJSON Paths.version m
         lift $ writeJSONFile coreFnFile json
+
       when (S.member JS codegenTargets) $ do
         foreignInclude <- case mn `M.lookup` foreigns of
           Just _
@@ -292,6 +296,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
             | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
             | otherwise -> return Nothing
         rawJs <- J.moduleToJs m foreignInclude
+
         dir <- lift $ makeIO "get the current directory" getCurrentDirectory
         let sourceMaps = S.member JSSourceMap codegenTargets
             (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
@@ -300,8 +305,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
             prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]
             js = T.unlines $ map ("// " <>) prefix ++ [pjs]
             mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
+
         lift $ do
           writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef)
+
           when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
       when (S.member Docs codegenTargets) $ do
         lift $ writeJSONFile (outputFilename mn "docs.json") docs
diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs
index 3eba2359a3..4436ce3a4c 100644
--- a/src/Language/PureScript/Make/BuildPlan.hs
+++ b/src/Language/PureScript/Make/BuildPlan.hs
@@ -214,3 +214,11 @@ construct MakeActions{..} cacheDb (sorted, graph) = do
 maximumMaybe :: Ord a => [a] -> Maybe a
 maximumMaybe [] = Nothing
 maximumMaybe xs = Just $ maximum xs
+
+
+-- constructFromDb  :: forall m. MonadBaseControl IO m
+--   => MakeActions m
+--   -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
+--   -> m (BuildPlan, CacheDb)
+-- constructFromDb MakeActions{..}  (sorted, graph) = do
+--   pure undefined
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index d8b01d0954..cbebe9a3e0 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -383,7 +383,8 @@ dropTables conn = do
 indexExportedEnv :: (MonadIO m) => P.Module -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
 indexExportedEnv module' env refs conn = liftIO do
   deleteModuleEnv
-  forConcurrently_ (P.getModuleDeclarations module') (indexFixity conn moduleName)
+  insertModule conn moduleName path
+  forConcurrently_ (P.exportedDeclarations module') (indexFixity conn moduleName)
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
   envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn)
   envFromModule E.dataConstructors & filter dataConstructorExportedOrDict & mapConcurrently_ (uncurry $ insertDataConstructor conn)
@@ -393,6 +394,8 @@ indexExportedEnv module' env refs conn = liftIO do
     -- & filter ((== Just moduleName) . P.getQual . tcdValue)
     & mapConcurrently_ (insertNamedDict conn)
   where
+    path = P.spanName (P.getModuleSourceSpan module')
+
     moduleName = P.getModuleName module'
     envFromModule :: (E.Environment -> Map.Map (Qualified k) v) -> [(Qualified k, v)]
     envFromModule f = f env & Map.toList & filter ((== Just moduleName) . P.getQual . fst)
@@ -413,14 +416,7 @@ indexExportedEnv module' env refs conn = liftIO do
         else dict {tcdValue = P.Qualified (P.ByModuleName moduleName) (P.disqualify $ tcdValue dict)}
 
     deleteModuleEnv = do
-      SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM type_operators WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM value_operators WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM modules WHERE module_name = ?" (SQL.Only moduleName)
 
     refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool
     refMatch f (k, _) = maybe True (any (f k)) refs
@@ -454,6 +450,15 @@ indexExportedEnv module' env refs conn = liftIO do
 
 type EnvValue = (P.SourceType, P.NameKind, P.NameVisibility)
 
+insertModule :: Connection -> P.ModuleName -> FilePath -> IO ()
+insertModule conn moduleName' path = do
+  SQL.executeNamed
+    conn
+    (SQL.Query "INSERT OR REPLACE INTO modules (module_name, path) VALUES (:module_name, :path)")
+    [ ":module_name" := P.runModuleName moduleName',
+      ":path" := path
+    ]
+
 insertEnvValue :: Connection -> P.Qualified P.Ident -> EnvValue -> IO ()
 insertEnvValue conn ident val = do
   SQL.execute
@@ -507,18 +512,22 @@ insertNamedDict conn dict = do
 
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT, type_name TEXT, source_type BLOB, type_kind TEXT, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT, class_name TEXT, class BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, types TEXT, kinds TEXT, dict BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS modules (module_name TEXT NOT NULL PRIMARY KEY, path TEXT, created_at DATETIME DEFAULT CURRENT_TIMESTAMP, hash INT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT references modules(module_name) ON DELETE CASCADE, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT references modules(module_name) ON DELETE CASCADE, type_name TEXT, source_type BLOB, type_kind TEXT, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT references modules(module_name) ON DELETE CASCADE, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT references modules(module_name) ON DELETE CASCADE, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT references modules(module_name) ON DELETE CASCADE, class_name TEXT, class BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT references modules(module_name) ON DELETE CASCADE, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, types TEXT, kinds TEXT, dict BLOB, debug TEXT)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
   addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
 addEnvIndexes conn = do
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS modules_module_name_idx ON modules(module_name)"
+  SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS modules_path_idx ON modules(path)"
+  SQL.execute_ conn "CREATE INDEX IF NOT EXISTS modules_created_at_idx ON modules(created_at)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_values_idx ON env_values(module_name, ident)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_types_idx ON env_types(module_name, type_name)"
   SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_data_constructors_idx ON env_data_constructors(module_name, constructor_name)"
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index 16c600430d..c511a3b987 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -550,12 +550,8 @@ insertImport conn mn = \case
 
 deleteModuleEnvImpl :: P.ModuleName -> Connection -> IO ()
 deleteModuleEnvImpl moduleName conn = do
-  SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM modules WHERE module_name = ?" (SQL.Only moduleName)
+
 
 getEnvConstraints :: E.Environment -> [P.SourceConstraint]
 getEnvConstraints env =

From f533a00a5601a0f39e25bee8979c910c35ecf715 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Fri, 3 Jan 2025 06:02:09 +0100
Subject: [PATCH 295/297] start makeDb

---
 src/Language/PureScript/Compile.hs |   5 +-
 src/Language/PureScript/Make.hs    | 142 +++++++++++++++++++++++++++++
 src/Language/PureScript/Sugar.hs   |   2 +-
 3 files changed, 146 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/Compile.hs b/src/Language/PureScript/Compile.hs
index 6d6253c8b3..594bd5bad2 100644
--- a/src/Language/PureScript/Compile.hs
+++ b/src/Language/PureScript/Compile.hs
@@ -9,8 +9,9 @@ import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
 import Language.PureScript.Make.Index (addAllIndexing, addDbConnection)
 import System.Directory (createDirectoryIfMissing)
 import Prelude
+import Language.PureScript.Names (ModuleName)
 
-compile :: P.Options -> [(FilePath, P.Text)] -> Connection -> FilePath -> Bool -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
+compile :: P.Options -> [(FilePath, P.Text)] -> Connection -> FilePath -> Bool -> IO (Either P.MultipleErrors [ModuleName], P.MultipleErrors)
 compile opts moduleFiles conn outputDir usePrefx = do
   runMake opts $ do
     ms <- CST.parseModulesFromFiles id moduleFiles
@@ -21,4 +22,4 @@ compile opts moduleFiles conn outputDir usePrefx = do
           addDbConnection conn $
             addAllIndexing conn $
               buildMakeActions outputDir filePathMap foreigns usePrefx
-    P.make makeActions (map snd ms)
\ No newline at end of file
+    P.makeDb makeActions (map snd ms)
\ No newline at end of file
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 994e2d4768..1963ca31b2 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -7,6 +7,7 @@ module Language.PureScript.Make
     rebuildModule',
     rebuildModuleWithProvidedEnv,
     make,
+    makeDb,
     inferForeignModules,
     module Monad,
     module Actions,
@@ -439,6 +440,147 @@ make ma@MakeActions {..} ms = do
 
       BuildPlan.markComplete buildPlan moduleName result
 
+
+makeDb ::
+  forall m.
+  (MonadBaseControl IO m, MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
+  MakeActions m ->
+  [CST.PartialResult Module] ->
+  m [ModuleName]
+makeDb ma@MakeActions {..} ms = do
+  checkModuleNames
+  cacheDb <- readCacheDb
+  conn <- getDbConnection
+
+  (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms
+
+  (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph)
+
+  -- Limit concurrent module builds to the number of capabilities as
+  -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`.
+  -- This is to ensure that modules complete fully before moving on, to avoid
+  -- holding excess memory during compilation from modules that were paused
+  -- by the Haskell runtime.
+  capabilities <- getNumCapabilities
+  let concurrency = max 1 capabilities
+  lock <- C.newQSem concurrency
+
+  let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
+  let totalModuleCount = length toBeRebuilt
+  for_ toBeRebuilt $ \m -> fork $ do
+    let moduleName = getModuleName . CST.resPartial $ m
+    let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
+    buildModule
+      conn
+      lock
+      buildPlan
+      moduleName
+      totalModuleCount
+      (spanName . getModuleSourceSpan . CST.resPartial $ m)
+      (fst $ CST.resFull m)
+      (fmap importPrim . snd $ CST.resFull m)
+      (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
+      -- Prevent hanging on other modules when there is an internal error
+      -- (the exception is thrown, but other threads waiting on MVars are released)
+      `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty)
+
+  -- Wait for all threads to complete, and collect results (and errors).
+  (failures, _successes) <-
+    let splitResults = \case
+          BuildJobSucceeded _ exts ->
+            Right exts
+          BuildJobFailed errs ->
+            Left errs
+          BuildJobSkipped ->
+            Left mempty
+     in M.mapEither splitResults <$> BuildPlan.collectResults buildPlan
+
+  -- Write the updated build cache database to disk
+  writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb
+
+  writePackageJson
+
+  -- If generating docs, also generate them for the Prim modules
+  outputPrimDocs
+
+  -- All threads have completed, rethrow any caught errors.
+  let errors = M.elems failures
+  unless (null errors) $ throwError (mconcat errors)
+
+  return (map (getModuleName . CST.resPartial) sorted)
+  where
+    checkModuleNames :: m ()
+    checkModuleNames = checkNoPrim *> checkModuleNamesAreUnique
+
+    checkNoPrim :: m ()
+    checkNoPrim =
+      for_ ms $ \m ->
+        let mn = getModuleName $ CST.resPartial m
+         in when (isBuiltinModuleName mn)
+              $ throwError
+                . errorMessage' (getModuleSourceSpan $ CST.resPartial m)
+              $ CannotDefinePrimModules mn
+
+    checkModuleNamesAreUnique :: m ()
+    checkModuleNamesAreUnique =
+      for_ (findDuplicates (getModuleName . CST.resPartial) ms) $ \mss ->
+        throwError . flip foldMap mss $ \ms' ->
+          let mn = getModuleName . CST.resPartial . NEL.head $ ms'
+           in errorMessage'' (fmap (getModuleSourceSpan . CST.resPartial) ms') $ DuplicateModule mn
+
+    -- Find all groups of duplicate values in a list based on a projection.
+    findDuplicates :: (Ord b) => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a]
+    findDuplicates f xs =
+      case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortOn f $ xs of
+        [] -> Nothing
+        xss -> Just xss
+
+    -- Sort a list so its elements appear in the same order as in another list.
+    inOrderOf :: (Ord a) => [a] -> [a] -> [a]
+    inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
+
+    buildModule :: Connection -> QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
+    buildModule conn lock buildPlan moduleName cnt fp pwarnings mres deps = do
+      result <- flip catchError (return . BuildJobFailed) $ do
+        let pwarnings' = CST.toMultipleWarnings fp pwarnings
+        tell pwarnings'
+        m <- CST.unwrapParserError fp mres
+        -- We need to wait for dependencies to be built, before checking if the current
+        -- module should be rebuilt, so the first thing to do is to wait on the
+        -- MVars for the module's dependencies.
+        mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps
+
+        case mexterns of
+          Just (_, externs) -> do
+            -- We need to ensure that all dependencies have been included in Env
+            C.modifyMVar_ (bpEnv buildPlan) $ \env -> do
+              let go :: Env -> ModuleName -> m Env
+                  go e dep = case lookup dep (zip deps externs) of
+                    Just exts
+                      | not (M.member dep e) -> externsEnv e exts
+                    _ -> return e
+              foldM go env deps
+            env <- C.readMVar (bpEnv buildPlan)
+            idx <- C.takeMVar (bpIndex buildPlan)
+            C.putMVar (bpIndex buildPlan) (idx + 1)
+
+            -- Bracket all of the per-module work behind the semaphore, including
+            -- forcing the result. This is done to limit concurrency and keep
+            -- memory usage down; see comments above.
+            (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do
+              -- Eventlog markers for profiling; see debug/eventlog.js
+              liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start"
+              -- Force the externs and warnings to avoid retaining excess module
+              -- data after the module is finished compiling.
+              extsAndWarnings <- evaluate . force <=< listen $ do
+                rebuildModuleWithIndexDb ma conn env m (Just (idx, cnt))
+              liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
+              return extsAndWarnings
+            return $ BuildJobSucceeded (pwarnings' <> warnings) exts
+          Nothing -> return BuildJobSkipped
+
+      BuildPlan.markComplete buildPlan moduleName result
+
 -- | Infer the module name for a module by looking for the same filename with
 -- a .js extension.
 inferForeignModules ::
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 387e93c8e9..c1d7ad49d0 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -97,6 +97,6 @@ desugarUsingDb conn env = do
 
   where
     rebracketUsingDb m = do 
-      (fixities, typeFixities) <- liftIO $ selectFixitiesFromModuleImports conn  env m 
+      (fixities, typeFixities) <- liftIO $ selectFixitiesFromModuleImports conn env m 
       rebracketFixitiesOnly (const True) fixities typeFixities m
       
\ No newline at end of file

From 3d7033c23cefc63f6f00f42ffea376cfda5423ff Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Tue, 7 Jan 2025 15:54:20 +0100
Subject: [PATCH 296/297] adds db build plan

---
 purescript.cabal                              |   1 +
 src/Language/PureScript/AST/Declarations.hs   |   6 +
 src/Language/PureScript/CoreFn/Binders.hs     |   5 +-
 src/Language/PureScript/CoreFn/Desugar.hs     |  32 ++-
 src/Language/PureScript/CoreFn/Expr.hs        |   9 +-
 src/Language/PureScript/CoreFn/Meta.hs        |   7 +-
 src/Language/PureScript/CoreFn/Module.hs      |   5 +-
 src/Language/PureScript/Externs.hs            |   3 +
 src/Language/PureScript/Ide/Rebuild.hs        |   2 +-
 src/Language/PureScript/Lsp/Rebuild.hs        |  11 +-
 src/Language/PureScript/Make.hs               | 190 +++++++++------
 src/Language/PureScript/Make/Actions.hs       |  16 +-
 src/Language/PureScript/Make/BuildPlanDB.hs   | 221 ++++++++++++++++++
 src/Language/PureScript/Make/Index.hs         | 121 +++++++---
 src/Language/PureScript/Make/Index/Select.hs  | 118 ++++++++--
 src/Language/PureScript/Renamer.hs            |   8 +-
 src/Language/PureScript/Sugar/Names.hs        |   1 +
 .../PureScript/TypeChecker/Synonyms.hs        |   9 +-
 src/Language/PureScript/TypeChecker/Types.hs  |   7 +-
 19 files changed, 614 insertions(+), 158 deletions(-)
 create mode 100644 src/Language/PureScript/Make/BuildPlanDB.hs

diff --git a/purescript.cabal b/purescript.cabal
index 367fc073ea..c898dc3966 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -376,6 +376,7 @@ library
     Language.PureScript.Make
     Language.PureScript.Make.Actions
     Language.PureScript.Make.BuildPlan
+    Language.PureScript.Make.BuildPlanDB
     Language.PureScript.Make.Cache
     Language.PureScript.Make.Index
     Language.PureScript.Make.Index.Select
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index ae17eedb69..9778e0540f 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -319,6 +319,12 @@ data ImportDeclarationType
   | Hiding [DeclarationRef]
   deriving (Eq, Ord, Show, Generic, Serialise, NFData)
 
+instance ToField ImportDeclarationType where
+  toField = toField . S.serialise
+
+instance FromField ImportDeclarationType where
+  fromField a = S.deserialise <$> fromField a
+
 isExplicit :: ImportDeclarationType -> Bool
 isExplicit (Explicit _) = True
 isExplicit _ = False
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
index 4b64b97c49..e4e6ef60ea 100644
--- a/src/Language/PureScript/CoreFn/Binders.hs
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 -- |
 -- The core functional representation for binders
 --
@@ -7,6 +8,8 @@ import Prelude
 
 import Language.PureScript.AST.Literals (Literal)
 import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified)
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
 
 -- |
 -- Data type for binders
@@ -31,7 +34,7 @@ data Binder a
   -- |
   -- A binder which binds its input to an identifier
   --
-  | NamedBinder a Ident (Binder a) deriving (Eq, Ord, Show, Functor)
+  | NamedBinder a Ident (Binder a) deriving (Eq, Ord, Show, Functor, Generic, NFData)
 
 
 extractBinderAnn :: Binder a -> a
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 4e398d879e..303aad7c86 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -2,7 +2,7 @@
 module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
 
 import Prelude
-import Protolude (ordNub, orEmpty, (<&>), join, for)
+import Protolude (ordNub, orEmpty, (<&>), join, for, when)
 
 
 import Data.Function (on)
@@ -23,26 +23,38 @@ import Language.PureScript.CoreFn.Module (Module(..))
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupValue)
 import Language.PureScript.Label (Label(..))
-import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual)
+import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName (ModuleName), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual)
 import Language.PureScript.PSString (PSString)
 import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..))
 import Language.PureScript.AST qualified as A
 import Language.PureScript.Constants.Prim qualified as C
-import Language.PureScript.Make.Index.Select (GetEnv (getDataConstructor))
+import Language.PureScript.Make.Index.Select (GetEnv (getDataConstructor, logGetEnv))
+import Control.DeepSeq (force)
+import Data.Text (Text)
 
 -- | Desugars a module from AST to CoreFn representation.
 moduleToCoreFn :: forall m. (Monad m, GetEnv m) => Environment -> A.Module -> m (Module Ann)
 moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =
   internalError "Module exports were not elaborated before moduleToCoreFn"
 moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = do
-  let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls)
-      imports' = dedupeImports imports
-      exps' = ordNub $ concatMap exportToCoreFn exps
-      reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps)
-      externs = ordNub $ mapMaybe externToCoreFn decls
-  decls' <- join <$> traverse declToCoreFn decls
+  log' "moduleToCoreFn start"
+  let !imports = force $ mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls)
+  log' "moduleToCoreFn imports"
+  let !imports' = force $ dedupeImports imports
+  log' "moduleToCoreFn dedupeImports"
+  let !exps' = force $ ordNub $ concatMap exportToCoreFn exps
+  log' "moduleToCoreFn exportToCoreFn"
+  let !reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps)
+  let !externs = ordNub $ mapMaybe externToCoreFn decls
+  log' "moduleToCoreFn externToCoreFn"
+  !decls' <- force . join <$> traverse declToCoreFn decls
+  log' "moduleToCoreFn declToCoreFn"
   pure $ Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls'
   where
+  log' :: Text -> m ()
+  log' t = do 
+    when (mn == ModuleName "OaHasuraFetch.Client") do 
+      logGetEnv t
   -- Creates a map from a module name to the re-export references defined in
   -- that module.
   reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident]
@@ -239,7 +251,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = do
     typeConstructor _ = internalError "Invalid argument to typeConstructor"
 
   lookupConstructor' :: Qualified (ProperName 'ConstructorName) -> m (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
-  lookupConstructor' name =   case M.lookup name (dataConstructors env) of
+  lookupConstructor' name = case M.lookup name (dataConstructors env) of
     Nothing -> do 
       ctrMb <- getDataConstructor name 
       case ctrMb of 
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 20ab333011..c34084641a 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 -- |
 -- The core functional representation
 --
@@ -11,6 +12,8 @@ import Language.PureScript.AST.Literals (Literal)
 import Language.PureScript.CoreFn.Binders (Binder)
 import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified)
 import Language.PureScript.PSString (PSString)
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
 
 -- |
 -- Data type for expressions and terms
@@ -52,7 +55,7 @@ data Expr a
   -- A let binding
   --
   | Let a [Bind a] (Expr a)
-  deriving (Eq, Ord, Show, Functor)
+  deriving (Eq, Ord, Show, Functor, Generic, NFData)
 
 -- |
 -- A let or module binding.
@@ -65,7 +68,7 @@ data Bind a
   -- |
   -- Mutually recursive binding group for several values
   --
-  | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor)
+  | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor, Generic, NFData)
 
 -- |
 -- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -84,7 +87,7 @@ data CaseAlternative a = CaseAlternative
     -- The result expression or a collect of guarded expressions
     --
   , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
-  } deriving (Eq, Ord, Show)
+  } deriving (Eq, Ord, Show, Generic, NFData)
 
 instance Functor CaseAlternative where
 
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
index 0baddca29b..2ec35472b8 100644
--- a/src/Language/PureScript/CoreFn/Meta.hs
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 -- |
 -- Metadata annotations for core functional representation
 --
@@ -6,6 +7,8 @@ module Language.PureScript.CoreFn.Meta where
 import Prelude
 
 import Language.PureScript.Names (Ident)
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
 
 -- |
 -- Metadata annotations
@@ -35,7 +38,7 @@ data Meta
   -- The contained function application was synthesized by the compiler
   --
   | IsSyntheticApp
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic, NFData)
 
 -- |
 -- Data constructor metadata
@@ -48,4 +51,4 @@ data ConstructorType
   -- |
   -- The constructor is for a type with multiple constructors
   --
-  | SumType deriving (Show, Eq, Ord)
+  | SumType deriving (Show, Eq, Ord, Generic, NFData)
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
index 09f5189c4a..fcf2dd200a 100644
--- a/src/Language/PureScript/CoreFn/Module.hs
+++ b/src/Language/PureScript/CoreFn/Module.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Language.PureScript.CoreFn.Module where
 
 import Prelude
@@ -8,6 +9,8 @@ import Language.PureScript.AST.SourcePos (SourceSpan)
 import Language.PureScript.Comments (Comment)
 import Language.PureScript.CoreFn.Expr (Bind)
 import Language.PureScript.Names (Ident, ModuleName)
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
 
 -- |
 -- The CoreFn module representation
@@ -22,4 +25,4 @@ data Module a = Module
   , moduleReExports :: Map ModuleName [Ident]
   , moduleForeign :: [Ident]
   , moduleDecls :: [Bind a]
-  } deriving (Functor, Show)
+  } deriving (Functor, Show, Generic, NFData)
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index bd25ba7b73..d93a8d676f 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -78,6 +78,9 @@ data ExternsImport = ExternsImport
   , eiImportedAs :: Maybe ModuleName
   } deriving (Show, Generic, NFData)
 
+instance FromRow ExternsImport where
+  fromRow = ExternsImport <$> field <*> field <*> field
+
 instance Serialise ExternsImport
 
 -- | A fixity declaration in an externs file
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 7b82c6c535..b3080e1804 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -184,7 +184,7 @@ shushProgress ma =
 -- | Stops any kind of codegen
 shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
-  ma { P.codegen = \_ _ _ _ _ _ -> pure ()
+  ma { P.codegen = \_ _ _ _ _ -> pure ()
      , P.ffiCodegen = \_ -> pure ()
      }
 
diff --git a/src/Language/PureScript/Lsp/Rebuild.hs b/src/Language/PureScript/Lsp/Rebuild.hs
index 58e7962482..809c96c6de 100644
--- a/src/Language/PureScript/Lsp/Rebuild.hs
+++ b/src/Language/PureScript/Lsp/Rebuild.hs
@@ -22,7 +22,7 @@ import Language.PureScript.Lsp.Cache (selectDependencies, selectDependencyHashFr
 import Language.PureScript.Lsp.Log (debugLsp, errorLsp, logPerfStandard, warnLsp)
 import Language.PureScript.Lsp.ReadFile (lspReadFileText)
 import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath), getInferExpressions, getMaxFilesInCache)
-import Language.PureScript.Lsp.State (addExternsToExportEnv, cacheEnvironment, cacheRebuild', cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, updateCachedRebuildResult, mergePartialArtifacts)
+import Language.PureScript.Lsp.State (addExternsToExportEnv, cacheEnvironment, cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, updateCachedRebuildResult, mergePartialArtifacts)
 import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState)
 import Language.PureScript.Lsp.Types qualified as Types
 import Language.PureScript.Make qualified as P
@@ -150,10 +150,13 @@ codegenTargets :: Set P.CodegenTarget
 codegenTargets = Set.fromList [P.JS, P.CoreFn, P.Docs]
 
 addRebuildCaching :: P.ModuleName  -> TVar LspState -> Int -> Text -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make
-addRebuildCaching modName stVar maxCache src depHash ma =
+addRebuildCaching modName stVar _maxCache _src _depHash ma =
   ma
-    { P.codegen = \prevEnv checkSt astM m docs ext -> lift (P.makeIO "Cache rebuild" $ cacheRebuild' stVar maxCache src ext (P.checkIdeArtifacts checkSt) astM depHash) <* P.codegen ma prevEnv checkSt astM m docs ext
-    , P.withCheckStateOnError = \checkSt -> P.makeIO "replace artifacts" $ mergePartialArtifacts stVar (P.checkIdeArtifacts checkSt) modName
+    { 
+    --   P.codegen = \prevEnv checkSt astM m docs ext -> lift (P.makeIO "Cache rebuild" $ cacheRebuild' stVar maxCache src ext (P.checkIdeArtifacts checkSt) astM depHash) <* P.codegen ma prevEnv checkSt astM m docs ext
+    -- , 
+    
+    P.withCheckStateOnError = \checkSt -> P.makeIO "replace artifacts" $ mergePartialArtifacts stVar (P.checkIdeArtifacts checkSt) modName
     }
 
 getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState)
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 1963ca31b2..a50fa6193c 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -1,5 +1,7 @@
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE NumDecimals #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module Language.PureScript.Make
   ( -- * Make API
@@ -29,7 +31,7 @@ import Control.Monad.Writer.Class (MonadWriter (..), censor)
 import Control.Monad.Writer.Strict (MonadTrans (lift), runWriterT)
 import Data.Foldable (fold, for_)
 import Data.Function (on)
-import Data.List (foldl', sortOn, intercalate)
+import Data.List (foldl', intercalate, sortOn)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
@@ -37,31 +39,34 @@ import Data.Set qualified as S
 import Data.Text qualified as T
 import Database.SQLite.Simple (Connection)
 import Debug.Trace (traceMarkerIO)
-import Language.PureScript.AST (ErrorMessageHint (..), Module (..), SourceSpan (..), getModuleName, getModuleSourceSpan, importPrim)
+import GHC.Conc (enableAllocationLimit, setAllocationCounter)
+import Language.PureScript.AST (ErrorMessageHint (..), Module (..), SourceSpan (..), getModuleName, getModuleSourceSpan, importPrim, internalModuleSourceSpan)
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Docs.Convert qualified as Docs
+import Language.PureScript.Docs.Types qualified as Docs
 import Language.PureScript.Environment (Environment, initEnvironment)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
-import Language.PureScript.Externs (ExternsFile, ExternsFixity, ExternsTypeFixity, applyExternsFileToEnvironment, moduleToExternsFile)
+import Language.PureScript.Externs (ExternsFile (..), ExternsFixity, ExternsTypeFixity, applyExternsFileToEnvironment, moduleToExternsFile)
 import Language.PureScript.Linter (Name (..), lint, lintImports)
 import Language.PureScript.Make.Actions as Actions
 import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult)
 import Language.PureScript.Make.BuildPlan qualified as BuildPlan
+import Language.PureScript.Make.BuildPlanDB qualified as BuildPlanDB
 import Language.PureScript.Make.Cache qualified as Cache
-import Language.PureScript.Make.Index.Select (getModuleFixities, selectFixitiesFromModuleImportsAndDecls, selectFixitiesFromModuleImports, GetEnv (deleteModuleEnv), runDbEnv, runWoGetEnv)
+import Language.PureScript.Make.Index.Select (GetEnv (deleteModuleEnv), dbEnv, getModuleFixities, runDbEnv, runWoGetEnv, selectFixitiesFromModuleImports)
 import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.ModuleDependencies (DependencyDepth (..), moduleSignature, sortModules)
-import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName)
+import Language.PureScript.Names (ModuleName (..), isBuiltinModuleName, runModuleName)
 import Language.PureScript.Renamer (renameInModule)
 import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, desugarUsingDb, externsEnv, primEnv)
 import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule)
 import Language.PureScript.TypeChecker.Monad qualified as P
+import Protolude (putErrText)
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 import Prelude
-import Language.PureScript.Docs.Types qualified as Docs
 
 -- | Rebuild a single module.
 --
@@ -141,10 +146,9 @@ rebuildModuleWithProvidedEnv initialCheckState MakeActions {..} exEnv env extern
   let mod' = Module ss coms moduleName regrouped exps
 
   corefn <- runWoGetEnv $ CF.moduleToCoreFn env' mod'
-  let 
-      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
-      (renamedIdents, renamed) = renameInModule optimized
-      exts = moduleToExternsFile mod' env' renamedIdents
+  let (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
+      (_renamedIdents, renamed) = renameInModule optimized
+  -- exts = moduleToExternsFile mod' env' renamedIdents
   ffiCodegen renamed
   -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
   -- but I have not done so for two reasons:
@@ -162,8 +166,21 @@ rebuildModuleWithProvidedEnv initialCheckState MakeActions {..} exEnv env extern
               ++ prettyPrintMultipleErrors defaultPPEOptions errs
         Right d -> d
 
-  evalSupplyT nextVar'' $ codegen env checkSt mod' renamed docs exts
-  return exts
+  evalSupplyT nextVar'' $ codegen env checkSt mod' renamed docs
+  return dummyExternsFile
+
+dummyExternsFile :: ExternsFile
+dummyExternsFile =
+  ExternsFile
+    { efVersion = "0",
+      efSourceSpan = internalModuleSourceSpan "<dummy>",
+      efModuleName = ModuleName "dummy",
+      efExports = [],
+      efImports = [],
+      efFixities = [],
+      efTypeFixities = [],
+      efDeclarations = []
+    }
 
 rebuildModuleWithProvidedEnvDb ::
   forall m.
@@ -179,9 +196,13 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
   progress $ CompilingModule moduleName moduleIndex
   let withPrim = importPrim m
   lint withPrim
+  putErrText $ "linted: " <> T.pack (show moduleName)
 
   ((Module ss coms _ elaborated exps, checkSt), nextVar) <-
-    desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv 
+    desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv
+
+  putErrText $ "type checked: " <> T.pack (show moduleName)
+
   let env' = P.checkEnv checkSt
 
   -- desugar case declarations *after* type- and exhaustiveness checking
@@ -191,15 +212,22 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
     desugarCaseGuards elaborated
 
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
+  putErrText $ "regrouped: " <> T.pack (show moduleName)
   let mod' = Module ss coms moduleName regrouped exps
 
+  !corefn <- fmap force $ runDbEnv conn $ CF.moduleToCoreFn env' mod'
+  putErrText $ "corefn: " <> T.pack (show moduleName)
+  let -- !(optimized, nextVar'') = force $ runSupply nextVar' $ CF.optimizeCoreFn corefn
+      optimized = corefn
+      nextVar'' = nextVar'
+  putErrText $ "optimized: " <> T.pack (show moduleName)
+
+  let !(_renamedIdents, renamed) = force (renameInModule optimized)
+  putErrText $ "renamed: " <> T.pack (show moduleName)
 
-  corefn <- runDbEnv conn $ CF.moduleToCoreFn env' mod'
-  let 
-      (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
-      (renamedIdents, renamed) = renameInModule optimized
-      exts = moduleToExternsFile mod' env' renamedIdents
+  -- exts = moduleToExternsFile mod' env' renamedIdents
   ffiCodegen renamed
+  putErrText $ "ffi codegen: " <> T.pack (show moduleName)
   -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
   -- but I have not done so for two reasons:
   -- 1. This should never fail; any genuine errors in the code should have been
@@ -208,16 +236,17 @@ rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(
   -- 2. We do not want to perform any extra work generating docs unless the
   -- user has asked for docs to be generated.
   let docs = Docs.Module moduleName (Just "TODO") [] []
-    -- case Docs.convertModuleWithoutExterns ops typeOps exEnv env' withPrim of
-    --     Left errs ->
-    --       internalError $
-    --         "Failed to produce docs for "
-    --           ++ T.unpack (runModuleName moduleName)
-    --           ++ "; details:\n"
-    --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
-    --     Right d -> d
-  evalSupplyT nextVar'' $ codegen env' checkSt mod' renamed docs exts
-  return exts
+  -- case Docs.convertModuleWithoutExterns ops typeOps exEnv env' withPrim of
+  --     Left errs ->
+  --       internalError $
+  --         "Failed to produce docs for "
+  --           ++ T.unpack (runModuleName moduleName)
+  --           ++ "; details:\n"
+  --           ++ prettyPrintMultipleErrors defaultPPEOptions errs
+  --     Right d -> d
+  evalSupplyT nextVar'' $ codegen env' checkSt mod' renamed docs
+  putErrText $ "codegen done: " <> T.pack (show moduleName)
+  return dummyExternsFile
 
 desugarAndTypeCheck ::
   forall m.
@@ -440,7 +469,6 @@ make ma@MakeActions {..} ms = do
 
       BuildPlan.markComplete buildPlan moduleName result
 
-
 makeDb ::
   forall m.
   (MonadBaseControl IO m, MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
@@ -454,7 +482,7 @@ makeDb ma@MakeActions {..} ms = do
 
   (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms
 
-  (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph)
+  (buildPlan, _newCacheDb) <- BuildPlanDB.construct ma cacheDb (sorted, graph)
 
   -- Limit concurrent module builds to the number of capabilities as
   -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`.
@@ -463,40 +491,60 @@ makeDb ma@MakeActions {..} ms = do
   -- by the Haskell runtime.
   capabilities <- getNumCapabilities
   let concurrency = max 1 capabilities
+  putErrText $ "concurrency: " <> T.pack (show concurrency)
   lock <- C.newQSem concurrency
 
-  let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
+  let toBeRebuilt = filter (BuildPlanDB.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
   let totalModuleCount = length toBeRebuilt
+
+      -- importedModules :: S.Set ModuleName
+      -- importedModules = S.fromList $ graph >>= snd
+
+      -- orphan :: ModuleName -> Bool
+      -- orphan mn = S.notMember mn importedModules
+
+      graphMap :: M.Map ModuleName [ModuleName]
+      graphMap = M.fromList graph
+
   for_ toBeRebuilt $ \m -> fork $ do
+    liftIO do
+      setAllocationCounter 8.0e9
+      enableAllocationLimit
     let moduleName = getModuleName . CST.resPartial $ m
-    let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
-    buildModule
-      conn
-      lock
-      buildPlan
-      moduleName
-      totalModuleCount
-      (spanName . getModuleSourceSpan . CST.resPartial $ m)
-      (fst $ CST.resFull m)
-      (fmap importPrim . snd $ CST.resFull m)
-      (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
-      -- Prevent hanging on other modules when there is an internal error
-      -- (the exception is thrown, but other threads waiting on MVars are released)
-      `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty)
+    let deps = fromMaybe (internalError "make: module not found in dependency graph.") (M.lookup moduleName graphMap)
+
+    let buildModule' =
+          buildModule
+            conn
+            lock
+            buildPlan
+            moduleName
+            totalModuleCount
+            (getModuleSourceSpan . CST.resPartial $ m)
+            (fst $ CST.resFull m)
+            (fmap importPrim . snd $ CST.resFull m)
+            (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
+            -- Prevent hanging on other modules when there is an internal error
+            -- (the exception is thrown, but other threads waiting on MVars are released)
+            `onException` do
+              putErrText $ "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Exception building: " <> runModuleName moduleName
+              BuildPlanDB.markComplete buildPlan moduleName (BuildPlanDB.BuildJobFailed mempty)
+
+    -- if orphan moduleName
+    --   then BuildPlanDB.markComplete buildPlan moduleName (BuildPlanDB.BuildJobSucceeded mempty)
+    --   else
+    buildModule'
 
   -- Wait for all threads to complete, and collect results (and errors).
   (failures, _successes) <-
     let splitResults = \case
-          BuildJobSucceeded _ exts ->
-            Right exts
-          BuildJobFailed errs ->
+          BuildPlanDB.BuildJobSucceeded _ ->
+            Right ()
+          BuildPlanDB.BuildJobFailed errs ->
             Left errs
-          BuildJobSkipped ->
+          BuildPlanDB.BuildJobSkipped ->
             Left mempty
-     in M.mapEither splitResults <$> BuildPlan.collectResults buildPlan
-
-  -- Write the updated build cache database to disk
-  writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb
+     in M.mapEither splitResults <$> BuildPlanDB.collectResults buildPlan
 
   writePackageJson
 
@@ -539,35 +587,39 @@ makeDb ma@MakeActions {..} ms = do
     inOrderOf :: (Ord a) => [a] -> [a] -> [a]
     inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
 
-    buildModule :: Connection -> QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
-    buildModule conn lock buildPlan moduleName cnt fp pwarnings mres deps = do
-      result <- flip catchError (return . BuildJobFailed) $ do
+    buildModule :: Connection -> QSem -> BuildPlanDB.BuildPlan -> ModuleName -> Int -> SourceSpan -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
+    buildModule conn lock buildPlan moduleName cnt ss pwarnings mres deps = do
+      let fp = spanName ss
+      result <- flip catchError (return . BuildPlanDB.BuildJobFailed) $ do
         let pwarnings' = CST.toMultipleWarnings fp pwarnings
         tell pwarnings'
         m <- CST.unwrapParserError fp mres
         -- We need to wait for dependencies to be built, before checking if the current
         -- module should be rebuilt, so the first thing to do is to wait on the
         -- MVars for the module's dependencies.
-        mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps
+        mexterns <- sequence <$> traverse (BuildPlanDB.getResult buildPlan) deps
+        -- let lookupResult mn =
+        --       fromMaybe (internalError "make: module not found in results") $
+        --         M.lookup mn _
 
         case mexterns of
-          Just (_, externs) -> do
+          Just externs -> do
             -- We need to ensure that all dependencies have been included in Env
-            C.modifyMVar_ (bpEnv buildPlan) $ \env -> do
+            C.modifyMVar_ (BuildPlanDB.bpEnv buildPlan) $ \env -> do
               let go :: Env -> ModuleName -> m Env
                   go e dep = case lookup dep (zip deps externs) of
-                    Just exts
-                      | not (M.member dep e) -> externsEnv e exts
+                    Just _exts
+                      | not (M.member dep e) -> dbEnv conn e ss dep
                     _ -> return e
               foldM go env deps
-            env <- C.readMVar (bpEnv buildPlan)
-            idx <- C.takeMVar (bpIndex buildPlan)
-            C.putMVar (bpIndex buildPlan) (idx + 1)
+            env <- C.readMVar (BuildPlanDB.bpEnv buildPlan)
+            idx <- C.takeMVar (BuildPlanDB.bpIndex buildPlan)
+            C.putMVar (BuildPlanDB.bpIndex buildPlan) (idx + 1)
 
             -- Bracket all of the per-module work behind the semaphore, including
             -- forcing the result. This is done to limit concurrency and keep
             -- memory usage down; see comments above.
-            (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do
+            (_e, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do
               -- Eventlog markers for profiling; see debug/eventlog.js
               liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start"
               -- Force the externs and warnings to avoid retaining excess module
@@ -576,10 +628,10 @@ makeDb ma@MakeActions {..} ms = do
                 rebuildModuleWithIndexDb ma conn env m (Just (idx, cnt))
               liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end"
               return extsAndWarnings
-            return $ BuildJobSucceeded (pwarnings' <> warnings) exts
-          Nothing -> return BuildJobSkipped
+            return $ BuildPlanDB.BuildJobSucceeded (pwarnings' <> warnings)
+          Nothing -> return BuildPlanDB.BuildJobSkipped
 
-      BuildPlan.markComplete buildPlan moduleName result
+      BuildPlanDB.markComplete buildPlan moduleName result
 
 -- | Infer the module name for a module by looking for the same filename with
 -- a .js extension.
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 465a07bb04..1e4671b103 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -47,7 +47,7 @@ import Language.PureScript.Environment (Environment (..))
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), errorMessage, errorMessage')
 import Language.PureScript.Externs (ExternsFile, externsFileName)
 import Language.PureScript.Make.Cache (CacheDb, ContentHash, normaliseForCache)
-import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeCborFile, writeJSONFile, writeTextFile)
+import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeJSONFile, writeTextFile)
 import Language.PureScript.Names (Ident (..), ModuleName, runModuleName)
 import Language.PureScript.Options (CodegenTarget (..), Options (..))
 import Language.PureScript.Pretty.Common (SMap (..))
@@ -62,6 +62,7 @@ import System.IO (stderr)
 import Prelude
 import Database.SQLite.Simple (Connection)
 import Language.PureScript.DB (mkConnection)
+import Protolude (putErrText)
 
 
 -- | Determines when to rebuild a module
@@ -122,7 +123,7 @@ data MakeActions m = MakeActions
     -- | Run actions using the final CheckState
     withCheckState :: CheckState -> m (),
     -- | Run the code generator for the module and write any required output files.
-    codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m (),
+    codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> SupplyT m (),
     -- | Check ffi and print it in the output directory.
     ffiCodegen :: CF.Module CF.Ann -> m (),
     -- | Respond to a progress update.
@@ -273,13 +274,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     withCheckState :: CheckState -> Make ()
     withCheckState _ = return ()
 
-    codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
-    codegen _prevEnv _endEnv _m m docs exts = do
+    codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> SupplyT Make ()
+    codegen _prevEnv _endEnv _m m docs = do
 
       let mn = CF.moduleName m
-      lift $ writeCborFile (outputFilename mn externsFileName) exts
 
       codegenTargets <- lift $ asks optionsCodegenTargets
+
       when (S.member CoreFn codegenTargets) $ do
         let coreFnFile = targetFilename mn CoreFn
             json = CFJ.moduleToJSON Paths.version m
@@ -296,7 +297,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
             | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
             | otherwise -> return Nothing
         rawJs <- J.moduleToJs m foreignInclude
-
+        putErrText "codegen 3"
         dir <- lift $ makeIO "get the current directory" getCurrentDirectory
         let sourceMaps = S.member JSSourceMap codegenTargets
             (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
@@ -305,13 +306,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
             prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]
             js = T.unlines $ map ("// " <>) prefix ++ [pjs]
             mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
-
+        putErrText "codegen 4"
         lift $ do
           writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef)
 
           when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
       when (S.member Docs codegenTargets) $ do
         lift $ writeJSONFile (outputFilename mn "docs.json") docs
+      putErrText "codegen 5"
 
     ffiCodegen :: CF.Module CF.Ann -> Make ()
     ffiCodegen m = do
diff --git a/src/Language/PureScript/Make/BuildPlanDB.hs b/src/Language/PureScript/Make/BuildPlanDB.hs
new file mode 100644
index 0000000000..08ecb896ea
--- /dev/null
+++ b/src/Language/PureScript/Make/BuildPlanDB.hs
@@ -0,0 +1,221 @@
+module Language.PureScript.Make.BuildPlanDB
+  ( BuildPlan(bpEnv, bpIndex)
+  , BuildJobResult(..)
+  , buildJobSuccess
+  , construct
+  , getResult
+  , collectResults
+  , markComplete
+  , needsRebuild
+  ) where
+
+import Prelude
+
+import Control.Concurrent.Async.Lifted as A
+import Control.Concurrent.Lifted as C
+import Control.Monad.Base (liftBase)
+import Control.Monad (foldM)
+import Control.Monad.Trans.Control (MonadBaseControl(..))
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Data.Foldable (foldl')
+import Data.Map qualified as M
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Time.Clock (UTCTime)
+import Language.PureScript.AST (Module, getModuleName)
+import Language.PureScript.Crash (internalError)
+import Language.PureScript.CST qualified as CST
+import Language.PureScript.Errors (MultipleErrors(..))
+import Language.PureScript.Make.Actions as Actions
+import Language.PureScript.Make.Cache (CacheDb, CacheInfo, checkChanged)
+import Language.PureScript.Names (ModuleName)
+import Language.PureScript.Sugar.Names.Env (Env, primEnv)
+import System.Directory (getCurrentDirectory)
+
+-- | The BuildPlan tracks information about our build progress, and holds all
+-- prebuilt modules for incremental builds.
+data BuildPlan = BuildPlan
+  { bpPrebuilt :: M.Map ModuleName Prebuilt
+  , bpBuildJobs :: M.Map ModuleName BuildJob
+  , bpEnv :: C.MVar Env
+  , bpIndex :: C.MVar Int
+  }
+
+data Prebuilt = Prebuilt
+  { pbModificationTime :: UTCTime
+  }
+
+newtype BuildJob = BuildJob
+  { bjResult :: C.MVar BuildJobResult
+    -- ^ Note: an empty MVar indicates that the build job has not yet finished.
+  }
+
+data BuildJobResult
+  = BuildJobSucceeded !MultipleErrors
+  -- ^ Succeeded, with warnings and externs
+  --
+  | BuildJobFailed !MultipleErrors
+  -- ^ Failed, with errors
+
+  | BuildJobSkipped
+  -- ^ The build job was not run, because an upstream build job failed
+
+buildJobSuccess :: BuildJobResult -> Maybe MultipleErrors
+buildJobSuccess (BuildJobSucceeded warnings) = Just warnings
+buildJobSuccess _ = Nothing
+
+-- | Information obtained about a particular module while constructing a build
+-- plan; used to decide whether a module needs rebuilding.
+data RebuildStatus = RebuildStatus
+  { statusModuleName :: ModuleName
+  , statusRebuildNever :: Bool
+  , statusNewCacheInfo :: Maybe CacheInfo
+    -- ^ New cache info for this module which should be stored for subsequent
+    -- incremental builds. A value of Nothing indicates that cache info for
+    -- this module should not be stored in the build cache, because it is being
+    -- rebuilt according to a RebuildPolicy instead.
+  , statusPrebuilt :: Maybe Prebuilt
+    -- ^ Prebuilt externs and timestamp for this module, if any.
+  }
+
+-- | Called when we finished compiling a module and want to report back the
+-- compilation result, as well as any potential errors that were thrown.
+markComplete
+  :: (MonadBaseControl IO m)
+  => BuildPlan
+  -> ModuleName
+  -> BuildJobResult
+  -> m ()
+markComplete buildPlan moduleName result = do
+  let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan)
+  putMVar rVar result
+
+-- | Whether or not the module with the given ModuleName needs to be rebuilt
+needsRebuild :: BuildPlan -> ModuleName -> Bool
+needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp)
+
+-- | Collects results for all prebuilt as well as rebuilt modules. This will
+-- block until all build jobs are finished. Prebuilt modules always return no
+-- warnings.
+collectResults
+  :: (MonadBaseControl IO m)
+  => BuildPlan
+  -> m (M.Map ModuleName BuildJobResult)
+collectResults buildPlan = do
+  let prebuiltResults = M.map (const $ BuildJobSucceeded (MultipleErrors [])) (bpPrebuilt buildPlan)
+  barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan
+  pure (M.union prebuiltResults barrierResults)
+
+-- | Gets the the build result for a given module name independent of whether it
+-- was rebuilt or prebuilt. Prebuilt modules always return no warnings.
+getResult
+  :: (MonadBaseControl IO m)
+  => BuildPlan
+  -> ModuleName
+  -> m (Maybe MultipleErrors)
+getResult buildPlan moduleName =
+  case M.lookup moduleName (bpPrebuilt buildPlan) of
+    Just _ ->
+      pure (Just (MultipleErrors []))
+    Nothing -> do
+      r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan)
+      pure $ buildJobSuccess r
+
+-- | Constructs a BuildPlan for the given module graph.
+--
+-- The given MakeActions are used to collect various timestamps in order to
+-- determine whether a module needs rebuilding.
+construct
+  :: forall m. MonadBaseControl IO m
+  => MakeActions m
+  -> CacheDb
+  -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
+  -> m (BuildPlan, CacheDb)
+construct MakeActions{..} cacheDb (sorted, graph) = do
+  let sortedModuleNames = map (getModuleName . CST.resPartial) sorted
+  rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus
+  let prebuilt =
+        foldl' collectPrebuiltModules M.empty $
+          mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses
+  let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames
+  buildJobs <- foldM makeBuildJob M.empty toBeRebuilt
+  env <- C.newMVar primEnv
+  idx <- C.newMVar 1
+  pure
+    ( BuildPlan prebuilt buildJobs env idx
+    , let
+        update = flip $ \s ->
+          M.alter (const (statusNewCacheInfo s)) (statusModuleName s)
+      in
+        foldl' update cacheDb rebuildStatuses
+    )
+  where
+    makeBuildJob prev moduleName = do
+      buildJob <- BuildJob <$> C.newEmptyMVar
+      pure (M.insert moduleName buildJob prev)
+
+    getRebuildStatus :: ModuleName -> m RebuildStatus
+    getRebuildStatus moduleName = do
+      inputInfo <- getInputTimestampsAndHashes moduleName
+      case inputInfo of
+        Left RebuildNever -> do
+          prebuilt <- findExistingExtern moduleName
+          pure (RebuildStatus
+            { statusModuleName = moduleName
+            , statusRebuildNever = True
+            , statusPrebuilt = prebuilt
+            , statusNewCacheInfo = Nothing
+            })
+        Left RebuildAlways -> do
+          pure (RebuildStatus
+            { statusModuleName = moduleName
+            , statusRebuildNever = False
+            , statusPrebuilt = Nothing
+            , statusNewCacheInfo = Nothing
+            })
+        Right cacheInfo -> do
+          cwd <- liftBase getCurrentDirectory
+          (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo
+          prebuilt <-
+            if isUpToDate
+              then findExistingExtern moduleName
+              else pure Nothing
+          pure (RebuildStatus
+            { statusModuleName = moduleName
+            , statusRebuildNever = False
+            , statusPrebuilt = prebuilt
+            , statusNewCacheInfo = Just newCacheInfo
+            })
+
+    findExistingExtern :: ModuleName -> m (Maybe Prebuilt)
+    findExistingExtern moduleName = runMaybeT $ do
+      timestamp <- MaybeT $ getOutputTimestamp moduleName
+      pure (Prebuilt timestamp)
+
+    collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt
+    collectPrebuiltModules prev (moduleName, rebuildNever, pb)
+      | rebuildNever = M.insert moduleName pb prev
+      | otherwise = do
+          let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
+          case traverse (fmap pbModificationTime . flip M.lookup prev) deps of
+            Nothing ->
+              -- If we end up here, one of the dependencies didn't exist in the
+              -- prebuilt map and so we know a dependency needs to be rebuilt, which
+              -- means we need to be rebuilt in turn.
+              prev
+            Just modTimes ->
+              case maximumMaybe modTimes of
+                Just depModTime | pbModificationTime pb < depModTime ->
+                  prev
+                _ -> M.insert moduleName pb prev
+
+maximumMaybe :: Ord a => [a] -> Maybe a
+maximumMaybe [] = Nothing
+maximumMaybe xs = Just $ maximum xs
+
+
+-- constructFromDb  :: forall m. MonadBaseControl IO m
+--   => MakeActions m
+--   -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
+--   -> m (BuildPlan, CacheDb)
+-- constructFromDb MakeActions{..}  (sorted, graph) = do
+--   pure undefined
diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index cbebe9a3e0..f1d57b45b9 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -54,19 +54,19 @@ addAllIndexing conn ma =
 
 -- addExternIndexing conn ma
 
-addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
-addAstModuleIndexing conn ma =
-  ma
-    { P.codegen = \prevEnv checkSt astM m docs ext ->
-        lift (indexAstModule conn (P.checkEnv checkSt) astM ext (getExportedNames ext)) <* P.codegen ma prevEnv checkSt astM m docs ext
-    }
+-- addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+-- addAstModuleIndexing conn ma =
+--   ma
+--     { P.codegen = \prevEnv checkSt astM m docs ext ->
+--         lift (indexAstModule conn (P.checkEnv checkSt) astM ext (getExportedNames ext)) <* P.codegen ma prevEnv checkSt astM m docs ext
+--     }
 
 addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
 addEnvIndexing conn ma =
   ma
-    { P.codegen = \prevEnv checkSt astM@(P.Module _ _ _ _ refs) m docs ext -> do
-        lift (indexExportedEnv astM (P.checkEnv checkSt) refs conn)
-        P.codegen ma prevEnv checkSt astM m docs ext
+    { P.codegen = \prevEnv checkSt astM m docs -> do
+        lift (indexExportedEnv astM (P.checkEnv checkSt) conn)
+        P.codegen ma prevEnv checkSt astM m docs
     }
 
 indexAstModule :: (MonadIO m) => Connection -> Environment -> P.Module -> ExternsFile -> Set P.Name -> m ()
@@ -89,7 +89,7 @@ indexAstModule conn _endEnv (P.Module _ss _comments moduleName' decls _exportRef
         _ -> False
 
   forM_ declsSorted \decl -> do
-    indexFixity conn moduleName' decl
+    indexDeclaration conn moduleName' decl
     let (ss, _) = P.declSourceAnn decl
         start = P.spanStart ss
         end = P.spanEnd ss
@@ -181,8 +181,8 @@ indexAstModule conn _endEnv (P.Module _ss _comments moduleName' decls _exportRef
     disqualifyIfInModule (P.Qualified (P.BySourcePos _) name) = Just name
     disqualifyIfInModule _ = Nothing
 
-indexFixity :: Connection -> P.ModuleName -> P.Declaration -> IO ()
-indexFixity conn moduleName' = \case
+indexDeclaration :: Connection -> P.ModuleName -> P.Declaration -> IO ()
+indexDeclaration conn moduleName' = \case
   P.FixityDeclaration _ (Left (P.ValueFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName val_mod) name) op)) ->
     SQL.executeNamed
       conn
@@ -211,6 +211,8 @@ indexFixity conn moduleName' = \case
         ":associativity" := P.showAssoc assoc,
         ":precedence" := prec
       ]
+  P.ImportDeclaration _ importedModule importType importedAs ->
+    insertImport conn moduleName' importedModule importedAs importType
   _ -> pure ()
 
 findMap :: (a -> Maybe b) -> [a] -> Maybe b
@@ -296,11 +298,11 @@ getExportedNames extern =
       P.ModuleRef _ name -> [P.ModName name]
       P.ReExportRef _ _ _ -> []
 
-addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
-addExternIndexing conn ma =
-  ma
-    { P.codegen = \prevEnv endEnv astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma prevEnv endEnv astM m docs ext
-    }
+-- addExternIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m
+-- addExternIndexing conn ma =
+--   ma
+--     { P.codegen = \prevEnv endEnv astM m docs ext -> lift (indexExtern conn ext) <* P.codegen ma prevEnv endEnv astM m docs ext
+--     }
 
 indexExtern :: (MonadIO m) => Connection -> ExternsFile -> m ()
 indexExtern conn extern = liftIO do
@@ -339,8 +341,7 @@ insertEfImport conn moduleName' ei = do
 initDb :: Connection -> IO ()
 initDb conn = do
   SQL.execute_ conn "pragma journal_mode=wal;"
-  SQL.execute_ conn "pragma foreign_keys=ON;"
-  SQL.execute_ conn "pragma cache_size=-6000;"
+  SQL.execute_ conn "pragma cache_size=-8000;"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)"
   SQL.execute_
     conn
@@ -352,8 +353,6 @@ initDb conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS available_srcs (path TEXT PRIMARY KEY NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS export_environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS environments (path TEXT PRIMARY KEY NOT NULL, hash INT NOT NULL, value BLOB NOT NULL, UNIQUE(path) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS imports (module_name TEXT, imported_module TEXT, imported_as TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS exports (module_name TEXT, ident TEXT, value BLOB)"
   initEnvTables conn
   addDbIndexes conn
 
@@ -380,20 +379,42 @@ dropTables conn = do
   SQL.execute_ conn "DROP TABLE IF EXISTS ef_imports"
   dropEnvTables conn
 
-indexExportedEnv :: (MonadIO m) => P.Module -> E.Environment -> Maybe [DeclarationRef] -> Connection -> m ()
-indexExportedEnv module' env refs conn = liftIO do
+indexExportedEnv :: (MonadIO m) => P.Module -> E.Environment -> Connection -> m ()
+indexExportedEnv module'@(P.Module _ _ mn _ refs) env conn = liftIO do
   deleteModuleEnv
   insertModule conn moduleName path
-  forConcurrently_ (P.exportedDeclarations module') (indexFixity conn moduleName)
+  forConcurrently_ (P.getModuleDeclarations module') (indexDeclaration conn moduleName)
+  forConcurrently_ (fold refs) (insertExport conn moduleName)
   envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn)
   envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn)
   envFromModule E.dataConstructors & filter dataConstructorExportedOrDict & mapConcurrently_ (uncurry $ insertDataConstructor conn)
   envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn)
-  envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry $ insertTypeClass conn)
+  envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry insertTypeClassAndTypes)
   dicts
     -- & filter ((== Just moduleName) . P.getQual . tcdValue)
     & mapConcurrently_ (insertNamedDict conn)
   where
+    insertTypeClassAndTypes :: Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
+    insertTypeClassAndTypes qualClassName@(P.Qualified _ className) tcd = do
+      insertTypeClass conn qualClassName tcd
+      for_
+        (P.Qualified (P.ByModuleName mn) (P.coerceProperName className) `Map.lookup` E.types env)
+        \(kind, tk) -> do
+          insertType conn (P.Qualified (P.ByModuleName mn) (P.coerceProperName className)) (kind, tk)
+          let dictName = P.dictTypeName . P.coerceProperName $ className
+          for_
+            (P.Qualified (P.ByModuleName mn) dictName `Map.lookup` E.types env)
+            \(dictKind, dictData) -> do
+              insertType conn (P.Qualified (P.ByModuleName mn) dictName) (dictKind, dictData)
+              case dictData of
+                (P.DataType _ _ [(dctor, _)]) -> do
+                  let dctorName = P.coerceProperName dctor
+                  for_
+                    (P.Qualified (P.ByModuleName mn) dctorName `Map.lookup` E.dataConstructors env)
+                    \(dty, _, st, idents) ->
+                      insertDataConstructor conn (P.Qualified (P.ByModuleName mn) dctorName) (dty, dictName, st, idents)
+                _ -> pure ()
+
     path = P.spanName (P.getModuleSourceSpan module')
 
     moduleName = P.getModuleName module'
@@ -416,11 +437,21 @@ indexExportedEnv module' env refs conn = liftIO do
         else dict {tcdValue = P.Qualified (P.ByModuleName moduleName) (P.disqualify $ tcdValue dict)}
 
     deleteModuleEnv = do
+      SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM type_operators WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.execute conn "DELETE FROM value_operators WHERE module_name = ?" (SQL.Only moduleName)
       SQL.execute conn "DELETE FROM modules WHERE module_name = ?" (SQL.Only moduleName)
 
     refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool
     refMatch f (k, _) = maybe True (any (f k)) refs
 
+    -- generatedNameOrExported (i, t) = not (P.isPlainIdent $ P.disqualify i) || nameExported (i, t)
+
     nameExported = refMatch \k -> \case
       P.ValueRef _ ident -> ident == P.disqualify k
       _ -> False
@@ -486,18 +517,15 @@ insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(
 insertTypeSynonym conn ident (idents, st) = do
   SQL.execute
     conn
-    "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type, debug) VALUES (?, ?, ?, ?, ?)"
-    (toDbQualifer ident :. (serialise idents, st, debug))
-  where
-    debug :: Text
-    debug = "show (idents, st)"
+    "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type) VALUES (?, ?, ?, ?)"
+    (toDbQualifer ident :. (serialise idents, st))
 
 insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO ()
 insertTypeClass conn ident tcd = do
   SQL.execute
     conn
     "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)"
-    ((clasMod, className) :. SQL.Only tcd)
+    ((clasMod, className) :. SQL.Only tcd {E.typeClassMembers = (\(a, b, _) -> (a, b, Nothing)) <$> E.typeClassMembers tcd})
   where
     (clasMod, className) = toDbQualifer ident
 
@@ -510,6 +538,31 @@ insertNamedDict conn dict = do
   where
     (clasMod, className) = toDbQualifer (tcdClassName dict)
 
+insertImport :: Connection -> P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> P.ImportDeclarationType -> IO ()
+insertImport conn moduleName' importedModule importedAs importType = do
+  SQL.executeNamed
+    conn
+    ( SQL.Query
+        "INSERT OR REPLACE INTO imports (module_name, imported_module, imported_as, value) VALUES (:module_name, :imported_module, :imported_as, :value)"
+    )
+    [ ":module_name" := moduleName',
+      ":imported_module" := importedModule,
+      ":imported_as" := importedAs,
+      ":value" := serialise importType
+    ]
+
+insertExport :: Connection -> P.ModuleName -> P.DeclarationRef -> IO ()
+insertExport conn moduleName' ref = do
+  SQL.executeNamed
+    conn
+    ( SQL.Query
+        "INSERT OR REPLACE INTO exports (module_name, ident, value) VALUES (:module_name, :ident, :value)"
+    )
+    [ ":module_name" := moduleName',
+      ":ident" := T.pack (show (P.declRefName ref)),
+      ":value" := ref
+    ]
+
 initEnvTables :: Connection -> IO ()
 initEnvTables conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS modules (module_name TEXT NOT NULL PRIMARY KEY, path TEXT, created_at DATETIME DEFAULT CURRENT_TIMESTAMP, hash INT)"
@@ -519,8 +572,10 @@ initEnvTables conn = do
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT references modules(module_name) ON DELETE CASCADE, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT references modules(module_name) ON DELETE CASCADE, class_name TEXT, class BLOB, debug TEXT)"
   SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT references modules(module_name) ON DELETE CASCADE, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, types TEXT, kinds TEXT, dict BLOB, debug TEXT)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
-  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, defined_in TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, defined_in TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS imports (module_name TEXT references modules(module_name) ON DELETE CASCADE, imported_module TEXT, imported_as TEXT, value BLOB)"
+  SQL.execute_ conn "CREATE TABLE IF NOT EXISTS exports (module_name TEXT references modules(module_name) ON DELETE CASCADE, ident TEXT, value BLOB)"
   addEnvIndexes conn
 
 addEnvIndexes :: Connection -> IO ()
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index c511a3b987..f481916bd7 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -19,7 +19,7 @@ import Data.Set qualified as Set
 import Data.Text qualified as T
 import Database.SQLite.Simple (Connection)
 import Database.SQLite.Simple qualified as SQL
-import Language.PureScript.AST.Declarations (ImportDeclarationType)
+import Language.PureScript.AST.Declarations (ImportDeclarationType, ExportSource (..))
 import Language.PureScript.AST.Declarations qualified as P
 import Language.PureScript.AST.Operators qualified as P
 import Language.PureScript.AST.Traversals (accumTypes)
@@ -28,7 +28,7 @@ import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (TypeClassData (typeClassSuperclasses))
 import Language.PureScript.Environment qualified as E
 import Language.PureScript.Environment qualified as P
-import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..))
+import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..), ExternsImport (..), ExternsDeclaration (..))
 import Language.PureScript.Linter.Imports qualified as P
 import Language.PureScript.Names (coerceProperName)
 import Language.PureScript.Names qualified as P
@@ -47,6 +47,12 @@ import Control.Monad.Supply.Class (MonadSupply (fresh, peek))
 import Control.Monad.Trans.Class (MonadTrans)
 import Control.Monad.Identity (IdentityT)
 import Control.Monad.Trans.Maybe (MaybeT)
+import Data.Map qualified as M
+import Language.PureScript.Errors (MultipleErrors, SourceSpan)
+import Language.PureScript.Sugar.Names.Exports (resolveExports)
+import Language.PureScript.Sugar.Names.Env (nullImports)
+import Language.PureScript.Sugar.Names.Imports (resolveModuleImport)
+import Language.PureScript.Externs qualified as P
 
 
 selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])])
@@ -323,6 +329,13 @@ selectModuleExports conn modName = do
     (SQL.Only modName)
     <&> fmap SQL.fromOnly
 
+selectModuleExternImports :: Connection -> P.ModuleName -> IO [P.ExternsImport]
+selectModuleExternImports conn modName = do
+  SQL.query
+    conn
+    "SELECT imported_module, value, imported_as FROM imports WHERE module_name = ?"
+    (SQL.Only modName)
+    
 insertExports :: Connection -> P.ModuleName -> Maybe [P.DeclarationRef] -> IO ()
 insertExports conn modName = \case
   Nothing -> internalError "selectEnvFromImports called before desguaring module"
@@ -456,20 +469,6 @@ selectAllClassInstances conn  = do
     "SELECT dict FROM env_type_class_instances"
     <&> (fmap (SQL.fromOnly >>> deserialise))
 
-selectClassInstances ::
-  Connection ->
-  P.Qualified (P.ProperName 'P.ClassName) ->
-  [P.Type ()] ->
-  IO [NamedDict]
-selectClassInstances conn classNameQual types = do
-  SQL.query
-    conn
-    "SELECT dict FROM env_type_class_instances WHERE module_name = ? AND class_name = ? AND types = ?"
-    (modName, className, A.encode types)
-    <&> (fmap (SQL.fromOnly >>> deserialise))
-  where
-    (modName, className) = toDbQualifer classNameQual
-
 selectClassInstancesByClassName ::
   Connection ->
   P.Qualified (P.ProperName 'P.ClassName) ->
@@ -521,7 +520,7 @@ selectImportedAs :: Connection -> P.ModuleName -> P.ModuleName -> IO (Maybe P.Mo
 selectImportedAs conn modName importedModName = do
   SQL.query
     conn
-    "SELECT imported_as FROM imports WHERE module_name = ? AND imported_module_name = ?"
+    "SELECT imported_as FROM imports WHERE module_name = ? AND imported_module = ?"
     (modName, importedModName)
     <&> (head >>> fmap SQL.fromOnly >>> join)
 
@@ -550,9 +549,16 @@ insertImport conn mn = \case
 
 deleteModuleEnvImpl :: P.ModuleName -> Connection -> IO ()
 deleteModuleEnvImpl moduleName conn = do
+  SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM type_operators WHERE module_name = ?" (SQL.Only moduleName)
+  SQL.execute conn "DELETE FROM value_operators WHERE module_name = ?" (SQL.Only moduleName)
   SQL.execute conn "DELETE FROM modules WHERE module_name = ?" (SQL.Only moduleName)
 
-
 getEnvConstraints :: E.Environment -> [P.SourceConstraint]
 getEnvConstraints env =
   E.names env & Map.elems >>= typeConstraints . view _1
@@ -693,4 +699,78 @@ instance Monad m => GetEnv (WoGetEnv m) where
   deleteModuleEnv _ = pure ()
   logGetEnv _ = pure ()
   
-  hasEnv = pure False
\ No newline at end of file
+  hasEnv = pure False
+
+
+
+-- | Create an environment from a collection of externs files
+dbEnv
+  :: forall m
+   . (MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+  => Connection
+  -> P.Env
+  -> SourceSpan 
+  -> P.ModuleName
+  -> m P.Env
+dbEnv conn env ss modName = do
+  exports <- liftIO $ selectModuleExports conn modName
+  imports <- liftIO $ selectModuleExternImports conn modName
+  ctrs <- liftIO $ selectModuleTypesAndCtrs conn modName
+  types <- liftIO $ selectModuleTypes conn modName
+
+  let members = P.Exports{..}
+      env' = M.insert modName (ss, nullImports, members) env
+      fromEFImport (ExternsImport mn mt qmn) = (mn, [(ss, Just mt, qmn)])
+
+      exportedCtrs =  ctrs <&> \(ty, cs) -> (ty, ([cs], localExportSource))
+
+      exportedTypes' = types <&>  (, ([], localExportSource))
+
+      exportedTypes :: M.Map (P.ProperName 'P.TypeName) ([P.ProperName 'P.ConstructorName], ExportSource)
+      exportedTypes = M.fromListWith combineCtrs $ exportedCtrs <> exportedTypes'
+        where 
+          combineCtrs (cs1, e) (cs2, _) = (cs1 <> cs2, e)
+
+      exportedTypeOps :: M.Map (P.OpName 'P.TypeOpName) ExportSource
+      exportedTypeOps = exportedRefs P.getTypeOpRef
+
+      exportedTypeClasses :: M.Map (P.ProperName 'P.ClassName) ExportSource
+      exportedTypeClasses = exportedRefs P.getTypeClassRef
+
+      exportedValues :: M.Map P.Ident ExportSource
+      exportedValues = exportedRefs P.getValueRef
+
+      exportedValueOps :: M.Map (P.OpName 'P.ValueOpName) ExportSource
+      exportedValueOps = exportedRefs P.getValueOpRef
+
+      exportedRefs :: Ord a => (P.DeclarationRef -> Maybe a) -> M.Map a ExportSource
+      exportedRefs f =
+        M.fromList $ (, localExportSource) <$> mapMaybe f exports
+
+  imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport imports)
+  exps <- resolveExports env' ss modName imps members exports
+  return $ M.insert modName (ss, imps, exps) env
+  where
+
+  -- An ExportSource for declarations local to the module which the given
+  -- ExternsFile corresponds to.
+  localExportSource =
+    ExportSource { exportSourceDefinedIn = modName
+                  , exportSourceImportedFrom = Nothing
+                  }
+
+
+
+selectModuleTypesAndCtrs :: Connection -> P.ModuleName -> IO [(P.ProperName 'P.TypeName, P.ProperName 'P.ConstructorName)]
+selectModuleTypesAndCtrs conn modName = do
+  SQL.query
+    conn
+    "SELECT type_name, constructor_name FROM env_data_constructors WHERE module_name = ?"
+    (SQL.Only modName)
+
+selectModuleTypes :: Connection -> P.ModuleName -> IO [P.ProperName 'P.TypeName]
+selectModuleTypes conn modName = do
+ fmap SQL.fromOnly <$>  SQL.query
+    conn
+    "SELECT type_name FROM env_types WHERE module_name = ?"
+    (SQL.Only modName)
\ No newline at end of file
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 548634d3b4..44f8f3875f 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -87,14 +87,14 @@ updateScope ident =
 -- |
 -- Finds the new name to use for an ident.
 --
-lookupIdent :: a -> Ident -> Rename Ident
+lookupIdent :: Show a => a -> Ident -> Rename Ident
 lookupIdent _ UnusedIdent = return UnusedIdent
-lookupIdent _modName name = do
+lookupIdent modName name = do
   name' <- gets $ M.lookup name . rsBoundNames
   case name' of
     Just name'' -> return name''
-    Nothing -> pure name
-      --  error $ "In " ++ show modName ++ " rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'"
+    Nothing ->
+       error $ "In " ++ (show modName :: [Char]) ++ " rename scope is missing ident '" ++ show name ++ "'"
 
 
 -- |
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index d081764d7f..66b6ca9846 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -112,6 +112,7 @@ externsEnv env ExternsFile{..} = do
   exportedRefs f =
     M.fromList $ (, localExportSource) <$> mapMaybe f efExports
 
+
 -- |
 -- Make all exports for a module explicit. This may still affect modules that
 -- have an exports list, as it will also make all data constructor exports
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 7f5e606c9e..b03f68aff2 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 -- |
 -- Functions for replacing fully applied type synonyms
@@ -14,6 +16,8 @@ import Control.Monad.State (MonadState)
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
+import GHC.Stack (HasCallStack)
+import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment (TypeKind)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), SourceSpan, errorMessage')
 import Language.PureScript.Make.Index.Select (GetEnv)
@@ -28,7 +32,7 @@ type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Source
 type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
 
 -- | Replace fully applied type synonyms
-replaceAllTypeSynonyms :: forall e m. (e ~ MultipleErrors, MonadState CheckState m, GetEnv m, MonadError e m) => SourceType -> m SourceType
+replaceAllTypeSynonyms :: forall e m. (HasCallStack) => (e ~ MultipleErrors, MonadState CheckState m, GetEnv m, MonadError e m) => SourceType -> m SourceType
 replaceAllTypeSynonyms = everywhereOnTypesTopDownM try
   where
     try :: SourceType -> m SourceType
@@ -46,7 +50,8 @@ replaceAllTypeSynonyms = everywhereOnTypesTopDownM try
                    in Just <$> try repl
                 else pure Nothing
           | length synArgs > c ->
-              throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
+              internalError $ "PartiallyAppliedSynonym: " <> show (ctor, ss, c, synArgs)
+        -- throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor
         _ -> return Nothing
     go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f
     go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index ea2f901052..934fd61b33 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -821,7 +821,7 @@ check'
   -> SourceType
   -> m TypedValue'
 check' val (ForAll ann vis ident mbK ty _) = do
-  env <- getEnv
+  -- env <- getEnv
   mn <- gets checkCurrentModule
   scope <- newSkolemScope
   sko <- newSkolemConstant
@@ -833,8 +833,11 @@ check' val (ForAll ann vis ident mbK ty _) = do
       -- was actually brought into scope. Otherwise we can end up skolemizing
       -- an undefined type variable that happens to clash with the variable we
       -- want to skolemize. This can happen due to synonym expansion (see 2542).
+  k <- lookupTypeMb (Qualified (byMaybeModuleName mn) (ProperName ident)) 
+
+  let  
       skVal
-        | Just _ <- M.lookup (Qualified (byMaybeModuleName mn) (ProperName ident)) $ types env =
+        | Just _ <- k =
             skolemizeTypesInValue ss ident mbK sko scope val
         | otherwise = val
   val' <- tvToExpr <$> check skVal sk

From 7775451eab40d3d05e7d60b79c2305a5777689a2 Mon Sep 17 00:00:00 2001
From: Rory Campbell <roryc89@googlemail.com>
Date: Mon, 3 Feb 2025 17:39:28 +0100
Subject: [PATCH 297/297] remove double delete

---
 src/Language/PureScript/Make/Index.hs        | 24 +++----
 src/Language/PureScript/Make/Index/Select.hs | 68 +++++++++++---------
 2 files changed, 49 insertions(+), 43 deletions(-)

diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs
index f1d57b45b9..7691553a09 100644
--- a/src/Language/PureScript/Make/Index.hs
+++ b/src/Language/PureScript/Make/Index.hs
@@ -381,7 +381,6 @@ dropTables conn = do
 
 indexExportedEnv :: (MonadIO m) => P.Module -> E.Environment -> Connection -> m ()
 indexExportedEnv module'@(P.Module _ _ mn _ refs) env conn = liftIO do
-  deleteModuleEnv
   insertModule conn moduleName path
   forConcurrently_ (P.getModuleDeclarations module') (indexDeclaration conn moduleName)
   forConcurrently_ (fold refs) (insertExport conn moduleName)
@@ -436,16 +435,19 @@ indexExportedEnv module'@(P.Module _ _ mn _ refs) env conn = liftIO do
         then dict
         else dict {tcdValue = P.Qualified (P.ByModuleName moduleName) (P.disqualify $ tcdValue dict)}
 
-    deleteModuleEnv = do
-      SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM type_operators WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM value_operators WHERE module_name = ?" (SQL.Only moduleName)
-      SQL.execute conn "DELETE FROM modules WHERE module_name = ?" (SQL.Only moduleName)
+    -- deleteModuleEnv = do
+    --   SQL.executeNamed
+    --     conn
+    --     "DELETE FROM env_values WHERE module_name = :module_name;\
+    --     \DELETE FROM env_types WHERE module_name = :module_name;\
+    --     \DELETE FROM env_data_constructors WHERE module_name = :module_name;\
+    --     \DELETE FROM env_type_synonyms WHERE module_name = :module_name;\
+    --     \DELETE FROM env_type_classes WHERE module_name = :module_name;\
+    --     \DELETE FROM env_type_class_instances WHERE module_name = :module_name;\
+    --     \DELETE FROM type_operators WHERE module_name = :module_name;\
+    --     \DELETE FROM value_operators WHERE module_name = :module_name;\
+    --     \DELETE FROM modules WHERE module_name = :module_name"
+    --     [":module_name" := P.runModuleName moduleName]
 
     refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool
     refMatch f (k, _) = maybe True (any (f k)) refs
diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs
index f481916bd7..b5e162ab08 100644
--- a/src/Language/PureScript/Make/Index/Select.hs
+++ b/src/Language/PureScript/Make/Index/Select.hs
@@ -17,7 +17,7 @@ import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Database.SQLite.Simple (Connection)
+import Database.SQLite.Simple (Connection, NamedParam ((:=)))
 import Database.SQLite.Simple qualified as SQL
 import Language.PureScript.AST.Declarations (ImportDeclarationType, ExportSource (..))
 import Language.PureScript.AST.Declarations qualified as P
@@ -97,7 +97,7 @@ selectFixitiesFromModuleImports conn env (P.Module _ _ _modName decls _refs) = d
     whenImportDecl :: (P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, a)]) -> P.Declaration -> IO (Maybe [(P.ModuleName, a)])
     whenImportDecl f = \case
       P.ImportDeclaration _ mn' idt importedAs -> Just  <$> f mn' idt
-        where 
+        where
           addImportedAs (mn'', a) = (fromMaybe mn'' importedAs, a)
       _ -> pure Nothing
 
@@ -335,7 +335,7 @@ selectModuleExternImports conn modName = do
     conn
     "SELECT imported_module, value, imported_as FROM imports WHERE module_name = ?"
     (SQL.Only modName)
-    
+
 insertExports :: Connection -> P.ModuleName -> Maybe [P.DeclarationRef] -> IO ()
 insertExports conn modName = \case
   Nothing -> internalError "selectEnvFromImports called before desguaring module"
@@ -448,9 +448,9 @@ selectTypeClass conn modName className =
         <&> (fmap SQL.fromOnly . head)
 
 selectTypeClass' :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData)
-selectTypeClass' conn = \case 
+selectTypeClass' conn = \case
    P.Qualified (P.ByModuleName modName) className -> selectTypeClass conn modName className
-   _ -> pure Nothing 
+   _ -> pure Nothing
 
 selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)]
 selectModuleTypeClasses conn moduleName' = do
@@ -460,8 +460,8 @@ selectModuleTypeClasses conn moduleName' = do
     (SQL.Only moduleName')
     <&> fmap (first (P.Qualified (P.ByModuleName moduleName')))
 
-selectAllClassInstances :: 
-  Connection -> 
+selectAllClassInstances ::
+  Connection ->
   IO [NamedDict]
 selectAllClassInstances conn  = do
   SQL.query_
@@ -487,14 +487,13 @@ selectDoesClassInstanceExist ::
   P.Qualified P.Ident ->
   IO Bool
 selectDoesClassInstanceExist conn ident  = do
-  res <- SQL.query
+  res :: [SQL.Only Int] <- SQL.query
     conn
-    "SELECT EXISTS (SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?)"
+    "SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?"
     (toDbQualifer ident)
-  res 
-    & head
-    & maybe False SQL.fromOnly
-    & return
+  unless (null res) do
+    putErrText $ "selectDoesClassInstanceExist true: " <> show ((toDbQualifer ident), res)
+  return $ not $ null res
 
 
 selectValueOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe (P.ModuleName, Text))
@@ -549,15 +548,20 @@ insertImport conn mn = \case
 
 deleteModuleEnvImpl :: P.ModuleName -> Connection -> IO ()
 deleteModuleEnvImpl moduleName conn = do
-  SQL.execute conn "DELETE FROM env_values WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_types WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_data_constructors WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_type_synonyms WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_type_classes WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM env_type_class_instances WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM type_operators WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM value_operators WHERE module_name = ?" (SQL.Only moduleName)
-  SQL.execute conn "DELETE FROM modules WHERE module_name = ?" (SQL.Only moduleName)
+      SQL.executeNamed
+        conn
+        "DELETE FROM env_values WHERE module_name = :module_name;\
+        \DELETE FROM env_types WHERE module_name = :module_name;\
+        \DELETE FROM env_data_constructors WHERE module_name = :module_name;\
+        \DELETE FROM env_type_synonyms WHERE module_name = :module_name;\
+        \DELETE FROM env_type_classes WHERE module_name = :module_name;\
+        \DELETE FROM env_type_class_instances WHERE module_name = :module_name;\
+        \DELETE FROM type_operators WHERE module_name = :module_name;\
+        \DELETE FROM value_operators WHERE module_name = :module_name;\
+        \DELETE FROM imports WHERE module_name = :module_name;\
+        \DELETE FROM exports WHERE module_name = :module_name;\
+        \DELETE FROM modules WHERE module_name = :module_name"
+        [":module_name" := P.runModuleName moduleName]
 
 getEnvConstraints :: E.Environment -> [P.SourceConstraint]
 getEnvConstraints env =
@@ -577,7 +581,7 @@ updateConcurrently a b = do
   g <- b
   pure $ f >>> g
 
-class GetEnv m where 
+class GetEnv m where
   getName :: P.Qualified P.Ident -> m (Maybe (P.SourceType, P.NameKind, P.NameVisibility))
   getType :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe (P.SourceType, P.TypeKind))
   getDataConstructor :: P.Qualified (P.ProperName 'P.ConstructorName) -> m (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))
@@ -590,7 +594,7 @@ class GetEnv m where
   logGetEnv :: Text -> m ()
 
 
-instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where 
+instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where
   getName = lift . getName
   getType = lift . getType
   getDataConstructor = lift . getDataConstructor
@@ -601,7 +605,7 @@ instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where
   deleteModuleEnv = lift . deleteModuleEnv
   logGetEnv = lift . logGetEnv
   hasEnv = lift hasEnv
-instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where 
+instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where
   getName = lift . getName
   getType = lift . getType
   getDataConstructor = lift . getDataConstructor
@@ -613,7 +617,7 @@ instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where
   logGetEnv = lift . logGetEnv
   hasEnv = lift hasEnv
 
-instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where 
+instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where
   getName = lift . getName
   getType = lift . getType
   getDataConstructor = lift . getDataConstructor
@@ -624,7 +628,7 @@ instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where
   deleteModuleEnv = lift . deleteModuleEnv
   logGetEnv = lift . logGetEnv
   hasEnv = lift hasEnv
-instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where 
+instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where
   getName = lift . getName
   getType = lift . getType
   getDataConstructor = lift . getDataConstructor
@@ -684,11 +688,11 @@ newtype WoGetEnv m a = WoGetEnv (m a)
 runWoGetEnv :: WoGetEnv m a -> m a
 runWoGetEnv (WoGetEnv m) = m
 
-instance MonadSupply m => MonadSupply (WoGetEnv m) where 
+instance MonadSupply m => MonadSupply (WoGetEnv m) where
   fresh = WoGetEnv fresh
   peek = WoGetEnv peek
 
-instance Monad m => GetEnv (WoGetEnv m) where 
+instance Monad m => GetEnv (WoGetEnv m) where
   getName _ = pure Nothing
   getType _ = pure Nothing
   getDataConstructor _ = pure Nothing
@@ -698,7 +702,7 @@ instance Monad m => GetEnv (WoGetEnv m) where
   hasTypeClassInEnv _ = pure False
   deleteModuleEnv _ = pure ()
   logGetEnv _ = pure ()
-  
+
   hasEnv = pure False
 
 
@@ -709,7 +713,7 @@ dbEnv
    . (MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
   => Connection
   -> P.Env
-  -> SourceSpan 
+  -> SourceSpan
   -> P.ModuleName
   -> m P.Env
 dbEnv conn env ss modName = do
@@ -728,7 +732,7 @@ dbEnv conn env ss modName = do
 
       exportedTypes :: M.Map (P.ProperName 'P.TypeName) ([P.ProperName 'P.ConstructorName], ExportSource)
       exportedTypes = M.fromListWith combineCtrs $ exportedCtrs <> exportedTypes'
-        where 
+        where
           combineCtrs (cs1, e) (cs2, _) = (cs1 <> cs2, e)
 
       exportedTypeOps :: M.Map (P.OpName 'P.TypeOpName) ExportSource