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/**/* diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index d81dd75c07..68a43fb25a 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 Data.Aeson qualified as A import Data.Bool (bool) @@ -13,26 +11,28 @@ 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.Errors.JSON (JSONResult(..), toJSONErrors) -import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..), warnFileTypeNotFound) -import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake) +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.Index (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.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, stderr, stdout) import System.IO.UTF8 (readUTF8FilesT) +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 @@ -40,7 +40,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 @@ -50,74 +50,84 @@ 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 + (_, 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 - let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix - P.make makeActions (map snd ms) + (makeErrors, makeWarnings) <- P.compile pscmOpts moduleFiles conn pscmOutputDir pscmUsePrefix 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) <> "'." @@ -125,11 +135,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 = @@ -143,13 +153,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/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/app/Command/Lsp.hs b/app/Command/Lsp.hs new file mode 100644 index 0000000000..71df1e8816 --- /dev/null +++ b/app/Command/Lsp.hs @@ -0,0 +1,48 @@ +module Command.Lsp (command) where + +import Language.PureScript.Lsp as Lsp +import Language.PureScript.Lsp.Types (mkEnv) +import Options.Applicative qualified as Opts +import Protolude +import System.Directory (setCurrentDirectory) + +data ServerOptions = ServerOptions + { _serverDirectory :: Maybe FilePath, + _serverOutputPath :: FilePath + } + 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 LSP process") + ) + ] + + server :: ServerOptions -> IO () + server (ServerOptions dir outputPath) = do + maybe (pure ()) setCurrentDirectory dir + putErrLn $ "Starting server with output path: " <> outputPath + env <- mkEnv outputPath + startServer outputPath env + + serverOptions :: Opts.Parser ServerOptions + serverOptions = + ServerOptions + <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd')) + <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") + + startServer outputPath env = do + code <- Lsp.main outputPath env + exitWith + ( case code of + 0 -> ExitSuccess + _ -> ExitFailure code + ) 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 0d32ce4814..5c97480c50 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, @@ -198,6 +199,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, @@ -208,7 +210,12 @@ 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, + unliftio-core >= 0.2.0.0 && < 0.3, + text-rope >= 0.2 && < 1.0, + ghc-datasize >= 0.2 && <= 0.2.7 library import: defaults @@ -272,8 +279,10 @@ 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 Language.PureScript.Docs Language.PureScript.Docs.AsHtml Language.PureScript.Docs.AsMarkdown @@ -332,10 +341,43 @@ library Language.PureScript.Linter.Exhaustive 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 + Language.PureScript.Lsp.Cache + Language.PureScript.Lsp.Cache.Query + 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 + 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 + Language.PureScript.Lsp.NameType + Language.PureScript.Lsp.Prim + 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 Language.PureScript.Make 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 @@ -378,6 +420,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 @@ -422,6 +465,7 @@ executable purs Command.Graph Command.Hierarchy Command.Ide + Command.Lsp Command.Publish Command.REPL SharedCLI @@ -442,6 +486,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, @@ -462,6 +507,7 @@ test-suite tests Language.PureScript.Ide.StateSpec Language.PureScript.Ide.Test Language.PureScript.Ide.UsageSpec + Language.PureScript.Lsp.Test PscIdeSpec TestAst TestCompiler @@ -471,6 +517,7 @@ test-suite tests TestGraph TestHierarchy TestIde + TestLsp TestMake TestPrimDocs TestPsci diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 1f427755f0..8dd11c13fa 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` @@ -153,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 cf0c83a42d..ac122369f9 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -3,36 +3,38 @@ -- | -- 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 Language.PureScript.Types (SourceConstraint, SourceType) +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)] @@ -90,7 +92,7 @@ data ErrorMessageHint | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) | RelatedPositions (NEL.NonEmpty SourceSpan) - deriving (Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, Serialise, NFData) -- | Categories of hints data HintCategory @@ -101,7 +103,7 @@ data HintCategory | SolverHint | DeclarationHint | OtherHint - deriving (Show, Eq) + deriving (Show, Eq, Ord) -- | -- In constraint solving, indicates whether there were `TypeUnknown`s that prevented @@ -112,7 +114,7 @@ data UnknownsHint = NoUnknowns | Unknowns | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]])) - deriving (Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, Serialise, NFData) -- | -- A module declaration, consisting of comments about the module, a module name, @@ -165,7 +167,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 @@ -306,7 +308,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 @@ -323,7 +325,7 @@ data RoleDeclarationData = RoleDeclarationData { rdeclSourceAnn :: !SourceAnn , rdeclIdent :: !(ProperName 'TypeName) , rdeclRoles :: ![Role] - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, S.Serialise, NFData) -- | A type declaration assigns a type to an identifier, eg: -- @@ -334,7 +336,7 @@ data TypeDeclarationData = TypeDeclarationData { tydeclSourceAnn :: !SourceAnn , tydeclIdent :: !Ident , tydeclType :: !SourceType - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, S.Serialise, NFData) getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d @@ -356,7 +358,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 (Eq, Ord, Show, Functor, Generic, S.Serialise, NFData, Foldable, Traversable) getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d @@ -370,7 +372,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration { dataCtorAnn :: !SourceAnn , dataCtorName :: !(ProperName 'ConstructorName) , dataCtorFields :: ![(Ident, SourceType)] - } deriving (Show, Eq, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, S.Serialise, NFData) mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. } @@ -445,13 +447,43 @@ 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 (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 + +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, 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 +494,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T data InstanceDerivationStrategy = KnownClassStrategy | NewtypeStrategy - deriving (Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, Serialise, NFData) -- | The members of a type class instance declaration data TypeInstanceBody @@ -472,7 +504,7 @@ data TypeInstanceBody -- ^ This is an instance derived from a newtype | ExplicitInstance [Declaration] -- ^ This is a regular (explicit) instance - deriving (Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, Serialise, NFData) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) @@ -488,7 +520,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 +657,13 @@ flattenDecls = concatMap flattenOne -- data Guard = ConditionGuard Expr | PatternGuard Binder Expr - deriving (Show, Generic, 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, NFData) + deriving (Eq, Ord, Show, Generic, Serialise, NFData) pattern MkUnguarded :: Expr -> GuardedExpr pattern MkUnguarded e = GuardedExpr [] e @@ -762,7 +794,65 @@ data Expr -- A value with source position information -- | PositionedValue SourceSpan [Comment] Expr - deriving (Show, Generic, NFData) + 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 _ e _) = "TypedValue " <> exprCtr e +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 _ _ e) = "PositionedValue " <> exprCtr e + + +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 _ expr _) = exprSourceSpan expr +exprSourceSpan (Let _ _ _) = Nothing +exprSourceSpan (Do _ _) = Nothing +exprSourceSpan (Ado _ _ _) = Nothing +exprSourceSpan (TypeClassDictionary sa _ _) = Just $ fst $ P.constraintAnn sa +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 @@ -776,7 +866,7 @@ data WhereProvenance -- The let binding was always a let binding -- | FromLet - deriving (Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, Serialise, NFData) -- | -- An alternative in a case statement @@ -790,7 +880,7 @@ data CaseAlternative = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: [GuardedExpr] - } deriving (Show, Generic, NFData) + } deriving (Eq, Ord, Show, Generic, Serialise, NFData) -- | -- A statement in a do-notation block @@ -812,7 +902,7 @@ data DoNotationElement -- A do notation element with source position information -- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement - deriving (Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, Serialise, NFData) -- For a record update such as: @@ -839,16 +929,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) 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/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/Compile.hs b/src/Language/PureScript/Compile.hs new file mode 100644 index 0000000000..657f74d005 --- /dev/null +++ b/src/Language/PureScript/Compile.hs @@ -0,0 +1,23 @@ +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 Prelude + +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 + 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/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/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..d82357992c --- /dev/null +++ b/src/Language/PureScript/DB.hs @@ -0,0 +1,20 @@ +module Language.PureScript.DB where + +import Database.SQLite.Simple (Connection, open) +import Protolude +import System.Directory (canonicalizePath, createDirectoryIfMissing) +import System.FilePath (()) + +mkConnection :: FilePath -> IO (FilePath, Connection) +mkConnection outputDir = do + createDirectoryIfMissing True outputDir + path <- mkDbPath outputDir + putErrLn $ "Opening sqlite database at " <> 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/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 82139ccbe4..c20602be72 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -2,6 +2,8 @@ module Language.PureScript.Docs.AsMarkdown ( Docs , runDocs , moduleAsMarkdown + , declAndModuleNameAsMarkdown + , declAsMarkdown , codeToString ) where @@ -33,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/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 e1f857031f..560055d334 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,10 +47,11 @@ 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 + -- | Information about a type class data TypeClassData = TypeClassData { typeClassArguments :: [(Text, Maybe SourceType)] @@ -71,7 +74,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 @@ -82,7 +85,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 +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, Ord, Generic) instance NFData NameKind instance Serialise NameKind diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a15c3690c..6185c5750f 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 @@ -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 @@ -2032,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/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/Externs.hs b/src/Language/PureScript/Externs.hs index a9669a9995..6a67f0da46 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -247,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 _ 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 diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 95ef36fde4..d0a7df6447 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -8,29 +8,28 @@ -- Maintainer : Christoph Hegemann -- Stability : experimental -- --- | --- Interface for the psc-ide-server ----------------------------------------------------------------------------- - {-# LANGUAGE PackageImports #-} +-- | +-- Interface for the psc-ide-server module Language.PureScript.Ide - ( handleCommand - ) 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) @@ -39,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 @@ -79,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 @@ -113,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 @@ -153,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) @@ -164,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 @@ -181,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 @@ -242,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/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 8a23f574e0..1b7097bac9 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -11,10 +11,12 @@ -- | -- Error types for psc-ide ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.Ide.Error ( IdeError(..) , prettyPrintTypeSingleLine + , textError ) where import Data.Aeson (KeyValue(..), ToJSON(..), Value, object) @@ -32,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/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/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs index 925881b2d0..ce74b49ec6 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 + , runErrLogger , logPerf , displayTimeSpec , labelTimespec @@ -9,7 +10,7 @@ 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, runStderrLoggingT) import Data.Text qualified as T import Language.PureScript.Ide.Types (IdeLogLevel(..)) import System.Clock (Clock(..), TimeSpec, diffTimeSpec, getTime, toNanoSecs) @@ -25,6 +26,16 @@ runLogger logLevel' = 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/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ebc34339eb..7b82c6c535 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) @@ -183,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 () } @@ -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..59f429ae24 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -8,43 +8,44 @@ -- Maintainer : Christoph Hegemann -- 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. @@ -226,7 +241,7 @@ populateVolatileStateSync = do (\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 +250,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 +262,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 +339,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 +500,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 b9120713f5..010a7b668d 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,45 @@ 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 +80,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 +88,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 +136,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 +144,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 @@ -327,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.hs b/src/Language/PureScript/LSP.hs new file mode 100644 index 0000000000..75cfdaf981 --- /dev/null +++ b/src/Language/PureScript/LSP.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PolyKinds #-} + +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 (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, 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) + +main :: FilePath -> LspEnvironment -> IO Int +main outputPath lspEnv = do + Server.runServer $ serverDefinition outputPath 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 + dbPath <- getDbPath + newDbPath <- liftIO $ mkDbPath (outputPath newConfig) + when (newDbPath /= dbPath) do + debugLsp "DB path changed" + liftIO $ putNewEnv lspEnv $ outputPath newConfig + prevConfig <- getPreviousConfig + when (globs newConfig /= globs prevConfig) do + debugLsp "Globs changed" + void updateAvailableSrcs + putPreviousConfig newConfig, + defaultConfig = defaultConfig initialOutputPath, + configSection = "purescript-lsp", + doInitialize = \env _ -> pure (Right env), + staticHandlers = const (lspHandlers lspEnv), + interpretHandler = \serverEnv -> + Server.Iso + ( runHandlerM serverEnv lspEnv + ) + liftIO, + options = lspOptions + } + +lspOptions :: Server.Options +lspOptions = + Server.defaultOptions + { Server.optTextDocumentSync = Just syncOptions, + Server.optCompletionTriggerCharacters = Just $ "._" <> ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] + } + +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.InL True + } + +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 f msg@(LSP.TRequestMessage _ id method _) k = do + let reqId = case id of + LSP.IdInt i -> Left i + LSP.IdString t -> Right t + methodText = T.pack $ LSP.someMethodToMethodString $ LSP.SomeMethod method + debugLsp methodText + logPerfStandard methodText $ do + Lifted.withAsync (f msg k) \asyncAct -> do + addRunningRequest lspEnv reqId asyncAct + result <- Lifted.waitCatch asyncAct + case result of + Left e -> do + case fromException e of + Just AsyncCancelled -> do + warnLsp $ "Request cancelled. Method: " <> methodText <> ". id: " <> show reqId + k $ Left $ LSP.TResponseError (Types.InL Types.LSPErrorCodes_RequestCancelled) "Cancelled" Nothing + _ -> do + 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 + Lifted.withAsync (f msg) \asyncAct -> do + result <- Lifted.waitCatch asyncAct + case result of + Left e -> do + case fromException e of + Just AsyncCancelled -> do + warnLsp $ "Notification cancelled. Method: " <> methodText + _ -> do + errorLsp $ "Notification failed. Method: " <> methodText <> ". Error: " <> show e + _ -> pure () \ No newline at end of file diff --git a/src/Language/PureScript/Lsp/AtPosition.hs b/src/Language/PureScript/Lsp/AtPosition.hs new file mode 100644 index 0000000000..20544140fb --- /dev/null +++ b/src/Language/PureScript/Lsp/AtPosition.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE BlockArguments #-} + +module Language.PureScript.Lsp.AtPosition where + +import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view) +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.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, onDeclsAtLine, posInSpan, sourcePosToPosition) +import Language.PureScript.Types (getAnnForType) +import Protolude +import Safe qualified + +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 + +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 :: [P.Declaration], + apDecls :: [P.Declaration], + 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 :: [(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: " + <> 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 (length apImport) + +nullEverythingAtPos :: EverythingAtPos +nullEverythingAtPos = EverythingAtPos [] [] [] [] [] [] [] [] [] + +topLevelDecl :: P.Declaration -> EverythingAtPos +topLevelDecl decl = nullEverythingAtPos {apTopLevelDecl = pure decl} + +withSpansOnly :: EverythingAtPos -> EverythingAtPos +withSpansOnly EverythingAtPos {..} = + EverythingAtPos + apTopLevelDecl + apDecls + (filter (view _2) apExprs) + (filter (view _2) apBinders) + [] + (filter (view _2) apDoNotationElements) + [] + apTypes + apImport + +withTypedValuesOnly :: EverythingAtPos -> EverythingAtPos +withTypedValuesOnly EverythingAtPos {..} = + EverythingAtPos + apTopLevelDecl + apDecls + (filter (isJust . exprTypes . view _3) apExprs) + (filter (isJust . binderTypes . view _3) apBinders) + [] + [] + [] + apTypes + apImport + where + (_, exprTypes, binderTypes, _, _) = + P.accumTypes (const $ Just ()) + +getEverythingAtPos :: [P.Declaration] -> Types.Position -> EverythingAtPos +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 + +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) + +debugExpr :: (Show a) => a -> Text +debugExpr = + 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 = " + . 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 :: + 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 + 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) $ + getDeclTypesAtPos pos decl + + case tipes of + [] -> nullRes + _ -> do + 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 + 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 + case smallestExpr exprsAtPos of + Just expr -> do + case expr of + P.Var _ (P.Qualified (P.BySourcePos srcPos) _) | srcPos /= P.SourcePos 0 0 -> do + handleExprInModule filePath srcPos + P.Var _ (P.Qualified (P.ByModuleName modName) ident) -> do + 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 = 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 = + P.exprSourceSpan expr <&> \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 (spanLineEnd - spanLineStart, 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))) + +smallestType :: [P.SourceType] -> Maybe P.SourceType +smallestType = Safe.minimumByMay (comparing getTypeLinesAndColumns) + +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))) + +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 + 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 + +modifySmallestExprAtPos :: (P.Expr -> P.Expr) -> Types.Position -> P.Module -> (P.Module, Maybe (P.Expr, P.Expr)) +modifySmallestExprAtPos fn pos m@(P.Module ss c mName _ refs) = + (P.Module ss c mName (fmap fst declsAndExpr) refs, asum $ snd <$> declsAndExpr) + where + 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 + where + (onDecl, _, _) = P.everywhereOnValuesM pure handleExpr pure + + handleExpr :: P.Expr -> StateT (Maybe (P.Expr, P.Expr)) Identity P.Expr + handleExpr expr = do + found <- get + 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 + +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 + 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 (go declaration) [] + where + go :: P.Declaration -> StateT [P.Expr] Identity P.Declaration + go = 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 + +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 + +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/Cache.hs b/src/Language/PureScript/Lsp/Cache.hs new file mode 100644 index 0000000000..44752204b0 --- /dev/null +++ b/src/Language/PureScript/Lsp/Cache.hs @@ -0,0 +1,167 @@ +module Language.PureScript.Lsp.Cache where + +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.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound) +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) +import System.FilePath (normalise, ()) + +selectAllExternsMap :: (MonadIO m, MonadReader LspEnvironment m) => m (Map P.ModuleName 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) + +selectDependencies :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m [ExternDependency] +selectDependencies (P.Module _ _ _ decls _) = do + DB.queryNamed (Query query') [":module_names" := A.encode (P.runModuleName <$> importedModuleNames decls)] + where + 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 + absPath <- liftIO $ makeAbsolute path + 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 + 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 +findAvailableExterns :: (MonadReader LspEnvironment m, MonadError IdeError m, MonadLsp ServerConfig m) => m [P.ModuleName] +findAvailableExterns = do + oDir <- outputPath <$> getConfig + 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 + +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 <- getConfig + srcs <- + liftIO $ + toInputGlobs $ + PSCGlobs + { pscInputGlobs = globs config, + pscInputGlobsFromFile = inputSrcFromFile config, + pscExcludeGlobs = [], + pscWarnFileTypeNotFound = warnFileTypeNotFound "lsp server" + } + for_ srcs $ \src -> do + canonPath <- liftIO $ canonicalizePath src + DB.executeNamed (Query "INSERT INTO available_srcs (path) VALUES (:path)") [":path" := canonPath] + absPath <- liftIO $ makeAbsolute src + when (absPath /= canonPath) $ + DB.executeNamed (Query "INSERT INTO available_srcs (path) VALUES (:path)") [":path" := absPath] + + 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/Cache/Query.hs b/src/Language/PureScript/Lsp/Cache/Query.hs new file mode 100644 index 0000000000..673903b315 --- /dev/null +++ b/src/Language/PureScript/Lsp/Cache/Query.hs @@ -0,0 +1,176 @@ +module Language.PureScript.Lsp.Cache.Query where + +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.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 + +------------------------------------------------------------------------------------------------------------------------ +------------ AST ------------------------------------------------------------------------------------------------------- +------------------------------------------------------------------------------------------------------------------------ + +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, 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 + ] + + pure $ listToMaybe decls + +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 + "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 ast_declarations.module_name = :module_name \ + \AND name = :name \ + \AND name_type IS :name_type" + [ ":module_name" := P.runModuleName moduleName', + ":name" := name, + ":name_type" := lspNameType + ] + 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" := lspNameType + ] + pure $ decls <&> fromOnly + +getAstDeclarationsStartingWith :: + (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => + P.ModuleName -> + Text -> + m [CompletionResult] +getAstDeclarationsStartingWith moduleName' prefix = do + limit <- getMaxCompletions + typeLen <- getMaxTypeLength + let offset = 0 :: Int + DB.queryNamed + ( SQL.Query $ + "SELECT ast_declarations.name, " + <> printedTypeTruncated typeLen + <> "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) \ + \AND instr(name, :prefix) == 1 \ + \AND generated = false \ + \ORDER BY name ASC \ + \LIMIT :limit \ + \OFFSET :offset" + ) + [ ":module_name" := P.runModuleName moduleName', + ":prefix" := prefix, + ":limit" := limit, + ":offset" := offset + ] + +getAstDeclarationsStartingWithAndSearchingModuleNames :: + (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => + P.ModuleName -> + P.ModuleName -> + Text -> + m [CompletionResult] +getAstDeclarationsStartingWithAndSearchingModuleNames moduleName' moduleNameContains prefix = do + limit <- getMaxCompletions + typeLen <- getMaxTypeLength + let offset = 0 :: Int + DB.queryNamed + ( SQL.Query $ + "SELECT ast_declarations.name, " + <> printedTypeTruncated typeLen + <> "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) \ + \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" + ) + [ ":module_name" := P.runModuleName moduleName', + ":prefix" := prefix, + ":module_name_contains" := P.runModuleName moduleNameContains, + ":limit" := limit, + ":offset" := offset + ] + +getAstDeclarationsStartingWithOnlyInModule :: + (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => + P.ModuleName -> + Text -> + m [CompletionResult] +getAstDeclarationsStartingWithOnlyInModule moduleName' prefix = do + limit <- getMaxCompletions + typeLen <- getMaxTypeLength + let offset = 0 :: Int + DB.queryNamed + ( SQL.Query $ + "SELECT ast_declarations.name, " + <> printedTypeTruncated typeLen + <> "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 \ + \AND instr(name, :prefix) == 1 \ + \AND generated = false \ + \ORDER BY name ASC \ + \LIMIT :limit \ + \OFFSET :offset" + ) + [ ":module_name" := P.runModuleName moduleName', + ":prefix" := prefix, + ":limit" := limit, + ":offset" := offset + ] + +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, + crType :: Text, + crModule :: P.ModuleName, + crNameType :: LspNameType + } + deriving (Show, Generic) + +instance SQL.FromRow CompletionResult where + 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/DB.hs b/src/Language/PureScript/Lsp/DB.hs new file mode 100644 index 0000000000..257d3603af --- /dev/null +++ b/src/Language/PureScript/Lsp/DB.hs @@ -0,0 +1,43 @@ +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) +import Protolude +import Language.PureScript.Lsp.State (getDbConn) + + +-- 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 + conn <- getDbConn + liftIO $ SQL.queryNamed conn q params + +query_ :: + (MonadIO m, MonadReader LspEnvironment m, FromRow r) => + Query -> + m [r] +query_ q = do + conn <- getDbConn + liftIO $ SQL.query_ conn q + +executeNamed :: + (MonadIO m, MonadReader LspEnvironment m) => + Query -> + [SQL.NamedParam] -> + m () +executeNamed q params = do + conn <- getDbConn + liftIO $ SQL.executeNamed conn q params + +execute_ :: (MonadReader LspEnvironment m, MonadIO m) => Query -> m () +execute_ q = do + conn <- getDbConn + liftIO $ SQL.execute_ conn q + diff --git a/src/Language/PureScript/Lsp/Diagnostics.hs b/src/Language/PureScript/Lsp/Diagnostics.hs new file mode 100644 index 0000000000..200739d661 --- /dev/null +++ b/src/Language/PureScript/Lsp/Diagnostics.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveAnyClass #-} + +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 +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, 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 (showDiagnosticsFilepath, showDiagnosticsModule)) +import Language.PureScript.Lsp.Types (LspEnvironment, RebuildResult (RebuildError, RebuildWarning)) +import Protolude hiding (to) +import Text.PrettyPrint.Boxes (render) + +getFileDiagnotics :: + ( LSP.HasParams s a1, + LSP.HasTextDocument a1 a2, + LSP.HasUri a2 Uri, + MonadLsp ServerConfig m, + MonadThrow m, + MonadReader LspEnvironment m + ) => + s -> + m [Diagnostic] +getFileDiagnotics msg = do + let uri :: Types.NormalizedUri + uri = getMsgUri msg & Types.toNormalizedUri + res <- rebuildFile uri + config <- getConfig + pure $ addJsonEdits $ getResultDiagnostics config 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 :: + ServerConfig -> + RebuildResult -> + [(Types.Diagnostic, [TitledTextEdit])] +getResultDiagnostics config res = case res of + RebuildError errors -> errorsToDiagnostics config Types.DiagnosticSeverity_Error errors + RebuildWarning errors -> errorsToDiagnostics config Types.DiagnosticSeverity_Warning errors + +errorsToDiagnostics :: ServerConfig -> Types.DiagnosticSeverity -> P.MultipleErrors -> [(Types.Diagnostic, [TitledTextEdit])] +errorsToDiagnostics config severity errs = + errorMessageDiagnostic config severity <$> runMultipleErrors errs + +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 $ checkWithPosition $ checkWithModule msg) + Nothing + Nothing + Nothing, + maybeToList (getErrorTextEdit msg) + ) + where + checkWithPosition = if showDiagnosticsFilepath config then identity else Errors.withoutPosition + + checkWithModule = if showDiagnosticsModule config then identity else Errors.withoutModule + + 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) + ) + +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/Docs.hs b/src/Language/PureScript/Lsp/Docs.hs new file mode 100644 index 0000000000..644378d007 --- /dev/null +++ b/src/Language/PureScript/Lsp/Docs.hs @@ -0,0 +1,72 @@ +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) +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) +import Language.PureScript.Lsp.ServerConfig (ServerConfig (outputPath)) +import Language.PureScript.Lsp.Types (LspEnvironment) +import Language.PureScript.Names qualified as P +import Protolude + +readModuleDocs :: (MonadLsp ServerConfig m) => P.ModuleName -> m (Maybe Docs.Module) +readModuleDocs modName = do + outputDirectory <- outputPath <$> getConfig + liftIO $ catchError (Just <$> parseDocsJsonFile outputDirectory modName) (const $ pure Nothing) + +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 :: (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) + where + getMarkdown :: [Docs.Declaration] -> Maybe Text + getMarkdown [] = Nothing + getMarkdown (decl : decls) = case decl of + _ | 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.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 + + 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 :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> Text -> m (Maybe Text) +readDeclarationDocsAsMarkdown modName ident = fmap (runDocs . declAsMarkdown) <$> readDeclarationDocs modName ident + +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 :: (MonadReader LspEnvironment m, MonadLsp ServerConfig m) => P.ModuleName -> Text -> m (Maybe P.SourceSpan) +readDeclarationDocsSourceSpan modName ident = readDeclarationDocs modName ident <&> (=<<) P.declSourceSpan + +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 new file mode 100644 index 0000000000..8127aef688 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +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 +import Language.LSP.Protocol.Message qualified as Message +import Language.LSP.Protocol.Types (Uri) +import Language.LSP.Protocol.Types qualified as Types +import Language.LSP.Server qualified as Server +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.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.ServerConfig (setTraceValue) +import Language.PureScript.Lsp.State (cancelRequest, getDbConn, removedCachedRebuild) +import Language.PureScript.Make.Index (dropTables, initDb) +import Language.PureScript.Lsp.Handlers.ClearCache (clearCacheHandlers) +import Language.PureScript.Lsp.Handlers.DebugCacheSize (debugCacheSizeHandler) + +handlers :: Server.Handlers HandlerM +handlers = + mconcat + [ simpleHandlers, + buildHandler, + completionAndResolveHandlers, + definitionHandler, + deleteOutputHandler, + diagnosticAndCodeActionHandlers, + formatHandler, + hoverHandler, + indexHandler, + clearCacheHandlers, + debugCacheSizeHandler + ] + 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_WorkspaceDidChangeWatchedFiles $ \_not -> do + pure (), + Server.notificationHandler Message.SMethod_TextDocumentDidOpen $ \_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 + 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_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 + ] + +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..aef815d026 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/Build.hs @@ -0,0 +1,52 @@ +{-# 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 (getConfig) +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, addJsonEdits) +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.Log (debugLsp) + +buildHandler :: Server.Handlers HandlerM +buildHandler = + Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"build") $ \_req res -> do + diags <- buildForLsp + res $ Right $ A.toJSON diags + +-- Either get progress to work or remove it +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 + config <- getConfig + pure $ addJsonEdits $ + (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/Handlers/ClearCache.hs b/src/Language/PureScript/Lsp/Handlers/ClearCache.hs new file mode 100644 index 0000000000..ccf8493f43 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/ClearCache.hs @@ -0,0 +1,25 @@ +{-# 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, 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: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/Completion.hs b/src/Language/PureScript/Lsp/Handlers/Completion.hs new file mode 100644 index 0000000000..ae973b86c4 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/Completion.hs @@ -0,0 +1,131 @@ +{-# 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.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 (logPerfStandard) +import Language.PureScript.Lsp.Monad (HandlerM) +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) +import Protolude hiding (to) + +completionAndResolveHandlers :: Server.Handlers HandlerM +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 ()) -> HandlerM () + forLsp val f = maybe nullRes f val + + forLsp filePathMb \filePath -> do + vfMb <- Server.getVirtualFile uri + forLsp vfMb \vf -> do + let (range, word) = getSymbolAt (VFS._file_text vf) pos + mNameMb <- parseModuleNameFromFile uri + forLsp mNameMb \mName -> do + let withQualifier = getIdentModuleQualifier word + wordWithoutQual = maybe word snd withQualifier + limit <- getMaxCompletions + matchingImport <- maybe (pure Nothing) (getMatchingImport uri . fst) withQualifier + decls <- logPerfStandard "get completion declarations" case (matchingImport, withQualifier) of + (Just (Import importModuleName _ _), _) -> do + getAstDeclarationsStartingWithOnlyInModule importModuleName wordWithoutQual + (_, Just (wordModuleName, _)) -> do + getAstDeclarationsStartingWithAndSearchingModuleNames mName wordModuleName wordWithoutQual + _ -> do + getAstDeclarationsStartingWith mName wordWithoutQual + res $ + Right $ + Types.InR $ + Types.InL $ + Types.CompletionList (length decls >= limit) Nothing $ + decls <&> \cr -> + let label = crName cr + nameType = crNameType cr + declModName = crModule cr + in Types.CompletionItem + { _label = label, + _labelDetails = + Just $ + Types.CompletionItemLabelDetails + (Just $ " " <> crType cr) + (Just $ readableTypeIn (crNameType cr) <> P.runModuleName declModName), + _kind = + Just case nameType of + 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 + KindNameType -> Types.CompletionItemKind_Struct + RoleNameType -> Types.CompletionItemKind_Struct, + _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 = 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 declModName label nameType 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 nameType _ _)) -> do + docsMb <- readDeclarationDocsWithNameType declModule nameType label + 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 <> " in " <> P.runModuleName declModule) + \docs -> + setDocs (readableType nameType <> " in " <> P.runModuleName declModule <> "\n\n" <> docs) + res $ + Right $ + withImports + & addDocs + _ -> res $ Right completionItem + ] \ 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..ee515dd05e --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/DebugCacheSize.hs @@ -0,0 +1,76 @@ +{-# 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, openFiles), OpenFile (..)) +import Numeric (showFFloat) +import Protolude hiding (to) + +debugCacheSizeHandler :: Server.Handlers HandlerM +debugCacheSizeHandler = + 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 + + debugLsp "Finished debugging cache sizes" + + 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 + +debugNfSize :: (NFData a) => Text -> a -> HandlerM () +debugNfSize label a = do + let !forced = force a + !evaluated <- liftIO $ closureSize forced + 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/Definition.hs b/src/Language/PureScript/Lsp/Handlers/Definition.hs new file mode 100644 index 0000000000..ac349fc2c1 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/Definition.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE BlockArguments #-} + +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 +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) + +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) + + 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 diff --git a/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs new file mode 100644 index 0000000000..1fd6f4e8e0 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/DeleteOutput.hs @@ -0,0 +1,31 @@ +{-# 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 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 = + Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"delete-output") $ \_req res -> do + deleteOutput + res $ Right A.Null + +deleteOutput :: HandlerM () +deleteOutput = do + outDir <- outputPath <$> getConfig + 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/Diagnostic.hs b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs new file mode 100644 index 0000000000..cde3428395 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/Diagnostic.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BlockArguments #-} + +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 (TitledTextEdit (..), getFileDiagnotics, getMsgUri) +import Language.PureScript.Lsp.Monad (HandlerM) +import Protolude hiding (to) + +diagnosticAndCodeActionHandlers :: Server.Handlers HandlerM +diagnosticAndCodeActionHandlers = + mconcat + [ Server.requestHandler Message.SMethod_TextDocumentDiagnostic $ \req res -> do + 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 :: [Types.Diagnostic] + diags = params ^. LSP.context . LSP.diagnostics + uri = getMsgUri req + + res $ + Right $ + Types.InL $ + diags >>= \diag -> + let titledEdits :: [TitledTextEdit] + titledEdits = case A.fromJSON <$> diag ^. LSP.data_ of + Just (A.Success tes) -> tes + _ -> [] + + 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 + ] + ] diff --git a/src/Language/PureScript/Lsp/Handlers/Format.hs b/src/Language/PureScript/Lsp/Handlers/Format.hs new file mode 100644 index 0000000000..b57aeba5ce --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/Format.hs @@ -0,0 +1,41 @@ +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 (getConfig) +import Language.LSP.Server qualified as Server +import Language.PureScript.Lsp.Imports (parseImportsFromFile, printImports) +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 + 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 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) + 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/Handlers/Hover.hs b/src/Language/PureScript/Lsp/Handlers/Hover.hs new file mode 100644 index 0000000000..fc87d845e8 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/Hover.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Language.PureScript.Lsp.Handlers.Hover (hoverHandler) 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.Docs.Convert.Single (convertComments) +import Language.PureScript.Docs.Types qualified as Docs +import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine) +import Language.PureScript.Lsp.AtPosition (binderSourceSpan, getImportRefNameType, spanToRange) +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 (cachedFilePaths, cachedRebuild) +import Language.PureScript.Lsp.Types (OpenFile (..)) +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 + let Types.HoverParams docIdent pos _prog = req ^. LSP.params + uri = docIdent ^. LSP.uri + filePathMb = Types.uriToFilePath uri + + nullRes = res $ Right $ Types.InR Types.Null + + markdownRes range md = + 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 + + 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 + when (isNothing cacheOpenMb) do + debugLsp $ "file path not cached: " <> T.pack filePath + debugLsp . show =<< cachedFilePaths + forLsp cacheOpenMb \OpenFile {..} -> do + let allArtifacts = ofArtifacts + 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 a@(IdeArtifact {..}) -> + case iaValue of + IaExpr exprTxt ident nameType -> do + 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, + showDocs <$> docs, + head foundTypes + ] + 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' + debugLsp $ "Hovering type name: " <> name' + markdownRes (Just $ spanToRange iaSpan) $ + joinMarkup + [ Just inferredRes, + showDocs <$> docs, + showTypeSection modName (P.runProperName name) <$> head foundTypes + ] + IaClassName name -> do + 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 + [ Just inferredRes, + showDocs <$> docs + ] + IaIdent ident -> do + markdownRes (Just $ spanToRange iaSpan) $ pursTypeStr ident (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts iaType) [] + 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) [] + 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 + (binderArtifact, actualBinder) = fromMaybe (a, binder) $ find (\(_, b) -> T.strip (P.prettyPrintBinder b) == word) binders + + let inferredRes = pursTypeStr (dispayBinderOnHover actualBinder) (Just $ prettyPrintTypeSingleLine $ useSynonymns allArtifacts $ Artifiacts.iaType binderArtifact) [] + markdownRes (Just range) inferredRes + + + 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 + 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 + ] + 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) + +showDocs :: Text -> Text +showDocs d = "**Docs**\n" <> d + +joinMarkup :: [Maybe Text] -> Text +joinMarkup = T.intercalate "\n---\n" . catMaybes + +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 + +dispayBinderOnHover :: P.Binder -> T.Text +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 + +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 -> "" + +pursMd :: Text -> Text +pursMd t = "```purescript\n" <> t <> "\n```" + +data InferError + = FileNotCached + | CompilationError P.MultipleErrors + | InferException Text + deriving (Show, Exception) diff --git a/src/Language/PureScript/Lsp/Handlers/Index.hs b/src/Language/PureScript/Lsp/Handlers/Index.hs new file mode 100644 index 0000000000..9bdac8fad2 --- /dev/null +++ b/src/Language/PureScript/Lsp/Handlers/Index.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeApplications #-} + +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 +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.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, 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) + +indexHandler :: Server.Handlers HandlerM +indexHandler = + mconcat + [ Server.requestHandler (Message.SMethod_CustomMethod $ Proxy @"index-fast") $ \_req res -> do + conn <- getDbConn + liftIO $ initDb conn + 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 + conn <- getDbConn + liftIO $ initDb conn + deleteOutput + diags <- buildForLsp + res $ Right $ A.toJSON diags + ] + where + indexExternAndDecls :: ExternsFile -> HandlerM () + indexExternAndDecls ef = do + conn <- getDbConn + indexExtern conn ef + indexAstModuleFromExtern conn ef + forConcurrently_ (P.efDeclarations ef) (indexAstDeclFromExternDecl conn ef (getExportedNames ef)) + +-- \| Finds all the externs inside the output folder and returns the +-- corresponding module names +findAvailableExterns :: + forall m. + ( MonadLsp ServerConfig m, + MonadBaseControl IO m, + MonadReader LspEnvironment m + ) => + m [ExternsFile] +findAvailableExterns = do + oDir <- outputPath <$> getConfig + directories <- liftIO $ getDirectoryContents oDir + moduleNames <- liftIO $ filterM (containsExterns oDir) directories + 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 + 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 P.externsFileName + res <- runExceptT $ readExternsFile path + case res of + Left err -> do + errorLsp $ "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/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 diff --git a/src/Language/PureScript/Lsp/Imports.hs b/src/Language/PureScript/Lsp/Imports.hs new file mode 100644 index 0000000000..a168e32010 --- /dev/null +++ b/src/Language/PureScript/Lsp/Imports.hs @@ -0,0 +1,194 @@ +module Language.PureScript.Lsp.Imports + ( getMatchingImport, + addImportToTextEdit, + getIdentModuleQualifier, + parseModuleNameFromFile, + parseImportsFromFile, + printImports, + ) +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.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 + +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 " <> 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 :: (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 :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m, MonadThrow m) => CompleteItemData -> m (Maybe [TextEdit]) +getImportEdits (CompleteItemData path moduleName' importedModuleName name nameType word (Range wordStart _)) = do + 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 nameType + case declMb of + Nothing -> do + errorLsp $ "In " <> T.pack path <> " failed to get declaration from module: " <> show (importedModuleName, name, nameType) + pure Nothing + 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 + 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 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 Text -> + LspNameType -> + [Import] -> + Maybe + ( [Import], -- new imports + Maybe P.ModuleName -- module qualifier + ) +addDeclarationToImports moduleName' importedModuleName wordQualifierMb declName ctrType nameType imports + | importingSelf = Nothing + | Just existing <- alreadyImportedModuleMb = case existing of + Import _ (P.Explicit refs') 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 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) + | otherwise = addExplicitNewImport + where + addExplicitNewImport = Just (Import importedModuleName (P.Explicit refs) wordQualifierMb : imports, wordQualifierMb) + withoutOldImport :: [Import] + withoutOldImport = maybe identity (\im -> filter (/= im)) alreadyImportedModuleMb imports + + refs :: [P.DeclarationRef] + 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 $ 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 + + 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' = ref' : refs + | otherwise = ref' : insertImportRef ref refs +insertImportRef ref [] = [ref] + +importsToTextEdit :: [Text] -> [Import] -> TextEdit +importsToTextEdit before imports = + TextEdit + ( LSP.Range + (LSP.Position beforeLine 0) + ( LSP.Position + ( beforeLine + fromIntegral (length printed) - 1 + ) + (maybe 0 (fromIntegral . T.length) $ lastMay printed) + ) + ) + (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 :: + (MonadThrow m, MonadLsp ServerConfig m) => + NormalizedUri -> + m (Either Text (P.ModuleName, [Text], [Import], [Text])) +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 -> + 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 diff --git a/src/Language/PureScript/Lsp/Log.hs b/src/Language/PureScript/Lsp/Log.hs new file mode 100644 index 0000000000..a297d89e78 --- /dev/null +++ b/src/Language/PureScript/Lsp/Log.hs @@ -0,0 +1,83 @@ +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) +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 + +warnLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m () +warnLsp = logLsp LogMsgWarning + +errorLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m () +errorLsp = logLsp LogMsgError + +debugLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m () +debugLsp = logLsp LogMsgDebug + +perfLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m () +perfLsp = logLsp LogMsgPerf + +logLsp :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => LogMsgSeverity -> Text -> m () +logLsp msgLogLevel msg = do + logLevel <- logLevel <$> getConfig + when (shouldLog msgLogLevel logLevel) $ do + now <- liftIO getCurrentTime + liftIO $ + putErrLn -- Use stderr for logging as LSP messages should be on stdout + ( "[ " + <> printLogMsgSeverity msgLogLevel + <> " ]" + <> " " + <> T.pack (formatTime defaultTimeLocale "%T" now) + <> "\n" + <> msg + <> "\n\n" + ) + +logPerfStandard :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => Text -> m t -> m t +logPerfStandard label f = logPerf (labelTimespec label) f + +logPerf :: (MonadLsp ServerConfig m, MonadReader LspEnvironment m) => (TimeSpec -> Text) -> m t -> m t +logPerf format f = do + start <- getPerfTime + result <- f + 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 + +data LogMsgSeverity + = LogMsgInfo + | LogMsgWarning + | LogMsgError + | LogMsgDebug + | 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] + 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/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 diff --git a/src/Language/PureScript/Lsp/Monad.hs b/src/Language/PureScript/Lsp/Monad.hs new file mode 100644 index 0000000000..846fc35ca7 --- /dev/null +++ b/src/Language/PureScript/Lsp/Monad.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE InstanceSigs #-} + +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 + +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 + 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 + +runHandlerM :: LanguageContextEnv ServerConfig -> LspEnvironment -> HandlerM a -> IO a +runHandlerM env lspEnv (HandlerM a) = runLspT env $ runReaderT a lspEnv \ No newline at end of file diff --git a/src/Language/PureScript/Lsp/NameType.hs b/src/Language/PureScript/Lsp/NameType.hs new file mode 100644 index 0000000000..7df4915c3e --- /dev/null +++ b/src/Language/PureScript/Lsp/NameType.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveAnyClass #-} + +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.AST.Declarations qualified as P + +data LspNameType + = IdentNameType + | ValOpNameType + | TyNameType + | TyOpNameType + | DctorNameType + | TyClassNameType + | ModNameType + | RoleNameType + | KindNameType + deriving (Show, Read, Eq, Ord, Generic, A.ToJSON, A.FromJSON, NFData) + +readableType :: LspNameType -> Text +readableType = \case + IdentNameType -> "Value" + ValOpNameType -> "Operator" + TyNameType -> "Type" + TyOpNameType -> "Type Operator" + DctorNameType -> "Constructor" + TyClassNameType -> "Type Class" + ModNameType -> "Module" + RoleNameType -> "Role" + KindNameType -> "Kind" + +readableTypeIn :: LspNameType -> Text +readableTypeIn = \case + IdentNameType -> "" + lnt -> readableType lnt <> " in " + +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 + IdentName _ -> IdentNameType + ValOpName _ -> ValOpNameType + TyName _ -> TyNameType + TyOpName _ -> TyOpNameType + DctorName _ -> DctorNameType + 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 + EDTypeSynonym _ _ _ -> TyNameType + EDDataConstructor _ _ _ _ _ -> DctorNameType + EDValue _ _ -> IdentNameType + EDClass _ _ _ _ _ _ -> TyClassNameType + EDInstance _ _ _ _ _ _ _ _ _ _ -> IdentNameType diff --git a/src/Language/PureScript/Lsp/Prim.hs b/src/Language/PureScript/Lsp/Prim.hs new file mode 100644 index 0000000000..f1e1983517 --- /dev/null +++ b/src/Language/PureScript/Lsp/Prim.hs @@ -0,0 +1,172 @@ +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.ExternsFile] +primExternsMap = + primExterns + <&> (\ef -> (P.efModuleName ef, [ef])) + & Map.fromListWith (<>) + +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 + _ -> [] + +-- 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/Print.hs b/src/Language/PureScript/Lsp/Print.hs new file mode 100644 index 0000000000..6b24924eb2 --- /dev/null +++ b/src/Language/PureScript/Lsp/Print.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +module Language.PureScript.Lsp.Print where + +import Control.Lens (Field1 (_1), (^.)) +import Data.Text qualified as T +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 +printDeclarationType decl = + Protolude.fold $ + (head :: [Text] -> Maybe Text) $ + 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 + +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 + +printDataDeclKind :: [(Text, Maybe P.SourceType)] -> Text +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) + +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 + 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 + +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/ReadFile.hs b/src/Language/PureScript/Lsp/ReadFile.hs new file mode 100644 index 0000000000..39cf113adc --- /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 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 + +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 new file mode 100644 index 0000000000..60627e1930 --- /dev/null +++ b/src/Language/PureScript/Lsp/Rebuild.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Language.PureScript.Lsp.Rebuild (rebuildFile, 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) +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.Imports (Import (Import), sliceImportSection) +import Language.PureScript.Ide.Rebuild (updateCacheDb) +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, 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 +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 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, + MonadReader Types.LspEnvironment m, + MonadLsp ServerConfig m + ) => + NormalizedUri -> + m Types.RebuildResult +rebuildFile uri = do + fp <- rebuildFilePathFromUri uri + logPerfStandard ("Rebuilt file: " <> T.pack fp) do + input <- lspReadFileText uri + 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. + ( MonadThrow m, + MonadReader Types.LspEnvironment m, + MonadLsp ServerConfig m + ) => + FilePath -> + [ExternDependency] -> + m (P.Env, P.Environment) +getEnv fp deps = do + cached <- cachedEnvironment fp deps + debugLsp $ "Export env cache hit: " <> show (isJust cached) + 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 = + addExternsToExportEnv P.primEnv + >=> either (throwM . CouldNotRebuildExportEnv . P.prettyPrintMultipleErrors P.noColorPPEOptions) pure + +data RebuildException + = CouldNotConvertUriToFilePath NormalizedUri + | CouldNotRebuildExportEnv [Char] + deriving (Exception, Show) + +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 = + 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 + } + +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 + } diff --git a/src/Language/PureScript/Lsp/ServerConfig.hs b/src/Language/PureScript/Lsp/ServerConfig.hs new file mode 100644 index 0000000000..cfcf85aaf8 --- /dev/null +++ b/src/Language/PureScript/Lsp/ServerConfig.hs @@ -0,0 +1,91 @@ +{-# 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.LogLevel (LspLogLevel (..)) +import Protolude +import Data.Aeson qualified as A +import Data.Aeson.Types qualified as AT + +data ServerConfig = ServerConfig + { outputPath :: FilePath, + globs :: [FilePath], + inputSrcFromFile :: Maybe FilePath, + logLevel :: LspLogLevel, + traceValue :: Maybe TraceValue, + formatter :: Formatter, + maxTypeLength :: Maybe Int, + maxCompletions :: Maybe Int, + maxFilesInCache :: Maybe Int, + inferExpressions :: Bool, + showDiagnosticsModule :: Bool, + showDiagnosticsFilepath :: Bool + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +defaultConfig :: FilePath -> ServerConfig +defaultConfig outputPath = + ServerConfig + { outputPath = outputPath, + globs = ["./src/**/*.purs"], + inputSrcFromFile = Nothing, + logLevel = LogAll, + traceValue = Nothing, + formatter = PursTidy, + maxTypeLength = Just defaultMaxTypeLength, + maxCompletions = Just defaultMaxCompletions, + maxFilesInCache = Just defaultMaxFilesInCache, + inferExpressions = True, + showDiagnosticsModule = False, + showDiagnosticsFilepath = False + } + +setTraceValue :: (MonadLsp ServerConfig m) => TraceValue -> m () +setTraceValue tv = do + config <- getConfig + setConfig (config {traceValue = Just tv}) + +defaultMaxTypeLength :: Int +defaultMaxTypeLength = 100 + +defaultMaxCompletions :: Int +defaultMaxCompletions = 50 + +defaultMaxFilesInCache :: Int +defaultMaxFilesInCache = 32 + +getMaxTypeLength :: (MonadLsp ServerConfig m) => m Int +getMaxTypeLength = + fromMaybe defaultMaxTypeLength . maxTypeLength <$> getConfig + +getMaxCompletions :: (MonadLsp ServerConfig m) => m Int +getMaxCompletions = + fromMaybe defaultMaxCompletions . maxCompletions <$> getConfig + +getMaxFilesInCache :: (MonadLsp ServerConfig m) => m Int +getMaxFilesInCache = + fromMaybe defaultMaxFilesInCache . maxFilesInCache <$> getConfig + + +getInferExpressions :: (MonadLsp ServerConfig m) => m Bool +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 diff --git a/src/Language/PureScript/Lsp/State.hs b/src/Language/PureScript/Lsp/State.hs new file mode 100644 index 0000000000..d129aa507f --- /dev/null +++ b/src/Language/PureScript/Lsp/State.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE TypeOperators #-} + +module Language.PureScript.Lsp.State + ( getState, + getDbConn, + cacheRebuild, + cacheRebuild', + updateCachedModule, + updateCachedModule', + cachedRebuild, + clearCache, + clearEnvCache, + clearRebuildCache, + removedCachedRebuild, + addExternsToExportEnv, + cancelRequest, + addRunningRequest, + removeRunningRequest, + getDbPath, + putNewEnv, + putPreviousConfig, + getPreviousConfig, + cachedFiles, + cachedFilePaths, + cachedEnvironment, + cacheEnvironment, + hashDeps, + hashDepHashs, + cachedOpenFileFromSrc, + updateCachedRebuildResult, + -- cachedExportEnvironment, + -- cacheExportEnvironment, + ) +where + +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 Database.SQLite.Simple (Connection) +import Language.LSP.Protocol.Types (type (|?) (..)) +import Language.LSP.Server (MonadLsp) +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.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) +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 + st <- lspStateVar <$> ask + maxFiles <- getMaxFilesInCache + liftIO $ cacheRebuild' st maxFiles src ef artifacts module' depHash + +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) src ef artifacts module' depHash Nothing) : filter ((/= fp) . fst) (openFiles x) + } + 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) + } + +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 + liftIO . atomically $ 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 + +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), (exportEnv, 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.Env, 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 + + +hashDeps :: [ExternDependency] -> Int +hashDeps = hashDepHashs . fmap edHash + +hashDepHashs :: [Int] -> Int +hashDepHashs = hash . sort + +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) + } + +clearRebuildCache :: (MonadReader LspEnvironment m, MonadIO m) => m () +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 = []} + +clearCache :: (MonadReader LspEnvironment m, MonadIO m) => m () +clearCache = clearRebuildCache >> clearEnvCache + +data BuildEnvCacheException = BuildEnvCacheException Text + deriving (Show) + +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 + +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 + Map.lookup eitherId . runningRequests <$> readTVar st + + for_ reqMb $ \req -> liftIO $ cancel req + where + eitherId = case requestId of + 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 + (path, newConn) <- mkConnection outputPath + atomically $ writeTVar (lspDbConnectionVar env) (path, newConn) + 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 new file mode 100644 index 0000000000..9c856a44e9 --- /dev/null +++ b/src/Language/PureScript/Lsp/Types.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveAnyClass #-} + +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.Errors 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 qualified as P +import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts) +import Protolude + +data LspEnvironment = LspEnvironment + { lspDbConnectionVar :: TVar (FilePath, Connection), + lspStateVar :: TVar LspState, + previousConfig :: TVar ServerConfig + } + +mkEnv :: FilePath -> IO LspEnvironment +mkEnv outputPath = do + connection <- newTVarIO =<< mkConnection outputPath + st <- newTVarIO emptyState + prevConfig <- newTVarIO $ defaultConfig outputPath + pure $ LspEnvironment connection st prevConfig + +emptyState :: LspState +emptyState = LspState mempty mempty mempty + +data LspConfig = LspConfig + { confOutputPath :: FilePath, + confGlobs :: [FilePath], + confInputSrcFromFile :: Maybe FilePath, + confLogLevel :: LspLogLevel + } + deriving (Show) + +data LspState = LspState + { openFiles :: [(FilePath, OpenFile)], + environments :: [((FilePath, Int), (P.Env, P.Environment))], + runningRequests :: Map (Either Int32 Text) (Async ()) + } + +data OpenFile = OpenFile + { ofModuleName :: P.ModuleName, + ofSrc :: Text, + ofExternsFile :: P.ExternsFile, + ofArtifacts :: IdeArtifacts, + ofModule :: P.Module, + ofDepHash :: Int, + ofRebuildResult :: Maybe RebuildResult + } + +data RebuildResult + = RebuildError P.MultipleErrors + | RebuildWarning P.MultipleErrors + +data ExternDependency = ExternDependency + { edExtern :: P.ExternsFile, + edLevel :: Int, + edHash :: Int + } + deriving (Show) + +instance FromRow ExternDependency where + fromRow = ExternDependency <$> (deserialise <$> field) <*> field <*> field + +instance ToRow ExternDependency where + toRow (ExternDependency ef level updated_at) = toRow (serialise ef, level, updated_at) + +data CompleteItemData = CompleteItemData + { cidPath :: FilePath, + cidModuleName :: P.ModuleName, + cidImportedModuleName :: P.ModuleName, + cidName :: Text, + cidNameType :: LspNameType, + cidWord :: Text, + wordRange :: Range + } + 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/Lsp/Util.hs b/src/Language/PureScript/Lsp/Util.hs new file mode 100644 index 0000000000..c424d20065 --- /dev/null +++ b/src/Language/PureScript/Lsp/Util.hs @@ -0,0 +1,233 @@ +{-# 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 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 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.Externs qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P +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 + && 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 _)) = + startLine <= fromIntegral (line + 1) + && endLine >= fromIntegral (line + 1) + +getDeclarationAtPos :: Types.Position -> [P.Declaration] -> Maybe P.Declaration +getDeclarationAtPos pos = find (posInSpan pos . fst . declSourceAnn) + +getWordAt :: Rope -> Types.Position -> (Types.Range, Text) +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) = getOnLine charPred line' _character + in (Types.Range (Types.Position _line $ fromIntegral wordStartCol) (Types.Position _line $ fromIntegral wordEndCol), _word) + +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 + let start = getPrevWs (fromIntegral col - 1) line' + end = getNextWs (fromIntegral col) 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 + getNextWs idx txt = case T.index txt idx of + 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 | charPred ch -> idx + 1 + _ -> getPrevWs (idx - 1) txt + +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 _ _ _ _ _ _ -> P.nullSourceSpan + 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 :: AST.SourceAnn -> [P.Comment] -> [P.Comment] + getComments (_, cs) acc = cs ++ acc + +sourcePosToPosition :: AST.SourcePos -> Types.Position +sourcePosToPosition (AST.SourcePos line col) = + Types.Position (fromIntegral $ line - 1) (fromIntegral $ col - 1) + +positionToSourcePos :: Types.Position -> AST.SourcePos +positionToSourcePos (Types.Position line col) = + AST.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 + +filePathToNormalizedUri :: FilePath -> Types.NormalizedUri +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 + +declsAtLine :: Int -> [P.Declaration] -> [P.Declaration] +declsAtLine l = go . sortBy (comparing declStartLine) + where + go (d : ds) | declStartLine d <= l && declEndLine d >= l = d : go ds + go (d : 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 _ = [] + + unsureEndLine = \case + P.ValueDeclaration {} -> True + P.ExternDeclaration {} -> True + P.TypeClassDeclaration {} -> True + 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 + +declEndLine :: P.Declaration -> Int +declEndLine = P.sourcePosLine . AST.spanEnd . P.declSourceSpan + +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) + +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.hs b/src/Language/PureScript/Make.hs index 5228dc86e6..eb87275f62 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,109 +1,116 @@ module Language.PureScript.Make - ( - -- * Make API - rebuildModule - , rebuildModule' - , make - , inferForeignModules - , module Monad - , module Actions - ) where - -import Prelude + ( -- * Make API + desugarAndTypeCheck, + rebuildModule, + rebuildModule', + rebuildModuleWithProvidedEnv, + 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.Strict (runWriterT) -import Data.Function (on) +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.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.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) -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) +import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule) +import Language.PureScript.TypeChecker.Monad qualified as P import System.Directory (doesFileExist) import System.FilePath (replaceExtension) +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 -rebuildModule' - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeActions m - -> Env - -> [ExternsFile] - -> Module - -> m ExternsFile +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 +rebuildModuleWithIndex :: + forall m. + (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + MakeActions m -> + Env -> + [ExternsFile] -> + Module -> + Maybe (Int, Int) -> + m ExternsFile +rebuildModuleWithIndex act exEnv externs m moduleIndex = do let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs - withPrim = importPrim m + 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 -> + Environment -> + [ExternsFile] -> + Module -> + Maybe (Int, Int) -> + m ExternsFile +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, 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) + ((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 -- since pattern guards introduces cases which the exhaustiveness checker @@ -113,12 +120,12 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ 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 @@ -126,24 +133,57 @@ 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 - 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 + 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 env checkSt mod' renamed docs exts return exts +desugarAndTypeCheck :: + (MonadError MultipleErrors m, MonadWriter MultipleErrors m, Foldable t) => + (Environment -> CheckState) -> + t (Module -> m b) -> + ModuleName -> + [ExternsFile] -> + Module -> + Env -> + Environment -> + m ((Module, CheckState), Integer) +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) $ initialCheckState 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, checkSt) + -- | 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 @@ -165,28 +205,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 @@ -204,93 +245,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 - 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 diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index f138327c8d..5e53f84228 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,65 +28,68 @@ 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(..)) +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 Prelude +import Language.PureScript.TypeChecker (CheckState) -- | 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. -- @@ -97,38 +99,40 @@ 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 :: 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 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. + 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 @@ -136,194 +140,207 @@ 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 :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make () - codegen 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 + + -- 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 + 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) @@ -333,24 +350,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 @@ -365,73 +380,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 @@ -446,10 +462,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 new file mode 100644 index 0000000000..938adb7657 --- /dev/null +++ b/src/Language/PureScript/Make/Index.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE BlockArguments #-} + +module Language.PureScript.Make.Index + ( initDb, + addAllIndexing, + addAstModuleIndexing, + addExternIndexing, + indexAstModuleFromExtern, + indexAstDeclFromExternDecl, + dropTables, + indexExtern, + getExportedNames, + ) +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 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, printTypeClassKind) +import Language.PureScript.Lsp.ServerConfig (ServerConfig) +import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName) +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 + +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 + } + +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 + (SQL.Query "INSERT OR REPLACE INTO ast_modules (module_name, path) VALUES (:module_name, :path)") + [ ":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] + 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 + 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' + + 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 + + for_ nameMb \name -> do + let exported = Set.member name exportedNames + nameType = fromMaybe (lspNameType name) $ declNameType decl + printedName = printName name + + SQL.executeNamed + conn + ( SQL.Query + "INSERT INTO ast_declarations \ + \ (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, + ":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 + ] + 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 + + SQL.executeNamed + conn + ( SQL.Query + "INSERT INTO ast_declarations \ + \ (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" := ctrPrintedType, + ":name_type" := DctorNameType, + ":ctr_type" := printedName, + ":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) + + 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 + +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) + _ -> Nothing + +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 :: (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 + _ -> efDeclSourceSpan externDecl + start = P.spanStart ss + end = P.spanEnd ss + printedType :: Text + printedType = printEfDeclType externDecl + + 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 + isTypeOfName _ _ = False + + moduleName' = efModuleName extern + + moduleDecls = P.efDeclarations extern + + 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 + +getExportedNames :: ExternsFile -> Set P.Name +getExportedNames extern = + Set.fromList $ + P.efExports extern >>= \case + 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 = + 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 + 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, hash, module_name) VALUES (:path, :ef_version, :value, :hash, :module_name)") + [ ":path" := path, + ":ef_version" := P.efVersion 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 + 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 + ] + +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 "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, 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, 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 + +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)" + 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)" + +dropTables :: Connection -> IO () +dropTables conn = do + SQL.execute_ conn "DROP TABLE IF EXISTS ast_declarations" + 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" 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 diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4d5a5ec604..ba430cc93e 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -5,6 +5,8 @@ module Language.PureScript.Pretty.Values ( prettyPrintValue , prettyPrintBinder , prettyPrintBinderAtom + , prettyPrintDeclaration + , prettyPrintLiteralValue ) where import Prelude hiding ((<>)) diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 4d713d5418..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, module S) where +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 @@ -73,3 +72,41 @@ desugar externs = >=> deriveInstances >=> desugarTypeClasses externs >=> createBindingGroupsModule + +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 + >=> desugarAdoModule + >=> 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/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 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. 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) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f012..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) @@ -257,7 +259,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 +269,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 +286,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) . @@ -309,12 +313,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 +332,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 +341,9 @@ typeCheckAll moduleName = traverse go typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case [(_, (val'', ty))] -> do 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" @@ -351,9 +359,11 @@ 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) + endIdeSubstitutions return . BindingGroupDeclaration $ NEL.fromList vals'' go d@(ExternDataDeclaration (ss, _) name kind) = do warnAndRethrow (addHint (ErrorInForeignImportData name) . addHint (positionedError ss)) $ do @@ -385,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) = @@ -407,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 () @@ -588,6 +609,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 new file mode 100644 index 0000000000..dced963d30 --- /dev/null +++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs @@ -0,0 +1,341 @@ +{-# 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 + ( IdeArtifacts, + IdeArtifact (..), + IdeArtifactValue (..), + artifactsAtSpan, + getArtifactsAtPosition, + emptyIdeArtifacts, + insertIaExpr, + insertIaBinder, + insertIaDecl, + insertIaType, + insertIaIdent, + insertTypeSynonym, + insertModule, + insertImport, + useSynonymns, + debugSynonyms, + smallestArtifact, + debugIdeArtifacts, + insertIaTypeName, + insertIaClassName, + moduleNameFromQual, + debugIdeArtifact, + substituteArtifactTypes, + endSubstitutions, + artifactInterest, + bindersAtPos, + ) +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 +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 +import Language.PureScript.Types qualified as P +import Protolude +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 + +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, Eq, Ord, Generic, NFData) + +data IdeArtifactValue + = IaExpr Text (Maybe Text) (Maybe LspNameType) + | IaDecl (Maybe Text) (Maybe LspNameType) + | IaBinder P.Binder + | IaIdent Text + | IaType P.SourceType + | IaTypeName (P.ProperName 'P.TypeName) + | IaClassName (P.ProperName 'P.ClassName) + | IaModule P.ModuleName + | IaImport P.ModuleName P.DeclarationRef + 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 + +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 _ _) = + 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 + a@(IdeArtifact {iaValue = IaBinder b}) -> Just (a, 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 + 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 + & maybe Set.empty (Set.filter ((==) span . iaSpan)) + +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) + ) + +getArtifactsAtPosition :: P.SourcePos -> IdeArtifacts -> [IdeArtifact] +getArtifactsAtPosition pos (IdeArtifacts m _ _) = + Map.lookup (P.sourcePosLine pos) m + & maybe [] Set.toList + & 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 + 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 + Just span + | not (generatedExpr expr) -> + insertAtLines span (IaExpr (fromMaybe "_" exprIdent) exprIdent (exprNameType expr)) ty mName defSpan + where + defSpan = + Left <$> (posFromQual =<< exprIdentQual expr) + + mName = exprIdentQual expr >>= moduleNameFromQual + + exprIdent :: Maybe Text + 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 :: 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 + +ellipsis :: Int -> Text -> Text +ellipsis n t = if T.length t > n then T.take (n - 3) t <> "..." else t + +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 + +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 + +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 + +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) + +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 + +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@(P.SourceSpan _ start _) value ty mName defSpan ia@(IdeArtifacts m u 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 + where + 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] + +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.TypedValue _ e _ -> generatedExpr e + P.PositionedValue _ _ e -> generatedExpr e + P.Unused {} -> True + P.DeferredDictionary {} -> True + P.TypeClassDictionary {} -> True + P.DerivedInstancePlaceholder {} -> True + _ -> 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 + P.NamedBinder ss ident _ -> (ss == P.nullSourceSpan) || generatedIdent ident + _ -> False + +generatedIdent :: P.Ident -> Bool +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) + <> ":" + <> 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 t _ _ -> "Expr: " <> t + IaDecl d _ -> "Decl: " <> fromMaybe "_" 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 + 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 \ No newline at end of file diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5be87c0057..ed88dc1975 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 @@ -51,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 @@ -160,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 @@ -170,8 +175,13 @@ inferKind = \tyToInfer -> throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v Just (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) pure (ty, kind $> ann) ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do env <- getEnv @@ -182,7 +192,8 @@ inferKind = \tyToInfer -> checkConstraint con ty' <- checkIsSaturatedType ty con'' <- applyConstraint con' - pure (ConstrainedType ann' con'' ty', E.kindType $> ann') + let kind = E.kindType $> ann' + pure (ConstrainedType ann' con'' ty', kind) ty@(TypeLevelString ann _) -> pure (ty, E.kindSymbol $> ann) ty@(TypeLevelInt ann _) -> @@ -613,6 +624,7 @@ kindOfWithScopedVars ty = do let binders = fst . fromJust $ completeBinderList ty' pure ((snd <$> binders, ty'), kind) + type DataDeclarationArgs = ( SourceAnn , ProperName 'TypeName @@ -859,8 +871,10 @@ 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 + let (_, kinds', args') = unapplyTypes applied pure $ Constraint ann clsName kinds' args' dat type InstanceDeclarationArgs = diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b6382e6707..42a3b1353c 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -21,13 +21,17 @@ 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, insertModule, insertImport) +import Protolude (whenM, isJust) +import Language.PureScript.AST.Binders (Binder) +import Language.PureScript.AST.Declarations (Declaration, Expr (..)) newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown) deriving (Eq, Show) @@ -105,11 +109,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 :: 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 +emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty Nothing emptyIdeArtifacts -- | Unification variables type Unknown = Int @@ -374,6 +385,72 @@ 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 = 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 + +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 + +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) } + +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 + +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..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,8 +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 + + diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3f758805c6..f59ba189ad 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE BlockArguments #-} -- | -- This module implements the type checker -- module Language.PureScript.TypeChecker.Types ( BindingGroupType(..) + , TypedValue'(..) , typesOf , checkTypeKind ) where @@ -12,7 +14,7 @@ module Language.PureScript.TypeChecker.Types infer Synthesize a type for a value - +f check Check a value has a given type @@ -24,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, (<=<)) @@ -169,32 +171,36 @@ 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 -- Check skolem variables did not escape their scope skolemEscapeCheck val' + addIdeIdent ss ident 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 -- 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 - - return (map fst inferred) + substituteIdeTypes $ removeRedundantConstraints . substituteType (checkSubstitution finalState) + + return $ map fst inferred where - replaceTypes + 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 @@ -224,6 +230,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. -- @@ -359,11 +379,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' @@ -451,7 +483,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" @@ -530,7 +562,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 @@ -591,6 +623,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 @@ -599,6 +632,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 @@ -612,21 +646,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 @@ -645,7 +692,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 @@ -659,29 +706,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 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' _ 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. @@ -756,8 +803,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 -- @@ -818,6 +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 argTy return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty | otherwise = internalError "Binder was not desugared" check' (App f arg) ret = do @@ -872,7 +925,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 @@ -902,10 +955,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 @@ -976,7 +1029,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' 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) diff --git a/stack.yaml b/stack.yaml index 88b27b1a46..390c4e0aa5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -27,6 +27,12 @@ extra-deps: - hspec-2.10.9 - 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 +- ghc-datasize-0.2.7@sha256:3397b0306f179836a0f5912e9888b5a0d2c40c2a6bba12965e82144a22de15a3,1132 nix: packages: - zlib 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..ba4b5f8238 --- /dev/null +++ b/tests/TestLsp.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +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, 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, 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) +import System.Timeout (timeout) +import Test.Hspec (Spec, describe, it, shouldBe) + +-- runPursLspSession :: + +spec :: Spec +spec = + it "should get definitions" do + runSessionWithConfig sessionConfig ("purs lsp server " <> globs) fullLatestClientCaps "tests/purs/lsp" do + void rebuildReq + doc <- openDoc "Main.purs" "purs" + defsAtLine4 <- getDefinitions doc (Position 4 1) + let expRange = Range (Position 4 0) (Position 4 24) + liftIO do + 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" + print rsp + case rsp ^. L.result of + Right x -> pure x + Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err + +sessionConfig :: SessionConfig +sessionConfig = SessionConfig 30 True True True clientConfig True True True Nothing + where + clientConfig :: KeyMap A.Value + clientConfig = KeyMap.singleton "purescript-lsp" (A.toJSON pursLspConfig) + + pursLspConfig :: Map Text.Text A.Value + pursLspConfig = Map.empty + +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 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!" +