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/.gitignore b/.gitignore index 0454beffcb..4a35fe051b 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,5 @@ TAGS *.ps *.svg tests/purs/make/ + +.codegpt \ No newline at end of file diff --git a/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 f5a501af75..359240785b 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -28,7 +28,7 @@ import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy.Char8 qualified as BSL8 import GHC.IO.Exception (IOErrorType(..), IOException(..)) import Language.PureScript.Ide (handleCommand) -import Language.PureScript.Ide.Command (Command(..), commandName) +import Language.PureScript.Ide.Command (commandName, Command(..)) import Language.PureScript.Ide.Util (decodeT, displayTimeSpec, encodeT, logPerf, runLogger) import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.State (updateCacheTimestamp) @@ -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 @@ -199,14 +202,22 @@ startServer port env = Network.withSocketsDo $ do logPerf message $ do result <- runExceptT $ do updateCacheTimestamp >>= \case - Nothing -> pure () + Nothing -> + handleCommand cmd' Just (before, after) -> do -- If the cache db file was changed outside of the IDE -- we trigger a reset before processing the command $(logInfo) ("cachedb was changed from: " <> show before <> ", to: " <> show after) - unless (isLoadAll cmd') $ - void (handleCommand Reset *> handleCommand (LoadSync [])) - handleCommand cmd' + let doReload = handleCommand Reset *> handleCommand (LoadSync []) + case cmd' of + -- handleCommand on Load [] already resets the state. + Load [] -> handleCommand cmd' + -- Focus needs to fire before doReload, because we + -- want to set the focused modules first before + -- loading everything with LoadSync []. + Focus _ -> handleCommand cmd' <* doReload + -- Otherwise, just doReload and then handle. + _ -> doReload *> handleCommand cmd' liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of Right r -> Aeson.encode r Left err -> Aeson.encode err @@ -219,11 +230,6 @@ startServer port env = Network.withSocketsDo $ do hFlush stdout liftIO $ catchGoneHandle (hClose h) -isLoadAll :: Command -> Bool -isLoadAll = \case - Load [] -> True - _ -> False - catchGoneHandle :: IO () -> IO () catchGoneHandle = handle (\e -> case e of 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..c898dc3966 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,45 @@ 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.BuildPlanDB Language.PureScript.Make.Cache + Language.PureScript.Make.Index + Language.PureScript.Make.Index.Select Language.PureScript.Make.Monad Language.PureScript.ModuleDependencies Language.PureScript.Names @@ -378,6 +422,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 +467,7 @@ executable purs Command.Graph Command.Hierarchy Command.Ide + Command.Lsp Command.Publish Command.REPL SharedCLI @@ -442,6 +488,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 +509,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 +519,7 @@ test-suite tests TestGraph TestHierarchy TestIde + TestLsp TestMake TestPrimDocs TestPsci diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index dd447a9c39..4e851cdc67 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -13,9 +13,10 @@ import Control.Monad.State (StateT(..)) import Control.Monad.Writer (MonadWriter) import Data.Functor.Identity (Identity(..)) +import Protolude (MonadIO) newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } - deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) + deriving (MonadIO, Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) runSupplyT :: Integer -> SupplyT m a -> m (a, Integer) runSupplyT n = flip runStateT n . unSupplyT diff --git a/src/Language/PureScript/AST/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..9778e0540f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -3,36 +3,40 @@ -- | -- 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 +import Database.SQLite.Simple.ToField (ToField (toField)) +import Database.SQLite.Simple.FromField (FromField (fromField)) -- | A map of locally-bound names in scope. type Context = [(Ident, SourceType)] @@ -90,7 +94,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 +105,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 +116,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 +169,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 @@ -206,6 +210,13 @@ data DeclarationRef | ReExportRef SourceSpan ExportSource DeclarationRef deriving (Show, Generic, NFData, Serialise) + +instance ToField DeclarationRef where + toField = toField . S.serialise + +instance FromField DeclarationRef where + fromField a = S.deserialise <$> fromField a + instance Eq DeclarationRef where (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' (TypeOpRef _ name) == (TypeOpRef _ name') = name == name' @@ -306,7 +317,13 @@ 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) + +instance ToField ImportDeclarationType where + toField = toField . S.serialise + +instance FromField ImportDeclarationType where + fromField a = S.deserialise <$> fromField a isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True @@ -323,7 +340,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 +351,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 +373,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 +387,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 +462,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 +509,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 +519,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 +535,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 +672,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 +809,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 +881,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 +895,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 +917,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 +944,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..1a0e3611c7 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, Foldable, Traversable, Generic, S.Serialise, NFData) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index eb217a2444..7c8f0b5ea5 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -12,6 +12,7 @@ import Data.Aeson ((.=)) import Data.Aeson qualified as A import Language.PureScript.Crash (internalError) +import Database.SQLite.Simple.FromField (FromField (fromField)) -- | -- A precedence level for an infix operator @@ -27,6 +28,9 @@ data Associativity = Infixl | Infixr | Infix instance NFData Associativity instance Serialise Associativity +instance FromField Associativity where + fromField = fmap readAssoc . fromField + showAssoc :: Associativity -> String showAssoc Infixl = "infixl" showAssoc Infixr = "infixr" diff --git a/src/Language/PureScript/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..594bd5bad2 --- /dev/null +++ b/src/Language/PureScript/Compile.hs @@ -0,0 +1,25 @@ +module Language.PureScript.Compile where + +import Control.Monad.IO.Class (liftIO) +import Data.Map qualified as M +import Database.SQLite.Simple (Connection) +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake) +import Language.PureScript.Make.Index (addAllIndexing, addDbConnection) +import System.Directory (createDirectoryIfMissing) +import Prelude +import Language.PureScript.Names (ModuleName) + +compile :: P.Options -> [(FilePath, P.Text)] -> Connection -> FilePath -> Bool -> IO (Either P.MultipleErrors [ModuleName], 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 = + addDbConnection conn $ + addAllIndexing conn $ + buildMakeActions outputDir filePathMap foreigns usePrefx + P.makeDb makeActions (map snd ms) \ No newline at end of file diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 4b64b97c49..e4e6ef60ea 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} -- | -- The core functional representation for binders -- @@ -7,6 +8,8 @@ import Prelude import Language.PureScript.AST.Literals (Literal) import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) -- | -- Data type for binders @@ -31,7 +34,7 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Eq, Ord, Show, Functor) + | NamedBinder a Ident (Binder a) deriving (Eq, Ord, Show, Functor, Generic, NFData) extractBinderAnn :: Binder a -> a diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 34bf08f1f3..303aad7c86 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE BlockArguments #-} module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where import Prelude -import Protolude (ordNub, orEmpty) +import Protolude (ordNub, orEmpty, (<&>), join, for, when) -import Control.Arrow (second) import Data.Function (on) import Data.Maybe (mapMaybe) @@ -21,27 +21,40 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupValue) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName (ModuleName), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A import Language.PureScript.Constants.Prim qualified as C +import Language.PureScript.Make.Index.Select (GetEnv (getDataConstructor, logGetEnv)) +import Control.DeepSeq (force) +import Data.Text (Text) -- | Desugars a module from AST to CoreFn representation. -moduleToCoreFn :: Environment -> A.Module -> Module Ann +moduleToCoreFn :: forall m. (Monad m, GetEnv m) => Environment -> A.Module -> m (Module Ann) moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = - let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) - imports' = dedupeImports imports - exps' = ordNub $ concatMap exportToCoreFn exps - reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) - externs = ordNub $ mapMaybe externToCoreFn decls - decls' = concatMap declToCoreFn decls - in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' +moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = do + log' "moduleToCoreFn start" + let !imports = force $ mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) + log' "moduleToCoreFn imports" + let !imports' = force $ dedupeImports imports + log' "moduleToCoreFn dedupeImports" + let !exps' = force $ ordNub $ concatMap exportToCoreFn exps + log' "moduleToCoreFn exportToCoreFn" + let !reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) + let !externs = ordNub $ mapMaybe externToCoreFn decls + log' "moduleToCoreFn externToCoreFn" + !decls' <- force . join <$> traverse declToCoreFn decls + log' "moduleToCoreFn declToCoreFn" + pure $ Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' where + log' :: Text -> m () + log' t = do + when (mn == ModuleName "OaHasuraFetch.Client") do + logGetEnv t -- Creates a map from a module name to the re-export references defined in -- that module. reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] @@ -62,8 +75,8 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = ssA ss = (ss, [], Nothing) -- Desugars member declarations from AST to CoreFn representation. - declToCoreFn :: A.Declaration -> [Bind Ann] - declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = + declToCoreFn :: A.Declaration -> m [Bind Ann] + declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = pure [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] where @@ -71,27 +84,37 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) = - flip fmap ctors $ \ctorDecl -> + for ctors $ \ctorDecl -> do let ctor = A.dataCtorName ctorDecl - (_, _, _, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) - in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields + (_, _, _, fields) <- lookupConstructor' (Qualified (ByModuleName mn) ctor) + return $ NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = - concatMap declToCoreFn ds - declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = - [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn (A.BindingGroupDeclaration ds) = - [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] - declToCoreFn _ = [] + concat <$> traverse declToCoreFn ds + declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = do + cfn <- exprToCoreFn ss com Nothing e + pure [NonRec (ssA ss) name cfn] + declToCoreFn (A.BindingGroupDeclaration ds) = do + exprs <- traverse (\(((ss, com), name), _, e) -> ((ssA ss, name),) <$> exprToCoreFn ss com Nothing e) ds + pure [Rec . NEL.toList $ exprs] + + declToCoreFn _ = return [] -- Desugars expressions from AST to CoreFn representation. - exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann - exprToCoreFn _ com _ (A.Literal ss lit) = - Literal (ss, com, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) + exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> m (Expr Ann) + exprToCoreFn _ com _ (A.Literal ss lit) = do + cfs <- traverse (exprToCoreFn ss com Nothing) lit + pure $ Literal (ss, com, Nothing) cfs + exprToCoreFn ss com _ (A.Accessor name v) = - Accessor (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v) - exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = - ObjectUpdate (ss, com, Nothing) (exprToCoreFn ss [] Nothing obj) (ty >>= unchangedRecordFields (fmap fst vs)) $ fmap (second (exprToCoreFn ss [] Nothing)) vs + Accessor (ss, com, Nothing) name <$> exprToCoreFn ss [] Nothing v + exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = do + cfn <- exprToCoreFn ss [] Nothing obj + cfns <- traverse (\(ps, expr) -> (ps,) <$> exprToCoreFn ss [] Nothing expr) vs + + -- ObjectUpdate (ss, com, Nothing) (exprToCoreFn ss [] Nothing obj) (ty >>= unchangedRecordFields (fmap fst vs)) $ fmap (second (exprToCoreFn ss [] Nothing)) vs + + pure $ ObjectUpdate (ss, com, Nothing) cfn (ty >>= unchangedRecordFields (fmap fst vs)) cfns where -- Return the unchanged labels of a closed record, or Nothing for other types or open records. unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString] @@ -104,14 +127,14 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = collect _ = Nothing unchangedRecordFields _ _ = Nothing exprToCoreFn ss com _ (A.Abs (A.VarBinder _ name) v) = - Abs (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v) + Abs (ss, com, Nothing) name <$> exprToCoreFn ss [] Nothing v exprToCoreFn _ _ _ (A.Abs _ _) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" - exprToCoreFn ss com _ (A.App v1 v2) = - App (ss, com, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2' + exprToCoreFn ss com _ (A.App v1 v2) = do + v1' <- exprToCoreFn ss [] Nothing v1 + v2' <- exprToCoreFn ss [] Nothing v2 + pure $ App (ss, com, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2' where - v1' = exprToCoreFn ss [] Nothing v1 - v2' = exprToCoreFn ss [] Nothing v2 isDictCtor = \case A.Constructor _ (Qualified _ name) -> isDictTypeName name _ -> False @@ -122,57 +145,67 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = A.Unused{} -> True _ -> False exprToCoreFn ss com _ (A.Unused _) = - Var (ss, com, Nothing) C.I_undefined + return $ Var (ss, com, Nothing) C.I_undefined exprToCoreFn _ com _ (A.Var ss ident) = - Var (ss, com, getValueMeta ident) ident - exprToCoreFn ss com _ (A.IfThenElse v1 v2 v3) = - Case (ss, com, Nothing) [exprToCoreFn ss [] Nothing v1] + return $ Var (ss, com, getValueMeta ident) ident + exprToCoreFn ss com _ (A.IfThenElse v1 v2 v3) = do + if' <- exprToCoreFn ss [] Nothing v1 + then' <- exprToCoreFn ss [] Nothing v2 + else' <- exprToCoreFn ss [] Nothing v3 + return $ Case (ss, com, Nothing) [if'] [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] - (Right $ exprToCoreFn ss [] Nothing v2) + (Right then') , CaseAlternative [NullBinder (ssAnn ss)] - (Right $ exprToCoreFn ss [] Nothing v3) ] - exprToCoreFn _ com _ (A.Constructor ss name) = - Var (ss, com, Just $ getConstructorMeta name) $ fmap properToIdent name + (Right else')] + exprToCoreFn _ com _ (A.Constructor ss name) = do + meta <- getConstructorMeta name + return $ Var (ss, com, Just meta) $ fmap properToIdent name exprToCoreFn ss com _ (A.Case vs alts) = - Case (ss, com, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) + Case (ss, com, Nothing) <$> traverse (exprToCoreFn ss [] Nothing) vs <*> traverse (altToCoreFn ss) alts exprToCoreFn ss com _ (A.TypedValue _ v ty) = exprToCoreFn ss com (Just ty) v - exprToCoreFn ss com _ (A.Let w ds v) = - Let (ss, com, getLetMeta w) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) + exprToCoreFn ss com _ (A.Let w ds v) = do + ds' <- concat <$> traverse declToCoreFn ds + Let (ss, com, getLetMeta w) ds' <$> exprToCoreFn ss [] Nothing v exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = exprToCoreFn ss (com ++ com1) ty v exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e -- Desugars case alternatives from AST to CoreFn representation. - altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann - altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) + altToCoreFn :: SourceSpan -> A.CaseAlternative -> m (CaseAlternative Ann) + altToCoreFn ss (A.CaseAlternative bs vs) = do + bs' <- traverse (binderToCoreFn ss []) bs + res <- go vs + return $ CaseAlternative bs' res where - go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann) + go :: [A.GuardedExpr] -> m (Either [(Guard Ann, Expr Ann)] (Expr Ann)) go [A.MkUnguarded e] - = Right (exprToCoreFn ss [] Nothing e) + = Right <$> exprToCoreFn ss [] Nothing e go gs - = Left [ (exprToCoreFn ss [] Nothing cond, exprToCoreFn ss [] Nothing e) - | A.GuardedExpr g e <- gs - , let cond = guardToExpr g - ] + = Left <$> for gs \(A.GuardedExpr g e)-> do + g' <- exprToCoreFn ss [] Nothing (guardToExpr g) + e' <- exprToCoreFn ss [] Nothing e + return (g', e') + guardToExpr :: [A.Guard] -> A.Expr guardToExpr [A.ConditionGuard cond] = cond guardToExpr _ = internalError "Guard not correctly desugared" -- Desugars case binders from AST to CoreFn representation. - binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann - binderToCoreFn _ com (A.LiteralBinder ss lit) = - LiteralBinder (ss, com, Nothing) (fmap (binderToCoreFn ss com) lit) + binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> m (Binder Ann) + binderToCoreFn _ com (A.LiteralBinder ss lit) = + LiteralBinder (ss, com, Nothing) <$> traverse (binderToCoreFn ss com) lit binderToCoreFn ss com A.NullBinder = - NullBinder (ss, com, Nothing) + return $ NullBinder (ss, com, Nothing) binderToCoreFn _ com (A.VarBinder ss name) = - VarBinder (ss, com, Nothing) name - binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = - let (_, tctor, _, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) + return $ VarBinder (ss, com, Nothing) name + binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = do + (_, tctor, _, _) <- lookupConstructor' dctor + meta <- getConstructorMeta dctor + ConstructorBinder (ss, com, Just meta) (Qualified mn' tctor) dctor <$> traverse (binderToCoreFn ss []) bs binderToCoreFn _ com (A.NamedBinder ss name b) = - NamedBinder (ss, com, Nothing) name (binderToCoreFn ss [] b) + NamedBinder (ss, com, Nothing) name <$> binderToCoreFn ss [] b binderToCoreFn _ com (A.PositionedBinder ss com1 b) = binderToCoreFn ss (com ++ com1) b binderToCoreFn ss com (A.TypedBinder _ b) = @@ -197,9 +230,9 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = _ -> Nothing -- Gets metadata for data constructors. - getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta + getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> m Meta getConstructorMeta ctor = - case lookupConstructor env ctor of + lookupConstructor' ctor <&> \case (Newtype, _, _, _) -> IsNewtype dc@(Data, _, _, fields) -> let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType @@ -217,6 +250,16 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) typeConstructor _ = internalError "Invalid argument to typeConstructor" + lookupConstructor' :: Qualified (ProperName 'ConstructorName) -> m (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) + lookupConstructor' name = case M.lookup name (dataConstructors env) of + Nothing -> do + ctrMb <- getDataConstructor name + case ctrMb of + Nothing -> internalError $ "Constructor " ++ show name ++ " not found in environment" + Just ctr -> return ctr + Just ctr -> return ctr + + -- | Find module names from qualified references to values. This is used to -- ensure instances are imported from any module that is referenced by the -- current module, not just from those that are imported explicitly (#667). diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 20ab333011..c34084641a 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} -- | -- The core functional representation -- @@ -11,6 +12,8 @@ import Language.PureScript.AST.Literals (Literal) import Language.PureScript.CoreFn.Binders (Binder) import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) import Language.PureScript.PSString (PSString) +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) -- | -- Data type for expressions and terms @@ -52,7 +55,7 @@ data Expr a -- A let binding -- | Let a [Bind a] (Expr a) - deriving (Eq, Ord, Show, Functor) + deriving (Eq, Ord, Show, Functor, Generic, NFData) -- | -- A let or module binding. @@ -65,7 +68,7 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor) + | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor, Generic, NFData) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -84,7 +87,7 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Generic, NFData) instance Functor CaseAlternative where diff --git a/src/Language/PureScript/CoreFn/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/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 0baddca29b..2ec35472b8 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} -- | -- Metadata annotations for core functional representation -- @@ -6,6 +7,8 @@ module Language.PureScript.CoreFn.Meta where import Prelude import Language.PureScript.Names (Ident) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) -- | -- Metadata annotations @@ -35,7 +38,7 @@ data Meta -- The contained function application was synthesized by the compiler -- | IsSyntheticApp - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) -- | -- Data constructor metadata @@ -48,4 +51,4 @@ data ConstructorType -- | -- The constructor is for a type with multiple constructors -- - | SumType deriving (Show, Eq, Ord) + | SumType deriving (Show, Eq, Ord, Generic, NFData) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 09f5189c4a..fcf2dd200a 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.CoreFn.Module where import Prelude @@ -8,6 +9,8 @@ import Language.PureScript.AST.SourcePos (SourceSpan) import Language.PureScript.Comments (Comment) import Language.PureScript.CoreFn.Expr (Bind) import Language.PureScript.Names (Ident, ModuleName) +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) -- | -- The CoreFn module representation @@ -22,4 +25,4 @@ data Module a = Module , moduleReExports :: Map ModuleName [Ident] , moduleForeign :: [Ident] , moduleDecls :: [Bind a] - } deriving (Functor, Show) + } deriving (Functor, Show, Generic, NFData) diff --git a/src/Language/PureScript/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/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index a7dc1758c7..747db9281f 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -3,6 +3,7 @@ module Language.PureScript.Docs.Convert ( convertModule + , convertModuleWithoutExterns ) where import Protolude hiding (check) @@ -29,6 +30,8 @@ import Language.PureScript.Sugar qualified as P import Language.PureScript.Types qualified as P import Language.PureScript.Constants.Prim qualified as Prim import Language.PureScript.Sugar (RebracketCaller(CalledByDocs)) +import Language.PureScript.Externs (ExternsFixity) +import Language.PureScript.Sugar.Operators (fromExternFixities) -- | -- Convert a single module to a Docs.Module, making use of a pre-existing @@ -45,6 +48,17 @@ convertModule :: convertModule externs env checkEnv = fmap (insertValueTypesAndAdjustKinds checkEnv . convertSingleModule) . partiallyDesugar externs env + +convertModuleWithoutExterns :: + MonadError P.MultipleErrors m => + [(P.ModuleName, [ExternsFixity])] -> + [(P.ModuleName, [P.ExternsTypeFixity])] -> + P.Env -> + P.Environment -> + P.Module -> + m Module +convertModuleWithoutExterns fixities typeFixities env checkEnv = + fmap (insertValueTypesAndAdjustKinds checkEnv . convertSingleModule) . partiallyDesugarWithouExterns fixities typeFixities env -- | -- Convert FFI declarations into `DataDeclaration` so that the declaration's -- roles (if any) can annotate the generated type parameter names. @@ -271,3 +285,28 @@ partiallyDesugar externs env = evalSupplyT 0 . desugar' isInstanceDecl P.TypeInstanceDeclaration {} = True isInstanceDecl _ = False + +-- | +-- Partially desugar modules so that they are suitable for extracting +-- documentation information from. This version does not use externs files +-- +partiallyDesugarWithouExterns :: + (MonadError P.MultipleErrors m) => + [(P.ModuleName, [ExternsFixity])] -> + [(P.ModuleName, [P.ExternsTypeFixity])] -> + P.Env -> + P.Module -> + m P.Module +partiallyDesugarWithouExterns fixities typeFixities env = evalSupplyT 0 . desugar' + where + desugar' = + P.desugarDoModule + >=> P.desugarAdoModule + >=> P.desugarLetPatternModule + >>> P.desugarCasesModule + >=> P.desugarTypeDeclarationsModule + >=> fmap fst . runWriterT . flip evalStateT (env, mempty) . P.desugarImports + >=> P.rebracketFiltered' CalledByDocs isInstanceDecl (fromExternFixities fixities typeFixities) + + isInstanceDecl P.TypeInstanceDeclaration {} = True + isInstanceDecl _ = False diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e1f857031f..1943bdb179 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.Environment where import Prelude import GHC.Generics (Generic) import Control.DeepSeq (NFData) -import Control.Monad (unless) +import Control.Monad (unless, (>=>)) import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) import Data.Aeson qualified as A @@ -21,12 +22,15 @@ import Data.Text qualified as T import Data.List.NonEmpty qualified as NEL import Language.PureScript.AST.SourcePos (nullSourceAnn) -import Language.PureScript.Crash (internalError) +import Language.PureScript.Crash (internalError, HasCallStack) import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName) import Language.PureScript.Roles (Role(..)) import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables) import Language.PureScript.Constants.Prim qualified as C +import Codec.Serialise qualified as S +import Database.SQLite.Simple.ToField (ToField (toField)) +import Database.SQLite.Simple.FromField (FromField (fromField), FieldParser) -- | The @Environment@ defines all values and types which are currently in scope: data Environment = Environment @@ -45,10 +49,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, Eq, Generic, S.Serialise) instance NFData Environment + -- | Information about a type class data TypeClassData = TypeClassData { typeClassArguments :: [(Text, Maybe SourceType)] @@ -71,10 +76,19 @@ 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, Eq, S.Serialise) instance NFData TypeClassData +instance ToField TypeClassData where + toField = toField . S.serialise + +instance FromField TypeClassData where + fromField = fmap S.deserialise . fromField + +-- instance ToRow TypeClassData where +-- toRow = _ + -- | A functional dependency indicates a relationship between two sets of -- type arguments in a class declaration. data FunctionalDependency = FunctionalDependency @@ -82,7 +96,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 @@ -238,6 +252,14 @@ data NameVisibility instance NFData NameVisibility instance Serialise NameVisibility +instance ToField NameVisibility where + toField = toField . show +instance FromField NameVisibility where + fromField = (fromField :: FieldParser Text) >=> \case + "Undefined" -> pure Undefined + "Defined" -> pure Defined + other -> fail $ "invalid NameVisibility: '" ++ T.unpack other ++ "'" + -- | A flag for whether a name is for an private or public value - only public values will be -- included in a generated externs file. data NameKind @@ -248,11 +270,21 @@ 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 +instance ToField NameKind where + toField = toField . show + +instance FromField NameKind where + fromField = (fromField :: FieldParser Text) >=> \case + "Private" -> pure Private + "Public" -> pure Public + "External" -> pure External + other -> fail $ "invalid NameKind: '" ++ T.unpack other ++ "'" + -- | The kinds of a type data TypeKind = DataType DataDeclType [(Text, Maybe SourceType, Role)] [(ProperName 'ConstructorName, [SourceType])] @@ -270,6 +302,12 @@ data TypeKind instance NFData TypeKind instance Serialise TypeKind +instance ToField TypeKind where + toField = toField . S.serialise + +instance FromField TypeKind where + fromField = fmap S.deserialise . fromField + -- | The type ('data' or 'newtype') of a data type declaration data DataDeclType = Data @@ -280,6 +318,14 @@ data DataDeclType instance NFData DataDeclType instance Serialise DataDeclType +instance ToField DataDeclType where + toField = toField . showDataDeclType + +instance FromField DataDeclType where + fromField = (fromField :: FieldParser Text) >=> \case + "data" -> pure Data + "newtype" -> pure Newtype + other -> fail $ "invalid DataDeclType: '" ++ T.unpack other ++ "'" showDataDeclType :: DataDeclType -> Text showDataDeclType Data = "data" @@ -653,9 +699,9 @@ primTypeErrorClasses = ] -- | Finds information about data constructors from the current environment. -lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) +lookupConstructor :: HasCallStack => Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) lookupConstructor env ctor = - fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env + fromMaybe (internalError $ "Data constructor not found: " <> show ctor) $ ctor `M.lookup` dataConstructors env -- | Finds information about values from the current environment. lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a15c3690c..2b3848959b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -81,7 +81,7 @@ data SimpleErrorMessage | OrphanTypeDeclaration Ident | OrphanKindDeclaration (ProperName 'TypeName) | OrphanRoleDeclaration (ProperName 'TypeName) - | RedefinedIdent Ident + | RedefinedIdent Ident Text | OverlappingNamesInLet Ident | UnknownName (Qualified Name) | UnknownImport ModuleName Name @@ -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 @@ -764,8 +774,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon line $ "The kind declaration for " <> markCode (runProperName nm) <> " should be followed by its definition." renderSimpleErrorMessage (OrphanRoleDeclaration nm) = line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." - renderSimpleErrorMessage (RedefinedIdent name) = - line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" + renderSimpleErrorMessage (RedefinedIdent name text) = + line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" <> text renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.S_bind, C.S_discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)))) = @@ -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..d93a8d676f 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -39,6 +39,8 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType) import Paths_purescript as Paths +import Database.SQLite.Simple (FromRow (fromRow), field) +import Control.Applicative ((<|>)) -- | The data which will be serialized to an externs file data ExternsFile = ExternsFile @@ -76,6 +78,9 @@ data ExternsImport = ExternsImport , eiImportedAs :: Maybe ModuleName } deriving (Show, Generic, NFData) +instance FromRow ExternsImport where + fromRow = ExternsImport <$> field <*> field <*> field + instance Serialise ExternsImport -- | A fixity declaration in an externs file @@ -89,10 +94,20 @@ data ExternsFixity = ExternsFixity , efOperator :: OpName 'ValueOpName -- | The value the operator is an alias for , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) - } deriving (Show, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData) instance Serialise ExternsFixity +instance FromRow ExternsFixity where + fromRow = do + assoc <- field + prec <- field + op <- field + aliasMod <- field + alias <- (Right <$> field) <|> (Left <$> field) + pure $ ExternsFixity assoc prec op (Qualified (ByModuleName aliasMod) alias) + -- ExternsFixity <$> field <*> field <*> field <*> field + -- | A type fixity declaration in an externs file data ExternsTypeFixity = ExternsTypeFixity { @@ -104,10 +119,18 @@ data ExternsTypeFixity = ExternsTypeFixity , efTypeOperator :: OpName 'TypeOpName -- | The value the operator is an alias for , efTypeAlias :: Qualified (ProperName 'TypeName) - } deriving (Show, Generic, NFData) + } deriving (Show, Eq, Ord, Generic, NFData) instance Serialise ExternsTypeFixity +instance FromRow ExternsTypeFixity where + fromRow = do + assoc <- field + prec <- field + op <- field + aliasMod <- field + ExternsTypeFixity assoc prec op . Qualified (ByModuleName aliasMod) <$> field + -- | A type or value declaration appearing in an externs file data ExternsDeclaration = -- | A type declaration @@ -247,7 +270,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 57601c3d45..d0a7df6447 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -8,27 +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 "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN) +import Control.Concurrent.Async.Lifted (mapConcurrently_) 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) @@ -37,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) -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 @@ -77,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 @@ -102,6 +110,8 @@ handleCommand c = case c of rebuildFileAsync file actualFile targets RebuildSync file actualFile targets -> rebuildFileSync file actualFile targets + Focus modulesToFocus -> + setFocusedModules modulesToFocus $> TextResult "Focused modules have been set." Cwd -> TextResult . T.pack <$> liftIO getCurrentDirectory Reset -> @@ -109,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 @@ -149,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) @@ -160,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 @@ -177,50 +194,57 @@ 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 efPaths = - map (\mn -> oDir toS (P.runModuleName mn) P.externsFileName) moduleNames + let -- But we only load the externs files that are in the focusedModules. + efModules = + if Set.null focusedModules + then moduleNames + else Set.toList $ Set.fromList moduleNames `Set.intersection` focusedModules + efPaths = + map (\mn -> oDir toS (P.runModuleName mn) P.externsFileName) efModules efiles <- traverse readExternFile efPaths - traverse_ insertExterns efiles + mapConcurrently_ insertExterns efiles -- We parse all source files, log eventual parse failures and insert the -- successful parses into the state. @@ -228,7 +252,14 @@ loadModules moduleNames = do partitionEithers <$> (parseModulesFromFiles =<< findAllSourceFiles) unless (null failures) $ logWarnN ("Failed to parse: " <> show failures) - traverse_ insertModule allModules + mapConcurrently_ insertModule allModules - pure (TextResult ("Loaded " <> show (length efiles) <> " modules and " - <> show (length allModules) <> " source files.")) + pure + ( TextResult + ( "Loaded " + <> show (length efiles) + <> " modules and " + <> show (length allModules) + <> " source files." + ) + ) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index ae4b6c9d8e..49e99a4474 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -62,6 +62,7 @@ data Command | List { listType :: ListType } | Rebuild FilePath (Maybe FilePath) (Set P.CodegenTarget) | RebuildSync FilePath (Maybe FilePath) (Set P.CodegenTarget) + | Focus [P.ModuleName] | Cwd | Reset | Quit @@ -79,6 +80,7 @@ commandName c = case c of List{} -> "List" Rebuild{} -> "Rebuild" RebuildSync{} -> "RebuildSync" + Focus{} -> "Focus" Cwd{} -> "Cwd" Reset{} -> "Reset" Quit{} -> "Quit" @@ -176,6 +178,13 @@ instance FromJSON Command where <$> params .: "file" <*> params .:? "actualFile" <*> (parseCodegenTargets =<< params .:? "codegen" .!= [ "js" ]) + "focus" -> do + params' <- o .:? "params" + case params' of + Nothing -> + pure (Focus []) + Just params -> + Focus <$> (map P.moduleNameFromString <$> params .:? "modules" .!= []) c -> fail ("Unknown command: " <> show c) where parseCodegenTargets ts = diff --git a/src/Language/PureScript/Ide/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..b3080e1804 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/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index ea49fd6a55..0f993bbad6 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -22,6 +22,8 @@ module Language.PureScript.Ide.SourceFile import Protolude +import Control.Concurrent.Async.Lifted (mapConcurrently) +import Control.Monad.Trans.Control (MonadBaseControl) import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Map qualified as Map import Language.PureScript qualified as P @@ -37,11 +39,11 @@ parseModule path file = Right m -> Right (path, m) parseModulesFromFiles - :: (MonadIO m, MonadError IdeError m) + :: (MonadIO m, MonadBaseControl IO m, MonadError IdeError m) => [FilePath] -> m [Either FilePath (FilePath, P.Module)] parseModulesFromFiles paths = do - files <- traverse ideReadFile paths + files <- mapConcurrently ideReadFile paths pure (inParallel (map (uncurry parseModule) files)) where inParallel :: [Either e (k, a)] -> [Either e (k, a)] diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 32478d7000..59f429ae24 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -8,76 +8,84 @@ -- 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 - -- 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 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 - liftIO (atomically (writeTVar ideVar emptyIdeState)) + durableState <- getDurableState + 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 @@ -89,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' @@ -106,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) @@ -125,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)) @@ -141,10 +154,27 @@ setVolatileStateSTM ref vs = do x {ideVolatileState = vs} pure () +-- | Retrieves the DurableState from the State. +getDurableState :: (Ide m) => m IdeDurableState +getDurableState = do + st <- ideStateVar <$> ask + liftIO (atomically (getDurableStateSTM st)) + +-- | STM version of getDurableState +getDurableStateSTM :: TVar IdeState -> STM IdeDurableState +getDurableStateSTM ref = ideDurableState <$> readTVar ref + +-- | Sets the DurableState inside Ide's state +setDurableStateSTM :: TVar IdeState -> IdeDurableState -> STM () +setDurableStateSTM ref md = do + modifyTVar ref $ \x -> + x {ideDurableState = md} + pure () + -- | Checks if the given ModuleName matches the last rebuild cache and if it -- does returns all loaded definitions + the definitions inside the rebuild -- cache -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 @@ -155,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 @@ -171,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)) @@ -180,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. @@ -204,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) @@ -213,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 @@ -225,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 -> @@ -295,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 @@ -444,6 +500,23 @@ resolveDataConstructorsForModule decls = dtors = decls - & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor)) - & foldr (\(IdeDataConstructor name typeName type') -> - Map.insertWith (<>) typeName [(name, type')]) Map.empty + & 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 + pure focusedModules + +setFocusedModules :: (Ide m) => [P.ModuleName] -> m () +setFocusedModules modulesToFocus = do + st <- ideStateVar <$> ask + liftIO (atomically (setFocusedModulesSTM st modulesToFocus)) + +setFocusedModulesSTM :: TVar IdeState -> [P.ModuleName] -> STM () +setFocusedModulesSTM ref modulesToFocus = do + setDurableStateSTM ref (IdeDurableState (Set.fromList modulesToFocus)) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 41532a3c51..010a7b668d 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -10,14 +10,17 @@ import Protolude hiding (moduleName) import Control.Concurrent.STM (TVar) import Control.Lens (Getting, Traversal', makeLenses) import Control.Monad.Fail (fail) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson (ToJSON, FromJSON, (.=)) import Data.Aeson qualified as Aeson import Data.IORef (IORef) import Data.Time.Clock (UTCTime) import Data.Map.Lazy qualified as M +import Data.Set qualified as S import Language.PureScript qualified as P import Language.PureScript.Errors.JSON qualified as P import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..)) +import Codec.Serialise (Serialise) type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a @@ -31,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 @@ -75,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 @@ -83,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) @@ -131,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 @@ -139,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 @@ -173,15 +178,16 @@ data IdeEnvironment = , ideCacheDbTimestamp :: IORef (Maybe UTCTime) } -type Ide m = (MonadIO m, MonadReader IdeEnvironment m) +type Ide m = (MonadIO m, MonadBaseControl IO m, MonadReader IdeEnvironment m) data IdeState = IdeState { ideFileState :: IdeFileState , ideVolatileState :: IdeVolatileState + , ideDurableState :: IdeDurableState } deriving (Show) emptyIdeState :: IdeState -emptyIdeState = IdeState emptyFileState emptyVolatileState +emptyIdeState = IdeState emptyFileState emptyVolatileState emptyDurableState emptyFileState :: IdeFileState emptyFileState = IdeFileState M.empty M.empty @@ -189,6 +195,8 @@ emptyFileState = IdeFileState M.empty M.empty emptyVolatileState :: IdeVolatileState emptyVolatileState = IdeVolatileState (AstData M.empty) M.empty Nothing +emptyDurableState :: IdeDurableState +emptyDurableState = IdeDurableState S.empty -- | @IdeFileState@ holds data that corresponds 1-to-1 to an entity on the -- filesystem. Externs correspond to the ExternsFiles the compiler emits into @@ -213,6 +221,15 @@ data IdeVolatileState = IdeVolatileState , vsCachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) } deriving (Show) +-- | @IdeDurableState@ holds data that persists across resets of the @IdeState@. +-- This is particularly useful for configuration variables that can be modified +-- during runtime. For instance, the module names for the "focus" feature are +-- stored in the drFocusedModules field, which the client populates using the +-- @Focus@ command to specify only which modules to load. +data IdeDurableState = IdeDurableState + { drFocusedModules :: Set P.ModuleName + } deriving (Show) + newtype Match a = Match (P.ModuleName, a) deriving (Show, Eq, Functor) @@ -313,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/Interactive.hs b/src/Language/PureScript/Interactive.hs index 5f88b079c3..061710d15f 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -42,6 +42,7 @@ import Language.PureScript.Interactive.Types as Interactive import System.Directory (getCurrentDirectory) import System.FilePath (()) import System.FilePath.Glob (glob) +import Language.PureScript.Make.Index.Select (runWoGetEnv, WoGetEnv) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () @@ -296,8 +297,8 @@ handleKindOf print' typ = do let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } k = check (snd <$> P.kindOf typ') chk - check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) - check sew = fst . runWriter . runExceptT . runStateT sew + check :: WoGetEnv (StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors))) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) + check sew st' = fst $ runWriter $ runExceptT $ flip runStateT st' $ runWoGetEnv sew case k of Left err -> printErrors err Right (kind, _) -> print' . P.prettyPrintType 1024 $ kind diff --git a/src/Language/PureScript/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/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 697fefe8a0..b5551107f7 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -3,35 +3,34 @@ -- The algorithm analyses the clauses of a definition one by one from top -- to bottom, where in each step it has the cases already missing (uncovered), -- and it generates the new set of missing cases. --- module Language.PureScript.Linter.Exhaustive - ( checkExhaustiveExpr - ) where - -import Prelude -import Protolude (ordNub) + ( checkExhaustiveExpr, + ) +where -import Control.Applicative (Applicative(..)) +import Control.Applicative (Applicative (..)) import Control.Arrow (first, second) -import Control.Monad (unless) -import Control.Monad.Writer.Class (MonadWriter(..)) - -import Data.List (foldl', sortOn) +import Control.Monad (unless, join) +import Control.Monad.Writer.Class (MonadWriter (..)) +import Data.Functor ((<&>)) +import Data.List (sortOn) import Data.Maybe (fromMaybe) -import Data.Map qualified as M import Data.Text qualified as T - -import Language.PureScript.AST.Binders (Binder(..)) -import Language.PureScript.AST.Declarations (CaseAlternative(..), Expr(..), Guard(..), GuardedExpr(..), pattern MkUnguarded, isTrueExpr) -import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.Binders (Binder (..)) +import Language.PureScript.AST.Declarations (CaseAlternative (..), Expr (..), Guard (..), GuardedExpr (..), isTrueExpr, pattern MkUnguarded) +import Language.PureScript.AST.Literals (Literal (..)) import Language.PureScript.AST.Traversals (everywhereOnValuesM) +import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (DataDeclType, Environment(..), TypeKind(..)) -import Language.PureScript.Errors (MultipleErrors, pattern NullSourceAnn, SimpleErrorMessage(..), SourceSpan, errorMessage') +import Language.PureScript.Environment (TypeKind (..)) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), SourceSpan, errorMessage', pattern NullSourceAnn) +import Language.PureScript.Make.Index.Select (GetEnv) import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) +import Language.PureScript.TypeChecker.Monad (CheckState, lookupConstructorMb, lookupTypeMb) import Language.PureScript.Types as P -import Language.PureScript.Constants.Prim qualified as C +import Protolude (MonadState, ifM, ordNub, foldlM) +import Prelude -- | There are two modes of failure for the redundancy check: -- @@ -43,55 +42,48 @@ data RedundancyError = Incomplete | Unknown -- | -- Qualifies a propername from a given qualified propername and a default module name --- -qualifyName - :: ProperName a - -> ModuleName - -> Qualified (ProperName b) - -> Qualified (ProperName a) +qualifyName :: + ProperName a -> + ModuleName -> + Qualified (ProperName b) -> + Qualified (ProperName a) qualifyName n defmn qn = Qualified (ByModuleName mn) n where - (mn, _) = qualify defmn qn + (mn, _) = qualify defmn qn -- | --- Given an environment and a datatype or newtype name, +-- Given a datatype or newtype name, -- this function returns the associated data constructors if it is the case of a datatype -- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe) -- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"]) --- -getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [SourceType])] -getConstructors env defmn n = extractConstructors lnte +getConstructors :: forall m. (MonadState CheckState m, GetEnv m) => ModuleName -> Qualified (ProperName 'ConstructorName) -> m [(ProperName 'ConstructorName, [SourceType])] +getConstructors defmn n = do + qpn <- getConsDataName n + lnte <- lookupTypeMb qpn + pure $ extractConstructors lnte where + extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])] + extractConstructors (Just (_, DataType _ _ pt)) = pt + extractConstructors other = internalError $ "Data name not in the scope of the current environment in extractConstructors: " ++ show other - extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])] - extractConstructors (Just (_, DataType _ _ pt)) = pt - extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" - - lnte :: Maybe (SourceType, TypeKind) - lnte = M.lookup qpn (types env) + getConsDataName :: Qualified (ProperName 'ConstructorName) -> m (Qualified (ProperName 'TypeName)) + getConsDataName con = + lookupConstructorMb con <&> \case + Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName." + Just (_, pm, _, _) -> qualifyName pm defmn con - qpn :: Qualified (ProperName 'TypeName) - qpn = getConsDataName n - - getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName) - getConsDataName con = - case getConsInfo con of - Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName." - Just (_, pm, _, _) -> qualifyName pm defmn con - - getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) - getConsInfo con = M.lookup con (dataConstructors env) +-- getConsInfo :: Qualified (ProperName 'ConstructorName) -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) +-- getConsInfo con = M.lookup con (dataConstructors env) -- | -- Replicates a wildcard binder --- initialize :: Int -> [Binder] initialize l = replicate l NullBinder -- | -- Applies a function over two lists of tuples that may lack elements --- -genericMerge :: Ord a => +genericMerge :: + (Ord a) => (a -> Maybe b -> Maybe c -> d) -> [(a, b)] -> [(a, c)] -> @@ -99,7 +91,7 @@ genericMerge :: Ord a => genericMerge _ [] [] = [] genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs -genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs') +genericMerge f bsl@((s, b) : bs) bsr@((s', b') : bs') | s < s' = f s (Just b) Nothing : genericMerge f bs bsr | s > s' = f s' Nothing (Just b') : genericMerge f bsl bs' | otherwise = f s (Just b) (Just b') : genericMerge f bs bs' @@ -107,49 +99,49 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs') -- | -- Find the uncovered set between two binders: -- the first binder is the case we are trying to cover, the second one is the matching binder --- -missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool) -missingCasesSingle _ _ _ NullBinder = ([], return True) -missingCasesSingle _ _ _ (VarBinder _ _) = ([], return True) -missingCasesSingle env mn (VarBinder _ _) b = missingCasesSingle env mn NullBinder b -missingCasesSingle env mn br (NamedBinder _ _ bl) = missingCasesSingle env mn br bl -missingCasesSingle env mn NullBinder cb@(ConstructorBinder ss con _) = - (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True) - where - allPatterns = map (\(p, t) -> ConstructorBinder ss (qualifyName p mn con) (initialize $ length t)) - $ getConstructors env mn con -missingCasesSingle env mn cb@(ConstructorBinder ss con bs) (ConstructorBinder _ con' bs') - | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder ss con) bs'', pr) - | otherwise = ([cb], return False) -missingCasesSingle env mn NullBinder (LiteralBinder ss (ObjectLiteral bs)) = - (map (LiteralBinder ss . ObjectLiteral . zip (map fst bs)) allMisses, pr) - where - (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs) -missingCasesSingle env mn (LiteralBinder _ (ObjectLiteral bs)) (LiteralBinder ss (ObjectLiteral bs')) = - (map (LiteralBinder ss . ObjectLiteral . zip sortedNames) allMisses, pr) +missingCasesSingle :: (MonadState CheckState m, GetEnv m) => ModuleName -> Binder -> Binder -> m ([Binder], Either RedundancyError Bool) +missingCasesSingle _ _ NullBinder = pure ([], return True) +missingCasesSingle _ _ (VarBinder _ _) = pure ([], return True) +missingCasesSingle mn (VarBinder _ _) b = missingCasesSingle mn NullBinder b +missingCasesSingle mn br (NamedBinder _ _ bl) = missingCasesSingle mn br bl +missingCasesSingle mn NullBinder cb@(ConstructorBinder ss con _) = do + ctrs <- getConstructors mn con + let allPatterns = + map (\(p, t) -> ConstructorBinder ss (qualifyName p mn con) (initialize $ length t)) ctrs + binders <- join <$> traverse (\cp -> fst <$> missingCasesSingle mn cp cb) allPatterns + return (binders, return True) +missingCasesSingle mn cb@(ConstructorBinder ss con bs) (ConstructorBinder _ con' bs') + | con == con' = do + (bs'', pr) <- missingCasesMultiple mn bs bs' + pure (map (ConstructorBinder ss con) bs'', pr) + | otherwise = return ([cb], return False) +missingCasesSingle mn NullBinder (LiteralBinder ss (ObjectLiteral bs)) = do + (allMisses, pr) <- missingCasesMultiple mn (initialize $ length bs) (map snd bs) + pure (map (LiteralBinder ss . ObjectLiteral . zip (map fst bs)) allMisses, pr) +missingCasesSingle mn (LiteralBinder _ (ObjectLiteral bs)) (LiteralBinder ss (ObjectLiteral bs')) = do + (allMisses, pr) <- uncurry (missingCasesMultiple mn) (unzip binders) + return (map (LiteralBinder ss . ObjectLiteral . zip sortedNames) allMisses, pr) where - (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders) + sortNames = sortOn fst - sortNames = sortOn fst + (sbs, sbs') = (sortNames bs, sortNames bs') - (sbs, sbs') = (sortNames bs, sortNames bs') + compB :: a -> Maybe a -> Maybe a -> (a, a) + compB e b b' = (fm b, fm b') + where + fm = fromMaybe e - compB :: a -> Maybe a -> Maybe a -> (a, a) - compB e b b' = (fm b, fm b') - where - fm = fromMaybe e + compBS :: b -> a -> Maybe b -> Maybe b -> (a, (b, b)) + compBS e s b b' = (s, compB e b b') - compBS :: b -> a -> Maybe b -> Maybe b -> (a, (b, b)) - compBS e s b b' = (s, compB e b b') - - (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs' -missingCasesSingle _ _ NullBinder (LiteralBinder ss (BooleanLiteral b)) = ([LiteralBinder ss . BooleanLiteral $ not b], return True) -missingCasesSingle _ _ (LiteralBinder ss (BooleanLiteral bl)) (LiteralBinder _ (BooleanLiteral br)) - | bl == br = ([], return True) - | otherwise = ([LiteralBinder ss $ BooleanLiteral bl], return False) -missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb -missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb -missingCasesSingle _ _ b _ = ([b], Left Unknown) + (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs' +missingCasesSingle _ NullBinder (LiteralBinder ss (BooleanLiteral b)) = return ([LiteralBinder ss . BooleanLiteral $ not b], return True) +missingCasesSingle _ (LiteralBinder ss (BooleanLiteral bl)) (LiteralBinder _ (BooleanLiteral br)) + | bl == br = return ([], return True) + | otherwise = return ([LiteralBinder ss $ BooleanLiteral bl], return False) +missingCasesSingle mn b (PositionedBinder _ _ cb) = missingCasesSingle mn b cb +missingCasesSingle mn b (TypedBinder _ cb) = missingCasesSingle mn b cb +missingCasesSingle _ b _ = return ([b], Left Unknown) -- | -- Returns the uncovered set of binders @@ -176,15 +168,14 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown) -- Up to now, we've decided to use `x` just because we expect to generate uncovered cases which might be -- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker -- (which ought to be available soon), or increase the complexity of the algorithm. --- -missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool) -missingCasesMultiple env mn = go +missingCasesMultiple :: (MonadState CheckState m, GetEnv m) => ModuleName -> [Binder] -> [Binder] -> m ([[Binder]], Either RedundancyError Bool) +missingCasesMultiple mn = go where - go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2) - where - (miss1, pr1) = missingCasesSingle env mn x y - (miss2, pr2) = go xs ys - go _ _ = ([], pure True) + go (x : xs) (y : ys) = do + (miss1, pr1) <- missingCasesSingle mn x y + (miss2, pr2) <- go xs ys + pure (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2) + go _ _ = pure ([], pure True) -- | -- Guard handling @@ -199,111 +190,127 @@ missingCasesMultiple env mn = go -- -- The function below say whether or not a guard has an `otherwise` expression -- It is considered that `otherwise` is defined in Prelude --- -isExhaustiveGuard :: Environment -> ModuleName -> [GuardedExpr] -> Bool -isExhaustiveGuard _ _ [MkUnguarded _] = True -isExhaustiveGuard env moduleName gs = - any (\(GuardedExpr grd _) -> isExhaustive grd) gs +isExhaustiveGuard :: forall m. (GetEnv m, MonadState CheckState m) => ModuleName -> [GuardedExpr] -> m Bool +isExhaustiveGuard _ [MkUnguarded _] = pure True +isExhaustiveGuard moduleName gs = + anyM (\(GuardedExpr grd _) -> isExhaustive grd) gs where - isExhaustive :: [Guard] -> Bool - isExhaustive = all checkGuard + isExhaustive :: [Guard] -> m Bool + isExhaustive = allM checkGuard - checkGuard :: Guard -> Bool - checkGuard (ConditionGuard cond) = isTrueExpr cond - checkGuard (PatternGuard binder _) = - case missingCasesMultiple env moduleName [NullBinder] [binder] of + checkGuard :: Guard -> m Bool + checkGuard (ConditionGuard cond) = pure $ isTrueExpr cond + checkGuard (PatternGuard binder _) = do + missing <- missingCasesSingle moduleName NullBinder binder + pure $ case missing of ([], _) -> True -- there are no missing pattern for this guard - _ -> False + _ -> False + +anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = pure False +anyM f (x : xs) = do + b <- f x + if b then pure True else anyM f xs + +allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool +allM _ [] = pure True +allM f (x : xs) = do + b <- f x + if b then allM f xs else pure False -- | -- Returns the uncovered set of case alternatives --- -missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool) -missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca) +missingCases :: (GetEnv m, MonadState CheckState m) => ModuleName -> [Binder] -> CaseAlternative -> m ([[Binder]], Either RedundancyError Bool) +missingCases mn uncovered ca = missingCasesMultiple mn uncovered (caseAlternativeBinders ca) -missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool) -missingAlternative env mn ca uncovered - | isExhaustiveGuard env mn (caseAlternativeResult ca) = mcases - | otherwise = ([uncovered], snd mcases) - where - mcases = missingCases env mn uncovered ca +missingAlternative :: (GetEnv m, MonadState CheckState m) => ModuleName -> CaseAlternative -> [Binder] -> m ([[Binder]], Either RedundancyError Bool) +missingAlternative mn ca uncovered = do + mcases <- missingCases mn uncovered ca + ifM (isExhaustiveGuard mn (caseAlternativeResult ca)) (pure mcases) (pure ([uncovered], snd mcases)) -- | -- Main exhaustivity checking function -- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument), -- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses. -- Then, returns the uncovered set of case alternatives. --- -checkExhaustive - :: forall m - . MonadWriter MultipleErrors m - => SourceSpan - -> Environment - -> ModuleName - -> Int - -> [CaseAlternative] - -> Expr - -> m Expr -checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas +checkExhaustive :: + forall m. + (MonadWriter MultipleErrors m, GetEnv m, MonadState CheckState m) => + SourceSpan -> + ModuleName -> + Int -> + [CaseAlternative] -> + Expr -> + m Expr +checkExhaustive ss mn numArgs cas expr = makeResult . first ordNub =<< foldlM step ([initialize numArgs], (pure True, [])) cas where - step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]])) - step (uncovered, (nec, redundant)) ca = - let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered) - (missed', approx) = splitAt 10000 (ordNub (concat missed)) - cond = or <$> sequenceA pr - in (missed', ( if null approx - then liftA2 (&&) cond nec - else Left Incomplete - , if and cond - then redundant - else caseAlternativeBinders ca : redundant - ) - ) + step :: + ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> + CaseAlternative -> + m ([[Binder]], (Either RedundancyError Bool, [[Binder]])) + step (uncovered, (nec, redundant)) ca = do + (missed, pr) <- unzip <$> traverse (missingAlternative mn ca) uncovered + let (missed', approx) = splitAt 10000 (ordNub (concat missed)) + cond = or <$> sequenceA pr + + -- let (missed, pr) = unzip (map (missingAlternative mn ca) uncovered) + -- (missed', approx) = splitAt 10000 (ordNub (concat missed)) + -- cond = or <$> sequenceA pr + pure ( missed', + ( if null approx + then liftA2 (&&) cond nec + else Left Incomplete, + if and cond + then redundant + else caseAlternativeBinders ca : redundant + ) + ) - makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr - makeResult (bss, (rr, bss')) = - do unless (null bss') tellRedundant - case rr of - Left Incomplete -> tellIncomplete - _ -> return () - return $ if null bss - then expr - else addPartialConstraint (second null (splitAt 5 bss)) expr - where - tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss' - tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck + makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr + makeResult (bss, (rr, bss')) = + do + unless (null bss') tellRedundant + case rr of + Left Incomplete -> tellIncomplete + _ -> return () + return $ + if null bss + then expr + else addPartialConstraint (second null (splitAt 5 bss)) expr + where + tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss' + tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck - -- We add a Partial constraint by annotating the expression to have type `Partial => _`. - -- - -- The binder information is provided so that it can be embedded in the constraint, - -- and then included in the error message. - addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr - addPartialConstraint (bss, complete) e = - TypedValue True e $ - srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) $ TypeWildcard NullSourceAnn IgnoredWildcard - where - constraintData :: ConstraintData - constraintData = - PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete + -- We add a Partial constraint by annotating the expression to have type `Partial => _`. + -- + -- The binder information is provided so that it can be embedded in the constraint, + -- and then included in the error message. + addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr + addPartialConstraint (bss, complete) e = + TypedValue True e $ + srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) $ + TypeWildcard NullSourceAnn IgnoredWildcard + where + constraintData :: ConstraintData + constraintData = + PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete -- | -- Exhaustivity checking --- -checkExhaustiveExpr - :: forall m - . MonadWriter MultipleErrors m - => SourceSpan - -> Environment - -> ModuleName - -> Expr - -> m Expr -checkExhaustiveExpr ss env mn = onExpr' +checkExhaustiveExpr :: + forall m. + (MonadWriter MultipleErrors m, GetEnv m, MonadState CheckState m) => + SourceSpan -> + ModuleName -> + Expr -> + m Expr +checkExhaustiveExpr ss mn = onExpr' where - (_, onExpr', _) = everywhereOnValuesM pure onExpr pure + (_, onExpr', _) = everywhereOnValuesM pure onExpr pure - onExpr :: Expr -> m Expr - onExpr e = case e of - Case es cas -> - checkExhaustive ss env mn (length es) cas e - _ -> - pure e + onExpr :: Expr -> m Expr + onExpr e = case e of + Case es cas -> + checkExhaustive ss mn (length es) cas e + _ -> + pure e diff --git a/src/Language/PureScript/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..809c96c6de --- /dev/null +++ b/src/Language/PureScript/Lsp/Rebuild.hs @@ -0,0 +1,170 @@ +{-# 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, cachedEnvironment, cachedOpenFileFromSrc, getDbConn, hashDeps, updateCachedRebuildResult, mergePartialArtifacts) +import Language.PureScript.Lsp.Types (ExternDependency (edExtern), LspEnvironment (lspStateVar), LspState) +import Language.PureScript.Lsp.Types qualified as Types +import Language.PureScript.Make qualified as P +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 moduleName 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 (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 :: P.ModuleName -> TVar LspState -> Int -> Text -> Int -> P.MakeActions P.Make -> P.MakeActions P.Make +addRebuildCaching modName stVar _maxCache _src _depHash ma = + ma + { + -- P.codegen = \prevEnv checkSt astM m docs ext -> lift (P.makeIO "Cache rebuild" $ cacheRebuild' stVar maxCache src ext (P.checkIdeArtifacts checkSt) astM depHash) <* P.codegen ma prevEnv checkSt astM m docs ext + -- , + + P.withCheckStateOnError = \checkSt -> P.makeIO "replace artifacts" $ mergePartialArtifacts stVar (P.checkIdeArtifacts checkSt) modName + } + +getIdeCheckState :: (MonadLsp ServerConfig m) => m (P.Environment -> P.CheckState) +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..4584a697eb --- /dev/null +++ b/src/Language/PureScript/Lsp/State.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE TypeOperators #-} + +module Language.PureScript.Lsp.State + ( getState, + getDbConn, + cacheRebuild, + cacheRebuild', + mergePartialArtifacts, + 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, handlePartialArtifacts) +import Language.PureScript.Names qualified as P + +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 + +mergePartialArtifacts :: TVar LspState -> IdeArtifacts -> P.ModuleName -> IO () +mergePartialArtifacts st artifacts moduleName = atomically . modifyTVar st $ \x -> + x + { openFiles = openFiles x <&> \(fp, ofile) -> + if ofModuleName ofile == moduleName + then (fp, ofile {ofArtifacts = handlePartialArtifacts (ofArtifacts ofile) artifacts}) + else (fp, ofile) + } + +updateCachedModule :: (MonadIO m, MonadReader LspEnvironment m) => P.Module -> m () +updateCachedModule module' = do + st <- lspStateVar <$> ask + 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..a50fa6193c 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,109 +1,140 @@ -module Language.PureScript.Make - ( - -- * Make API - rebuildModule - , rebuildModule' - , make - , inferForeignModules - , module Monad - , module Actions - ) where +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NumDecimals #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} -import Prelude +module Language.PureScript.Make + ( -- * Make API + rebuildModule, + rebuildModule', + rebuildModuleWithProvidedEnv, + make, + makeDb, + 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.State (get) 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.List (foldl', sortOn) +import Data.Function (on) +import Data.List (foldl', intercalate, 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 Database.SQLite.Simple (Connection) import Debug.Trace (traceMarkerIO) -import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim) -import Language.PureScript.Crash (internalError) +import GHC.Conc (enableAllocationLimit, setAllocationCounter) +import Language.PureScript.AST (ErrorMessageHint (..), Module (..), SourceSpan (..), getModuleName, getModuleSourceSpan, importPrim, internalModuleSourceSpan) import Language.PureScript.CST qualified as CST +import Language.PureScript.CoreFn qualified as CF +import Language.PureScript.Crash (internalError) import Language.PureScript.Docs.Convert qualified as Docs -import Language.PureScript.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.Docs.Types qualified as Docs +import Language.PureScript.Environment (Environment, initEnvironment) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) +import Language.PureScript.Externs (ExternsFile (..), ExternsFixity, ExternsTypeFixity, applyExternsFileToEnvironment, moduleToExternsFile) +import Language.PureScript.Linter (Name (..), lint, lintImports) +import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.BuildPlan (BuildJobResult (..), BuildPlan (..), getResult) import Language.PureScript.Make.BuildPlan qualified as BuildPlan +import Language.PureScript.Make.BuildPlanDB qualified as BuildPlanDB import Language.PureScript.Make.Cache qualified as Cache -import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Index.Select (GetEnv (deleteModuleEnv), dbEnv, getModuleFixities, runDbEnv, runWoGetEnv, selectFixitiesFromModuleImports) 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, desugarUsingDb, externsEnv, primEnv) +import Language.PureScript.TypeChecker (CheckState (..), emptyCheckState, typeCheckModule) +import Language.PureScript.TypeChecker.Monad qualified as P +import Protolude (putErrText) import System.Directory (doesFileExist) import System.FilePath (replaceExtension) +import Prelude -- | 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 act exEnv env externs m moduleIndex + +rebuildModuleWithIndexDb :: + forall m. + (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) => + MakeActions m -> + Connection -> + Env -> + Module -> + Maybe (Int, Int) -> + m ExternsFile +rebuildModuleWithIndexDb act conn exEnv m moduleIndex = do + rebuildModuleWithProvidedEnvDb emptyCheckState act conn exEnv m moduleIndex + +rebuildModuleWithProvidedEnv :: + forall m. + (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Environment -> CheckState) -> + MakeActions m -> + Env -> + Environment -> + [ExternsFile] -> + Module -> + Maybe (Int, Int) -> + m ExternsFile +rebuildModuleWithProvidedEnv initialCheckState MakeActions {..} exEnv env externs m@(Module _ _ moduleName _ _) moduleIndex = do + progress $ CompilingModule moduleName moduleIndex + let withPrim = importPrim m lint withPrim - - ((Module ss coms _ elaborated exps, 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 withCheckStateOnError withCheckState 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 +144,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 + corefn <- runWoGetEnv $ CF.moduleToCoreFn env' mod' + let (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn + (_renamedIdents, renamed) = renameInModule optimized + -- exts = moduleToExternsFile mod' env' renamedIdents + ffiCodegen renamed -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, -- but I have not done so for two reasons: -- 1. This should never fail; any genuine errors in the code should have been @@ -126,26 +157,182 @@ 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 + 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 + return dummyExternsFile + +dummyExternsFile :: ExternsFile +dummyExternsFile = + ExternsFile + { efVersion = "0", + efSourceSpan = internalModuleSourceSpan "", + efModuleName = ModuleName "dummy", + efExports = [], + efImports = [], + efFixities = [], + efTypeFixities = [], + efDeclarations = [] + } + +rebuildModuleWithProvidedEnvDb :: + forall m. + (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadIO m) => + (Environment -> CheckState) -> + MakeActions m -> + Connection -> + Env -> + Module -> + Maybe (Int, Int) -> + m ExternsFile +rebuildModuleWithProvidedEnvDb initialCheckState MakeActions {..} conn exEnv m@(Module _ _ moduleName _ _) moduleIndex = do + progress $ CompilingModule moduleName moduleIndex + let withPrim = importPrim m + lint withPrim + putErrText $ "linted: " <> T.pack (show moduleName) + + ((Module ss coms _ elaborated exps, checkSt), nextVar) <- + desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError withCheckState moduleName withPrim exEnv + + putErrText $ "type checked: " <> T.pack (show moduleName) + + let env' = P.checkEnv checkSt + + -- desugar case declarations *after* type- and exhaustiveness checking + -- since pattern guards introduces cases which the exhaustiveness checker + -- reports as not-exhaustive. + (deguarded, nextVar') <- runSupplyT nextVar $ do + desugarCaseGuards elaborated + + regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded + putErrText $ "regrouped: " <> T.pack (show moduleName) + let mod' = Module ss coms moduleName regrouped exps + + !corefn <- fmap force $ runDbEnv conn $ CF.moduleToCoreFn env' mod' + putErrText $ "corefn: " <> T.pack (show moduleName) + let -- !(optimized, nextVar'') = force $ runSupply nextVar' $ CF.optimizeCoreFn corefn + optimized = corefn + nextVar'' = nextVar' + putErrText $ "optimized: " <> T.pack (show moduleName) - evalSupplyT nextVar'' $ codegen renamed docs exts - return exts + let !(_renamedIdents, renamed) = force (renameInModule optimized) + putErrText $ "renamed: " <> T.pack (show moduleName) + + -- exts = moduleToExternsFile mod' env' renamedIdents + ffiCodegen renamed + putErrText $ "ffi codegen: " <> T.pack (show moduleName) + -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, + -- but I have not done so for two reasons: + -- 1. This should never fail; any genuine errors in the code should have been + -- caught earlier in this function. Therefore if we do fail here it indicates + -- a bug in the compiler, which should be reported as such. + -- 2. We do not want to perform any extra work generating docs unless the + -- user has asked for docs to be generated. + let docs = Docs.Module moduleName (Just "TODO") [] [] + -- case Docs.convertModuleWithoutExterns ops typeOps exEnv env' withPrim of + -- Left errs -> + -- internalError $ + -- "Failed to produce docs for " + -- ++ T.unpack (runModuleName moduleName) + -- ++ "; details:\n" + -- ++ prettyPrintMultipleErrors defaultPPEOptions errs + -- Right d -> d + evalSupplyT nextVar'' $ codegen env' checkSt mod' renamed docs + putErrText $ "codegen done: " <> T.pack (show moduleName) + return dummyExternsFile + +desugarAndTypeCheck :: + forall m. + (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Environment -> CheckState) -> + (CheckState -> m ()) -> + (CheckState -> m ()) -> + ModuleName -> + [ExternsFile] -> + Module -> + Env -> + Environment -> + m ((Module, CheckState), Integer) +desugarAndTypeCheck initialCheckState withCheckStateOnError withCheckState moduleName externs withPrim exEnv env = runSupplyT 0 $ do + (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) + let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' + (checked, checkSt@(CheckState {..})) <- runStateT (catchError (runWoGetEnv $ typeCheckModule modulesExports desugared) mergeCheckState) $ initialCheckState env + lift $ withCheckState checkSt + let usedImports' = + foldl' + ( flip $ \(fromModuleName, newtypeCtorName) -> + M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName + ) + usedImports + checkConstructorImportsForCoercible + -- Imports cannot be linted before type checking because we need to + -- known which newtype constructors are used to solve Coercible + -- constraints in order to not report them as unused. + censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports' + return (checked, checkSt) + where + mergeCheckState errs = do + checkSt <- get + lift $ lift $ withCheckStateOnError checkSt + throwError errs + +desugarAndTypeCheckDb :: + forall m. + (MonadError MultipleErrors m, MonadIO m, MonadWriter MultipleErrors m) => + (Environment -> CheckState) -> + Connection -> + (CheckState -> m ()) -> + (CheckState -> m ()) -> + ModuleName -> + Module -> + Env -> + m ((Module, CheckState), Integer) +desugarAndTypeCheckDb initialCheckState conn withCheckStateOnError _withCheckState moduleName withPrim exEnv = runSupplyT 0 $ do + runDbEnv conn $ deleteModuleEnv moduleName + (desugared, (exEnv', usedImports)) <- runStateT (desugarUsingDb conn exEnv withPrim) (exEnv, mempty) + let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' + -- env <- selectEnvFromDefinitions conn exEnv' desugared + let env = initEnvironment + (checked, checkSt@(CheckState {..})) <- runStateT (catchError (runDbEnv conn $ typeCheckModule modulesExports desugared) mergeCheckState) (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) + where + mergeCheckState errs = do + checkSt <- get + lift $ lift $ withCheckStateOnError checkSt + throwError errs -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. -- -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without -- having to typecheck those modules again. -make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeActions m - -> [CST.PartialResult Module] - -> m [ExternsFile] -make ma@MakeActions{..} ms = do +make :: + forall m. + (MonadBaseControl IO m, MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + MakeActions m -> + [CST.PartialResult Module] -> + m [ExternsFile] +make ma@MakeActions {..} ms = do checkModuleNames cacheDb <- readCacheDb + conn <- getDbConnection (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms @@ -165,28 +352,30 @@ 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 + conn + lock + buildPlan + moduleName + totalModuleCount (spanName . getModuleSourceSpan . CST.resPartial $ m) (fst $ CST.resFull m) (fmap importPrim . snd $ CST.resFull m) (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) - -- Prevent hanging on other modules when there is an internal error -- (the exception is thrown, but other threads waiting on MVars are released) `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty) -- Wait for all threads to complete, and collect results (and errors). (failures, successes) <- - let - splitResults = \case - BuildJobSucceeded _ exts -> - Right exts - BuildJobFailed errs -> - Left errs - BuildJobSkipped -> - Left mempty - in - M.mapEither splitResults <$> BuildPlan.collectResults buildPlan + 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 +393,255 @@ 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 :: Connection -> QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () + buildModule conn lock buildPlan moduleName cnt fp pwarnings mres deps = do + result <- flip catchError (return . BuildJobFailed) $ do + let pwarnings' = CST.toMultipleWarnings fp pwarnings + tell pwarnings' + m <- CST.unwrapParserError fp mres + -- We need to wait for dependencies to be built, before checking if the current + -- module should be rebuilt, so the first thing to do is to wait on the + -- MVars for the module's dependencies. + mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps + + case mexterns of + Just (_, externs) -> do + -- We need to ensure that all dependencies have been included in Env + C.modifyMVar_ (bpEnv buildPlan) $ \env -> do + let go :: Env -> ModuleName -> m Env + go e dep = case lookup dep (zip deps externs) of + Just exts + | not (M.member dep e) -> externsEnv e exts + _ -> return e + foldM go env deps + env <- C.readMVar (bpEnv buildPlan) + idx <- C.takeMVar (bpIndex buildPlan) + C.putMVar (bpIndex buildPlan) (idx + 1) + + -- Bracket all of the per-module work behind the semaphore, including + -- forcing the result. This is done to limit concurrency and keep + -- memory usage down; see comments above. + (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do + -- Eventlog markers for profiling; see debug/eventlog.js + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" + -- Force the externs and warnings to avoid retaining excess module + -- data after the module is finished compiling. + extsAndWarnings <- evaluate . force <=< listen $ do + rebuildModuleWithIndexDb ma conn env m (Just (idx, cnt)) + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" + return extsAndWarnings + return $ BuildJobSucceeded (pwarnings' <> warnings) exts + Nothing -> return BuildJobSkipped + + BuildPlan.markComplete buildPlan moduleName result + +makeDb :: + forall m. + (MonadBaseControl IO m, MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + MakeActions m -> + [CST.PartialResult Module] -> + m [ModuleName] +makeDb ma@MakeActions {..} ms = do + checkModuleNames + cacheDb <- readCacheDb + conn <- getDbConnection + + (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms + + (buildPlan, _newCacheDb) <- BuildPlanDB.construct ma cacheDb (sorted, graph) + + -- Limit concurrent module builds to the number of capabilities as + -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`. + -- This is to ensure that modules complete fully before moving on, to avoid + -- holding excess memory during compilation from modules that were paused + -- by the Haskell runtime. + capabilities <- getNumCapabilities + let concurrency = max 1 capabilities + putErrText $ "concurrency: " <> T.pack (show concurrency) + lock <- C.newQSem concurrency + + let toBeRebuilt = filter (BuildPlanDB.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted + let totalModuleCount = length toBeRebuilt + + -- importedModules :: S.Set ModuleName + -- importedModules = S.fromList $ graph >>= snd + + -- orphan :: ModuleName -> Bool + -- orphan mn = S.notMember mn importedModules + + graphMap :: M.Map ModuleName [ModuleName] + graphMap = M.fromList graph + + for_ toBeRebuilt $ \m -> fork $ do + liftIO do + setAllocationCounter 8.0e9 + enableAllocationLimit + let moduleName = getModuleName . CST.resPartial $ m + let deps = fromMaybe (internalError "make: module not found in dependency graph.") (M.lookup moduleName graphMap) + + let buildModule' = + buildModule + conn + lock + buildPlan + moduleName + totalModuleCount + (getModuleSourceSpan . CST.resPartial $ m) + (fst $ CST.resFull m) + (fmap importPrim . snd $ CST.resFull m) + (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) + -- Prevent hanging on other modules when there is an internal error + -- (the exception is thrown, but other threads waiting on MVars are released) + `onException` do + putErrText $ "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Exception building: " <> runModuleName moduleName + BuildPlanDB.markComplete buildPlan moduleName (BuildPlanDB.BuildJobFailed mempty) + + -- if orphan moduleName + -- then BuildPlanDB.markComplete buildPlan moduleName (BuildPlanDB.BuildJobSucceeded mempty) + -- else + buildModule' + + -- Wait for all threads to complete, and collect results (and errors). + (failures, _successes) <- + let splitResults = \case + BuildPlanDB.BuildJobSucceeded _ -> + Right () + BuildPlanDB.BuildJobFailed errs -> + Left errs + BuildPlanDB.BuildJobSkipped -> + Left mempty + in M.mapEither splitResults <$> BuildPlanDB.collectResults buildPlan + + writePackageJson + + -- If generating docs, also generate them for the Prim modules + outputPrimDocs + + -- All threads have completed, rethrow any caught errors. + let errors = M.elems failures + unless (null errors) $ throwError (mconcat errors) + return (map (getModuleName . CST.resPartial) sorted) where - checkModuleNames :: m () - checkModuleNames = checkNoPrim *> checkModuleNamesAreUnique - - checkNoPrim :: m () - checkNoPrim = - for_ ms $ \m -> - let mn = getModuleName $ CST.resPartial m - in when (isBuiltinModuleName mn) $ - throwError - . errorMessage' (getModuleSourceSpan $ CST.resPartial m) - $ CannotDefinePrimModules mn - - checkModuleNamesAreUnique :: m () - checkModuleNamesAreUnique = - for_ (findDuplicates (getModuleName . CST.resPartial) ms) $ \mss -> - throwError . flip foldMap mss $ \ms' -> - let mn = getModuleName . CST.resPartial . NEL.head $ ms' - in errorMessage'' (fmap (getModuleSourceSpan . CST.resPartial) ms') $ DuplicateModule mn - - -- Find all groups of duplicate values in a list based on a projection. - findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a] - findDuplicates f xs = - case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortOn f $ xs of - [] -> Nothing - xss -> Just xss - - -- Sort a list so its elements appear in the same order as in another list. - inOrderOf :: (Ord a) => [a] -> [a] -> [a] - inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - - buildModule :: 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 :: Connection -> QSem -> BuildPlanDB.BuildPlan -> ModuleName -> Int -> SourceSpan -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () + buildModule conn lock buildPlan moduleName cnt ss pwarnings mres deps = do + let fp = spanName ss + result <- flip catchError (return . BuildPlanDB.BuildJobFailed) $ do + let pwarnings' = CST.toMultipleWarnings fp pwarnings + tell pwarnings' + m <- CST.unwrapParserError fp mres + -- We need to wait for dependencies to be built, before checking if the current + -- module should be rebuilt, so the first thing to do is to wait on the + -- MVars for the module's dependencies. + mexterns <- sequence <$> traverse (BuildPlanDB.getResult buildPlan) deps + -- let lookupResult mn = + -- fromMaybe (internalError "make: module not found in results") $ + -- M.lookup mn _ + + case mexterns of + Just externs -> do + -- We need to ensure that all dependencies have been included in Env + C.modifyMVar_ (BuildPlanDB.bpEnv buildPlan) $ \env -> do + let go :: Env -> ModuleName -> m Env + go e dep = case lookup dep (zip deps externs) of + Just _exts + | not (M.member dep e) -> dbEnv conn e ss dep + _ -> return e + foldM go env deps + env <- C.readMVar (BuildPlanDB.bpEnv buildPlan) + idx <- C.takeMVar (BuildPlanDB.bpIndex buildPlan) + C.putMVar (BuildPlanDB.bpIndex buildPlan) (idx + 1) + + -- Bracket all of the per-module work behind the semaphore, including + -- forcing the result. This is done to limit concurrency and keep + -- memory usage down; see comments above. + (_e, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do + -- Eventlog markers for profiling; see debug/eventlog.js + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" + -- Force the externs and warnings to avoid retaining excess module + -- data after the module is finished compiling. + extsAndWarnings <- evaluate . force <=< listen $ do + rebuildModuleWithIndexDb ma conn env m (Just (idx, cnt)) + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" + return extsAndWarnings + return $ BuildPlanDB.BuildJobSucceeded (pwarnings' <> warnings) + Nothing -> return BuildPlanDB.BuildJobSkipped + + BuildPlanDB.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..1e4671b103 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,72 @@ 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, writeJSONFile, writeTextFile) +import Language.PureScript.Names (Ident (..), ModuleName, runModuleName) +import Language.PureScript.Options (CodegenTarget (..), Options (..)) +import Language.PureScript.Pretty.Common (SMap (..)) +import Language.PureScript.TypeChecker (CheckState) import Paths_purescript qualified as Paths import SourceMap (generate) -import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..)) +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 Database.SQLite.Simple (Connection) +import Language.PureScript.DB (mkConnection) +import Protolude (putErrText) + -- | 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 +103,44 @@ 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 when type checking fails + withCheckStateOnError :: CheckState -> m (), + -- | Run actions using the final CheckState + withCheckState :: CheckState -> m (), + -- | Run the code generator for the module and write any required output files. + codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> 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 (), + -- | Get database connection + getDbConnection :: m Connection, + -- | Write to the output directory the package.json file allowing Node.js to + -- load .js files as ES modules. + writePackageJson :: m (), + -- | If generating docs, output the documentation for the Prim modules + outputPrimDocs :: m () } -- | Given the output directory, determines the location for the @@ -136,194 +148,230 @@ 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 + withCheckState + withCheckState + codegen + ffiCodegen + progress + readCacheDb + writeCacheDb + getDbConnection + 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 + + withCheckState :: CheckState -> Make () + withCheckState _ = return () + + codegen :: Environment -> CheckState -> Module -> CF.Module CF.Ann -> Docs.Module -> SupplyT Make () + codegen _prevEnv _endEnv _m m docs = do + + let mn = CF.moduleName m + + 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 + putErrText "codegen 3" + dir <- lift $ makeIO "get the current directory" getCurrentDirectory + let sourceMaps = S.member JSSourceMap codegenTargets + (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) + 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 "" + putErrText "codegen 4" + lift $ do + writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef) + + when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + when (S.member Docs codegenTargets) $ do + lift $ writeJSONFile (outputFilename mn "docs.json") docs + putErrText "codegen 5" + + ffiCodegen :: CF.Module CF.Ann -> Make () + ffiCodegen m = do + 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 + + getDbConnection :: Make Connection + getDbConnection = liftIO $ snd <$> mkConnection outputDir + + writePackageJson :: Make () + writePackageJson = writePackageJson' outputDir data ForeignModuleType = ESModule | CJSModule deriving (Show) @@ -333,24 +381,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 +411,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 +493,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/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 3eba2359a3..4436ce3a4c 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -214,3 +214,11 @@ construct MakeActions{..} cacheDb (sorted, graph) = do maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing maximumMaybe xs = Just $ maximum xs + + +-- constructFromDb :: forall m. MonadBaseControl IO m +-- => MakeActions m +-- -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) +-- -> m (BuildPlan, CacheDb) +-- constructFromDb MakeActions{..} (sorted, graph) = do +-- pure undefined diff --git a/src/Language/PureScript/Make/BuildPlanDB.hs b/src/Language/PureScript/Make/BuildPlanDB.hs new file mode 100644 index 0000000000..08ecb896ea --- /dev/null +++ b/src/Language/PureScript/Make/BuildPlanDB.hs @@ -0,0 +1,221 @@ +module Language.PureScript.Make.BuildPlanDB + ( BuildPlan(bpEnv, bpIndex) + , BuildJobResult(..) + , buildJobSuccess + , construct + , getResult + , collectResults + , markComplete + , needsRebuild + ) where + +import Prelude + +import Control.Concurrent.Async.Lifted as A +import Control.Concurrent.Lifted as C +import Control.Monad.Base (liftBase) +import Control.Monad (foldM) +import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Foldable (foldl') +import Data.Map qualified as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time.Clock (UTCTime) +import Language.PureScript.AST (Module, getModuleName) +import Language.PureScript.Crash (internalError) +import Language.PureScript.CST qualified as CST +import Language.PureScript.Errors (MultipleErrors(..)) +import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Cache (CacheDb, CacheInfo, checkChanged) +import Language.PureScript.Names (ModuleName) +import Language.PureScript.Sugar.Names.Env (Env, primEnv) +import System.Directory (getCurrentDirectory) + +-- | The BuildPlan tracks information about our build progress, and holds all +-- prebuilt modules for incremental builds. +data BuildPlan = BuildPlan + { bpPrebuilt :: M.Map ModuleName Prebuilt + , bpBuildJobs :: M.Map ModuleName BuildJob + , bpEnv :: C.MVar Env + , bpIndex :: C.MVar Int + } + +data Prebuilt = Prebuilt + { pbModificationTime :: UTCTime + } + +newtype BuildJob = BuildJob + { bjResult :: C.MVar BuildJobResult + -- ^ Note: an empty MVar indicates that the build job has not yet finished. + } + +data BuildJobResult + = BuildJobSucceeded !MultipleErrors + -- ^ Succeeded, with warnings and externs + -- + | BuildJobFailed !MultipleErrors + -- ^ Failed, with errors + + | BuildJobSkipped + -- ^ The build job was not run, because an upstream build job failed + +buildJobSuccess :: BuildJobResult -> Maybe MultipleErrors +buildJobSuccess (BuildJobSucceeded warnings) = Just warnings +buildJobSuccess _ = Nothing + +-- | Information obtained about a particular module while constructing a build +-- plan; used to decide whether a module needs rebuilding. +data RebuildStatus = RebuildStatus + { statusModuleName :: ModuleName + , statusRebuildNever :: Bool + , statusNewCacheInfo :: Maybe CacheInfo + -- ^ New cache info for this module which should be stored for subsequent + -- incremental builds. A value of Nothing indicates that cache info for + -- this module should not be stored in the build cache, because it is being + -- rebuilt according to a RebuildPolicy instead. + , statusPrebuilt :: Maybe Prebuilt + -- ^ Prebuilt externs and timestamp for this module, if any. + } + +-- | Called when we finished compiling a module and want to report back the +-- compilation result, as well as any potential errors that were thrown. +markComplete + :: (MonadBaseControl IO m) + => BuildPlan + -> ModuleName + -> BuildJobResult + -> m () +markComplete buildPlan moduleName result = do + let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + putMVar rVar result + +-- | Whether or not the module with the given ModuleName needs to be rebuilt +needsRebuild :: BuildPlan -> ModuleName -> Bool +needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp) + +-- | Collects results for all prebuilt as well as rebuilt modules. This will +-- block until all build jobs are finished. Prebuilt modules always return no +-- warnings. +collectResults + :: (MonadBaseControl IO m) + => BuildPlan + -> m (M.Map ModuleName BuildJobResult) +collectResults buildPlan = do + let prebuiltResults = M.map (const $ BuildJobSucceeded (MultipleErrors [])) (bpPrebuilt buildPlan) + barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan + pure (M.union prebuiltResults barrierResults) + +-- | Gets the the build result for a given module name independent of whether it +-- was rebuilt or prebuilt. Prebuilt modules always return no warnings. +getResult + :: (MonadBaseControl IO m) + => BuildPlan + -> ModuleName + -> m (Maybe MultipleErrors) +getResult buildPlan moduleName = + case M.lookup moduleName (bpPrebuilt buildPlan) of + Just _ -> + pure (Just (MultipleErrors [])) + Nothing -> do + r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + pure $ buildJobSuccess r + +-- | Constructs a BuildPlan for the given module graph. +-- +-- The given MakeActions are used to collect various timestamps in order to +-- determine whether a module needs rebuilding. +construct + :: forall m. MonadBaseControl IO m + => MakeActions m + -> CacheDb + -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) + -> m (BuildPlan, CacheDb) +construct MakeActions{..} cacheDb (sorted, graph) = do + let sortedModuleNames = map (getModuleName . CST.resPartial) sorted + rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus + let prebuilt = + foldl' collectPrebuiltModules M.empty $ + mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses + let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames + buildJobs <- foldM makeBuildJob M.empty toBeRebuilt + env <- C.newMVar primEnv + idx <- C.newMVar 1 + pure + ( BuildPlan prebuilt buildJobs env idx + , let + update = flip $ \s -> + M.alter (const (statusNewCacheInfo s)) (statusModuleName s) + in + foldl' update cacheDb rebuildStatuses + ) + where + makeBuildJob prev moduleName = do + buildJob <- BuildJob <$> C.newEmptyMVar + pure (M.insert moduleName buildJob prev) + + getRebuildStatus :: ModuleName -> m RebuildStatus + getRebuildStatus moduleName = do + inputInfo <- getInputTimestampsAndHashes moduleName + case inputInfo of + Left RebuildNever -> do + prebuilt <- findExistingExtern moduleName + pure (RebuildStatus + { statusModuleName = moduleName + , statusRebuildNever = True + , statusPrebuilt = prebuilt + , statusNewCacheInfo = Nothing + }) + Left RebuildAlways -> do + pure (RebuildStatus + { statusModuleName = moduleName + , statusRebuildNever = False + , statusPrebuilt = Nothing + , statusNewCacheInfo = Nothing + }) + Right cacheInfo -> do + cwd <- liftBase getCurrentDirectory + (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo + prebuilt <- + if isUpToDate + then findExistingExtern moduleName + else pure Nothing + pure (RebuildStatus + { statusModuleName = moduleName + , statusRebuildNever = False + , statusPrebuilt = prebuilt + , statusNewCacheInfo = Just newCacheInfo + }) + + findExistingExtern :: ModuleName -> m (Maybe Prebuilt) + findExistingExtern moduleName = runMaybeT $ do + timestamp <- MaybeT $ getOutputTimestamp moduleName + pure (Prebuilt timestamp) + + collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt + collectPrebuiltModules prev (moduleName, rebuildNever, pb) + | rebuildNever = M.insert moduleName pb prev + | otherwise = do + let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) + case traverse (fmap pbModificationTime . flip M.lookup prev) deps of + Nothing -> + -- If we end up here, one of the dependencies didn't exist in the + -- prebuilt map and so we know a dependency needs to be rebuilt, which + -- means we need to be rebuilt in turn. + prev + Just modTimes -> + case maximumMaybe modTimes of + Just depModTime | pbModificationTime pb < depModTime -> + prev + _ -> M.insert moduleName pb prev + +maximumMaybe :: Ord a => [a] -> Maybe a +maximumMaybe [] = Nothing +maximumMaybe xs = Just $ maximum xs + + +-- constructFromDb :: forall m. MonadBaseControl IO m +-- => MakeActions m +-- -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) +-- -> m (BuildPlan, CacheDb) +-- constructFromDb MakeActions{..} (sorted, graph) = do +-- pure undefined diff --git a/src/Language/PureScript/Make/Index.hs b/src/Language/PureScript/Make/Index.hs new file mode 100644 index 0000000000..7691553a09 --- /dev/null +++ b/src/Language/PureScript/Make/Index.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Language.PureScript.Make.Index + ( initDb, + addAllIndexing, + indexAstModuleFromExtern, + indexAstDeclFromExternDecl, + dropTables, + indexExtern, + getExportedNames, + insertEnvValue, + insertType, + insertDataConstructor, + insertTypeSynonym, + addDbConnection, + ) +where + +import Codec.Serialise (serialise) +import Control.Concurrent.Async.Lifted (forConcurrently_, mapConcurrently_) +import Data.List (partition) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Database.SQLite.Simple (Connection, NamedParam ((:=)), type (:.) (..)) +import Database.SQLite.Simple qualified as SQL +import Distribution.Compat.Directory (makeAbsolute) +import Language.LSP.Server (MonadLsp) +import Language.PureScript qualified as P +import Language.PureScript.AST.Declarations (DeclarationRef) +import Language.PureScript.Environment (Environment) +import Language.PureScript.Environment qualified as E +import Language.PureScript.Externs (ExternsFile (efModuleName)) +import Language.PureScript.Lsp.NameType (LspNameType (DctorNameType), declNameType, externDeclNameType, lspNameType) +import Language.PureScript.Lsp.Print (printCtrType, printDataDeclKind, printDeclarationType, printEfDeclName, printEfDeclType, printName, printType, printTypeClassKind) +import Language.PureScript.Lsp.ServerConfig (ServerConfig) +import Language.PureScript.Lsp.Util (efDeclSourceSpan, getOperatorValueName) +import Language.PureScript.Make.Index.Select (toDbQualifer) +import Language.PureScript.Names (Qualified ()) +import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (tcdClassName, tcdValue)) +import Protolude hiding (moduleName) + +addDbConnection :: (Monad m) => Connection -> P.MakeActions m -> P.MakeActions m +addDbConnection conn ma = + ma + { P.getDbConnection = pure conn + } + +addAllIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m +addAllIndexing conn ma = + -- addAstModuleIndexing conn $ + addEnvIndexing conn ma + +-- addExternIndexing conn ma + +-- addAstModuleIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m +-- addAstModuleIndexing conn ma = +-- ma +-- { P.codegen = \prevEnv checkSt astM m docs ext -> +-- lift (indexAstModule conn (P.checkEnv checkSt) astM ext (getExportedNames ext)) <* P.codegen ma prevEnv checkSt astM m docs ext +-- } + +addEnvIndexing :: (MonadIO m) => Connection -> P.MakeActions m -> P.MakeActions m +addEnvIndexing conn ma = + ma + { P.codegen = \prevEnv checkSt astM m docs -> do + lift (indexExportedEnv astM (P.checkEnv checkSt) conn) + P.codegen ma prevEnv checkSt astM m docs + } + +indexAstModule :: (MonadIO m) => Connection -> Environment -> P.Module -> ExternsFile -> Set P.Name -> m () +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 + indexDeclaration conn moduleName' decl + 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 + _ -> printDataDeclKind args + -- case inferSynRes of + -- Left err -> "Inference error: " <> T.pack (P.prettyPrintMultipleErrors P.noColorPPEOptions err) + -- Right (_, tyKind) -> + -- printType $ foldr addDataDeclArgKind (void tyKind) args + P.TypeClassDeclaration _ name args _ _ _ -> case getMatchingKind P.ClassSig (P.coerceProperName name) of + Just kind -> printType kind + _ -> printTypeClassKind args + _ -> 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 + +indexDeclaration :: Connection -> P.ModuleName -> P.Declaration -> IO () +indexDeclaration conn moduleName' = \case + P.FixityDeclaration _ (Left (P.ValueFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName val_mod) name) op)) -> + SQL.executeNamed + conn + ( SQL.Query + "INSERT INTO value_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \ + \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)" + ) + [ ":module_name" := moduleName', + ":op_name" := P.runOpName op, + ":alias_module_name" := val_mod, + ":alias" := either P.runIdent P.runProperName name, + ":associativity" := P.showAssoc assoc, + ":precedence" := prec + ] + P.FixityDeclaration _ (Right (P.TypeFixity (P.Fixity assoc prec) (P.Qualified (P.ByModuleName ty_mod) name) op)) -> + SQL.executeNamed + conn + ( SQL.Query + "INSERT INTO type_operators (module_name, op_name, alias_module_name, alias, associativity, precedence) \ + \ VALUES (:module_name, :op_name, :alias_module_name, :alias, :associativity, :precedence)" + ) + [ ":module_name" := moduleName', + ":op_name" := P.runOpName op, + ":alias_module_name" := ty_mod, + ":alias" := name, + ":associativity" := P.showAssoc assoc, + ":precedence" := prec + ] + P.ImportDeclaration _ importedModule importType importedAs -> + insertImport conn moduleName' importedModule importedAs importType + _ -> pure () + +findMap :: (a -> Maybe b) -> [a] -> Maybe b +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 cache_size=-8000;" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS ast_modules (module_name TEXT, path TEXT, UNIQUE(module_name) on conflict replace, UNIQUE(path) on conflict replace)" + SQL.execute_ + conn + "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)" + initEnvTables conn + 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" + dropEnvTables conn + +indexExportedEnv :: (MonadIO m) => P.Module -> E.Environment -> Connection -> m () +indexExportedEnv module'@(P.Module _ _ mn _ refs) env conn = liftIO do + insertModule conn moduleName path + forConcurrently_ (P.getModuleDeclarations module') (indexDeclaration conn moduleName) + forConcurrently_ (fold refs) (insertExport conn moduleName) + envFromModule E.names & filter nameExported & mapConcurrently_ (uncurry $ insertEnvValue conn) + envFromModule E.types & filter typeOrClassExported & mapConcurrently_ (uncurry $ insertType conn) + envFromModule E.dataConstructors & filter dataConstructorExportedOrDict & mapConcurrently_ (uncurry $ insertDataConstructor conn) + envFromModule E.typeSynonyms & filter typeExported & mapConcurrently_ (uncurry $ insertTypeSynonym conn) + envFromModule E.typeClasses & filter typeClassExported & mapConcurrently_ (uncurry insertTypeClassAndTypes) + dicts + -- & filter ((== Just moduleName) . P.getQual . tcdValue) + & mapConcurrently_ (insertNamedDict conn) + where + insertTypeClassAndTypes :: Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO () + insertTypeClassAndTypes qualClassName@(P.Qualified _ className) tcd = do + insertTypeClass conn qualClassName tcd + for_ + (P.Qualified (P.ByModuleName mn) (P.coerceProperName className) `Map.lookup` E.types env) + \(kind, tk) -> do + insertType conn (P.Qualified (P.ByModuleName mn) (P.coerceProperName className)) (kind, tk) + let dictName = P.dictTypeName . P.coerceProperName $ className + for_ + (P.Qualified (P.ByModuleName mn) dictName `Map.lookup` E.types env) + \(dictKind, dictData) -> do + insertType conn (P.Qualified (P.ByModuleName mn) dictName) (dictKind, dictData) + case dictData of + (P.DataType _ _ [(dctor, _)]) -> do + let dctorName = P.coerceProperName dctor + for_ + (P.Qualified (P.ByModuleName mn) dctorName `Map.lookup` E.dataConstructors env) + \(dty, _, st, idents) -> + insertDataConstructor conn (P.Qualified (P.ByModuleName mn) dctorName) (dty, dictName, st, idents) + _ -> pure () + + path = P.spanName (P.getModuleSourceSpan module') + + moduleName = P.getModuleName module' + envFromModule :: (E.Environment -> Map.Map (Qualified k) v) -> [(Qualified k, v)] + envFromModule f = f env & Map.toList & filter ((== Just moduleName) . P.getQual . fst) + + dicts :: [NamedDict] + dicts = + E.typeClassDictionaries env + & Map.elems + >>= Map.elems + >>= Map.elems + >>= toList + <&> localToQualified + + localToQualified :: NamedDict -> NamedDict + localToQualified dict = + if P.isQualified (tcdValue dict) + then dict + else dict {tcdValue = P.Qualified (P.ByModuleName moduleName) (P.disqualify $ tcdValue dict)} + + -- deleteModuleEnv = do + -- SQL.executeNamed + -- conn + -- "DELETE FROM env_values WHERE module_name = :module_name;\ + -- \DELETE FROM env_types WHERE module_name = :module_name;\ + -- \DELETE FROM env_data_constructors WHERE module_name = :module_name;\ + -- \DELETE FROM env_type_synonyms WHERE module_name = :module_name;\ + -- \DELETE FROM env_type_classes WHERE module_name = :module_name;\ + -- \DELETE FROM env_type_class_instances WHERE module_name = :module_name;\ + -- \DELETE FROM type_operators WHERE module_name = :module_name;\ + -- \DELETE FROM value_operators WHERE module_name = :module_name;\ + -- \DELETE FROM modules WHERE module_name = :module_name" + -- [":module_name" := P.runModuleName moduleName] + + refMatch :: (Qualified a -> DeclarationRef -> Bool) -> (Qualified a, b) -> Bool + refMatch f (k, _) = maybe True (any (f k)) refs + + -- generatedNameOrExported (i, t) = not (P.isPlainIdent $ P.disqualify i) || nameExported (i, t) + + nameExported = refMatch \k -> \case + P.ValueRef _ ident -> ident == P.disqualify k + _ -> False + + typeClassExported = refMatch \k -> \case + P.TypeClassRef _ className -> className == P.disqualify k + _ -> False + + typeOrClassExported :: (Qualified (P.ProperName 'P.TypeName), b) -> Bool + typeOrClassExported kv = + P.isDictTypeName (P.disqualify $ fst kv) + || typeExported kv + || typeClassExported (first (fmap P.coerceProperName) kv) + + typeExported = refMatch \k -> \case + P.TypeRef _ typeName _ -> typeName == P.disqualify k + _ -> False + + dataConstructorExportedOrDict :: (Qualified (P.ProperName 'P.ConstructorName), b) -> Bool + dataConstructorExportedOrDict kv = + P.isDictTypeName (P.disqualify $ fst kv) + || dataConstructorExported kv + + dataConstructorExported = refMatch \k -> \case + P.TypeRef _ _ ctrs -> maybe False (elem (P.disqualify k)) ctrs + _ -> False + +type EnvValue = (P.SourceType, P.NameKind, P.NameVisibility) + +insertModule :: Connection -> P.ModuleName -> FilePath -> IO () +insertModule conn moduleName' path = do + SQL.executeNamed + conn + (SQL.Query "INSERT OR REPLACE INTO modules (module_name, path) VALUES (:module_name, :path)") + [ ":module_name" := P.runModuleName moduleName', + ":path" := path + ] + +insertEnvValue :: Connection -> P.Qualified P.Ident -> EnvValue -> IO () +insertEnvValue conn ident val = do + SQL.execute + conn + "INSERT OR REPLACE INTO env_values (module_name, ident, source_type, name_kind, name_visibility) VALUES (?, ?, ?, ?, ?)" + (toDbQualifer ident :. val) + +type EnvType = (P.SourceType, P.TypeKind) + +insertType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> EnvType -> IO () +insertType conn ident val = do + SQL.execute + conn + "INSERT OR REPLACE INTO env_types (module_name, type_name, source_type, type_kind) VALUES (?, ?, ?, ?)" + (toDbQualifer ident :. val) + +insertDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) -> IO () +insertDataConstructor conn ident (ddt, ty, st, idents) = do + SQL.execute + conn + "INSERT OR REPLACE INTO env_data_constructors (module_name, constructor_name, data_decl_type, type_name, source_type, idents) VALUES (?, ?, ?, ?, ?, ?)" + (toDbQualifer ident :. (ddt, ty, st, serialise idents)) + +insertTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> ([(Text, Maybe P.SourceType)], P.SourceType) -> IO () +insertTypeSynonym conn ident (idents, st) = do + SQL.execute + conn + "INSERT OR REPLACE INTO env_type_synonyms (module_name, type_name, idents, source_type) VALUES (?, ?, ?, ?)" + (toDbQualifer ident :. (serialise idents, st)) + +insertTypeClass :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData -> IO () +insertTypeClass conn ident tcd = do + SQL.execute + conn + "INSERT OR REPLACE INTO env_type_classes (module_name, class_name, class) VALUES (?, ?, ?)" + ((clasMod, className) :. SQL.Only tcd {E.typeClassMembers = (\(a, b, _) -> (a, b, Nothing)) <$> E.typeClassMembers tcd}) + where + (clasMod, className) = toDbQualifer ident + +insertNamedDict :: Connection -> NamedDict -> IO () +insertNamedDict conn dict = do + SQL.execute + conn + "INSERT OR REPLACE INTO env_type_class_instances (module_name, instance_name, class_module, class_name, dict) VALUES (?, ?, ?, ?, ?)" + (toDbQualifer (tcdValue dict) :. (clasMod, className, serialise dict)) + where + (clasMod, className) = toDbQualifer (tcdClassName dict) + +insertImport :: Connection -> P.ModuleName -> P.ModuleName -> Maybe P.ModuleName -> P.ImportDeclarationType -> IO () +insertImport conn moduleName' importedModule importedAs importType = do + SQL.executeNamed + conn + ( SQL.Query + "INSERT OR REPLACE INTO imports (module_name, imported_module, imported_as, value) VALUES (:module_name, :imported_module, :imported_as, :value)" + ) + [ ":module_name" := moduleName', + ":imported_module" := importedModule, + ":imported_as" := importedAs, + ":value" := serialise importType + ] + +insertExport :: Connection -> P.ModuleName -> P.DeclarationRef -> IO () +insertExport conn moduleName' ref = do + SQL.executeNamed + conn + ( SQL.Query + "INSERT OR REPLACE INTO exports (module_name, ident, value) VALUES (:module_name, :ident, :value)" + ) + [ ":module_name" := moduleName', + ":ident" := T.pack (show (P.declRefName ref)), + ":value" := ref + ] + +initEnvTables :: Connection -> IO () +initEnvTables conn = do + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS modules (module_name TEXT NOT NULL PRIMARY KEY, path TEXT, created_at DATETIME DEFAULT CURRENT_TIMESTAMP, hash INT)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_values (module_name TEXT references modules(module_name) ON DELETE CASCADE, ident TEXT, source_type BLOB, name_kind TEXT, name_visibility TEXT, debug TEXT)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_types (module_name TEXT references modules(module_name) ON DELETE CASCADE, type_name TEXT, source_type BLOB, type_kind TEXT, debug TEXT)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_data_constructors (module_name TEXT references modules(module_name) ON DELETE CASCADE, constructor_name TEXT, data_decl_type TEXT, type_name TEXT, source_type BLOB, idents BLOB, debug TEXT)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_synonyms (module_name TEXT references modules(module_name) ON DELETE CASCADE, type_name TEXT, idents BLOB, source_type BLOB, debug TEXT)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_classes (module_name TEXT references modules(module_name) ON DELETE CASCADE, class_name TEXT, class BLOB, debug TEXT)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS env_type_class_instances (module_name TEXT references modules(module_name) ON DELETE CASCADE, instance_name TEXT, class_module TEXT, class_name TEXT, idents TEXT, types TEXT, kinds TEXT, dict BLOB, debug TEXT)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS value_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, defined_in TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS type_operators (module_name TEXT references modules(module_name) ON DELETE CASCADE, defined_in TEXT, op_name TEXT, alias_module_name TEXT, alias TEXT, associativity TEXT, precedence INTEGER, UNIQUE(module_name, op_name) on conflict replace)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS imports (module_name TEXT references modules(module_name) ON DELETE CASCADE, imported_module TEXT, imported_as TEXT, value BLOB)" + SQL.execute_ conn "CREATE TABLE IF NOT EXISTS exports (module_name TEXT references modules(module_name) ON DELETE CASCADE, ident TEXT, value BLOB)" + addEnvIndexes conn + +addEnvIndexes :: Connection -> IO () +addEnvIndexes conn = do + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS modules_module_name_idx ON modules(module_name)" + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS modules_path_idx ON modules(path)" + SQL.execute_ conn "CREATE INDEX IF NOT EXISTS modules_created_at_idx ON modules(created_at)" + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_values_idx ON env_values(module_name, ident)" + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_types_idx ON env_types(module_name, type_name)" + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_data_constructors_idx ON env_data_constructors(module_name, constructor_name)" + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_synonyms_idx ON env_type_synonyms(module_name, type_name)" + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_classes_idx ON env_type_classes(module_name, class_name)" + SQL.execute_ conn "CREATE UNIQUE INDEX IF NOT EXISTS env_type_class_instances_idx ON env_type_class_instances(module_name, instance_name)" + SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_class_name_idx ON env_type_class_instances(class_name)" + SQL.execute_ conn "CREATE INDEX IF NOT EXISTS env_type_class_instances_class_module_idx ON env_type_class_instances(class_module)" + +dropEnvTables :: Connection -> IO () +dropEnvTables conn = do + SQL.execute_ conn "DROP TABLE IF EXISTS env_values" + SQL.execute_ conn "DROP TABLE IF EXISTS env_types" + SQL.execute_ conn "DROP TABLE IF EXISTS env_data_constructors" + SQL.execute_ conn "DROP TABLE IF EXISTS env_type_synonyms" + SQL.execute_ conn "DROP TABLE IF EXISTS env_type_classes" diff --git a/src/Language/PureScript/Make/Index/Select.hs b/src/Language/PureScript/Make/Index/Select.hs new file mode 100644 index 0000000000..b5e162ab08 --- /dev/null +++ b/src/Language/PureScript/Make/Index/Select.hs @@ -0,0 +1,780 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# HLINT ignore "Redundant bracket" #-} + +module Language.PureScript.Make.Index.Select where + +import Codec.Serialise (deserialise) +import Control.Arrow ((>>>)) +import Control.Concurrent.Async.Lifted (forConcurrently, forConcurrently_, mapConcurrently, mapConcurrently_) +import Control.Lens (Field1 (_1), Field2 (_2), Field3 (_3), view) +import Control.Monad.Writer (MonadWriter (tell), Writer, execWriter, WriterT) +import Control.Monad.Writer.Strict qualified as Strict +import Data.Aeson qualified as A +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Database.SQLite.Simple (Connection, NamedParam ((:=))) +import Database.SQLite.Simple qualified as SQL +import Language.PureScript.AST.Declarations (ImportDeclarationType, ExportSource (..)) +import Language.PureScript.AST.Declarations qualified as P +import Language.PureScript.AST.Operators qualified as P +import Language.PureScript.AST.Traversals (accumTypes) +import Language.PureScript.AST.Traversals qualified as P +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (TypeClassData (typeClassSuperclasses)) +import Language.PureScript.Environment qualified as E +import Language.PureScript.Environment qualified as P +import Language.PureScript.Externs (ExternsFixity (..), ExternsTypeFixity (..), ExternsImport (..), ExternsDeclaration (..)) +import Language.PureScript.Linter.Imports qualified as P +import Language.PureScript.Names (coerceProperName) +import Language.PureScript.Names qualified as P +import Language.PureScript.Sugar.BindingGroups (usedTypeNames) +import Language.PureScript.Sugar.Names (Exports (exportedValueOps)) +import Language.PureScript.Sugar.Names.Env qualified as P +-- import Language.PureScript.TypeChecker.Monad qualified as P +import Language.PureScript.TypeClassDictionaries (NamedDict) +import Language.PureScript.TypeClassDictionaries qualified as P +import Language.PureScript.Types (Constraint (constraintClass)) +import Language.PureScript.Types qualified as P +import Protolude hiding (moduleName) +import Protolude.Partial (fromJust) +import Control.Monad.Supply (SupplyT) +import Control.Monad.Supply.Class (MonadSupply (fresh, peek)) +import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Identity (IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import Data.Map qualified as M +import Language.PureScript.Errors (MultipleErrors, SourceSpan) +import Language.PureScript.Sugar.Names.Exports (resolveExports) +import Language.PureScript.Sugar.Names.Env (nullImports) +import Language.PureScript.Sugar.Names.Imports (resolveModuleImport) +import Language.PureScript.Externs qualified as P + + +selectFixitiesFromModuleImportsAndDecls :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])]) +selectFixitiesFromModuleImportsAndDecls conn env module' = do + (fixitiesFromImports, typeFixitiesFromImports) <- selectFixitiesFromModuleImports conn env module' + let (fixitiesFromDecls, typeFixitiesFromDecls) = getModuleFixities module' + pure ((P.getModuleName module', fixitiesFromDecls) : fixitiesFromImports, (P.getModuleName module', typeFixitiesFromDecls) : typeFixitiesFromImports) + +getModuleFixities :: P.Module -> ([ExternsFixity], [ExternsTypeFixity]) +getModuleFixities (P.Module _ _ _ decls _) = (externsFixitiesInModule, externsTypeFixitiesInModule) + where + externsFixitiesInModule :: [ExternsFixity] + externsFixitiesInModule = + fixitiesInModule <&> \(P.ValueFixity (P.Fixity assoc prec) ident opName) -> + ExternsFixity assoc prec opName ident + + externsTypeFixitiesInModule :: [ExternsTypeFixity] + externsTypeFixitiesInModule = + typeFixitiesInModule <&> \(P.TypeFixity (P.Fixity assoc prec) ident opName) -> + ExternsTypeFixity assoc prec opName ident + + (fixitiesInModule, typeFixitiesInModule) = + partitionEithers $ + decls >>= \case + P.FixityDeclaration _ fixity -> [fixity] + _ -> [] + +selectFixitiesFromModuleImports :: Connection -> P.Env -> P.Module -> IO ([(P.ModuleName, [ExternsFixity])], [(P.ModuleName, [ExternsTypeFixity])]) +selectFixitiesFromModuleImports conn env (P.Module _ _ _modName decls _refs) = do + valueOps <- onImports selectImportValueFixities + -- when (_modName == P.ModuleName "Data.NonEmpty") do + -- putErrText $ show _modName + -- putErrText $ "valueOps: " <> show valueOps + typeOps <- onImports selectImportTypeFixities + pure (valueOps, typeOps) + where + onImports :: Ord a => + (Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, a)]) -> + IO [(P.ModuleName, [a])] + onImports fn = groupByModule . join . catMaybes <$> forConcurrently decls (whenImportDecl (fn conn env)) + + whenImportDecl :: (P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, a)]) -> P.Declaration -> IO (Maybe [(P.ModuleName, a)]) + whenImportDecl f = \case + P.ImportDeclaration _ mn' idt importedAs -> Just <$> f mn' idt + where + addImportedAs (mn'', a) = (fromMaybe mn'' importedAs, a) + _ -> pure Nothing + + groupByModule :: Ord a => [(P.ModuleName, a)] -> [(P.ModuleName, [a])] + groupByModule = Map.toList . fmap ordNub . Map.fromListWith (<>) . fmap (fmap pure) + +selectImportValueFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, ExternsFixity)] +selectImportValueFixities conn env modName = \case + P.Implicit -> selectValueFixitiesFromExports conn exports + P.Explicit refs -> selectValueFixitiesFromExports conn $ Map.filterWithKey (inRefs refs) exports + P.Hiding refs -> selectValueFixitiesFromExports conn $ Map.filterWithKey (fmap not . inRefs refs) exports + where + exports = exportedValueOps $ lookupExports modName env + inRefs refs opName _ = opName `elem` opRefs + where + opRefs = refsValueOps env refs + +lookupExports :: P.ModuleName -> P.Env -> Exports +lookupExports modName env = maybe P.nullExports (view _3) (Map.lookup modName env) + +lookupImports :: P.ModuleName -> P.Env -> P.Imports +lookupImports modName env = view _2 $ fromJust $ Map.lookup modName env + +refsValueOps :: P.Env -> [P.DeclarationRef] -> [P.OpName 'P.ValueOpName] +refsValueOps env = (=<<) (refValueOp env) + +refValueOp :: P.Env -> P.DeclarationRef -> [P.OpName 'P.ValueOpName] +refValueOp env = \case + P.ValueOpRef _ ident -> pure ident + P.ReExportRef _ _ ref -> refValueOp env ref + _ -> [] + +selectValueFixitiesFromExports :: Connection -> Map (P.OpName 'P.ValueOpName) P.ExportSource -> IO [(P.ModuleName, ExternsFixity)] +selectValueFixitiesFromExports conn = fmap catMaybes . mapConcurrently select . Map.toList + where + select (opName, P.ExportSource {..}) = fmap (exportSourceDefinedIn,) <$> selectImportValueFixity conn exportSourceDefinedIn opName + +selectImportValueFixity :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe ExternsFixity) +selectImportValueFixity conn modName opName = do + SQL.query + conn + "SELECT associativity, precedence, op_name, alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name = ?" + (modName, opName) + <&> head + +selectImportTypeFixities :: Connection -> P.Env -> P.ModuleName -> ImportDeclarationType -> IO [(P.ModuleName, ExternsTypeFixity)] +selectImportTypeFixities conn env modName = \case + P.Implicit -> selectTypeFixitiesFromExports conn exports + P.Explicit refs -> selectTypeFixitiesFromExports conn $ Map.filterWithKey (inRefs refs) exports + P.Hiding refs -> selectTypeFixitiesFromExports conn $ Map.filterWithKey (fmap not . inRefs refs) exports + where + exports = P.exportedTypeOps $ view _3 $ fromJust $ Map.lookup modName env + inRefs refs opName _ = opName `elem` opRefs + where + opRefs = refsTypeOps refs + +refsTypeOps :: [P.DeclarationRef] -> [P.OpName 'P.TypeOpName] +refsTypeOps = mapMaybe refTypeOp + +refTypeOp :: P.DeclarationRef -> Maybe (P.OpName 'P.TypeOpName) +refTypeOp = \case + P.TypeOpRef _ ident -> Just ident + P.ReExportRef _ _ ref -> refTypeOp ref + _ -> Nothing + +selectTypeFixitiesFromExports :: Connection -> Map (P.OpName 'P.TypeOpName) P.ExportSource -> IO [(P.ModuleName, ExternsTypeFixity)] +selectTypeFixitiesFromExports conn = fmap catMaybes . mapConcurrently select . Map.toList + where + select (opName, P.ExportSource {..}) = fmap (exportSourceDefinedIn,) <$> selectImportTypeFixity conn exportSourceDefinedIn opName + +selectImportTypeFixity :: Connection -> P.ModuleName -> P.OpName 'P.TypeOpName -> IO (Maybe ExternsTypeFixity) +selectImportTypeFixity conn modName opName = do + SQL.query + conn + "SELECT associativity, precedence, op_name, alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name = ?" + (modName, opName) + <&> head + +type ClassDict = + Map.Map + P.QualifiedBy + ( Map.Map + (P.Qualified (P.ProperName 'P.ClassName)) + (Map.Map (P.Qualified P.Ident) (NEL.NonEmpty NamedDict)) + ) + +getTypesToImportFromEnv :: P.Environment -> Set (P.Qualified ToImport) +getTypesToImportFromEnv env = + nameImports + <> typeImports + <> ctrImports + <> synonymImports + <> dictImports + <> classImports + where + nameImports = + E.names env + & Map.elems + <&> (typesToImport . view _1) + & Set.unions + + typeImports = + E.types env + & Map.elems + <&> (typesToImport . view _1) + & Set.unions + + ctrImports = + E.dataConstructors env + & Map.elems + <&> (typesToImport . view _3) + & Set.unions + + synonymImports = + E.typeSynonyms env + & Map.elems + <&> (typesToImport . view _2) + & Set.unions + + dictImports = + E.typeClassDictionaries env + & Map.elems + >>= Map.elems + >>= (fmap (Set.unions . fmap namedDictImports) . Map.elems) + & Set.unions + + classImports = + E.typeClasses env + & Map.elems + <&> typeClassImports + & Set.unions + +namedDictImports :: NamedDict -> Set (P.Qualified ToImport) +namedDictImports dict = P.tcdDependencies dict & maybe Set.empty (Set.unions . fmap (Set.unions . fmap typesToImport . P.constraintArgs)) + +typeClassImports :: P.TypeClassData -> Set (P.Qualified ToImport) +typeClassImports tcd = + P.typeClassSuperclasses tcd + <&> constraintImports + & Set.unions + +typeClassDataTypes :: P.TypeClassData -> [P.SourceType] +typeClassDataTypes tcd = P.typeClassSuperclasses tcd >>= P.constraintArgs + +getUsedNames :: P.Declaration -> Set (P.Qualified ToImport) +getUsedNames d = getUsedValueNames d <> getDeclTypesToImport d + +getUsedValueNames :: P.Declaration -> Set (P.Qualified ToImport) +getUsedValueNames = execWriter . handleDecl + where + (handleDecl, _, _) = P.everywhereOnValuesM onDecl onExpr pure + + onDecl :: P.Declaration -> Writer (Set (P.Qualified ToImport)) P.Declaration + onDecl d = do + case d of + P.TypeInstanceDeclaration _ _ _ _ _ deps cl _ _ -> + tell $ + Set.fromList [fmap TiClass cl, TiType . P.coerceProperName <$> cl] <> Set.unions (constraintImports <$> deps) + _ -> pure () + pure d + + onExpr :: P.Expr -> Writer (Set (P.Qualified ToImport)) P.Expr + onExpr e = do + case e of + P.Var _ qn -> tell $ Set.singleton $ fmap TiIdent qn + P.Constructor _ qn -> tell $ Set.singleton $ fmap TiDctor qn + P.DeferredDictionary cn@(P.Qualified qb cn') _types -> + tell $ + Set.fromList + [ fmap TiClass cn, + TiType . P.coerceProperName <$> cn, + P.Qualified qb $ TiDeferredDictionary cn' + ] + P.DerivedInstancePlaceholder cn _ -> + tell $ + Set.fromList + [ fmap TiClass cn, + TiType . P.coerceProperName <$> cn + ] + _ -> pure () + pure e + +getDeclTypesToImport :: P.Declaration -> Set (P.Qualified ToImport) +getDeclTypesToImport = declTypeNames + where + (declTypeNames, _, _, _, _) = P.accumTypes $ P.everythingOnTypes (<>) \case + P.TypeConstructor _ tyName -> Set.singleton $ fmap TiType tyName + P.ConstrainedType _ c _ -> constraintImports c + where + (P.Qualified qb cl) = P.constraintClass c + _ -> Set.empty + +constraintImports :: P.SourceConstraint -> Set (P.Qualified ToImport) +constraintImports c = + Set.fromList + [ TiClass <$> P.constraintClass c, + TiType . P.coerceProperName <$> P.constraintClass c, + P.Qualified qb $ TiDeferredDictionary cl + ] + where + (P.Qualified qb cl) = P.constraintClass c + +typesToImport :: P.SourceType -> Set (P.Qualified ToImport) +typesToImport = P.everythingOnTypes (<>) \case + P.TypeConstructor _ tyName -> Set.singleton $ fmap TiType tyName + P.ConstrainedType _ c _ -> + Set.fromList + [ TiClass <$> P.constraintClass c, + TiType . P.coerceProperName <$> P.constraintClass c, + P.Qualified qb $ TiDeferredDictionary cl + ] + where + (P.Qualified qb cl) = P.constraintClass c + _ -> Set.empty + +data ToImport + = TiIdent P.Ident + | TiType (P.ProperName 'P.TypeName) + | TiDctor (P.ProperName 'P.ConstructorName) + | TiClass (P.ProperName 'P.ClassName) + | TiDeferredDictionary (P.ProperName 'P.ClassName) + deriving (Show, Eq, Ord) + +selectModuleExports :: Connection -> P.ModuleName -> IO [P.DeclarationRef] +selectModuleExports conn modName = do + SQL.query + conn + "SELECT value FROM exports WHERE module_name = ?" + (SQL.Only modName) + <&> fmap SQL.fromOnly + +selectModuleExternImports :: Connection -> P.ModuleName -> IO [P.ExternsImport] +selectModuleExternImports conn modName = do + SQL.query + conn + "SELECT imported_module, value, imported_as FROM imports WHERE module_name = ?" + (SQL.Only modName) + +insertExports :: Connection -> P.ModuleName -> Maybe [P.DeclarationRef] -> IO () +insertExports conn modName = \case + Nothing -> internalError "selectEnvFromImports called before desguaring module" + Just refs -> forConcurrently_ refs (insertExport conn modName) + +insertExport :: Connection -> P.ModuleName -> P.DeclarationRef -> IO () +insertExport conn modName ref = + SQL.execute + conn + "INSERT INTO exports (module_name, ident, value) VALUES (?, ?, ?)" + (modName, (show $ P.declRefName ref) :: Text, ref) + +selectEnvValue :: Connection -> P.Qualified P.Ident -> IO (Maybe (P.SourceType, P.NameKind, P.NameVisibility)) +selectEnvValue conn ident = do + SQL.query + conn + "SELECT source_type, name_kind, name_visibility FROM env_values WHERE module_name = ? AND ident = ?" + (toDbQualifer ident) + <&> head + +selectModuleEnvValues :: Connection -> P.ModuleName -> IO [(P.Qualified P.Ident, (P.SourceType, P.NameKind, P.NameVisibility))] +selectModuleEnvValues conn moduleName' = do + SQL.query + conn + "SELECT ident, source_type, name_kind, name_visibility FROM env_values WHERE module_name = ?" + (SQL.Only moduleName') + <&> fmap (\(ident, st, nk, nv) -> (P.Qualified (P.ByModuleName moduleName') ident, (st, nk, nv))) + +selectType :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe (P.SourceType, P.TypeKind)) +selectType conn ident = case Map.lookup ident P.allPrimTypes of + Just a -> pure $ Just a + Nothing -> + SQL.query + conn + "SELECT source_type, type_kind FROM env_types WHERE module_name = ? AND type_name = ?" + (modName, ty_name) + <&> head + where + (modName, ty_name) = toDbQualifer ident + +selectType' :: Connection -> P.ModuleName -> P.ProperName 'P.TypeName -> IO (Maybe (P.SourceType, P.TypeKind)) +selectType' conn nMame ident = selectType conn (P.Qualified (P.ByModuleName nMame) ident) + +selectModuleEnvTypes :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), (P.SourceType, P.TypeKind))] +selectModuleEnvTypes conn moduleName' = do + SQL.query + conn + "SELECT type_name, source_type, type_kind FROM env_types WHERE module_name = ?" + (SQL.Only moduleName') + <&> fmap (\(ty, st, tk) -> (P.Qualified (P.ByModuleName moduleName') ty, (st, tk))) + +selectDataConstructor :: Connection -> P.Qualified (P.ProperName 'P.ConstructorName) -> IO (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident])) +selectDataConstructor conn ident = do + SQL.query + conn + "SELECT data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND constructor_name = ?" + (toDbQualifer ident) + <&> (head >>> fmap deserialiseIdents) + where + deserialiseIdents (ddt, ty, st, idents) = (ddt, ty, st, deserialise idents) + +selectTypeDataConstructors :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))] +selectTypeDataConstructors conn ident = do + SQL.query + conn + "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ? AND type_name = ?" + (toDbQualifer ident) + <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents))) + where + moduleName' = fromJust $ P.getQual ident + +selectModuleDataConstructors :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ConstructorName), (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]))] +selectModuleDataConstructors conn moduleName' = do + SQL.query + conn + "SELECT constructor_name, data_decl_type, type_name, source_type, idents FROM env_data_constructors WHERE module_name = ?" + (SQL.Only moduleName') + <&> fmap (\(ctr, ddt, ty, st, idents) -> (P.Qualified (P.ByModuleName moduleName') ctr, (ddt, ty, st, deserialise idents))) + +selectTypeSynonym :: Connection -> P.Qualified (P.ProperName 'P.TypeName) -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType)) +selectTypeSynonym conn tyName = do + SQL.query + conn + "SELECT idents, source_type FROM env_type_synonyms WHERE module_name = ? AND type_name = ?" + (toDbQualifer tyName) + <&> (head >>> fmap deserialiseIdents) + where + deserialiseIdents (idents, st) = (deserialise idents, st) + +selectTypeSynonym' :: Connection -> P.ModuleName -> P.ProperName 'P.TypeName -> IO (Maybe ([(Text, Maybe P.SourceType)], P.SourceType)) +selectTypeSynonym' conn nMame ident = selectTypeSynonym conn (P.Qualified (P.ByModuleName nMame) ident) + +selectModuleTypeSynonyms :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.TypeName), ([(Text, Maybe P.SourceType)], P.SourceType))] +selectModuleTypeSynonyms conn moduleName' = do + SQL.query + conn + "SELECT type_name, idents, source_type FROM env_type_synonyms WHERE module_name = ?" + (SQL.Only moduleName') + <&> fmap (\(ty, idents, st) -> (P.Qualified (P.ByModuleName moduleName') ty, (deserialise idents, st))) + +selectTypeClass :: Connection -> P.ModuleName -> P.ProperName 'P.ClassName -> IO (Maybe P.TypeClassData) +selectTypeClass conn modName className = + case Map.lookup (P.Qualified (P.ByModuleName modName) className) P.allPrimClasses of + Just a -> pure $ Just a + Nothing -> + SQL.query + conn + "SELECT class FROM env_type_classes WHERE module_name = ? AND class_name = ?" + (modName, className) + <&> (fmap SQL.fromOnly . head) + +selectTypeClass' :: Connection -> P.Qualified (P.ProperName 'P.ClassName) -> IO (Maybe P.TypeClassData) +selectTypeClass' conn = \case + P.Qualified (P.ByModuleName modName) className -> selectTypeClass conn modName className + _ -> pure Nothing + +selectModuleTypeClasses :: Connection -> P.ModuleName -> IO [(P.Qualified (P.ProperName 'P.ClassName), P.TypeClassData)] +selectModuleTypeClasses conn moduleName' = do + SQL.query + conn + "SELECT class_name, class FROM env_type_classes WHERE module_name = ?" + (SQL.Only moduleName') + <&> fmap (first (P.Qualified (P.ByModuleName moduleName'))) + +selectAllClassInstances :: + Connection -> + IO [NamedDict] +selectAllClassInstances conn = do + SQL.query_ + conn + "SELECT dict FROM env_type_class_instances" + <&> (fmap (SQL.fromOnly >>> deserialise)) + +selectClassInstancesByClassName :: + Connection -> + P.Qualified (P.ProperName 'P.ClassName) -> + IO [NamedDict] +selectClassInstancesByClassName conn classNameQual = do + SQL.query + conn + "SELECT dict FROM env_type_class_instances WHERE class_module = ? AND class_name = ?" + (modName, className) + <&> fmap (SQL.fromOnly >>> deserialise) + where + (modName, className) = toDbQualifer classNameQual + +selectDoesClassInstanceExist :: + Connection -> + P.Qualified P.Ident -> + IO Bool +selectDoesClassInstanceExist conn ident = do + res :: [SQL.Only Int] <- SQL.query + conn + "SELECT 1 FROM env_type_class_instances WHERE module_name = ? AND instance_name = ?" + (toDbQualifer ident) + unless (null res) do + putErrText $ "selectDoesClassInstanceExist true: " <> show ((toDbQualifer ident), res) + return $ not $ null res + + +selectValueOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.ValueOpName -> IO (Maybe (P.ModuleName, Text)) +selectValueOperatorAlias conn modName opName = do + SQL.query + conn + "SELECT alias_module_name, alias FROM value_operators WHERE module_name = ? AND op_name = ?" + (modName, P.runOpName opName) + <&> head + +selectTypeOperatorAlias :: Connection -> P.ModuleName -> P.OpName 'P.TypeOpName -> IO (Maybe (P.ModuleName, P.ProperName 'P.TypeName)) +selectTypeOperatorAlias conn modName opName = do + SQL.query + conn + "SELECT alias_module_name, alias FROM type_operators WHERE module_name = ? AND op_name = ?" + (modName, P.runOpName opName) + <&> head + +selectImportedAs' :: Connection -> P.ModuleName -> P.ModuleName -> IO P.ModuleName +selectImportedAs' conn modName importedModName = fromMaybe importedModName <$> selectImportedAs conn modName importedModName + +selectImportedAs :: Connection -> P.ModuleName -> P.ModuleName -> IO (Maybe P.ModuleName) +selectImportedAs conn modName importedModName = do + SQL.query + conn + "SELECT imported_as FROM imports WHERE module_name = ? AND imported_module = ?" + (modName, importedModName) + <&> (head >>> fmap SQL.fromOnly >>> join) + +type DbQualifer a = (P.ModuleName, a) + +toDbQualifer :: P.Qualified a -> DbQualifer a +toDbQualifer (P.Qualified (P.ByModuleName mn) a) = (mn, a) +toDbQualifer (P.Qualified (P.BySourcePos _) _) = internalError "toDbQualifer called with BySourcePos" + +fromJustWithErr :: (HasCallStack) => (Show e) => e -> Maybe a -> a +fromJustWithErr err = \case + Just a -> a + Nothing -> internalError $ "fromJustWithErr: " <> show err + +insertImports :: Connection -> P.ModuleName -> [P.Declaration] -> IO () +insertImports conn mn = mapConcurrently_ (insertImport conn mn) + +insertImport :: Connection -> P.ModuleName -> P.Declaration -> IO () +insertImport conn mn = \case + P.ImportDeclaration _ importedModuleName _ importedAs -> do + SQL.execute + conn + "INSERT INTO imports (module_name, imported_module, imported_as) VALUES (?, ?, ?)" + (mn, importedModuleName, importedAs) + _ -> pure () + +deleteModuleEnvImpl :: P.ModuleName -> Connection -> IO () +deleteModuleEnvImpl moduleName conn = do + SQL.executeNamed + conn + "DELETE FROM env_values WHERE module_name = :module_name;\ + \DELETE FROM env_types WHERE module_name = :module_name;\ + \DELETE FROM env_data_constructors WHERE module_name = :module_name;\ + \DELETE FROM env_type_synonyms WHERE module_name = :module_name;\ + \DELETE FROM env_type_classes WHERE module_name = :module_name;\ + \DELETE FROM env_type_class_instances WHERE module_name = :module_name;\ + \DELETE FROM type_operators WHERE module_name = :module_name;\ + \DELETE FROM value_operators WHERE module_name = :module_name;\ + \DELETE FROM imports WHERE module_name = :module_name;\ + \DELETE FROM exports WHERE module_name = :module_name;\ + \DELETE FROM modules WHERE module_name = :module_name" + [":module_name" := P.runModuleName moduleName] + +getEnvConstraints :: E.Environment -> [P.SourceConstraint] +getEnvConstraints env = + E.names env & Map.elems >>= typeConstraints . view _1 + +typeConstraints :: P.Type a -> [P.Constraint a] +typeConstraints = P.everythingOnTypes (<>) \case + P.ConstrainedType _ c _ -> [c] + _ -> [] + +pipe :: [a -> a] -> a -> a +pipe = foldl' (>>>) identity + +updateConcurrently :: IO (a -> b) -> IO (b -> c) -> IO (a -> c) +updateConcurrently a b = do + f <- a + g <- b + pure $ f >>> g + +class GetEnv m where + getName :: P.Qualified P.Ident -> m (Maybe (P.SourceType, P.NameKind, P.NameVisibility)) + getType :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe (P.SourceType, P.TypeKind)) + getDataConstructor :: P.Qualified (P.ProperName 'P.ConstructorName) -> m (Maybe (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident])) + getTypeSynonym :: P.Qualified (P.ProperName 'P.TypeName) -> m (Maybe ([(Text, Maybe P.SourceType)], P.SourceType)) + getTypeClass :: P.Qualified (P.ProperName 'P.ClassName) -> m (Maybe P.TypeClassData) + getTypeClassDictionary :: P.Qualified (P.ProperName 'P.ClassName) -> m [NamedDict] + hasTypeClassInEnv :: P.Qualified P.Ident -> m Bool + hasEnv :: m Bool + deleteModuleEnv :: P.ModuleName -> m () + logGetEnv :: Text -> m () + + +instance (Monad m, GetEnv m) => GetEnv (MaybeT m ) where + getName = lift . getName + getType = lift . getType + getDataConstructor = lift . getDataConstructor + getTypeSynonym = lift . getTypeSynonym + getTypeClass = lift . getTypeClass + getTypeClassDictionary = lift . getTypeClassDictionary + hasTypeClassInEnv = lift . hasTypeClassInEnv + deleteModuleEnv = lift . deleteModuleEnv + logGetEnv = lift . logGetEnv + hasEnv = lift hasEnv +instance (Monad m, GetEnv m) => GetEnv (ExceptT e m ) where + getName = lift . getName + getType = lift . getType + getDataConstructor = lift . getDataConstructor + getTypeSynonym = lift . getTypeSynonym + getTypeClass = lift . getTypeClass + getTypeClassDictionary = lift . getTypeClassDictionary + hasTypeClassInEnv = lift . hasTypeClassInEnv + deleteModuleEnv = lift . deleteModuleEnv + logGetEnv = lift . logGetEnv + hasEnv = lift hasEnv + +instance (Monad m, Monoid w, GetEnv m) => GetEnv (WriterT w m ) where + getName = lift . getName + getType = lift . getType + getDataConstructor = lift . getDataConstructor + getTypeSynonym = lift . getTypeSynonym + getTypeClass = lift . getTypeClass + getTypeClassDictionary = lift . getTypeClassDictionary + hasTypeClassInEnv = lift . hasTypeClassInEnv + deleteModuleEnv = lift . deleteModuleEnv + logGetEnv = lift . logGetEnv + hasEnv = lift hasEnv +instance (Monad m, Monoid w, GetEnv m) => GetEnv (Strict.WriterT w m ) where + getName = lift . getName + getType = lift . getType + getDataConstructor = lift . getDataConstructor + getTypeSynonym = lift . getTypeSynonym + getTypeClass = lift . getTypeClass + getTypeClassDictionary = lift . getTypeClassDictionary + hasTypeClassInEnv = lift . hasTypeClassInEnv + deleteModuleEnv = lift . deleteModuleEnv + logGetEnv = lift . logGetEnv + hasEnv = lift hasEnv + +newtype DbEnv m a = DbEnv (ReaderT Connection m a) + deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadError e, MonadWriter w, MonadTrans) + +instance MonadSupply m => MonadSupply (DbEnv m) + + +runDbEnv :: Connection -> DbEnv m a -> m a +runDbEnv conn (DbEnv m) = runReaderT m conn + +instance (MonadIO m) => GetEnv (DbEnv m) where + getName ident = DbEnv $ do + conn <- ask + liftIO $ selectEnvValue conn ident + getType ty = DbEnv $ do + conn <- ask + liftIO $ selectType conn ty + getDataConstructor ctr = DbEnv $ do + conn <- ask + liftIO $ selectDataConstructor conn ctr + getTypeSynonym syn = DbEnv $ do + conn <- ask + liftIO $ selectTypeSynonym conn syn + getTypeClass cls = DbEnv $ do + conn <- ask + liftIO $ selectTypeClass' conn cls + deleteModuleEnv modName = DbEnv $ do + conn <- ask + liftIO $ deleteModuleEnvImpl modName conn + hasTypeClassInEnv ident = DbEnv $ do + conn <- ask + liftIO $ selectDoesClassInstanceExist conn ident + logGetEnv msg = DbEnv $ do + liftIO $ putErrText msg + + hasEnv = pure True + + + getTypeClassDictionary cls = DbEnv $ do + conn <- ask + liftIO $ selectClassInstancesByClassName conn cls + + +newtype WoGetEnv m a = WoGetEnv (m a) + deriving (Functor, Applicative, Monad, MonadIO, MonadState s, MonadError e, MonadWriter w) + +runWoGetEnv :: WoGetEnv m a -> m a +runWoGetEnv (WoGetEnv m) = m + +instance MonadSupply m => MonadSupply (WoGetEnv m) where + fresh = WoGetEnv fresh + peek = WoGetEnv peek + +instance Monad m => GetEnv (WoGetEnv m) where + getName _ = pure Nothing + getType _ = pure Nothing + getDataConstructor _ = pure Nothing + getTypeSynonym _ = pure Nothing + getTypeClass _ = pure Nothing + getTypeClassDictionary _ = pure [] + hasTypeClassInEnv _ = pure False + deleteModuleEnv _ = pure () + logGetEnv _ = pure () + + hasEnv = pure False + + + +-- | Create an environment from a collection of externs files +dbEnv + :: forall m + . (MonadIO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Connection + -> P.Env + -> SourceSpan + -> P.ModuleName + -> m P.Env +dbEnv conn env ss modName = do + exports <- liftIO $ selectModuleExports conn modName + imports <- liftIO $ selectModuleExternImports conn modName + ctrs <- liftIO $ selectModuleTypesAndCtrs conn modName + types <- liftIO $ selectModuleTypes conn modName + + let members = P.Exports{..} + env' = M.insert modName (ss, nullImports, members) env + fromEFImport (ExternsImport mn mt qmn) = (mn, [(ss, Just mt, qmn)]) + + exportedCtrs = ctrs <&> \(ty, cs) -> (ty, ([cs], localExportSource)) + + exportedTypes' = types <&> (, ([], localExportSource)) + + exportedTypes :: M.Map (P.ProperName 'P.TypeName) ([P.ProperName 'P.ConstructorName], ExportSource) + exportedTypes = M.fromListWith combineCtrs $ exportedCtrs <> exportedTypes' + where + combineCtrs (cs1, e) (cs2, _) = (cs1 <> cs2, e) + + exportedTypeOps :: M.Map (P.OpName 'P.TypeOpName) ExportSource + exportedTypeOps = exportedRefs P.getTypeOpRef + + exportedTypeClasses :: M.Map (P.ProperName 'P.ClassName) ExportSource + exportedTypeClasses = exportedRefs P.getTypeClassRef + + exportedValues :: M.Map P.Ident ExportSource + exportedValues = exportedRefs P.getValueRef + + exportedValueOps :: M.Map (P.OpName 'P.ValueOpName) ExportSource + exportedValueOps = exportedRefs P.getValueOpRef + + exportedRefs :: Ord a => (P.DeclarationRef -> Maybe a) -> M.Map a ExportSource + exportedRefs f = + M.fromList $ (, localExportSource) <$> mapMaybe f exports + + imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport imports) + exps <- resolveExports env' ss modName imps members exports + return $ M.insert modName (ss, imps, exps) env + where + + -- An ExportSource for declarations local to the module which the given + -- ExternsFile corresponds to. + localExportSource = + ExportSource { exportSourceDefinedIn = modName + , exportSourceImportedFrom = Nothing + } + + + +selectModuleTypesAndCtrs :: Connection -> P.ModuleName -> IO [(P.ProperName 'P.TypeName, P.ProperName 'P.ConstructorName)] +selectModuleTypesAndCtrs conn modName = do + SQL.query + conn + "SELECT type_name, constructor_name FROM env_data_constructors WHERE module_name = ?" + (SQL.Only modName) + +selectModuleTypes :: Connection -> P.ModuleName -> IO [P.ProperName 'P.TypeName] +selectModuleTypes conn modName = do + fmap SQL.fromOnly <$> SQL.query + conn + "SELECT type_name FROM env_types WHERE module_name = ?" + (SQL.Only modName) \ No newline at end of file diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index e5df3610bf..32e1633d4f 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,26 +1,29 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} -- | -- Data types for names --- module Language.PureScript.Names where -import Prelude - import Codec.Serialise (Serialise) import Control.Applicative ((<|>)) -import Control.Monad.Supply.Class (MonadSupply(..)) import Control.DeepSeq (NFData) -import Data.Functor.Contravariant (contramap) -import Data.Vector qualified as V - -import GHC.Generics (Generic) -import Data.Aeson (FromJSON(..), FromJSONKey(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..), defaultOptions, parseJSON2, toJSON2, withArray) +import Control.Monad.Supply.Class (MonadSupply (..)) +import Data.Aeson (FromJSON (..), FromJSONKey (..), Options (..), SumEncoding (..), ToJSON (..), ToJSONKey (..), defaultOptions, parseJSON2, toJSON2, withArray) +import Data.Aeson qualified as A import Data.Aeson.TH (deriveJSON) +import Data.Functor.Contravariant (contramap) import Data.Text (Text) import Data.Text qualified as T - +import Data.Vector qualified as V +import Database.SQLite.Simple.FromField (FromField (fromField)) +import Database.SQLite.Simple.ToField (ToField (toField)) +import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) +import Prelude +import Protolude (isUpper) +import Database.SQLite.Simple.Ok (Ok) +import Data.Char (isAlphaNum) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -34,6 +37,7 @@ data Name deriving (Eq, Ord, Show, Generic) instance NFData Name + instance Serialise Name getIdentName :: Name -> Maybe Ident @@ -66,38 +70,35 @@ getClassName _ = Nothing -- `Ident` because functions that match on `Ident` can ignore all -- `InternalIdent`s with a single pattern, and thus don't have to change if -- a new `InternalIdentData` constructor is created. --- data InternalIdentData - -- Used by CoreFn.Laziness - = RuntimeLazyFactory | Lazy !Text + = -- Used by CoreFn.Laziness + RuntimeLazyFactory + | Lazy !Text deriving (Show, Eq, Ord, Generic) instance NFData InternalIdentData + instance Serialise InternalIdentData -- | -- Names for value identifiers --- data Ident - -- | - -- An alphanumeric identifier - -- - = Ident Text - -- | - -- A generated name for an identifier - -- - | GenIdent (Maybe Text) Integer - -- | - -- A generated name used only for type-checking - -- - | UnusedIdent - -- | - -- A generated name used only for internal transformations - -- - | InternalIdent !InternalIdentData + = -- | + -- An alphanumeric identifier + Ident Text + | -- | + -- A generated name for an identifier + GenIdent (Maybe Text) Integer + | -- | + -- A generated name used only for type-checking + UnusedIdent + | -- | + -- A generated name used only for internal transformations + InternalIdent !InternalIdentData deriving (Show, Eq, Ord, Generic) instance NFData Ident + instance Serialise Ident unusedIdent :: Text @@ -108,30 +109,36 @@ runIdent (Ident i) = i runIdent (GenIdent Nothing n) = "$" <> T.pack (show n) runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n) runIdent UnusedIdent = unusedIdent -runIdent InternalIdent{} = error "unexpected InternalIdent" +runIdent InternalIdent {} = error "unexpected InternalIdent" showIdent :: Ident -> Text showIdent = runIdent -freshIdent :: MonadSupply m => Text -> m Ident +freshIdent :: (MonadSupply m) => Text -> m Ident freshIdent name = GenIdent (Just name) <$> fresh -freshIdent' :: MonadSupply m => m Ident +freshIdent' :: (MonadSupply m) => m Ident freshIdent' = GenIdent Nothing <$> fresh isPlainIdent :: Ident -> Bool -isPlainIdent Ident{} = True +isPlainIdent Ident {} = True isPlainIdent _ = False -- | -- Operator alias names. --- -newtype OpName (a :: OpNameType) = OpName { runOpName :: Text } +newtype OpName (a :: OpNameType) = OpName {runOpName :: Text} deriving (Show, Eq, Ord, Generic) instance NFData (OpName a) + instance Serialise (OpName a) +instance ToField (OpName a) where + toField (OpName a) = toField a + +instance FromField (OpName a) where + fromField a = OpName <$> fromField a + instance ToJSON (OpName a) where toJSON = toJSON . runOpName @@ -143,7 +150,6 @@ showOp op = "(" <> runOpName op <> ")" -- | -- The closed set of operator alias types. --- data OpNameType = ValueOpName | TypeOpName | AnyOpName eraseOpName :: OpName a -> OpName 'AnyOpName @@ -154,11 +160,11 @@ coerceOpName = OpName . runOpName -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. --- -newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text } +newtype ProperName (a :: ProperNameType) = ProperName {runProperName :: Text} deriving (Show, Eq, Ord, Generic) instance NFData (ProperName a) + instance Serialise (ProperName a) instance ToJSON (ProperName a) where @@ -167,29 +173,38 @@ instance ToJSON (ProperName a) where instance FromJSON (ProperName a) where parseJSON = fmap ProperName . parseJSON + +instance ToField (ProperName a) where + toField (ProperName a) = toField a + +instance FromField (ProperName a) where + fromField a = do + n <- fromField a + if isUpper $ T.head n then + pure $ ProperName n + else + fail "ProperName must be capitalized" -- | -- The closed set of proper name types. --- data ProperNameType = TypeName | ConstructorName | ClassName | Namespace + deriving (Show, Generic, A.FromJSON, A.ToJSON) -- | -- Coerces a ProperName from one ProperNameType to another. This should be used -- with care, and is primarily used to convert ClassNames into TypeNames after -- classes have been desugared. --- coerceProperName :: ProperName a -> ProperName b coerceProperName = ProperName . runProperName -- | -- Module names --- newtype ModuleName = ModuleName Text deriving (Show, Eq, Ord, Generic) - deriving newtype Serialise + deriving newtype (Serialise, ToField, FromField) instance NFData ModuleName @@ -211,6 +226,7 @@ pattern ByNullSourcePos :: QualifiedBy pattern ByNullSourcePos = BySourcePos (SourcePos 0 0) instance NFData QualifiedBy + instance Serialise QualifiedBy isBySourcePos :: QualifiedBy -> Bool @@ -227,15 +243,15 @@ toMaybeModuleName (BySourcePos _) = Nothing -- | -- A qualified name, i.e. a name with an optional module name --- data Qualified a = Qualified QualifiedBy a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) -instance NFData a => NFData (Qualified a) -instance Serialise a => Serialise (Qualified a) +instance (NFData a) => NFData (Qualified a) +instance (Serialise a) => Serialise (Qualified a) + showQualified :: (a -> Text) -> Qualified a -> Text -showQualified f (Qualified (BySourcePos _) a) = f a +showQualified f (Qualified (BySourcePos _) a) = f a showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a getQual :: Qualified a -> Maybe ModuleName @@ -243,14 +259,12 @@ getQual (Qualified qb _) = toMaybeModuleName qb -- | -- Provide a default module name, if a name is unqualified --- qualify :: ModuleName -> Qualified a -> (ModuleName, a) qualify m (Qualified (BySourcePos _) a) = (m, a) qualify _ (Qualified (ByModuleName m) a) = (m, a) -- | -- Makes a qualified value from a name and module name. --- mkQualified :: a -> ModuleName -> Qualified a mkQualified name mn = Qualified (ByModuleName mn) name @@ -261,48 +275,44 @@ disqualify (Qualified _ a) = a -- | -- Remove the qualification from a value when it is qualified with a particular -- module name. --- disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a disqualifyFor _ _ = Nothing -- | -- Checks whether a qualified value is actually qualified with a module reference --- isQualified :: Qualified a -> Bool -isQualified (Qualified (BySourcePos _) _) = False +isQualified (Qualified (BySourcePos _) _) = False isQualified _ = True -- | -- Checks whether a qualified value is not actually qualified with a module reference --- isUnqualified :: Qualified a -> Bool isUnqualified = not . isQualified -- | -- Checks whether a qualified value is qualified with a particular module --- isQualifiedWith :: ModuleName -> Qualified a -> Bool isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn' isQualifiedWith _ _ = False -instance ToJSON a => ToJSON (Qualified a) where +instance (ToJSON a) => ToJSON (Qualified a) where toJSON (Qualified qb a) = case qb of ByModuleName mn -> toJSON2 (mn, a) BySourcePos ss -> toJSON2 (ss, a) -instance FromJSON a => FromJSON (Qualified a) where +instance (FromJSON a) => FromJSON (Qualified a) where parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName' where - byModule = do - (mn, a) <- parseJSON2 v - pure $ Qualified (ByModuleName mn) a - bySourcePos = do - (ss, a) <- parseJSON2 v - pure $ Qualified (BySourcePos ss) a - byMaybeModuleName' = do - (mn, a) <- parseJSON2 v - pure $ Qualified (byMaybeModuleName mn) a + byModule = do + (mn, a) <- parseJSON2 v + pure $ Qualified (ByModuleName mn) a + bySourcePos = do + (ss, a) <- parseJSON2 v + pure $ Qualified (BySourcePos ss) a + byMaybeModuleName' = do + (mn, a) <- parseJSON2 v + pure $ Qualified (byMaybeModuleName mn) a instance ToJSON ModuleName where toJSON (ModuleName name) = toJSON (T.splitOn "." name) @@ -318,5 +328,21 @@ instance ToJSONKey ModuleName where instance FromJSONKey ModuleName where fromJSONKey = fmap moduleNameFromString fromJSONKey -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) +$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''InternalIdentData) +$(deriveJSON (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Ident) + +instance ToField Ident where + toField = \case + Ident a -> toField a + ident -> toField $ A.encode ident + +instance FromField Ident where + fromField a = (decodeAlphaNumIdent =<< fromField a) <|> (decodeJsonIdent =<< fromField a) + where + decodeAlphaNumIdent :: Text -> Ok Ident + decodeAlphaNumIdent txt = if all (\c -> isAlphaNum c || c == '\'') $ T.unpack txt then + pure $ Ident txt + else + fail $ "Failed to decode alphanum ident: " <> show txt + + decodeJsonIdent str = maybe (fail $ "Failed to decode json ident: " <> show str) pure $ A.decode str 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/Renamer.hs b/src/Language/PureScript/Renamer.hs index aff42ca288..44f8f3875f 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -16,7 +16,7 @@ import Data.Set qualified as S import Data.Text qualified as T import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), Expr(..), Literal(..), Module(..)) -import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent, showIdent) +import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent) import Language.PureScript.Traversals (eitherM, pairM, sndM) -- | @@ -87,13 +87,14 @@ updateScope ident = -- | -- Finds the new name to use for an ident. -- -lookupIdent :: Ident -> Rename Ident -lookupIdent UnusedIdent = return UnusedIdent -lookupIdent name = do +lookupIdent :: Show a => a -> Ident -> Rename Ident +lookupIdent _ UnusedIdent = return UnusedIdent +lookupIdent modName name = do name' <- gets $ M.lookup name . rsBoundNames case name' of Just name'' -> return name'' - Nothing -> error $ "Rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'" + Nothing -> + error $ "In " ++ (show modName :: [Char]) ++ " rename scope is missing ident '" ++ show name ++ "'" -- | @@ -102,10 +103,10 @@ lookupIdent name = do -- externs files as well. -- renameInModule :: Module Ann -> (M.Map Ident Ident, Module Ann) -renameInModule m@(Module _ _ _ _ _ exports _ foreigns decls) = (rsBoundNames, m { moduleExports, moduleDecls }) +renameInModule m@(Module _ _ name _ _ exports _ foreigns decls) = (rsBoundNames, m { moduleExports, moduleDecls }) where ((moduleDecls, moduleExports), RenameState{..}) = runRename foreigns $ - (,) <$> renameInDecls decls <*> traverse lookupIdent exports + (,) <$> renameInDecls decls <*> traverse (lookupIdent name) exports -- | -- Renames within a list of declarations. The list is processed in three @@ -152,38 +153,38 @@ renameInDecls = renameValuesInDecl :: Bind Ann -> Rename (Bind Ann) renameValuesInDecl = \case - NonRec a name val -> NonRec a name <$> renameInValue val + NonRec a name val -> NonRec a name <$> renameInValue name val Rec ds -> Rec <$> traverse updateValues ds where updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) - updateValues (aname, val) = (aname, ) <$> renameInValue val + updateValues (aname, val) = (aname, ) <$> renameInValue (snd aname) val -- | -- Renames within a value. -- -renameInValue :: Expr Ann -> Rename (Expr Ann) -renameInValue (Literal ann l) = - Literal ann <$> renameInLiteral renameInValue l -renameInValue c@Constructor{} = return c -renameInValue (Accessor ann prop v) = - Accessor ann prop <$> renameInValue v -renameInValue (ObjectUpdate ann obj copy vs) = - (\obj' -> ObjectUpdate ann obj' copy) <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs -renameInValue (Abs ann name v) = - newScope $ Abs ann <$> updateScope name <*> renameInValue v -renameInValue (App ann v1 v2) = - App ann <$> renameInValue v1 <*> renameInValue v2 -renameInValue (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) = +renameInValue :: Ident -> Expr Ann -> Rename (Expr Ann) +renameInValue declName (Literal ann l) = + Literal ann <$> renameInLiteral (renameInValue declName) l +renameInValue _ c@Constructor{} = return c +renameInValue declName (Accessor ann prop v) = + Accessor ann prop <$> renameInValue declName v +renameInValue declName (ObjectUpdate ann obj copy vs) = + (\obj' -> ObjectUpdate ann obj' copy) <$> renameInValue declName obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue declName v) vs +renameInValue declName (Abs ann name v) = + newScope $ Abs ann <$> updateScope name <*> renameInValue declName v +renameInValue declName (App ann v1 v2) = + App ann <$> renameInValue declName v1 <*> renameInValue declName v2 +renameInValue declName (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) = -- This should only rename identifiers local to the current module: either -- they aren't qualified, or they are but they have a name that should not -- have appeared in a module's externs, so they must be from this module's -- top-level scope. - Var ann . Qualified qb <$> lookupIdent name -renameInValue v@Var{} = return v -renameInValue (Case ann vs alts) = - newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts -renameInValue (Let ann ds v) = - newScope $ Let ann <$> renameInDecls ds <*> renameInValue v + Var ann . Qualified qb <$> lookupIdent (declName, qb) name +renameInValue _ v@Var{} = return v +renameInValue declName (Case ann vs alts) = + newScope $ Case ann <$> traverse (renameInValue declName) vs <*> traverse (renameInCaseAlternative declName) alts +renameInValue declName (Let ann ds v) = + newScope $ Let ann <$> renameInDecls ds <*> renameInValue declName v -- | -- Renames within literals. @@ -196,10 +197,10 @@ renameInLiteral _ l = return l -- | -- Renames within case alternatives. -- -renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann) -renameInCaseAlternative (CaseAlternative bs v) = newScope $ +renameInCaseAlternative :: Ident -> CaseAlternative Ann -> Rename (CaseAlternative Ann) +renameInCaseAlternative name (CaseAlternative bs v) = newScope $ CaseAlternative <$> traverse renameInBinder bs - <*> eitherM (traverse (pairM renameInValue renameInValue)) renameInValue v + <*> eitherM (traverse (pairM (renameInValue name) (renameInValue name))) (renameInValue name) v -- | -- Renames within binders. diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 4d713d5418..c1d7ad49d0 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -1,23 +1,18 @@ -- | -- Desugaring passes --- -module Language.PureScript.Sugar (desugar, module S) where +module Language.PureScript.Sugar (desugar, desugarUsingDb, 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 Language.PureScript.AST (Module) import Language.PureScript.Errors (MultipleErrors) import Language.PureScript.Externs (ExternsFile) import Language.PureScript.Linter.Imports (UsedImports) +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 +20,9 @@ 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 +import Database.SQLite.Simple (Connection) +import Language.PureScript.Make.Index.Select (selectFixitiesFromModuleImports) -- | -- The desugaring pipeline proceeds as follows: @@ -50,15 +48,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 +70,33 @@ desugar externs = >=> deriveInstances >=> desugarTypeClasses externs >=> createBindingGroupsModule + +desugarUsingDb :: + (MonadSupply m, MonadIO m) => + (MonadWriter MultipleErrors m) => + (MonadError MultipleErrors m) => + (MonadState (Env, UsedImports) m) => + Connection -> + Env -> + Module -> + m Module +desugarUsingDb conn env = do + desugarSignedLiterals + >>> desugarObjectConstructors + >=> desugarDoModule + >=> desugarAdoModule + >=> desugarLetPatternModule + >>> desugarCasesModule + >=> desugarTypeDeclarationsModule + >=> desugarImports + >=> rebracketUsingDb + >=> checkFixityExports + >=> deriveInstances + >=> desugarTypeClassesUsingDB conn + >=> createBindingGroupsModule + + where + rebracketUsingDb m = do + (fixities, typeFixities) <- liftIO $ selectFixitiesFromModuleImports conn env m + rebracketFixitiesOnly (const True) fixities typeFixities m + \ No newline at end of file diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d2f9aebf2b..5d024cafc1 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -6,6 +6,8 @@ module Language.PureScript.Sugar.BindingGroups ( createBindingGroups , createBindingGroupsModule , collapseBindingGroups + , usedIdents + , usedTypeNames ) where import Prelude diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index d081764d7f..66b6ca9846 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -112,6 +112,7 @@ externsEnv env ExternsFile{..} = do exportedRefs f = M.fromList $ (, localExportSource) <$> mapMaybe f efExports + -- | -- Make all exports for a module explicit. This may still affect modules that -- have an exports list, as it will also make all data constructor exports diff --git a/src/Language/PureScript/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..9aa63c2dad 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -4,99 +4,134 @@ -- -- 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, + rebracketFiltered', + checkFixityExports, + fromExternFixities, + ) +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, HasCallStack) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition) +import Language.PureScript.Externs (ExternsFile (..), ExternsFixity (..), ExternsTypeFixity (..)) +import Language.PureScript.Names (Ident (..), Name (..), OpName, OpNameType (..), ProperName, ProperNameType (..), Qualified (..), QualifiedBy (..), freshIdent', pattern ByNullSourcePos) +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. + HasCallStack => + (MonadError MultipleErrors m) => + (MonadSupply m) => + (Declaration -> Bool) -> + [(P.ModuleName, [ExternsFixity])] -> + [(P.ModuleName, [ExternsTypeFixity])] -> + Module -> + m Module +rebracketFixitiesOnly pred_ exFixities exTypeFixities = + rebracketFiltered' CalledByCompile pred_ $ fromExternFixities exFixities exTypeFixities + -- fixities <> typeFixities +-- +fromExternFixities :: (Foldable t1, Foldable t2) => t2 (P.ModuleName, [ExternsFixity]) -> t1 (P.ModuleName, [ExternsTypeFixity]) -> [Either ValueFixityRecord TypeFixityRecord] +fromExternFixities exFixities exTypeFixities = fixities <> typeFixities + where + fixities = concatMap (\(mName, fs) -> fmap (fromFixity mName) fs) exFixities + typeFixities = concatMap (\(mName, fs) -> fmap (fromTypeFixity mName) fs) exTypeFixities + -- >>= \(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. + HasCallStack => + (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. + HasCallStack => + (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 +141,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 +227,40 @@ 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. + HasCallStack => + (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 +270,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 +304,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/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index 29725c711a..6f9417a798 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -8,9 +8,11 @@ import Language.PureScript.AST (Associativity, Binder(..), SourceSpan) import Language.PureScript.Errors (MultipleErrors) import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) import Language.PureScript.Sugar.Operators.Common (matchOperators) +import GHC.Stack (HasCallStack) matchBinderOperators - :: MonadError MultipleErrors m + :: HasCallStack + => MonadError MultipleErrors m => [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Binder -> m Binder diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 7fd6df9645..0f9a354caa 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -1,4 +1,5 @@ -module Language.PureScript.Sugar.Operators.Common where +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +module Language.PureScript.Sugar.Operators.Common (Chain, matchOperators, token) where import Prelude @@ -17,7 +18,7 @@ import Text.Parsec.Pos qualified as P import Text.Parsec.Expr qualified as P import Language.PureScript.AST (Associativity(..), ErrorMessageHint(..), SourceSpan) -import Language.PureScript.Crash (internalError) +import Language.PureScript.Crash (internalError, HasCallStack) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..)) import Language.PureScript.Names (OpName, Qualified, eraseOpName) @@ -61,7 +62,8 @@ opTable ops fromOp reapply = matchOperators :: forall m a nameType - . Show a + . HasCallStack + => Show a => MonadError MultipleErrors m => (a -> Bool) -> (a -> Maybe (a, a, a)) @@ -104,9 +106,10 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains opInfo :: M.Map (Qualified (OpName nameType)) (Integer, Associativity) opInfo = M.fromList $ concatMap (\(n, o) -> map (\(name, assoc) -> (name, (n, assoc))) o) (zip [0..] ops) opPrec :: Qualified (OpName nameType) -> Integer - opPrec = fst . fromJust . flip M.lookup opInfo + opPrec a = fst $ fromJust' a $ M.lookup a opInfo opAssoc :: Qualified (OpName nameType) -> Associativity - opAssoc = snd . fromJust . flip M.lookup opInfo + opAssoc a = snd $ fromJust' a $ M.lookup a opInfo + chainOpSpans :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan) chainOpSpans = foldr (\(ss, name) -> M.alter (Just . maybe (pure ss) (NEL.cons ss)) name) M.empty . mapMaybe fromOp $ rights chain opUsages :: Qualified (OpName nameType) -> Int @@ -142,3 +145,9 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains mkPositionedError chainOpSpans grp = ErrorMessage [PositionedError (fromJust . flip M.lookup chainOpSpans =<< grp)] + +fromJust' :: HasCallStack => Show a => a -> Maybe b -> b +fromJust' a m = case m of + Just b -> b + Nothing -> internalError $ "mkErrors: lookup not found for: " ++ show a + \ No newline at end of file diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 0815eb1610..1e151397e8 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -12,9 +12,11 @@ import Language.PureScript.AST (Associativity, Expr(..), SourceSpan) import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) import Language.PureScript.Sugar.Operators.Common (Chain, matchOperators, token) import Language.PureScript.Errors (MultipleErrors) +import GHC.Stack (HasCallStack) matchExprOperators :: MonadError MultipleErrors m + => HasCallStack => [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Expr -> m Expr diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 81001511cb..847de3b5a7 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -8,9 +8,11 @@ import Language.PureScript.Errors (MultipleErrors) import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) import Language.PureScript.Sugar.Operators.Common (matchOperators) import Language.PureScript.Types (SourceType, Type(..), srcTypeApp) +import GHC.Stack (HasCallStack) matchTypeOperators :: MonadError MultipleErrors m + => HasCallStack => SourceSpan -> [[(Qualified (OpName 'TypeOpName), Associativity)]] -> SourceType diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4f3129baf8..3e367406e9 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -6,6 +6,7 @@ module Language.PureScript.Sugar.TypeClasses ( desugarTypeClasses , typeClassMemberName , superClassDictionaryNames + , desugarTypeClassesUsingDB ) where import Prelude @@ -13,7 +14,7 @@ import Prelude import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State (MonadState(..), StateT, evalStateT, modify) +import Control.Monad.State (StateT, evalStateT, modify, gets, MonadIO (liftIO)) import Control.Monad.Supply.Class (MonadSupply) import Data.Graph (SCC(..), stronglyConnComp) import Data.List (find, partition) @@ -35,10 +36,31 @@ import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations (desugarCases) import Language.PureScript.TypeClassDictionaries (superclassName) import Language.PureScript.Types +import Database.SQLite.Simple (Connection) +import Language.PureScript.Make.Index.Select (selectTypeClass) +import Control.Monad.State.Class (get) type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData -type Desugar = StateT MemberMap +class GetTypeClass m where + getTypeClass :: (ModuleName, ProperName 'ClassName) -> m (Maybe TypeClassData) + addTypeClass :: (ModuleName, ProperName 'ClassName) -> TypeClassData -> m () + + +instance Monad m => GetTypeClass (StateT MemberMap m) where + getTypeClass name = gets (M.lookup name) + addTypeClass name tc = modify (M.insert name tc) + +instance (MonadIO m) => GetTypeClass (StateT (Connection, MemberMap) m) where + getTypeClass qual@(m, name) = do + sync <- gets (M.lookup qual . snd) + case sync of + Just tc -> return (Just tc) + Nothing -> do + (conn, _) <- get + liftIO (selectTypeClass conn m name) + + addTypeClass name tc = modify (second (M.insert name tc)) -- | -- Add type synonym declarations for type class dictionary types, and value declarations for type class @@ -49,10 +71,31 @@ desugarTypeClasses => [ExternsFile] -> Module -> m Module -desugarTypeClasses externs = flip evalStateT initialState . desugarModule +desugarTypeClasses externs = go + $ M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) where - initialState :: MemberMap - initialState = + 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 + + go + :: (MonadSupply m, MonadError MultipleErrors m) + => MemberMap + -> Module + -> m Module + go classes = flip evalStateT initialState . desugarModule + where + initialState :: MemberMap + initialState = mkInitialState classes + +-- desugarTypeClassesUsingDb + +mkInitialState :: MemberMap -> MemberMap +mkInitialState classes = mconcat [ M.mapKeys (qualify C.M_Prim) primClasses , M.mapKeys (qualify C.M_Prim_Coerce) primCoerceClasses @@ -61,21 +104,24 @@ 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 +desugarTypeClassesUsingDB + :: (MonadIO m, MonadSupply m, MonadError MultipleErrors m) + => Connection + -> Module + -> m Module +desugarTypeClassesUsingDB conn = flip evalStateT initialState . desugarModule + where + initialState :: (Connection, MemberMap) + initialState = (conn, mkInitialState M.empty) desugarModule - :: (MonadSupply m, MonadError MultipleErrors m) + :: forall m. + (MonadSupply m, MonadError MultipleErrors m, GetTypeClass m) => Module - -> Desugar m Module + -> m Module desugarModule (Module ss coms name decls (Just exps)) = do let (classDecls, restDecls) = partition isTypeClassDecl decls classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls @@ -83,11 +129,11 @@ desugarModule (Module ss coms name decls (Just exps)) = do (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps) return $ Module ss coms name (concat restDeclss ++ concat classDeclss) $ Just (exps ++ catMaybes restNewExpss ++ catMaybes classNewExpss) where - desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m) - => ModuleName + desugarClassDecl :: + ModuleName -> [DeclarationRef] -> SCC Declaration - -> Desugar m (Maybe DeclarationRef, [Declaration]) + -> m (Maybe DeclarationRef, [Declaration]) desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d desugarClassDecl _ _ (CyclicSCC ds') | Just ds'' <- nonEmpty ds' = throwError . errorMessage' (declSourceSpan (NEL.head ds'')) $ CycleInTypeClassDeclaration (NEL.map classDeclName ds'') @@ -197,15 +243,16 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- }; -} desugarDecl - :: (MonadSupply m, MonadError MultipleErrors m) + :: forall m . + (MonadSupply m, MonadError MultipleErrors m, GetTypeClass m) => ModuleName -> [DeclarationRef] -> Declaration - -> Desugar m (Maybe DeclarationRef, [Declaration]) + -> m (Maybe DeclarationRef, [Declaration]) desugarDecl mn exps = go where go d@(TypeClassDeclaration sa name args implies deps members) = do - modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) + addTypeClass (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration sa na chainId idx name deps className tys body) = do name' <- desugarInstName name @@ -232,7 +279,7 @@ desugarDecl mn exps = go -- Completes the name generation for type class instances that do not have -- a unique name defined in source code. - desugarInstName :: MonadSupply m => Either Text Ident -> Desugar m Ident + desugarInstName :: Either Text Ident -> m Ident desugarInstName = either freshIdent pure expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef @@ -315,6 +362,7 @@ unit = srcTypeApp tyRecord srcREmpty typeInstanceDictionaryDeclaration :: forall m . MonadError MultipleErrors m + => GetTypeClass m => SourceAnn -> Ident -> ModuleName @@ -322,15 +370,14 @@ typeInstanceDictionaryDeclaration -> Qualified (ProperName 'ClassName) -> [SourceType] -> [Declaration] - -> Desugar m Declaration + -> m Declaration typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = rethrow (addHint (ErrorInInstance className tys)) $ do - m <- get -- Lookup the type arguments and member types for the type class TypeClassData{..} <- - maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $ - M.lookup (qualify mn className) m + maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return =<< + getTypeClass (qualify mn className) -- Replace the type arguments with the appropriate types in the member types let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) . tuple3To2) typeClassMembers @@ -367,7 +414,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = where - memberToValue :: [(Ident, SourceType)] -> Declaration -> Desugar m Expr + memberToValue :: [(Ident, SourceType)] -> Declaration -> m Expr memberToValue tys' (ValueDecl (ss', _) ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage' ss' $ ExtraneousClassMember ident className) return $ lookup ident tys' return val diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f012..31fc5267a5 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. -- @@ -8,10 +9,10 @@ module Language.PureScript.TypeChecker ) where import Prelude -import Protolude (headMay, maybeToLeft, ordNub) +import Protolude (headMay, maybeToLeft, ordNub, ifM, whenM) import Control.Lens ((^..), _2) -import Control.Monad (when, unless, void, forM, zipWithM_) +import Control.Monad (when, unless, void, forM, zipWithM_, (>=>)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) @@ -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,9 +47,11 @@ 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 +import Language.PureScript.Make.Index.Select (GetEnv (deleteModuleEnv, getTypeClass, logGetEnv, hasEnv, hasTypeClassInEnv, getType)) addDataType - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> DataDeclType -> ProperName 'TypeName @@ -69,7 +72,7 @@ addDataType moduleName dtype name args dctors ctorKind = do addDataConstructor moduleName dtype name dctor fields polyType addDataConstructor - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, GetEnv m) => ModuleName -> DataDeclType -> ProperName 'TypeName @@ -84,7 +87,7 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do putEnv $ env { dataConstructors = M.insert (Qualified (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } checkRoleDeclaration - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> RoleDeclarationData -> m () @@ -92,7 +95,8 @@ checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) warnAndRethrow (addHint (ErrorInRoleDeclaration name) . addHint (positionedError ss)) $ do env <- getEnv let qualName = Qualified (ByModuleName moduleName) name - case M.lookup qualName (types env) of + kindAndData <- lookupTypeMb qualName + case kindAndData of Just (kind, DataType dtype args dctors) -> do checkRoleDeclarationArity name declaredRoles (length args) checkRoles args declaredRoles @@ -104,7 +108,7 @@ checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) _ -> internalError "Unsupported role declaration" addTypeSynonym - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ProperName 'TypeName -> [(Text, Maybe SourceType)] @@ -122,14 +126,14 @@ addTypeSynonym moduleName name args ty kind = do , typeSynonyms = M.insert qualName (args, ty) (typeSynonyms env) } valueIsNotDefined - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, GetEnv m) => ModuleName -> Ident -> m () valueIsNotDefined moduleName name = do - env <- getEnv - case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of - Just _ -> throwError . errorMessage $ RedefinedIdent name + nameMb <- lookupName (Qualified (ByModuleName moduleName) name) + case nameMb of + Just found -> throwError . errorMessage $ RedefinedIdent name $ " valueIsNotDefined: " <> T.pack (show (name, found)) Nothing -> return () addValue @@ -145,7 +149,7 @@ addValue moduleName name ty nameKind = do addTypeClass :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => ModuleName -> Qualified (ProperName 'ClassName) -> [(Text, Maybe SourceType)] @@ -169,18 +173,26 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do mkNewClass :: m TypeClassData mkNewClass = do - env <- getEnv implies' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms implies - let ctIsEmpty = null classMembers && all (typeClassIsEmpty . findSuperClass env) implies' + ctIsEmpty <- if null classMembers + then allM (fmap typeClassIsEmpty . findSuperClass) implies' + else pure False pure $ makeTypeClassData args classMembers implies' dependencies ctIsEmpty where - findSuperClass env c = case M.lookup (constraintClass c) (typeClasses env) of - Just tcd -> tcd - Nothing -> internalError "Unknown super class in TypeClassDeclaration" + findSuperClass c = lookupTypeClassUnsafe $ constraintClass c + -- case M.lookup (constraintClass c) (typeClasses env) of + -- Just tcd -> tcd + -- Nothing -> internalError "Unknown super class in TypeClassDeclaration" toPair (TypeDeclaration (TypeDeclarationData _ ident ty)) = (ident, ty) toPair _ = internalError "Invalid declaration in TypeClassDeclaration" +allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool +allM _ [] = pure True +allM f (x:xs) = do + b <- f x + if b then allM f xs else pure False + addTypeClassDictionaries :: (MonadState CheckState m) => QualifiedBy @@ -228,7 +240,7 @@ checkTypeClassInstance cls i = check where -- Check that type synonyms are fully-applied in a type -- checkTypeSynonyms - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m) => SourceType -> m () checkTypeSynonyms = void . replaceAllTypeSynonyms @@ -250,14 +262,23 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- typeCheckAll :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => ModuleName -> [Declaration] -> m [Declaration] -typeCheckAll moduleName = traverse go +typeCheckAll moduleName = traverse go -- (logDecl >=> go >=> logDone) where + -- logDecl :: Declaration -> m Declaration + -- logDecl d = do + -- logGetEnv ("TypeChecking: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d)) + -- return d + + -- logDone :: Declaration -> m Declaration + -- logDone d = do + -- logGetEnv ("TypeChecked: " <> T.pack (show moduleName) <> ": " <> T.pack ( show $ declName d)) + -- return d 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 +288,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 +305,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 +332,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,32 +351,33 @@ 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 - env <- getEnv + go d@(ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do let declHint = if isPlainIdent name then addHint (ErrorInValueDeclaration name) else id warnAndRethrow (declHint . addHint (positionedError ss)) $ do - val' <- checkExhaustiveExpr ss env moduleName val + val' <- checkExhaustiveExpr ss moduleName val valueIsNotDefined moduleName name typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case [(_, (val'', ty))] -> do addValue moduleName name ty nameKind + addIdeDecl d ty + addIdeIdent ss name ty return $ ValueDecl sa name nameKind [] [MkUnguarded val''] _ -> internalError "typesOf did not return a singleton" go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do - env <- getEnv let sss = fmap (\(((ss, _), _), _, _) -> ss) vals warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, ident), _, _) -> ident) vals)) . addHint (PositionedError sss)) $ do for_ vals $ \((_, ident), _, _) -> valueIsNotDefined moduleName ident - vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss env moduleName expr) vals + vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss moduleName expr) vals tys <- typesOf RecursiveBindingGroup moduleName $ fmap (\(sai, _, ty) -> (sai, ty)) vals' vals'' <- forM [ (sai, val, nameKind, ty) | (sai@(_, name), nameKind, _) <- vals' , ((_, name'), (val, ty)) <- tys , name == name' - ] $ \(sai@(_, name), val, nameKind, ty) -> do + ] $ \(sai@((ss, _), name), val, nameKind, ty) -> do addValue moduleName name ty nameKind + addIdeIdent ss name ty return (sai, nameKind, val) return . BindingGroupDeclaration $ NEL.fromList vals'' go d@(ExternDataDeclaration (ss, _) name kind) = do @@ -365,15 +390,17 @@ typeCheckAll moduleName = traverse go return d go d@(ExternDeclaration (ss, _) name ty) = do warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do - env <- getEnv (elabTy, kind) <- withFreshSubstitution $ do ((unks, ty'), kind) <- kindOfWithUnknowns ty ty'' <- varIfUnknown unks ty' pure (ty'', kind) checkTypeKind elabTy kind - case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of - Just _ -> throwError . errorMessage $ RedefinedIdent name - Nothing -> putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) }) + nameMb <- lookupName (Qualified (ByModuleName moduleName) name) + case nameMb of + Just _ -> throwError . errorMessage $ RedefinedIdent name $ " typeCheckAll: " <> T.pack (show (Qualified (ByModuleName moduleName) name)) + Nothing -> do + env <- getEnv + putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) }) return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d @@ -385,33 +412,47 @@ 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) = rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do - env <- getEnv let qualifiedDictName = Qualified (ByModuleName moduleName) dictName - flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> - guardWith (errorMessage (DuplicateInstance dictName ss)) $ - not (M.member qualifiedDictName dictionaries) - case M.lookup className (typeClasses env) of - Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" - Just typeClass -> do - checkInstanceArity dictName className typeClass tys - (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys) - tys'' <- traverse replaceAllTypeSynonyms tys' - zipWithM_ (checkTypeClassInstance typeClass) [0..] tys'' - let nonOrphanModules = findNonOrphanModules className typeClass tys'' - checkOrphanInstance dictName className tys'' nonOrphanModules - let chainId = Just ch - checkOverlappingInstance ss chainId dictName vars className typeClass tys'' nonOrphanModules - _ <- traverseTypeInstanceBody checkInstanceMembers body - deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps' - let dict = - TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $ - if isPlainIdent dictName then Nothing else Just $ srcInstanceType ss vars className tys'' - addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) - return d + ifM hasEnv + (do + whenM (hasTypeClassInEnv qualifiedDictName) $ throwError . errorMessage $ DuplicateInstance dictName ss + ) + (do + env <- getEnv + flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> + guardWith (errorMessage (DuplicateInstance dictName ss)) $ + not (M.member qualifiedDictName dictionaries)) + typeClass <- lookupTypeClassUnsafe className + checkInstanceArity dictName className typeClass tys + (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys) + tys'' <- traverse replaceAllTypeSynonyms tys' + zipWithM_ (checkTypeClassInstance typeClass) [0..] tys'' + let nonOrphanModules = findNonOrphanModules className typeClass tys'' + checkOrphanInstance dictName className tys'' nonOrphanModules + let chainId = Just ch + checkOverlappingInstance ss chainId dictName vars className typeClass tys'' nonOrphanModules + _ <- traverseTypeInstanceBody checkInstanceMembers body + deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps' + let + srcType = srcInstanceType ss vars className tys'' + dict = + TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $ + if isPlainIdent dictName then Nothing else Just srcType + + addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) + + kind <- lookupTypeMb (coerceProperName <$> className) + + addIdeClassName (Just $ fromMaybe moduleName $ getQual className) ss + ( ProperName $ (("typeCheckAll: " <> T.pack (show tys'') <> " : ") <>) $ runProperName $ disqualify className) + $ maybe P.srcTypeWildcard fst kind + + return d checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m () checkInstanceArity dictName className typeClass tys = do @@ -579,7 +620,7 @@ checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name -- typeCheckModule :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => M.Map ModuleName Exports -> Module -> m Module @@ -587,6 +628,7 @@ typeCheckModule _ (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated before typeCheckModule" typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do + deleteModuleEnv mn let (decls', imports) = partitionEithers $ fromImportDecl <$> decls modify (\s -> s { checkCurrentModule = Just mn, checkCurrentModuleImports = imports }) decls'' <- typeCheckAll mn $ ignoreWildcardsUnderCompleteTypeSignatures <$> decls' diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 8d5dcde9b6..ad6cd23413 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -24,14 +24,15 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) -import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule) +import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule, lookupTypeClassOrThrow, lookupTypeClassMb, lookupTypeClassDictionariesForClass, addDictsToEnvMap) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, SourceType, Type(..), completeBinderList, eqType, everythingOnTypes, replaceAllTypeVars, srcTypeVar, usedTypeVariables) +import Language.PureScript.Make.Index.Select (GetEnv (getTypeClassDictionary)) -- | Extract the name of the newtype appearing in the last type argument of -- a derived newtype instance. @@ -48,6 +49,7 @@ extractNewtypeName mn deriveInstance :: forall m . MonadError MultipleErrors m + => GetEnv m => MonadState CheckState m => MonadSupply m => MonadWriter MultipleErrors m @@ -57,13 +59,10 @@ deriveInstance -> m Expr deriveInstance instType className strategy = do mn <- unsafeCheckCurrentModule - env <- getEnv instUtc@UnwrappedTypeConstructor{ utcArgs = tys } <- maybe (internalCompilerError "invalid instance type") pure $ unwrapTypeConstructor instType let ctorName = coerceProperName <$> utcQTyCon instUtc - TypeClassData{..} <- - note (errorMessage . UnknownName $ fmap TyClassName className) $ - className `M.lookup` typeClasses env + TypeClassData{..} <- lookupTypeClassOrThrow className case strategy of KnownClassStrategy -> let @@ -111,6 +110,7 @@ deriveNewtypeInstance . MonadError MultipleErrors m => MonadState CheckState m => MonadWriter MultipleErrors m + => GetEnv m => Qualified (ProperName 'ClassName) -> [SourceType] -> UnwrappedTypeConstructor @@ -151,11 +151,12 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs verifySuperclasses :: m () verifySuperclasses = do - env <- getEnv - for_ (M.lookup className (typeClasses env)) $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } -> + typeClass <- lookupTypeClassMb className + for_ typeClass $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } -> for_ superclasses $ \Constraint{..} -> do let constraintClass' = qualify (internalError "verifySuperclasses: unknown class module") constraintClass - for_ (M.lookup constraintClass (typeClasses env)) $ \TypeClassData{ typeClassDependencies = deps } -> + conTypeClass <- lookupTypeClassMb constraintClass + for_ conTypeClass $ \TypeClassData{ typeClassDependencies = deps } -> -- We need to check whether the newtype is mentioned, because of classes like MonadWriter -- with its Monoid superclass constraint. when (not (null args) && any ((fst (last args) `elem`) . usedTypeVariables) constraintArgs) $ do @@ -171,20 +172,23 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs -- check, since the superclass might have multiple type arguments, so overlaps might still -- be possible, so we warn again. for_ (extractNewtypeName mn tys) $ \nm -> do - unless (hasNewtypeSuperclassInstance constraintClass' nm (typeClassDictionaries env)) $ + consDicts <- lookupTypeClassDictionariesForClass (ByModuleName (fst constraintClass')) constraintClass + newtypeDicts <- lookupTypeClassDictionariesForClass (ByModuleName (fst nm)) constraintClass + unless (hasNewtypeSuperclassInstance constraintClass' nm (consDicts <> newtypeDicts)) $ tell . errorMessage $ MissingNewtypeSuperclassInstance constraintClass className tys else tell . errorMessage $ UnverifiableSuperclassInstance constraintClass className tys -- Note that this check doesn't actually verify that the superclass is -- newtype-derived; see #3168. The whole verifySuperclasses feature -- is pretty sketchy, and could use a thorough review and probably rewrite. - hasNewtypeSuperclassInstance (suModule, suClass) nt@(newtypeModule, _) dicts = - let su = Qualified (ByModuleName suModule) suClass + hasNewtypeSuperclassInstance (suModule, _) nt@(newtypeModule, _) dicts = + let getDictNewtypeNames mn' = + toList . extractNewtypeName mn' . tcdInstanceTypes + <=< foldMap toList . M.elems lookIn mn' = elem nt - . (toList . extractNewtypeName mn' . tcdInstanceTypes - <=< foldMap toList . M.elems - <=< toList . (M.lookup su <=< M.lookup (ByModuleName mn'))) + . (getDictNewtypeNames mn' + <=< toList . Just) $ dicts in lookIn suModule || lookIn newtypeModule @@ -207,7 +211,7 @@ lookupTypeInfo UnwrappedTypeConstructor{..} = do deriveEq :: forall m - . MonadError MultipleErrors m + . (MonadError MultipleErrors m, GetEnv m) => MonadState CheckState m => MonadSupply m => UnwrappedTypeConstructor @@ -269,6 +273,7 @@ deriveEq1 = pure [(Libs.S_eq1, mkRef Libs.I_eq)] deriveOrd :: forall m . MonadError MultipleErrors m + => GetEnv m => MonadState CheckState m => MonadSupply m => UnwrappedTypeConstructor @@ -439,6 +444,7 @@ validateParamsInTypeConstructors :: forall c m . MonadError MultipleErrors m => MonadState CheckState m + => GetEnv m => Qualified (ProperName 'ClassName) -> UnwrappedTypeConstructor -> Bool @@ -456,7 +462,8 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con (True, _) -> Left $ kindType -:> kindType ctors <- traverse (traverse $ traverse replaceAllTypeSynonyms) tiCtors tcds <- getTypeClassDictionaries - let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf tcds tiArgSubst (maybe That These mbLParam param) False) ctors + classTcds <- getTypeClassDictionary derivingClass + let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf (addDictsToEnvMap classTcds tcds) tiArgSubst (maybe That These mbLParam param) False) ctors let relatedClasses = [monoClass, biClass] ++ ([contraClass, proClass] <*> (contravariantClasses <$> toList contravarianceSupport)) for_ (nonEmpty $ ordNub problemSpans) $ \sss -> throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass relatedClasses (isJust contravarianceSupport) @@ -645,7 +652,7 @@ mkTraversal mn isBi te@TraversalExprs{..} getContraversalExprs (TraversalOps @_ deriveFunctor :: forall m - . MonadError MultipleErrors m + . (MonadError MultipleErrors m, GetEnv m) => MonadState CheckState m => MonadSupply m => Maybe Bool -- does left parameter exist, and is it contravariant? @@ -691,7 +698,7 @@ applyWhen cond f = if cond then f else identity deriveFoldable :: forall m - . MonadError MultipleErrors m + . (MonadError MultipleErrors m, GetEnv m) => MonadState CheckState m => MonadSupply m => Bool -- is there a left parameter (are we deriving Bifoldable)? @@ -788,7 +795,7 @@ foldMapOps = TraversalOps { visitExpr = toConst, .. } deriveTraversable :: forall m - . MonadError MultipleErrors m + . (MonadError MultipleErrors m, GetEnv m) => MonadState CheckState m => MonadSupply m => Bool -- is there a left parameter (are we deriving Bitraversable)? diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 85bdfee4aa..9a2389cc5a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -38,13 +38,13 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Literal(..), pattern NullSourceSpan, everywhereOnValuesTopDownM, nullSourceSpan, everythingOnValues) import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) +import Language.PureScript.Environment (FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual) import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') -import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint) +import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint, lookupTypeClassMb, lookupTypeClassUnsafe, addDictsToEnvMap) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, substituteType, unifyTypes) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..), superclassName) @@ -53,6 +53,7 @@ import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString, mkString, decodeString) import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.Constants.Prim qualified as C +import Language.PureScript.Make.Index.Select (GetEnv (getTypeClassDictionary)) -- | Describes what sort of dictionary to generate for type class instances data Evidence @@ -113,7 +114,7 @@ combineContexts = M.unionWith (M.unionWith (M.unionWith (<>))) -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m, GetEnv m) => Bool -> Expr -> m (Expr, [(Ident, InstanceContext, SourceConstraint)]) @@ -181,7 +182,7 @@ instance Monoid t => Monoid (Matched t) where -- return a type class dictionary reference. entails :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m, GetEnv m) => SolverOptions -- ^ Solver options -> SourceConstraint @@ -194,34 +195,34 @@ entails entails SolverOptions{..} constraint context hints = overConstraintArgsAll (lift . lift . traverse replaceAllTypeSynonyms) constraint >>= solve where - forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict] - forClassNameM env ctx cn@C.Coercible kinds args = - fromMaybe (forClassName env ctx cn kinds args) <$> - solveCoercible env ctx kinds args - forClassNameM env ctx cn kinds args = - pure $ forClassName env ctx cn kinds args - - forClassName :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> [TypeClassDict] - forClassName _ ctx cn@C.Warn _ [msg] = + forClassNameM :: InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict] + forClassNameM ctx cn@C.Coercible kinds args = + fromMaybe (forClassName ctx cn kinds args) <$> + solveCoercible ctx kinds args + forClassNameM ctx cn kinds args = + pure $ forClassName ctx cn kinds args + + forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> [TypeClassDict] + forClassName ctx cn@C.Warn _ [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. findDicts ctx cn ByNullSourcePos ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing Nothing] - forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts - forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts - forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts - forClassName _ _ C.SymbolCons _ args | Just dicts <- solveSymbolCons args = dicts - forClassName _ _ C.IntAdd _ args | Just dicts <- solveIntAdd args = dicts - forClassName _ ctx C.IntCompare _ args | Just dicts <- solveIntCompare ctx args = dicts - forClassName _ _ C.IntMul _ args | Just dicts <- solveIntMul args = dicts - forClassName _ _ C.IntToString _ args | Just dicts <- solveIntToString args = dicts - forClassName _ _ C.Reflectable _ args | Just dicts <- solveReflectable args = dicts - forClassName _ _ C.RowUnion kinds args | Just dicts <- solveUnion kinds args = dicts - forClassName _ _ C.RowNub kinds args | Just dicts <- solveNub kinds args = dicts - forClassName _ _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts - forClassName _ _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts - forClassName _ _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts - forClassName _ ctx cn@(Qualified (ByModuleName mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys))) - forClassName _ _ _ _ _ = internalError "forClassName: expected qualified class name" + forClassName _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts + forClassName _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts + forClassName _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts + forClassName _ C.SymbolCons _ args | Just dicts <- solveSymbolCons args = dicts + forClassName _ C.IntAdd _ args | Just dicts <- solveIntAdd args = dicts + forClassName ctx C.IntCompare _ args | Just dicts <- solveIntCompare ctx args = dicts + forClassName _ C.IntMul _ args | Just dicts <- solveIntMul args = dicts + forClassName _ C.IntToString _ args | Just dicts <- solveIntToString args = dicts + forClassName _ C.Reflectable _ args | Just dicts <- solveReflectable args = dicts + forClassName _ C.RowUnion kinds args | Just dicts <- solveUnion kinds args = dicts + forClassName _ C.RowNub kinds args | Just dicts <- solveNub kinds args = dicts + forClassName _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts + forClassName _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts + forClassName _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts + forClassName ctx cn@(Qualified (ByModuleName mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys))) + forClassName _ _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: SourceType -> Maybe ModuleName ctorModules (TypeConstructor _ (Qualified (ByModuleName mn) _)) = Just mn @@ -245,24 +246,24 @@ entails SolverOptions{..} constraint context hints = latestSubst <- lift . lift $ gets checkSubstitution let kinds'' = map (substituteType latestSubst) kinds' tys'' = map (substituteType latestSubst) tys' - + + fromDb <- lift . lift $ getTypeClassDictionary className' -- Get the inferred constraint context so far, and merge it with the global context inferred <- lift get -- We need information about functional dependencies, so we have to look up the class -- name in the environment: - env <- lift . lift $ gets checkEnv - let classesInScope = typeClasses env + typeClass <- lift . lift $ lookupTypeClassMb className' TypeClassData { typeClassArguments , typeClassDependencies , typeClassIsEmpty , typeClassCoveringSets , typeClassMembers - } <- case M.lookup className' classesInScope of + } <- case typeClass of Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd - dicts <- lift . lift $ forClassNameM env (combineContexts context inferred) className' kinds'' tys'' + dicts <- lift . lift $ forClassNameM (addDictsToEnvMap fromDb $ combineContexts context inferred) className' kinds'' tys'' let (catMaybes -> ambiguous, instances) = partitionEithers $ do chain :: NonEmpty TypeClassDict <- @@ -470,15 +471,15 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined - solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) - solveCoercible env ctx kinds [a, b] = do + solveCoercible :: InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) + solveCoercible ctx kinds [a, b] = do let coercibleDictsInScope = findDicts ctx C.Coercible ByNullSourcePos givens = flip mapMaybe coercibleDictsInScope $ \case dict | [a', b'] <- tcdInstanceTypes dict -> Just (a', b') | otherwise -> Nothing - GivenSolverState{ inertGivens } <- execStateT (solveGivens env) $ + GivenSolverState{ inertGivens } <- execStateT solveGivens $ initialGivenSolverState givens - (WantedSolverState{ inertWanteds }, hints') <- runWriterT . execStateT (solveWanteds env) $ + (WantedSolverState{ inertWanteds }, hints') <- runWriterT . execStateT solveWanteds $ initialWantedSolverState inertGivens a b -- Solving fails when there's irreducible wanteds left. -- @@ -491,7 +492,7 @@ entails SolverOptions{..} constraint context hints = [] -> pure $ Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing Nothing] (k, a', b') : _ | a' == b && b' == a -> throwError $ insoluble k b' a' (k, a', b') : _ -> throwError $ insoluble k a' b' - solveCoercible _ _ _ _ = pure Nothing + solveCoercible _ _ _ = pure Nothing solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope Nothing 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing Nothing] @@ -866,14 +867,13 @@ matches deps TypeClassDictionaryInScope{..} tys = -- | Add a dictionary for the constraint to the scope, and dictionaries -- for all implied superclass instances. newDictionaries - :: MonadState CheckState m + :: (MonadState CheckState m, GetEnv m) => [(Qualified (ProperName 'ClassName), Integer)] -> Qualified Ident -> SourceConstraint -> m [NamedDict] newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = do - tcs <- gets (typeClasses . checkEnv) - let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs + TypeClassData{..} <- lookupTypeClassUnsafe className supDicts <- join <$> zipWithM (\(Constraint ann supName supKinds supArgs _) index -> let sub = zip (map fst typeClassArguments) instanceTy in newDictionaries ((supName, index) : path) diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 8abaac31ca..e0a121713a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -15,7 +15,7 @@ module Language.PureScript.TypeChecker.Entailment.Coercible import Prelude hiding (interact) -import Control.Applicative ((<|>), empty) +import Control.Applicative ((<|>), empty, Applicative (liftA2)) import Control.Arrow ((&&&)) import Control.Monad ((<=<), guard, unless, when) import Control.Monad.Error.Class (MonadError, catchError, throwError) @@ -23,7 +23,7 @@ import Control.Monad.State (MonadState, StateT, get, gets, modify, put) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Writer.Strict (MonadWriter, Writer, execWriter, runWriter, runWriterT, tell) +import Control.Monad.Writer.Strict (MonadWriter, runWriterT, tell, execWriterT) import Data.Either (partitionEithers) import Data.Foldable (fold, foldl', for_, toList) import Data.Functor (($>)) @@ -36,17 +36,19 @@ import Data.Map qualified as M import Data.Set qualified as S import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds) +import Language.PureScript.Environment (DataDeclType(..), TypeKind(..), unapplyKinds) import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..)) import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName) import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds') -import Language.PureScript.TypeChecker.Monad (CheckState(..)) +import Language.PureScript.TypeChecker.Monad (CheckState(..), lookupTypeMb, lookupTypeUnsafe) import Language.PureScript.TypeChecker.Roles (lookupRoles) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, substituteType) import Language.PureScript.Roles (Role(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes) import Language.PureScript.Constants.Prim qualified as Prim +import Language.PureScript.Make.Index.Select (GetEnv) +import Control.Monad.Trans.Writer.Strict (WriterT) -- | State of the given constraints solver. data GivenSolverState = @@ -118,30 +120,33 @@ initialGivenSolverState = -- 3c. Otherwise canonicalization can succeed with derived constraints which we -- add to the unsolved queue and then go back to 1. solveGivens - :: MonadError MultipleErrors m + :: forall m + . (MonadError MultipleErrors m, GetEnv m) => MonadState CheckState m - => Environment - -> StateT GivenSolverState m () -solveGivens env = go (0 :: Int) where + => (StateT GivenSolverState m ()) +solveGivens = go (0 :: Int) where + go :: Int -> StateT GivenSolverState m () go n = do - when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance + when (n > 1000) $ throwError $ errorMessage PossiblyInfiniteCoercibleInstance gets unsolvedGivens >>= \case [] -> pure () given : unsolved -> do (k, a, b) <- lift $ unify given GivenSolverState{..} <- get - lift (fst <$> runWriterT (canon env Nothing k a b `catchError` recover)) >>= \case - Irreducible -> case interact env (a, b) inertGivens of - Just (Simplified (a', b')) -> - put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. } - Just Discharged -> - put $ GivenSolverState { unsolvedGivens = unsolved, .. } - Nothing -> do - let (kickedOut, kept) = partitionEithers $ kicksOut env (a, b) <$> inertGivens - put $ GivenSolverState - { inertGivens = (k, a, b) : kept - , unsolvedGivens = kickedOut <> unsolved - } + lift (fst <$> runWriterT (canon Nothing k a b `catchError` recover)) >>= \case + Irreducible -> do + i <- lift $ interact (a, b) inertGivens + case i of + Just (Simplified (a', b')) -> + put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. } + Just Discharged -> + put $ GivenSolverState { unsolvedGivens = unsolved, .. } + Nothing -> do + (kickedOut, kept) <- partitionEithers <$> traverse (lift . kicksOut (a, b)) inertGivens + put $ GivenSolverState + { inertGivens = (k, a, b) : kept + , unsolvedGivens = kickedOut <> unsolved + } Canonicalized deriveds -> put $ GivenSolverState { unsolvedGivens = toList deriveds <> unsolved, .. } go (n + 1) @@ -206,12 +211,12 @@ initialWantedSolverState givens a b = -- interact the latter with the former, we would report an insoluble -- @Coercible Boolean Char@. solveWanteds - :: MonadError MultipleErrors m + :: forall m. + (MonadError MultipleErrors m, GetEnv m, MonadState CheckState m) => MonadWriter [ErrorMessageHint] m - => MonadState CheckState m - => Environment - -> StateT WantedSolverState m () -solveWanteds env = go (0 :: Int) where + => StateT WantedSolverState m () +solveWanteds = go (0 :: Int) where + go :: Int -> StateT WantedSolverState m () go n = do when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance gets unsolvedWanteds >>= \case @@ -219,8 +224,8 @@ solveWanteds env = go (0 :: Int) where wanted : unsolved -> do (k, a, b) <- lift $ unify wanted WantedSolverState{..} <- get - lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case - Irreducible -> case interact env (a, b) inertGivens of + lift (canon (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case + Irreducible -> lift (interact (a, b) inertGivens) >>= \case Just (Simplified (a', b')) -> put $ WantedSolverState { unsolvedWanteds = (a', b') : unsolved, .. } Just Discharged -> @@ -234,8 +239,8 @@ solveWanteds env = go (0 :: Int) where Canonicalized deriveds -> put $ WantedSolverState { unsolvedWanteds = toList deriveds <> unsolved, .. } go (n + 1) - recover wanted givens errors = - case interact env wanted givens of + recover wanted givens errors = do + interact wanted givens >>= \case Nothing -> throwError errors Just (Simplified wanted') -> pure . Canonicalized $ S.singleton wanted' Just Discharged -> pure $ Canonicalized mempty @@ -271,7 +276,7 @@ solveWanteds env = go (0 :: Int) where -- @Coercible (D \@k) (D \@k)@ constraint which could be trivially solved by -- reflexivity instead of having to saturate the type constructors. unify - :: MonadError MultipleErrors m + :: (MonadError MultipleErrors m, GetEnv m) => MonadState CheckState m => (SourceType, SourceType) -> m (SourceType, SourceType, SourceType) @@ -296,17 +301,20 @@ data Interaction -- | Interact an irreducible constraint with an inert set of givens. interact - :: Environment - -> (SourceType, SourceType) + :: (GetEnv m, MonadState CheckState m) + => (SourceType, SourceType) -> [(SourceType, SourceType, SourceType)] - -> Maybe Interaction -interact env irred = go where - go [] = Nothing - go (inert : _) - | canDischarge inert irred = Just Discharged - | Just derived <- interactSameTyVar inert irred = Just $ Simplified derived - | Just derived <- interactDiffTyVar env inert irred = Just $ Simplified derived - go (_ : inerts) = go inerts + -> m (Maybe Interaction) +interact irred = go where + go [] = pure Nothing + go (inert : inserts) + | canDischarge inert irred = pure $ Just Discharged + | Just derived <- interactSameTyVar inert irred = pure $ Just $ Simplified derived + | otherwise = + interactDiffTyVar inert irred >>= \case + Just s -> pure $ Just $ Simplified s + _ -> go inserts + -- | A given constraint of the form @Coercible a b@ can discharge constraints -- of the form @Coercible a b@ and @Coercible b a@. @@ -361,27 +369,32 @@ interactSameTyVar (_, tv1, ty1) (tv2, ty2) -- the non canonical given @Coercible b (D b)@ it would give @Coercible a (D b)@, -- which would keep interacting indefinitely with the given. interactDiffTyVar - :: Environment - -> (SourceType, SourceType, SourceType) + :: (GetEnv m, MonadState CheckState m) + => (SourceType, SourceType, SourceType) -> (SourceType, SourceType) - -> Maybe (SourceType, SourceType) -interactDiffTyVar env (_, tv1, ty1) (tv2, ty2) + -> m (Maybe (SourceType, SourceType)) +interactDiffTyVar (_, tv1, ty1) (tv2, ty2) | tv1 /= tv2 && isCanonicalTyVarEq (tv2, ty2) - , (ty2', Any True) <- runWriter $ rewrite env (tv1, ty1) ty2 - = Just (tv2, ty2') - | otherwise = Nothing + = do + rewriteRes <- runWriterT $ rewrite (tv1, ty1) ty2 + case rewriteRes of + (ty2', Any True) -> pure $ + Just (tv2, ty2') + _ -> pure Nothing + | otherwise = pure Nothing -- | A canonical constraint of the form @Coercible tv1 ty1@ can rewrite the -- right hand side of an irreducible constraint of the form @Coercible tv2 ty2@ -- by substituting @ty1@ for every occurrence of @tv1@ at representational and -- phantom role in @ty2@. Nominal occurrences are left untouched. -rewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Writer Any SourceType -rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where +rewrite :: (GetEnv m, MonadState CheckState m) => (SourceType, SourceType) -> SourceType -> WriterT Any m SourceType +rewrite (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1 go ty2 | (Skolem{}, _, xs) <- unapplyTypes ty2, not $ null xs = rewriteTyVarApp go ty2 | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do - rewriteTyConApp go (lookupRoles env tyName) ty2 + roles <- lookupRoles tyName + rewriteTyConApp go roles ty2 go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k go (ForAll sa vis tv k ty scope) = ForAll sa vis tv k <$> go ty <*> pure scope go (ConstrainedType sa Constraint{..} ty) | s1 `S.notMember` foldMap skolems constraintArgs = @@ -389,7 +402,7 @@ rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest go (KindedType sa ty k) = KindedType sa <$> go ty <*> pure k go ty2 = pure ty2 -rewrite _ _ = pure +rewrite _ = pure -- | Rewrite the head of a type application of the form @tv a_0 .. a_n@. rewriteTyVarApp @@ -421,8 +434,8 @@ rewriteTyConApp f = go where KindApp sa <$> go roles ty <*> pure k go _ ty = pure ty -canRewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Bool -canRewrite env irred = getAny . execWriter . rewrite env irred +canRewrite :: (MonadState CheckState m, GetEnv m ) => (SourceType, SourceType) -> SourceType -> m Bool +canRewrite irred = fmap getAny . execWriterT . rewrite irred -- | An irreducible given constraint must kick out of the inert set any -- constraint it can rewrite when it becomes inert, otherwise solving would be @@ -441,14 +454,16 @@ canRewrite env irred = getAny . execWriter . rewrite env irred -- not be able to rewrite it to @Coercible a (g b)@ and discharge the wanted, -- but inverting the givens would work. kicksOut - :: Environment - -> (SourceType, SourceType) + :: (GetEnv m, MonadState CheckState m) + => (SourceType, SourceType) -> (SourceType, SourceType, SourceType) - -> Either (SourceType, SourceType) (SourceType, SourceType, SourceType) -kicksOut env irred (_, tv2, ty2) - | isCanonicalTyVarEq (tv2, ty2) && canRewrite env irred ty2 - = Left (tv2, ty2) -kicksOut _ _ inert = Right inert + ->m ( Either (SourceType, SourceType) (SourceType, SourceType, SourceType)) +kicksOut irred inert@(_, tv2, ty2) + | isCanonicalTyVarEq (tv2, ty2) + = do + cr <- canRewrite irred ty2 + pure $ if cr then Left (tv2, ty2) else Right inert +kicksOut _ inert = pure $ Right inert -- | A constraint of the form @Coercible tv ty@ is canonical when @tv@ does not -- occur in @ty@. Non canonical constraints do not interact to prevent loops. @@ -478,19 +493,18 @@ data Canonicalized -- | Canonicalization takes a wanted constraint and try to reduce it to a set of -- simpler constraints whose satisfaction will imply the goal. canon - :: MonadError MultipleErrors m + :: (MonadError MultipleErrors m, GetEnv m) => MonadWriter [ErrorMessageHint] m => MonadState CheckState m - => Environment - -> Maybe [(SourceType, SourceType, SourceType)] + => Maybe [(SourceType, SourceType, SourceType)] -> SourceType -> SourceType -> SourceType -> m Canonicalized -canon env givens k a b = +canon givens k a b = maybe (throwError $ insoluble k a b) pure <=< runMaybeT $ canonRefl a b - <|> canonUnsaturatedHigherKindedType env a b + <|> canonUnsaturatedHigherKindedType a b <|> canonRow a b -- We unwrap newtypes before trying the decomposition rules because it let -- us solve more constraints. @@ -509,11 +523,11 @@ canon env givens k a b = -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@ -- which we can then decompose to @Coercible a b@ and discharge with the -- given. - <|> canonNewtypeLeft env a b - <|> canonNewtypeRight env a b - <|> canonDecomposition env a b - <|> canonDecompositionFailure env k a b - <|> canonNewtypeDecomposition env givens a b + <|> canonNewtypeLeft a b + <|> canonNewtypeRight a b + <|> canonDecomposition a b + <|> canonDecompositionFailure k a b + <|> canonNewtypeDecomposition givens a b <|> canonNewtypeDecompositionFailure a b <|> canonTypeVars a b <|> canonTypeVarLeft a b @@ -552,25 +566,30 @@ canonRefl a b = canonUnsaturatedHigherKindedType :: MonadError MultipleErrors m => MonadState CheckState m - => Environment - -> SourceType + => GetEnv m + => SourceType -> SourceType -> MaybeT m Canonicalized -canonUnsaturatedHigherKindedType env a b +canonUnsaturatedHigherKindedType a b | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a - , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env) - , (aks, _) <- unapplyKinds ak - , length axs < length aks = do - ak' <- lift $ do - let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak - instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps - unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs - pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak' - let (aks', _) = unapplyKinds ak' - tys <- traverse freshTypeWithKind $ drop (length axs) aks' - let a' = foldl' srcTypeApp a tys - b' = foldl' srcTypeApp b tys - pure . Canonicalized $ S.singleton (a', b') + = do + (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") <$> lookupTypeMb aTyName + let (aks, _) = unapplyKinds ak + if length axs < length aks + then do + ak' <- lift $ do + let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak + instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps + unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs + pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak' + let (aks', _) = unapplyKinds ak' + tys <- traverse freshTypeWithKind $ drop (length axs) aks' + let a' = foldl' srcTypeApp a tys + b' = foldl' srcTypeApp b tys + pure . Canonicalized $ S.singleton (a', b') + else empty + + | otherwise = empty -- | Constraints of the form @@ -578,7 +597,7 @@ canonUnsaturatedHigherKindedType env a b -- yield a constraint @Coercible r s@ and constraints on the types for each -- label in both rows. Labels exclusive to one row yield a failure. canonRow - :: MonadError MultipleErrors m + :: (MonadError MultipleErrors m, GetEnv m) => MonadState CheckState m => SourceType -> SourceType @@ -628,23 +647,18 @@ data UnwrapNewtypeError -- | Unwraps a newtype and yields its underlying type with the newtype arguments -- substituted in (e.g. @N[D/a] = D@ given @newtype N a = N a@ and @data D = D@). unwrapNewtype - :: MonadState CheckState m + :: (MonadState CheckState m, GetEnv m) => MonadWriter [ErrorMessageHint] m - => Environment - -> SourceType + => SourceType -> m (Either UnwrapNewtypeError SourceType) -unwrapNewtype env = go (0 :: Int) where +unwrapNewtype = go (0 :: Int) where go n ty = runExceptT $ do when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports case unapplyTypes ty of - (TypeConstructor _ newtypeName, ks, xs) - | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <- - lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName ks - -- We refuse to unwrap newtypes over polytypes because we don't know how - -- to canonicalize them yet and we'd rather try to make progress with - -- another rule. - , isMonoType wrappedTy -> do + (TypeConstructor _ newtypeName, ks, xs) -> do + lookupNewtypeConstructorInScope currentModuleName currentModuleImports newtypeName ks >>= \case + Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) | isMonoType wrappedTy -> do unless inScope $ do tell [MissingConstructorImportForCoercible newtypeCtorName] throwError CannotUnwrapConstructor @@ -653,6 +667,7 @@ unwrapNewtype env = go (0 :: Int) where ExceptT (go (n + 1) wrappedTySub) `catchError` \case CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain CannotUnwrapConstructor -> pure wrappedTySub + _ -> throwError CannotUnwrapConstructor _ -> throwError CannotUnwrapConstructor addConstructorImportForCoercible fromModuleName newtypeCtorName = modify $ \st -> st { checkConstructorImportsForCoercible = S.insert (fromModuleName, newtypeCtorName) $ checkConstructorImportsForCoercible st } @@ -660,23 +675,28 @@ unwrapNewtype env = go (0 :: Int) where -- | Looks up a given name and, if it names a newtype, returns the names of the -- type's parameters, the type the newtype wraps and the names of the type's -- fields. -lookupNewtypeConstructor - :: Environment - -> Qualified (ProperName 'TypeName) +lookupNewtypeConstructor + :: GetEnv m + => MonadState CheckState m + => Qualified (ProperName 'TypeName) -> [SourceType] - -> Maybe ([Text], ProperName 'ConstructorName, SourceType) -lookupNewtypeConstructor env qualifiedNewtypeName ks = do - (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) - let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk - instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs ks - pure (map (\(name, _, _) -> name) tvs, ctorName, replaceAllTypeVars instantiatedKinds wrappedTy) + -> m (Maybe ([Text], ProperName 'ConstructorName, SourceType)) +lookupNewtypeConstructor qualifiedNewtypeName ks = do + nt <- lookupTypeUnsafe qualifiedNewtypeName + case nt of + (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) -> do + let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk + instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs ks + pure $ Just (map (\(name, _, _) -> name) tvs, ctorName, replaceAllTypeVars instantiatedKinds wrappedTy) + _ -> pure Nothing -- | Behaves like 'lookupNewtypeConstructor' but also returns whether the -- newtype constructor is in scope and the module from which it is imported, or -- 'Nothing' if it is defined in the current module. lookupNewtypeConstructorInScope - :: Environment - -> Maybe ModuleName + :: GetEnv m + => MonadState CheckState m + => Maybe ModuleName -> [ ( SourceAnn , ModuleName , ImportDeclarationType @@ -686,16 +706,19 @@ lookupNewtypeConstructorInScope ] -> Qualified (ProperName 'TypeName) -> [SourceType] - -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType) -lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do + -> m (Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType)) +lookupNewtypeConstructorInScope currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do let fromModule = find isNewtypeCtorImported currentModuleImports fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule isDefinedInCurrentModule = toMaybeModuleName newtypeModuleName == currentModuleName isImported = isJust fromModule inScope = isDefinedInCurrentModule || isImported - (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks - pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy) + ntCtr <- lookupNewtypeConstructor qualifiedNewtypeName ks + pure $ case ntCtr of + Nothing -> Nothing + Just (tvs, ctorName, wrappedTy) -> + pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy) where isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) = case M.lookup newtypeName exportedTypes of @@ -713,13 +736,13 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali -- @Coercible a b@ if unwrapping the newtype yields @a@. canonNewtypeLeft :: MonadState CheckState m + => GetEnv m => MonadWriter [ErrorMessageHint] m - => Environment - -> SourceType + => SourceType -> SourceType -> MaybeT m Canonicalized -canonNewtypeLeft env a b = - unwrapNewtype env a >>= \case +canonNewtypeLeft a b = + unwrapNewtype a >>= \case Left CannotUnwrapInfiniteNewtypeChain -> empty Left CannotUnwrapConstructor -> empty Right a' -> pure . Canonicalized $ S.singleton (a', b) @@ -728,13 +751,13 @@ canonNewtypeLeft env a b = -- @Coercible a b@ if unwrapping the newtype yields @b@. canonNewtypeRight :: MonadState CheckState m + => GetEnv m => MonadWriter [ErrorMessageHint] m - => Environment - -> SourceType + => SourceType -> SourceType -> MaybeT m Canonicalized -canonNewtypeRight env = - flip $ canonNewtypeLeft env +canonNewtypeRight = + flip canonNewtypeLeft -- | Decomposes constraints of the form @Coercible (D a_0 .. a_n) (D b_0 .. b_n)@ -- into constraints on their representational arguments, ignoring phantom @@ -750,14 +773,14 @@ canonNewtypeRight env = -- We can decompose @Coercible (D a b d) (D a c e)@ into @Coercible b c@, but -- decomposing @Coercible (D a c d) (D b c d)@ would fail. decompose - :: MonadError MultipleErrors m - => Environment - -> Qualified (ProperName 'TypeName) + :: (MonadError MultipleErrors m, GetEnv m, MonadState CheckState m) + => Qualified (ProperName 'TypeName) -> [SourceType] -> [SourceType] -> m Canonicalized -decompose env tyName axs bxs = do - let roles = lookupRoles env tyName +decompose tyName axs bxs = do + roles <- lookupRoles tyName + let f role ax bx = case role of Nominal -- If we had first-class equality constraints, we'd just @@ -780,16 +803,19 @@ decompose env tyName axs bxs = do -- @D@ is not a newtype, yield constraints on their arguments. canonDecomposition :: MonadError MultipleErrors m - => Environment - -> SourceType + => GetEnv m + => MonadState CheckState m + => SourceType -> SourceType -> MaybeT m Canonicalized -canonDecomposition env a b +canonDecomposition a b | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b , aTyName == bTyName - , Nothing <- lookupNewtypeConstructor env aTyName [] = - decompose env aTyName axs bxs + = do + lookupNewtypeConstructor aTyName [] >>= \case + Just _ -> empty + _ -> decompose aTyName axs bxs | otherwise = empty -- | Constraints of the form @Coercible (D1 a_0 .. a_n) (D2 b_0 .. b_n)@, where @@ -797,18 +823,21 @@ canonDecomposition env a b -- newtypes, are insoluble. canonDecompositionFailure :: MonadError MultipleErrors m - => Environment - -> SourceType + => GetEnv m + => MonadState CheckState m + => SourceType -> SourceType -> SourceType -> MaybeT m Canonicalized -canonDecompositionFailure env k a b +canonDecompositionFailure k a b | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a , (TypeConstructor _ bTyName, _, _) <- unapplyTypes b - , aTyName /= bTyName - , Nothing <- lookupNewtypeConstructor env aTyName [] - , Nothing <- lookupNewtypeConstructor env bTyName [] = - throwError $ insoluble k a b + , aTyName /= bTyName = + -- , Nothing <- lookupNewtypeConstructor aTyName [] + -- , Nothing <- lookupNewtypeConstructor bTyName [] = + liftA2 (,) (lookupNewtypeConstructor aTyName []) (lookupNewtypeConstructor bTyName []) >>= \case + (Nothing, Nothing) -> throwError $ insoluble k a b + _ -> empty | otherwise = empty -- | Wanted constraints of the form @Coercible (N a_0 .. a_n) (N b_0 .. b_n)@, @@ -845,21 +874,19 @@ canonDecompositionFailure env k a b -- @Coercible (Const a a) (Const a b)@ to @Coercible a b@ we would not be able -- to discharge it with the given. canonNewtypeDecomposition - :: MonadError MultipleErrors m - => Environment - -> Maybe [(SourceType, SourceType, SourceType)] + :: (MonadError MultipleErrors m, GetEnv m, MonadState CheckState m) + => Maybe [(SourceType, SourceType, SourceType)] -> SourceType -> SourceType -> MaybeT m Canonicalized -canonNewtypeDecomposition env (Just givens) a b +canonNewtypeDecomposition (Just givens) a b | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b - , aTyName == bTyName - , Just _ <- lookupNewtypeConstructor env aTyName [] = do + , aTyName == bTyName = do let givensCanDischarge = any (\given -> canDischarge given (a, b)) givens guard $ not givensCanDischarge - decompose env aTyName axs bxs -canonNewtypeDecomposition _ _ _ _ = empty + lift $ decompose aTyName axs bxs +canonNewtypeDecomposition _ _ _ = empty -- | Constraints of the form @Coercible (N1 a_0 .. a_n) (N2 b_0 .. b_n)@, where -- @N1@ and @N2@ are different type constructors and either of them is a diff --git a/src/Language/PureScript/TypeChecker/IdeArtifacts.hs b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs new file mode 100644 index 0000000000..affe066472 --- /dev/null +++ b/src/Language/PureScript/TypeChecker/IdeArtifacts.hs @@ -0,0 +1,354 @@ +{-# 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, + artifactInterest, + bindersAtPos, + handlePartialArtifacts, + ) +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 (P.Type ()) (P.Type ())) -- type synonym substitutions + deriving (Show, Generic, NFData) + +type Line = Int + +emptyIdeArtifacts :: IdeArtifacts +emptyIdeArtifacts = IdeArtifacts Map.empty Map.empty + +handlePartialArtifacts :: IdeArtifacts -> IdeArtifacts -> IdeArtifacts +handlePartialArtifacts (IdeArtifacts existing sy) (IdeArtifacts partial syPartial) = + IdeArtifacts newArtifacts (Map.union syPartial sy) + where + newArtifacts = Map.unionWith Set.union partial (Map.filterWithKey (\k _ -> not (k `Set.member` linesUsed)) existing) + + linesUsed :: Set Line + linesUsed = + partial + & Map.toList + >>= (\(_, as) -> getArtifactLines <$> Set.toList as) + & Set.unions + +getArtifactLines :: IdeArtifact -> Set Line +getArtifactLines ia = Set.fromList [P.sourcePosLine $ P.spanStart $ iaSpan ia .. P.sourcePosLine $ P.spanEnd $ iaSpan ia] + +debugIdeArtifacts :: IdeArtifacts -> Text +debugIdeArtifacts = T.intercalate "\n" . fmap showCount . lineCounts + 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 s) = IdeArtifacts (Map.map (Set.map (onArtifactType f)) m) s + +onArtifactType :: (P.SourceType -> P.SourceType) -> IdeArtifact -> IdeArtifact +onArtifactType f (IdeArtifact {..}) = IdeArtifact iaSpan iaValue (f iaType) iaDefinitionModule iaDefinitionPos + +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 s) = + if start == P.SourcePos 0 0 || start == P.SourcePos 1 1 -- ignore internal module spans + then ia + else IdeArtifacts (foldr insert m (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 s) = IdeArtifacts m (Map.insert (void syn) (void ty) s) + +useSynonymns :: forall a. IdeArtifacts -> P.Type a -> P.Type () +useSynonymns (IdeArtifacts _ s) ty = P.everywhereOnTypes go (void ty) + 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..628fef1a7a 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 @@ -42,7 +43,7 @@ import Data.Functor (($>)) import Data.IntSet qualified as IS import Data.List (nubBy, sortOn, (\\)) import Data.Map qualified as M -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Text (Text) import Data.Text qualified as T import Data.Traversable (for) @@ -51,11 +52,12 @@ import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified) -import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution) +import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, lookupType, lookupTypeMb, lookupSynonymMb) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.Types import Language.PureScript.Pretty.Types (prettyPrintType) +import Language.PureScript.Make.Index.Select (GetEnv) generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType generalizeUnknowns unks ty = @@ -154,7 +156,7 @@ unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) pure $ (lvl, (u, ty)) : rest inferKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> m (SourceType, SourceType) inferKind = \tyToInfer -> @@ -164,25 +166,28 @@ inferKind = \tyToInfer -> where go = \case ty@(TypeConstructor ann v) -> do - env <- getEnv - case M.lookup v (E.types env) of - Nothing -> - throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v - Just (kind, E.LocalTypeVariable) -> do + k <- lookupType (fst ann) v + case k of + (kind, E.LocalTypeVariable) -> do kind' <- apply kind pure (ty, kind' $> ann) - Just (kind, _) -> do + (kind, _) -> do + -- let className = coerceProperName <$> v + -- case M.lookup className (E.typeClasses env) of + -- Just _ -> addIdeClassNameQual (fst ann) className (kind $> ann) + -- Nothing -> addIdeTypeNameQual (fst ann) v (kind $> ann) pure (ty, kind $> ann) ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do - env <- getEnv - con' <- case M.lookup (coerceProperName <$> v) (E.types env) of - Nothing -> - throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v - Just _ -> + kindMb <- lookupTypeMb (coerceProperName <$> v) + con' <- case kindMb of + Just _ -> do checkConstraint con + Nothing -> + throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v ty' <- checkIsSaturatedType ty con'' <- applyConstraint con' - 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 _) -> @@ -242,7 +247,7 @@ inferKind = \tyToInfer -> internalError $ "inferKind: Unimplemented case \n" <> prettyPrintType 100 ty inferAppKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceAnn -> (SourceType, SourceType) -> SourceType @@ -269,13 +274,13 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of cannotApplyTypeToType fn arg where requiresSynonymsToExpand = \case - TypeConstructor _ v -> M.notMember v . E.typeSynonyms <$> getEnv + TypeConstructor _ v -> isJust <$> lookupSynonymMb v TypeApp _ l _ -> requiresSynonymsToExpand l KindApp _ l _ -> requiresSynonymsToExpand l _ -> pure True cannotApplyTypeToType - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> SourceType -> m a @@ -285,7 +290,7 @@ cannotApplyTypeToType fn arg = do internalCompilerError . T.pack $ "Cannot apply type to type: " <> debugType (srcTypeApp fn arg) cannotApplyKindToType - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> SourceType -> m a @@ -296,7 +301,7 @@ cannotApplyKindToType poly arg = do internalCompilerError . T.pack $ "Cannot apply kind to type: " <> debugType (srcKindApp poly arg) checkKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> SourceType -> m SourceType @@ -310,13 +315,13 @@ checkKind = checkKind' False -- error. -- checkIsSaturatedType - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> m SourceType checkIsSaturatedType ty = checkKind' True ty E.kindType checkKind' - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => Bool -> SourceType -> SourceType @@ -331,7 +336,7 @@ checkKind' requireSynonymsToExpand ty kind2 = do instantiateKind (ty', kind1') kind2' instantiateKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => (SourceType, SourceType) -> SourceType -> m SourceType @@ -349,7 +354,7 @@ instantiateKind (ty, kind1) kind2 = case kind1 of _ -> False subsumesKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> SourceType -> m () @@ -380,7 +385,7 @@ subsumesKind = go unifyKinds a b unifyKinds - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> SourceType -> m () @@ -393,7 +398,7 @@ unifyKinds = unifyKindsWithFailure $ \w1 w2 -> -- | local position context. This is useful when invoking kind unification -- | outside of kind checker internals. unifyKinds' - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> SourceType -> m () @@ -404,7 +409,7 @@ unifyKinds' = unifyKindsWithFailure $ \w1 w2 -> -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> SourceType -> m () @@ -412,7 +417,7 @@ checkTypeKind ty kind = unifyKindsWithFailure (\_ _ -> throwError . errorMessage $ ExpectedType ty kind) kind E.kindType unifyKindsWithFailure - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => (SourceType -> SourceType -> m ()) -> SourceType -> SourceType @@ -464,7 +469,7 @@ unifyKindsWithFailure onFailure = go onFailure (rowFromList w1) (rowFromList w2) solveUnknown - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => Unknown -> SourceType -> m () @@ -512,7 +517,7 @@ promoteKind u2 ty = do pure ty' elaborateKind - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> m SourceType elaborateKind = \case @@ -521,12 +526,8 @@ elaborateKind = \case TypeLevelInt ann _ -> pure $ E.tyInt $> ann TypeConstructor ann v -> do - env <- getEnv - case M.lookup v (E.types env) of - Nothing -> - throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v - Just (kind, _) -> - ($> ann) <$> apply kind + (kind, _) <- lookupType (fst ann) v + ($> ann) <$> apply kind TypeVar ann a -> do moduleName <- unsafeCheckCurrentModule kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName a) @@ -588,7 +589,7 @@ checkEscapedSkolems ty = errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty' kindOfWithUnknowns - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> m (([(Unknown, SourceType)], SourceType), SourceType) kindOfWithUnknowns ty = do @@ -598,14 +599,14 @@ kindOfWithUnknowns ty = do -- | Infer the kind of a single type kindOf - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> m (SourceType, SourceType) kindOf = fmap (first snd) . kindOfWithScopedVars -- | Infer the kind of a single type, returning the kinds of any scoped type variables kindOfWithScopedVars - :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack, GetEnv m) => SourceType -> m (([(Text, SourceType)], SourceType), SourceType) kindOfWithScopedVars ty = do @@ -613,6 +614,7 @@ kindOfWithScopedVars ty = do let binders = fst . fromJust $ completeBinderList ty' pure ((snd <$> binders, ty'), kind) + type DataDeclarationArgs = ( SourceAnn , ProperName 'TypeName @@ -628,7 +630,7 @@ type DataDeclarationResult = ) kindOfData - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> DataDeclarationArgs -> m DataDeclarationResult @@ -636,7 +638,7 @@ kindOfData moduleName dataDecl = head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] inferDataDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> DataDeclarationArgs -> m [(DataConstructorDeclaration, SourceType)] @@ -656,7 +658,7 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do fmap (fmap (addVisibility visibility . mkForAll ctorBinders)) . inferDataConstructor tyCtor' inferDataConstructor - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => SourceType -> DataConstructorDeclaration -> m (DataConstructorDeclaration, SourceType) @@ -680,7 +682,7 @@ type TypeDeclarationResult = ) kindOfTypeSynonym - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> TypeDeclarationArgs -> m TypeDeclarationResult @@ -688,7 +690,7 @@ kindOfTypeSynonym moduleName typeDecl = head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] inferTypeSynonym - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> TypeDeclarationArgs -> m SourceType @@ -797,7 +799,7 @@ type ClassDeclarationResult = ) kindOfClass - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> ClassDeclarationArgs -> m ClassDeclarationResult @@ -805,7 +807,7 @@ kindOfClass moduleName clsDecl = head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] inferClassDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> ClassDeclarationArgs -> m ([(Text, SourceType)], [SourceConstraint], [Declaration]) @@ -821,7 +823,7 @@ inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = <*> for decls checkClassMemberDeclaration checkClassMemberDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => Declaration -> m Declaration checkClassMemberDeclaration = \case @@ -846,7 +848,7 @@ mapTypeDeclaration f = \case other checkConstraint - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => SourceConstraint -> m SourceConstraint checkConstraint (Constraint ann clsName kinds args dat) = do @@ -859,8 +861,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 = @@ -878,7 +882,7 @@ type InstanceDeclarationResult = ) checkInstanceDeclaration - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> InstanceDeclarationArgs -> m InstanceDeclarationResult @@ -899,7 +903,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do pure (allConstraints, allKinds, allArgs, varKinds) checkKindDeclaration - :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> SourceType -> m SourceType @@ -934,19 +938,19 @@ checkKindDeclaration _ ty = do other -> pure other existingSignatureOrFreshKind - :: forall m. MonadState CheckState m + :: forall m. (MonadState CheckState m, GetEnv m) => ModuleName -> SourceSpan -> ProperName 'TypeName -> m SourceType existingSignatureOrFreshKind moduleName ss name = do - env <- getEnv - case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of + tyMb <- lookupTypeMb (Qualified (ByModuleName moduleName) name) + case tyMb of Nothing -> freshKind ss Just (kind, _) -> pure kind kindsOfAll - :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModuleName -> [TypeDeclarationArgs] -> [DataDeclarationArgs] diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b6382e6707..ed71d575c1 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,4 +1,7 @@ {-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | -- Monads for type checking and type inference and associated data types @@ -20,14 +23,20 @@ import Data.Text (Text, isPrefixOf, unpack) import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..)) -import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName) +import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), DataDeclType) +import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition, DeclarationRef, errorMessage') +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, Name (TyClassName, TyName)) import Language.PureScript.Pretty.Types (prettyPrintType) import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar) import Text.PrettyPrint.Boxes (render) +import Language.PureScript.TypeChecker.IdeArtifacts (IdeArtifacts, emptyIdeArtifacts, insertIaExpr, insertIaBinder, insertIaIdent, insertIaDecl, insertIaType, insertIaTypeName, insertIaClassName, moduleNameFromQual, substituteArtifactTypes, insertTypeSynonym, insertModule, insertImport) +import Protolude (whenM, isJust, (&)) +import Language.PureScript.AST.Binders (Binder) +import Language.PureScript.AST.Declarations (Declaration, Expr (..)) +import Language.PureScript.Make.Index.Select (GetEnv (getName, getType, getTypeClass, getDataConstructor, getTypeClassDictionary)) +import Language.PureScript.Make.Index.Select qualified as Select newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown) deriving (Eq, Show) @@ -105,11 +114,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 @@ -194,24 +210,34 @@ withTypeClassDictionaries -> m a withTypeClassDictionaries entries action = do orig <- get - - let mentries = - M.fromListWith (M.unionWith (M.unionWith (<>))) - [ (qb, M.singleton className (M.singleton tcdValue (pure entry))) - | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className } - <- entries - ] - - modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } } + + modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = addDictsToEnvMap entries (typeClassDictionaries . checkEnv $ st) } } a <- action modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } return a +addDictsToEnvMap :: [NamedDict] + -> M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) + -> M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) +addDictsToEnvMap entries envMap = + M.unionWith (M.unionWith (M.unionWith (<>))) envMap (typeClassDictionariesEnvMap entries) + + +typeClassDictionariesEnvMap :: [NamedDict] + -> M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) +typeClassDictionariesEnvMap entries = + M.fromListWith (M.unionWith (M.unionWith (<>))) + [ (qb, M.singleton className (M.singleton tcdValue (pure entry))) + | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className } + <- entries + ] + -- | Get the currently available map of type class dictionaries getTypeClassDictionaries - :: (MonadState CheckState m) + :: (MonadState CheckState m, GetEnv m) => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv + -- $ addDictsToEnvMap dbDicts envDicts -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries @@ -222,11 +248,20 @@ lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeCl -- | Lookup type class dictionaries in a module. lookupTypeClassDictionariesForClass - :: (MonadState CheckState m) + :: (MonadState CheckState m, GetEnv m) => QualifiedBy -> Qualified (ProperName 'ClassName) -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) -lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn +lookupTypeClassDictionariesForClass mn cn = do + dicts <- lookupTypeClassDictionaries mn + case M.lookup cn dicts of + Just d -> pure d + Nothing -> do + inDb <- getTypeClassDictionary cn + modifyEnv $ \env -> env { typeClassDictionaries = addDictsToEnvMap inDb (typeClassDictionaries env) } + pure $ key inDb + where + key = M.fromList . fmap \a -> (tcdValue a, pure a) -- | Temporarily bind a collection of names to local variables bindLocalVariables @@ -263,31 +298,47 @@ preservingNames action = do modifyEnv $ \e -> e { names = orig } return a +lookupName + :: (MonadState CheckState m, GetEnv m) + => Qualified Ident + -> m (Maybe (SourceType, NameKind, NameVisibility)) +lookupName qual = do + env <- getEnv + case M.lookup qual (names env) of + Nothing -> do + nameMb <- getName qual + nameMb & maybe (return ()) \name -> + modifyEnv (\env' -> env' { names = M.insert qual name (names env') }) + return nameMb + n -> return n + -- | Lookup the type of a value by name in the @Environment@ lookupVariable - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m) => Qualified Ident -> m SourceType lookupVariable qual = do - env <- getEnv - case M.lookup qual (names env) of + nameMb <- lookupName qual + case nameMb of Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual) Just (ty, _, _) -> return ty + + -- | Lookup the visibility of a value by name in the @Environment@ getVisibility - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m) => Qualified Ident -> m NameVisibility getVisibility qual = do - env <- getEnv - case M.lookup qual (names env) of + nameMb <- lookupName qual + case nameMb of Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual) Just (_, _, vis) -> return vis -- | Assert that a name is visible checkVisibility - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m) => Qualified Ident -> m () checkVisibility name@(Qualified _ var) = do @@ -296,22 +347,117 @@ checkVisibility name@(Qualified _ var) = do Undefined -> throwError . errorMessage $ CycleInDeclaration var _ -> return () +lookupTypeMb + :: (MonadState CheckState m, GetEnv m) + => Qualified (ProperName 'TypeName) + -> m (Maybe (SourceType, TypeKind)) +lookupTypeMb qual = do + env <- getEnv + case M.lookup qual (types env) of + Nothing -> do + tyMb <- getType qual + tyMb & maybe (return ()) \ty -> modifyEnv (\env' -> env' { types = M.insert qual ty (types env') }) + return tyMb + ty -> return ty + +lookupType :: (MonadState CheckState m, GetEnv m, MonadError MultipleErrors m) => SourceSpan -> Qualified (ProperName 'TypeName) -> m (SourceType, TypeKind) +lookupType span' v = + lookupTypeMb v >>= \case + Nothing -> throwError . errorMessage' span' $ UnknownName $ fmap TyName v + Just ty -> return ty + +lookupTypeUnsafe :: (MonadState CheckState m, GetEnv m) => Qualified (ProperName 'TypeName) -> m (SourceType, TypeKind) +lookupTypeUnsafe qual = lookupTypeMb qual >>= \case + Nothing -> internalError $ "lookupTypeUnsafe: Encountered unknown type in: " <> show qual + Just ty -> return ty + + +lookupSynonymMb + :: (MonadState CheckState m, GetEnv m) + => Qualified (ProperName 'TypeName) + -> m (Maybe ([(Text, Maybe SourceType)], SourceType)) +lookupSynonymMb qual = do + env <- getEnv + case M.lookup qual (typeSynonyms env) of + Nothing -> do + sybMb <- Select.getTypeSynonym qual + sybMb & maybe (return ()) \syb -> modifyEnv (\env' -> env' { typeSynonyms = M.insert qual syb (typeSynonyms env') }) + return sybMb + syn -> return syn + -- | Lookup the kind of a type by name in the @Environment@ lookupTypeVariable - :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m) => ModuleName -> Qualified (ProperName 'TypeName) -> m SourceType lookupTypeVariable currentModule (Qualified qb name) = do env <- getEnv case M.lookup (Qualified qb' name) (types env) of - Nothing -> throwError . errorMessage $ UndefinedTypeVariable name + Nothing -> do + ty <- getType (Qualified qb' name) + case ty of + Nothing -> throwError . errorMessage $ UndefinedTypeVariable name + Just kind@(k, _) -> do + modifyEnv (\env' -> env' { types = M.insert (Qualified qb' name) kind (types env') }) + return k Just (k, _) -> return k where qb' = ByModuleName $ case qb of ByModuleName m -> m BySourcePos _ -> currentModule +lookupConstructorMb + :: (MonadState CheckState m, GetEnv m) + => Qualified (ProperName 'ConstructorName) + -> m (Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) +lookupConstructorMb name = do + env <- getEnv + case M.lookup name (dataConstructors env) of + Nothing -> do + ctrMb <- getDataConstructor name + case ctrMb of + Nothing -> return Nothing + Just ctr -> do + modifyEnv (\env' -> env' { dataConstructors = M.insert name ctr (dataConstructors env') }) + return $ Just ctr + ctr -> return ctr + +lookupConstructorUnsafe + :: ( MonadState CheckState m, GetEnv m) + => Qualified (ProperName 'ConstructorName) + -> m (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) +lookupConstructorUnsafe name = lookupConstructorMb name >>= \case + Nothing -> internalError $ "lookupConstructorUnsafe: Encountered unknown constructor in: " <> show name + Just ctr -> return ctr + +lookupTypeClassMb + :: (MonadState CheckState m, GetEnv m) + => Qualified (ProperName 'ClassName) + -> m (Maybe TypeClassData) +lookupTypeClassMb name = do + env <- getEnv + case M.lookup name (typeClasses env) of + Nothing -> do + getTypeClass name + tc -> return tc + +lookupTypeClassUnsafe + :: (MonadState CheckState m, GetEnv m) + => Qualified (ProperName 'ClassName) + -> m TypeClassData +lookupTypeClassUnsafe name = lookupTypeClassMb name >>= \case + Nothing -> internalError $ "lookupTypeClassUnsafe: Encountered unknown type class in: " <> show name + Just tc -> return tc + +lookupTypeClassOrThrow + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m, GetEnv m) + => Qualified (ProperName 'ClassName) + -> m TypeClassData +lookupTypeClassOrThrow name = lookupTypeClassMb name >>= \case + Nothing -> throwError . errorMessage $ UnknownName $ fmap TyClassName name + Just tc -> return tc + -- | Get the current @Environment@ getEnv :: (MonadState CheckState m) => m Environment getEnv = gets checkEnv @@ -374,6 +520,69 @@ 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 + +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/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 7b38a317b7..c76563dd71 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -29,6 +29,8 @@ import Language.PureScript.Errors (DataConstructorDeclaration(..), MultipleError import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..)) import Language.PureScript.Roles (Role(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), freeTypeVariables, unapplyTypes) +import Language.PureScript.Make.Index.Select (GetEnv) +import Language.PureScript.TypeChecker.Monad (CheckState, lookupTypeMb) -- | -- A map of a type's formal parameter names to their roles. This type's @@ -78,11 +80,21 @@ updateRoleEnv qualTyName roles' roleEnv = -- returns an empty list. -- lookupRoles - :: Environment - -> Qualified (ProperName 'TypeName) - -> [Role] -lookupRoles env tyName = - fromMaybe [] $ M.lookup tyName (types env) >>= typeKindRoles . snd + :: (GetEnv m, MonadState CheckState m) + => Qualified (ProperName 'TypeName) + -> m [Role] +lookupRoles tyName = do + tysMb <- lookupTypeMb tyName + case tysMb of + Nothing -> pure [] + Just ty -> + pure $ fromMaybe [] $ typeKindRoles $ snd ty + + + + -- fromMaybe (pure []) $ typeKindRoles . snd <$> M.lookup tyName tys + + -- fromMaybe (pure []) $ M.lookup tyName (types env) >>= typeKindRoles . snd -- | -- Compares the inferred roles to the explicitly declared roles and ensures diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 26da5e980f..6e60f3ac4f 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -24,6 +24,7 @@ import Language.PureScript.TypeChecker.Monad (CheckState, getHints, getTypeClass import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, unifyTypes) import Language.PureScript.Types (RowListItem(..), SourceType, Type(..), eqType, isREmpty, replaceTypeVars, rowFromList) +import Language.PureScript.Make.Index.Select (GetEnv) -- | Subsumption can operate in two modes: -- @@ -59,7 +60,7 @@ defaultCoercion SNoElaborate = () -- | Check that one type subsumes another, rethrowing errors to provide a better error message subsumes - :: (MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => SourceType -> SourceType -> m (Expr -> Expr) @@ -69,7 +70,7 @@ subsumes ty1 ty2 = -- | Check that one type subsumes another subsumes' - :: (MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => ModeSing mode -> SourceType -> SourceType diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 567ae415ef..b03f68aff2 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -1,62 +1,63 @@ {-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} -- | -- Functions for replacing fully applied type synonyms --- module Language.PureScript.TypeChecker.Synonyms - ( SynonymMap - , KindMap - , replaceAllTypeSynonyms - ) where + ( SynonymMap, + KindMap, + replaceAllTypeSynonyms, + ) +where -import Prelude - -import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.State (MonadState) -import Data.Maybe (fromMaybe) import Data.Map qualified as M +import Data.Maybe (fromMaybe) import Data.Text (Text) -import Language.PureScript.Environment (Environment(..), TypeKind) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage') -import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified) -import Language.PureScript.TypeChecker.Monad (CheckState, getEnv) -import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars) +import GHC.Stack (HasCallStack) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (TypeKind) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), SourceSpan, errorMessage') +import Language.PureScript.Make.Index.Select (GetEnv) +import Language.PureScript.Names (ProperName, ProperNameType (..), Qualified) +import Language.PureScript.TypeChecker.Monad (CheckState, lookupSynonymMb, lookupTypeMb) +import Language.PureScript.Types (SourceType, Type (..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars) +import Prelude -- | Type synonym information (arguments with kinds, aliased type), indexed by name type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) -replaceAllTypeSynonyms' - :: SynonymMap - -> KindMap - -> SourceType - -> Either MultipleErrors SourceType -replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try - where - try :: SourceType -> Either MultipleErrors SourceType - try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t - - go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType) - go ss c kargs args (TypeConstructor _ ctor) - | Just (synArgs, body) <- M.lookup ctor syns - , c == length synArgs - , kindArgs <- lookupKindArgs ctor - , length kargs == length kindArgs - = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body - in Just <$> try repl - | Just (synArgs, _) <- M.lookup ctor syns - , length synArgs > c - = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor - go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f - go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f - go _ _ _ _ _ = return Nothing - - lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text] - lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds - -- | Replace fully applied type synonyms -replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType -replaceAllTypeSynonyms d = do - env <- getEnv - either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d +replaceAllTypeSynonyms :: forall e m. (HasCallStack) => (e ~ MultipleErrors, MonadState CheckState m, GetEnv m, MonadError e m) => SourceType -> m SourceType +replaceAllTypeSynonyms = everywhereOnTypesTopDownM try + where + try :: SourceType -> m SourceType + try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t + + go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> m (Maybe SourceType) + go ss c kargs args (TypeConstructor _ ctor) = do + lookupSynonymMb ctor >>= \case + Just (synArgs, body) + | c == length synArgs -> do + kindArgs <- lookupKindArgs ctor + if length kargs == length kindArgs + then + let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body + in Just <$> try repl + else pure Nothing + | length synArgs > c -> + internalError $ "PartiallyAppliedSynonym: " <> show (ctor, ss, c, synArgs) + -- throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor + _ -> return Nothing + go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f + go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f + go _ _ _ _ _ = return Nothing + + lookupKindArgs :: Qualified (ProperName 'TypeName) -> m [Text] + lookupKindArgs ctor = do + k <- lookupTypeMb ctor + pure $ fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< k diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 6158f48a82..6758c86f4f 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -22,6 +22,7 @@ import Language.PureScript.Pretty.Types as P import Language.PureScript.TypeChecker.Skolems as Skolem import Language.PureScript.TypeChecker.Synonyms as P import Language.PureScript.Types as P +import Language.PureScript.Make.Index.Select (runWoGetEnv) checkInEnvironment :: Environment @@ -53,7 +54,7 @@ checkSubsume checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do let initializeSkolems = Skolem.introduceSkolemScope - <=< P.replaceAllTypeSynonyms + <=< (runWoGetEnv . P.replaceAllTypeSynonyms) <=< P.replaceTypeWildcards userT' <- initializeSkolems userT @@ -61,14 +62,14 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do let dummyExpression = P.Var nullSourceSpan (P.Qualified P.ByNullSourcePos (P.Ident "x")) - elab <- subsumes envT' userT' + elab <- runWoGetEnv $ subsumes envT' userT' -- TODO add DB subst <- gets TC.checkSubstitution let expP = P.overTypes (P.substituteType subst) (elab dummyExpression) -- Now check that any unsolved constraints have not become impossible (traverse_ . traverse_) (\(_, context, constraint) -> do let constraint' = P.mapConstraintArgs (map (P.substituteType subst)) constraint - flip evalStateT Map.empty . evalWriterT $ + runWoGetEnv $ flip evalStateT Map.empty . evalWriterT $ -- TODO add DB Entailment.entails (Entailment.SolverOptions { solverShouldGeneralize = True @@ -76,7 +77,7 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do }) constraint' context []) unsolved -- Finally, check any constraints which were found during elaboration - Entailment.replaceTypeClassDictionaries (isJust unsolved) expP + runWoGetEnv $ Entailment.replaceTypeClassDictionaries (isJust unsolved) expP -- TODO add DB accessorSearch :: Maybe [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)] @@ -88,7 +89,7 @@ accessorSearch accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment env st $ do let initializeSkolems = Skolem.introduceSkolemScope - <=< P.replaceAllTypeSynonyms + <=< (runWoGetEnv . P.replaceAllTypeSynonyms) <=< P.replaceTypeWildcards userT' <- initializeSkolems userT @@ -96,7 +97,7 @@ accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment e rowType <- freshTypeWithKind (P.kindRow P.kindType) resultType <- freshTypeWithKind P.kindType let recordFunction = srcTypeApp (srcTypeApp tyFunction (srcTypeApp tyRecord rowType)) resultType - _ <- subsumes recordFunction userT' + _ <- runWoGetEnv $ subsumes recordFunction userT' -- TODO add DB subst <- gets TC.checkSubstitution let solvedRow = toRowPair <$> fst (rowToList (substituteType subst rowType)) tcS <- get diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3f758805c6..934fd61b33 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, (<=<)) @@ -49,7 +51,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) @@ -62,6 +64,7 @@ import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, replaceTypeWild import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString) +import Language.PureScript.Make.Index.Select (GetEnv) data BindingGroupType = RecursiveBindingGroup @@ -75,16 +78,16 @@ data TypedValue' = TypedValue' Bool Expr SourceType tvToExpr :: TypedValue' -> Expr tvToExpr (TypedValue' c e t) = TypedValue c e t --- | Lookup data about a type class in the @Environment@ -lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData -lookupTypeClass name = - let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name - in gets (findClass . typeClasses . checkEnv) +-- -- | Lookup data about a type class in the @Environment@ +-- lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData +-- lookupTypeClass name = +-- let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name +-- in gets (findClass . typeClasses . checkEnv) -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => BindingGroupType -> ModuleName -> [((SourceAnn, Ident), Expr)] @@ -123,7 +126,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- ambiguous types to be inferred if they can be solved by some functional -- dependency. conData <- forM unsolved $ \(_, _, con) -> do - TypeClassData{ typeClassDependencies } <- lookupTypeClass $ constraintClass con + TypeClassData{ typeClassDependencies } <- lookupTypeClassUnsafe $ constraintClass con let -- The set of unknowns mentioned in each argument. unknownsForArg :: [S.Set Int] @@ -169,32 +172,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 +231,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. -- @@ -245,7 +266,7 @@ data SplitBindingGroup = SplitBindingGroup -- This function also generates fresh unification variables for the types of -- declarations without type annotations, returned in the 'UntypedData' structure. typeDictionaryForBindingGroup - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Maybe ModuleName -> [((SourceAnn, Ident), Expr)] -> m SplitBindingGroup @@ -282,7 +303,7 @@ typeDictionaryForBindingGroup moduleName vals = do -- | Check the type annotation of a typed value in a binding group. checkTypedBindingGroupElement - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => ModuleName -> ((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation @@ -301,7 +322,7 @@ checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => ((SourceAnn, Ident), (Expr, SourceType)) -- ^ The identifier we are trying to define, along with the expression and its assigned type -- (at this point, this should be a unification variable) @@ -321,7 +342,7 @@ typeForBindingGroupElement (ident, (val, ty)) dict = do -- This is necessary during type checking to avoid unifying a polymorphic type with a -- unification variable. instantiatePolyTypeWithUnknowns - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, GetEnv m) => Expr -> SourceType -> m (Expr, SourceType) @@ -346,7 +367,7 @@ instantiatePolyTypeWithUnknownsUntilVisible val (ForAll _ TypeVarInvisible ident instantiatePolyTypeWithUnknownsUntilVisible val $ replaceTypeVars ident u ty instantiatePolyTypeWithUnknownsUntilVisible val ty = return (val, ty) -instantiateConstraint :: MonadState CheckState m => Expr -> Type SourceAnn -> m (Expr, Type SourceAnn) +instantiateConstraint :: (MonadState CheckState m, GetEnv m) => Expr -> Type SourceAnn -> m (Expr, Type SourceAnn) instantiateConstraint val (ConstrainedType _ con ty) = do dicts <- getTypeClassDictionaries hints <- getHints @@ -359,16 +380,28 @@ 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) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) + => Expr + -> m TypedValue' +infer val = withErrorMessageHint (ErrorInferringType val) $ inferAndAddToIde val + + +inferAndAddToIde :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Expr -> m TypedValue' -infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val +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' :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Expr -> m TypedValue' infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue' True v tyInt @@ -451,7 +484,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" @@ -489,8 +522,8 @@ infer' (Var ss var) = do return $ TypedValue' True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty' _ -> return $ TypedValue' True (Var ss var) ty infer' v@(Constructor _ c) = do - env <- getEnv - case M.lookup c (dataConstructors env) of + ctrMb <- lookupConstructorMb c + case ctrMb of Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty, _) -> TypedValue' True v <$> (introduceSkolemScope <=< replaceAllTypeSynonyms $ ty) infer' (Case vals binders) = do @@ -530,7 +563,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 @@ -540,7 +573,7 @@ inferProperties :: ( MonadSupply m , MonadState CheckState m , MonadError MultipleErrors m - , MonadWriter MultipleErrors m + , MonadWriter MultipleErrors m, GetEnv m ) => [(PSString, Expr)] -> m [(PSString, (Expr, SourceType))] @@ -552,7 +585,7 @@ inferWithinRecord :: ( MonadSupply m , MonadState CheckState m , MonadError MultipleErrors m - , MonadWriter MultipleErrors m + , MonadWriter MultipleErrors m, GetEnv m ) => Expr -> m (Expr, SourceType) @@ -574,7 +607,7 @@ propertyShouldInstantiate = \case _ -> False inferLetBinding - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => [Declaration] -> [Declaration] -> Expr @@ -591,6 +624,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 +633,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,23 +647,36 @@ 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, GetEnv 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) + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv 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 - env <- getEnv - case M.lookup ctor (dataConstructors env) of +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 + ctrMb <- lookupConstructorMb ctor + case ctrMb of Just (_, _, ty, _) -> do (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn @@ -645,7 +693,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 +707,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. @@ -695,7 +743,7 @@ binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. instantiateForBinders - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => [Expr] -> [CaseAlternative] -> m ([Expr], [SourceType]) @@ -712,7 +760,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- Check the types of the return values in a set of binders in a case statement -- checkBinders - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => [SourceType] -> SourceType -> [CaseAlternative] @@ -728,7 +776,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do return $ r : rs checkGuardedRhs - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => GuardedExpr -> SourceType -> m GuardedExpr @@ -752,23 +800,28 @@ checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do -- Check the type of a value, rethrowing errors to provide a better error message -- check - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Expr -> SourceType -> m TypedValue' -check val ty = withErrorMessageHint' val (ErrorCheckingType val ty) $ 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, GetEnv m) + => Expr -> SourceType -> m TypedValue' +checkAndAddToIde val ty = do + tv <- check' val ty + addTypedValueToIde tv -- | -- Check the type of a value -- check' :: forall m - . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Expr -> SourceType -> m TypedValue' check' val (ForAll ann vis ident mbK ty _) = do - env <- getEnv + -- env <- getEnv mn <- gets checkCurrentModule scope <- newSkolemScope sko <- newSkolemConstant @@ -780,14 +833,17 @@ check' val (ForAll ann vis ident mbK ty _) = do -- was actually brought into scope. Otherwise we can end up skolemizing -- an undefined type variable that happens to clash with the variable we -- want to skolemize. This can happen due to synonym expansion (see 2542). + k <- lookupTypeMb (Qualified (byMaybeModuleName mn) (ProperName ident)) + + let skVal - | Just _ <- M.lookup (Qualified (byMaybeModuleName mn) (ProperName ident)) $ types env = + | Just _ <- k = skolemizeTypesInValue ss ident mbK sko scope val | otherwise = val val' <- tvToExpr <$> check skVal sk return $ TypedValue' True val' (ForAll ann vis ident mbK ty (Just scope)) check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName className)) _ _ _) ty) = do - TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls + TypeClassData{ typeClassIsEmpty } <- lookupTypeClassUnsafe cls -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` -- that wraps empty dictionary solutions in `Unused`. dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> className) @@ -818,6 +874,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 +929,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 @@ -889,8 +946,8 @@ check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val val' <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest)) return $ TypedValue' True (Accessor prop val') ty check' v@(Constructor _ c) ty = do - env <- getEnv - case M.lookup c (dataConstructors env) of + ctrMb <- lookupConstructorMb c + case ctrMb of Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 @@ -902,10 +959,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 @@ -918,7 +975,7 @@ check' val ty = do -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- checkProperties - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Expr -> [(PSString, Expr)] -> SourceType @@ -965,7 +1022,7 @@ checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where -- * The elaborated expression for the function application (since we might need to -- insert type class dictionaries, etc.) checkFunctionApplication - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Expr -- ^ The function expression -> SourceType @@ -976,11 +1033,13 @@ 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' - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, GetEnv m) => Expr -> SourceType -> Expr diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e4f1040ebf..d2d349685d 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -33,6 +33,7 @@ import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, un import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown) +import Language.PureScript.Make.Index.Select (GetEnv) -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. freshType :: (MonadState CheckState m) => m SourceType @@ -61,7 +62,7 @@ freshTypeWithKind kind = state $ \st -> do (srcTUnknown t, st') -- | Update the substitution to solve a type constraint -solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m () +solveType :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => Int -> SourceType -> m () solveType u t = rethrow (onErrorMessages withoutPosition) $ do -- We strip the position so that any errors get rethrown with the position of -- the original unification constraint. Otherwise errors may arise from arbitrary @@ -106,7 +107,7 @@ unknownsInType t = everythingOnTypes (.) go t [] go _ = id -- | Unify two types, updating the current substitution -unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () +unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => SourceType -> SourceType -> m () unifyTypes t1 t2 = do sub <- gets checkSubstitution withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) @@ -160,7 +161,7 @@ unifyTypes t1 t2 = do -- -- Common labels are identified and unified. Remaining labels and types are unified with a -- trailing row unification variable, if appropriate. -unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () +unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m, GetEnv m) => SourceType -> SourceType -> m () unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2 diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 593e8c1a8d..3f6cd66ee9 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,11 @@ 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) +-- instance type NamedDict = TypeClassDictionaryInScope (Qualified Ident) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index ef00e21a07..0791fe7e64 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -6,7 +6,7 @@ module Language.PureScript.Types where import Prelude import Protolude (ordNub, fromMaybe) -import Codec.Serialise (Serialise) +import Codec.Serialise (Serialise, serialise, deserialise) import Control.Applicative ((<|>)) import Control.Arrow (first, second) import Control.DeepSeq (NFData) @@ -28,6 +28,8 @@ import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName) import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) +import Database.SQLite.Simple.ToField (ToField (toField)) +import Database.SQLite.Simple.FromField (FromField (fromField)) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn @@ -115,6 +117,12 @@ data Type a instance NFData a => NFData (Type a) instance Serialise a => Serialise (Type a) +instance Serialise a => ToField (Type a) where + toField = toField . serialise + +instance Serialise a => FromField (Type a) where + fromField = fmap deserialise <$> fromField + srcTUnknown :: Int -> SourceType srcTUnknown = TUnknown NullSourceAnn 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!" +