purescript · purefunctor · Apr 9, 2022 · Apr 9, 2022
diff --git a/purescript.cabal b/purescript.cabal
@@ -254,6 +254,7 @@ library
     Language.PureScript.Ide.Types
     Language.PureScript.Ide.Usage
     Language.PureScript.Ide.Util
+    Language.PureScript.Ide.Psii
     Language.PureScript.Interactive
     Language.PureScript.Interactive.Completion
     Language.PureScript.Interactive.Directive

diff --git a/src/Language/PureScript/Ide/Psii.hs b/src/Language/PureScript/Ide/Psii.hs
@@ -0,0 +1,50 @@
+-- |
+-- `psii` stands for `PureScript IDE Information`.
+--
+-- Q: How to read `psii`?
+-- A: As in "psy" or "sai".
+module Language.PureScript.Ide.Psii where
+
+import Protolude
+
+import Data.String (String)
+import qualified Data.Text as T
+
+import Language.PureScript.AST
+import Language.PureScript.Names
+import Language.PureScript.Pretty
+import Language.PureScript.Types
+
+-- |
+-- The verbosity of IDE information.
+data PsiiVerbosity
+  -- | Include no information at all.
+  = PsiiNoInformation
+  -- | Include top-level information.
+  | PsiiOnlyTopLevel
+  -- | Include local information.
+  | PsiiWithLocal
+  deriving (Show, Eq, Ord)
+
+-- |
+-- The information entry to be emitted.
+data PsiiInformation
+  -- |
+  -- Value declarations.
+  = PsiiValueDecl PsiiValueDecl'
+  deriving (Show, Eq, Ord)
+
+data PsiiValueDecl' = PsiiValueDecl'
+  { psiiValueDeclSpan :: SourceSpan
+  , psiiValueDeclIdent :: Qualified Ident
+  , psiiValueDeclType :: SourceType
+  }
+  deriving (Show, Eq, Ord)
+
+debugInformation :: PsiiInformation -> String
+debugInformation (PsiiValueDecl (PsiiValueDecl' {..})) =
+  let
+    ident' = runIdent $ disqualify psiiValueDeclIdent
+    type' = T.strip $ T.pack $ prettyPrintType maxBound psiiValueDeclType
+  in
+    T.unpack $ "(" <> ident' <> " :: " <> type' <> ")"
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -29,13 +29,15 @@ import           Data.Maybe (fromMaybe)
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.Text as T
+import           Debug.Trace (traceM)
 import           Language.PureScript.AST
 import           Language.PureScript.Crash
 import qualified Language.PureScript.CST as CST
 import qualified Language.PureScript.Docs.Convert as Docs
 import           Language.PureScript.Environment
 import           Language.PureScript.Errors
 import           Language.PureScript.Externs
+import           Language.PureScript.Ide.Psii
 import           Language.PureScript.Linter
 import           Language.PureScript.ModuleDependencies
 import           Language.PureScript.Names
@@ -100,6 +102,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
     -- 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'
+    _ <- traverse (traceM . debugInformation) $ S.toList checkPsiiInformation
     return (checked, checkEnv)
 
   -- desugar case declarations *after* type- and exhaustiveness checking

diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -33,6 +33,7 @@ import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype
 import Language.PureScript.Crash
 import Language.PureScript.Environment
 import Language.PureScript.Errors
+import Language.PureScript.Ide.Psii
 import Language.PureScript.Linter
 import Language.PureScript.Linter.Wildcards
 import Language.PureScript.Names
@@ -359,6 +360,7 @@ typeCheckAll moduleName = traverse go
       typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case
         [(_, (val'', ty))] -> do
           addValue moduleName name ty nameKind
+          insertPsiiInformation $ PsiiValueDecl $ PsiiValueDecl' ss (Qualified (Just moduleName) 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/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -21,6 +21,7 @@ import qualified Data.List.NonEmpty as NEL
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.Environment
 import Language.PureScript.Errors
+import Language.PureScript.Ide.Psii
 import Language.PureScript.Names
 import Language.PureScript.Pretty.Types
 import Language.PureScript.Pretty.Values
@@ -104,11 +105,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.
+  , checkPsiiVerbosity :: PsiiVerbosity
+  -- ^ The verbosity of IDE information to be collected.
+  , checkPsiiInformation :: S.Set (PsiiInformation)
+  -- ^ The IDE information collected through type-checking.
   }
 
 -- | 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 PsiiNoInformation mempty
 
 -- | Unification variables
 type Unknown = Int
@@ -166,6 +171,10 @@ withErrorMessageHint hint action = do
   modify $ \st -> st { checkHints = checkHints orig }
   return a
 
+insertPsiiInformation :: MonadState CheckState m => PsiiInformation -> m ()
+insertPsiiInformation information =
+  modify $ \st -> st { checkPsiiInformation = S.insert information $ checkPsiiInformation st }
+
 -- | 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]

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -49,6 +49,7 @@ import Language.PureScript.AST
 import Language.PureScript.Crash
 import Language.PureScript.Environment
 import Language.PureScript.Errors
+import Language.PureScript.Ide.Psii
 import Language.PureScript.Names
 import Language.PureScript.Traversals
 import Language.PureScript.TypeChecker.Entailment
@@ -491,6 +492,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)
+  insertPsiiInformation $ PsiiValueDecl $ PsiiValueDecl' ss (Qualified Nothing ident) ty''
   bindNames (M.singleton (Qualified Nothing 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
@@ -499,6 +501,7 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] :
     let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined)
     bindNames dict $ infer val
   warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy'
+  insertPsiiInformation $ PsiiValueDecl $ PsiiValueDecl' ss (Qualified Nothing ident) valTy'
   bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined))
     $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j
 inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do