diff --git a/purescript.cabal b/purescript.cabal index 5b3c8ff35c..9a6a41edf7 100644 --- 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 new file mode 100644 index 0000000000..0044f48c8b --- /dev/null +++ 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 index 3e68387e2c..c89eb0b6c3 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -29,6 +29,7 @@ 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 @@ -36,6 +37,7 @@ 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 index 8db639e694..12406f867b 100644 --- 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 index b4fafa9fa8..bcd503ac7a 100644 --- 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 index 77d1d32504..43f8e5e911 100644 --- 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