wasp-lang/wasp
1
1
Fork 0
mirror of https://github.com/wasp-lang/wasp.git synced 2024-12-27 02:52:22 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'main' into wasp-ai

Browse Source
This commit is contained in:
Martin Sosic 2023-06-21 11:06:45 +02:00
commit cfa09771e1
43 changed files with 948 additions and 458 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
waspc/cli/src/Wasp/Cli/Command.hs
View File

@ -1,24 +1,35 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Wasp.Cli.Command
( Command,
runCommand,
CommandError (..),
-- * Requirements
-- See "Wasp.Cli.Command.Requires" for documentation.
require,
Requirable (checkRequirement),
)
where
import Control.Monad.Except (ExceptT, MonadError, runExceptT)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State.Strict (StateT, evalStateT, gets, modify)
import Data.Data (Typeable, cast)
import Data.Maybe (mapMaybe)
import System.Exit (exitFailure)
import Wasp.Cli.Message (cliSendMessage)
import qualified Wasp.Message as Msg
newtype Command a = Command {_runCommand :: ExceptT CommandError IO a}
newtype Command a = Command {_runCommand :: StateT [Requirement] (ExceptT CommandError IO) a}
deriving (Functor, Applicative, Monad, MonadIO, MonadError CommandError)
runCommand :: Command a -> IO ()
runCommand cmd = do
runExceptT (_runCommand cmd) >>= \case
runExceptT (flip evalStateT [] $ _runCommand cmd) >>= \case
Left cmdError -> do
cliSendMessage $ Msg.Failure (_errorTitle cmdError) (_errorMsg cmdError)
exitFailure
@ -27,3 +38,33 @@ runCommand cmd = do
-- TODO: What if we want to recognize errors in order to handle them?
-- Should we add _commandErrorType? Should CommandError be parametrized by it, is that even possible?
data CommandError = CommandError {_errorTitle :: !String, _errorMsg :: !String}
data Requirement where
Requirement :: Requirable r => r -> Requirement
class Typeable r => Requirable r where
-- | Check if the requirement is met and return a value representing that
-- requirement.
--
-- This function must always return a value: if the requirement is not met,
-- throw a 'CommandError'.
checkRequirement :: Command r
-- | Assert that a requirement is met and receive information about that
-- requirement, if any is offered.
--
-- To use, pattern match on the result, e.g.
--
-- @
-- do
-- HasDbConnection <- require
-- @
require :: Requirable r => Command r
require =
Command (gets (mapMaybe cast)) >>= \case
(req : _) -> return req
[] -> do
-- Requirement hasn't been met, so run the check
req <- checkRequirement
Command $ modify (Requirement req :)
return req

6
waspc/cli/src/Wasp/Cli/Command/Build.hs
View File

@ -13,11 +13,9 @@ import System.Directory
removeDirectoryRecursive,
)
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Command.Common
( findWaspProjectRootDirFromCwd,
)
import Wasp.Cli.Command.Compile (compileIOWithOptions, printCompilationResult)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Cli.Common as Common
import Wasp.Cli.Message (cliSendMessage)
import Wasp.CompileOptions (CompileOptions (..))
@ -35,7 +33,7 @@ import Wasp.Project (CompileError, CompileWarning)
-- Very similar to 'compile'.
build :: Command ()
build = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
let buildDir =
waspProjectDir </> Common.dotWaspDirInWaspProjectDir
</> Common.buildDirInDotWaspDir

4
waspc/cli/src/Wasp/Cli/Command/Clean.hs
View File

@ -10,14 +10,14 @@ import System.Directory
removeDirectoryRecursive,
)
import Wasp.Cli.Command (Command)
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Cli.Common as Common
import qualified Wasp.Message as Msg
clean :: Command ()
clean = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
let dotWaspDirFp = SP.toFilePath $ waspProjectDir SP.</> Common.dotWaspDirInWaspProjectDir
cliSendMessageC $ Msg.Start "Deleting .wasp/ directory..."
doesDotWaspDirExist <- liftIO $ doesDirectoryExist dotWaspDirFp

36
waspc/cli/src/Wasp/Cli/Command/Common.hs
View File

@ -1,52 +1,20 @@
module Wasp.Cli.Command.Common
( findWaspProjectRootDirFromCwd,
findWaspProjectRoot,
readWaspCompileInfo,
( readWaspCompileInfo,
throwIfExeIsNotAvailable,
)
where
import Control.Monad.Except
import qualified Control.Monad.Except as E
import Data.Maybe (fromJust)
import StrongPath (Abs, Dir, Path')
import qualified StrongPath as SP
import StrongPath.Operations
import System.Directory (doesFileExist, doesPathExist, findExecutable, getCurrentDirectory)
import qualified System.FilePath as FP
import System.Directory (findExecutable)
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Common (dotWaspRootFileInWaspProjectDir)
import qualified Wasp.Cli.Common as Cli.Common
import Wasp.Project (WaspProjectDir)
import Wasp.Util (ifM)
import qualified Wasp.Util.IO as IOUtil
findWaspProjectRoot :: Path' Abs (Dir ()) -> Command (Path' Abs (Dir WaspProjectDir))
findWaspProjectRoot currentDir = do
let absCurrentDirFp = SP.fromAbsDir currentDir
doesCurrentDirExist <- liftIO $ doesPathExist absCurrentDirFp
unless doesCurrentDirExist (throwError notFoundError)
let dotWaspRootFilePath = absCurrentDirFp FP.</> SP.fromRelFile dotWaspRootFileInWaspProjectDir
isCurrentDirRoot <- liftIO $ doesFileExist dotWaspRootFilePath
if isCurrentDirRoot
then return $ SP.castDir currentDir
else do
let parentDir = SP.parent currentDir
when (parentDir == currentDir) (throwError notFoundError)
findWaspProjectRoot parentDir
where
notFoundError =
CommandError
"Wasp command failed"
( "Couldn't find wasp project root - make sure"
++ " you are running this command from a Wasp project."
)
findWaspProjectRootDirFromCwd :: Command (Path' Abs (Dir WaspProjectDir))
findWaspProjectRootDirFromCwd = do
absCurrentDir <- liftIO getCurrentDirectory
findWaspProjectRoot (fromJust $ SP.parseAbsDir absCurrentDir)
readWaspCompileInfo :: Path' Abs (Dir WaspProjectDir) -> IO String
readWaspCompileInfo waspDir =
ifM

8
waspc/cli/src/Wasp/Cli/Command/Compile.hs
View File

@ -18,10 +18,8 @@ import Data.List (intercalate)
import StrongPath (Abs, Dir, Path', (</>))
import qualified Wasp.AppSpec as AS
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Command.Common
( findWaspProjectRootDirFromCwd,
)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Cli.Common as Common
import Wasp.Cli.Message (cliSendMessage)
import Wasp.CompileOptions (CompileOptions (..))
@ -36,7 +34,7 @@ compile = do
-- TODO: Consider a way to remove the redundancy of finding the project root
-- here and in compileWithOptions. One option could be to add this to defaultCompileOptions
-- add make externalCodeDirPath a helper function, along with any others we typically need.
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
compileWithOptions $ defaultCompileOptions waspProjectDir
-- | Compiles Wasp project that the current working directory is part of.
@ -47,7 +45,7 @@ compile = do
-- Finally, throws if there was a compile error, otherwise returns any compile warnings.
compileWithOptions :: CompileOptions -> Command [CompileWarning]
compileWithOptions options = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
let outDir =
waspProjectDir </> Common.dotWaspDirInWaspProjectDir
</> Common.generatedCodeDirInDotWaspDir

5
waspc/cli/src/Wasp/Cli/Command/Db.hs
View File

@ -4,8 +4,8 @@ module Wasp.Cli.Command.Db
where
import Wasp.Cli.Command (Command, runCommand)
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Compile (compileWithOptions, defaultCompileOptions)
import Wasp.Cli.Command.Require (DbConnectionEstablished (DbConnectionEstablished), InWaspProject (InWaspProject), require)
import Wasp.CompileOptions (CompileOptions (generatorWarningsFilter))
import Wasp.Generator.Monad (GeneratorWarning (GeneratorNeedsMigrationWarning))
@ -19,8 +19,9 @@ runDbCommand = runCommand . makeDbCommand
makeDbCommand :: Command a -> Command a
makeDbCommand cmd = do
-- Ensure code is generated and npm dependencies are installed.
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
_ <- compileWithOptions $ compileOptions waspProjectDir
DbConnectionEstablished <- require
cmd
where
compileOptions waspProjectDir =

6
waspc/cli/src/Wasp/Cli/Command/Db/Migrate.hs
View File

@ -8,10 +8,8 @@ import Control.Monad.Except (ExceptT (ExceptT), liftEither, runExceptT, throwErr
import Control.Monad.IO.Class (liftIO)
import StrongPath (Abs, Dir, Path', (</>))
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Command.Common
( findWaspProjectRootDirFromCwd,
)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Cli.Common as Cli.Common
import Wasp.Generator.Common (ProjectRootDir)
import Wasp.Generator.DbGenerator.Common (MigrateArgs (..), defaultMigrateArgs)
@ -24,7 +22,7 @@ import Wasp.Project.Db.Migrations (DbMigrationsDir, dbMigrationsDirInWaspProject
-- The migrate function takes care of copying migrations from the generated project back to the source code.
migrateDev :: [String] -> Command ()
migrateDev optionalMigrateArgs = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
let waspDbMigrationsDir = waspProjectDir </> dbMigrationsDirInWaspProjectDir
let projectRootDir =
waspProjectDir

4
waspc/cli/src/Wasp/Cli/Command/Db/Reset.hs
View File

@ -6,15 +6,15 @@ where
import Control.Monad.IO.Class (liftIO)
import StrongPath ((</>))
import Wasp.Cli.Command (Command)
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Cli.Common as Common
import Wasp.Generator.DbGenerator.Operations (dbReset)
import qualified Wasp.Message as Msg
reset :: Command ()
reset = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
let genProjectDir =
waspProjectDir </> Common.dotWaspDirInWaspProjectDir </> Common.generatedCodeDirInDotWaspDir

4
waspc/cli/src/Wasp/Cli/Command/Db/Seed.hs
View File

@ -16,16 +16,16 @@ import qualified Wasp.AppSpec.App.Db as AS.Db
import qualified Wasp.AppSpec.ExtImport as AS.ExtImport
import qualified Wasp.AppSpec.Valid as ASV
import Wasp.Cli.Command (Command, CommandError (CommandError))
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Compile (analyze)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Cli.Common as Common
import Wasp.Generator.DbGenerator.Operations (dbSeed)
import qualified Wasp.Message as Msg
seed :: Maybe String -> Command ()
seed maybeUserProvidedSeedName = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
let genProjectDir =
waspProjectDir </> Common.dotWaspDirInWaspProjectDir </> Common.generatedCodeDirInDotWaspDir

4
waspc/cli/src/Wasp/Cli/Command/Db/Studio.hs
View File

@ -8,8 +8,8 @@ import Control.Concurrent.Async (concurrently)
import Control.Monad.IO.Class (liftIO)
import StrongPath ((</>))
import Wasp.Cli.Command (Command)
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Cli.Common as Common
import Wasp.Generator.DbGenerator.Jobs (runStudio)
import Wasp.Generator.Job.IO (readJobMessagesAndPrintThemPrefixed)
@ -17,7 +17,7 @@ import qualified Wasp.Message as Msg
studio :: Command ()
studio = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
let genProjectDir =
waspProjectDir </> Common.dotWaspDirInWaspProjectDir </> Common.generatedCodeDirInDotWaspDir

4
waspc/cli/src/Wasp/Cli/Command/Deploy.hs
View File

@ -7,12 +7,12 @@ import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import System.Environment (getExecutablePath)
import Wasp.Cli.Command (Command, CommandError (CommandError))
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import qualified Wasp.Project.Deployment
deploy :: [String] -> Command ()
deploy cmdArgs = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
deployResult <- liftIO $ do
-- `getExecutablePath` has some caveats:
-- https://frasertweedale.github.io/blog-fp/posts/2022-05-10-improved-executable-path-queries.html

4
waspc/cli/src/Wasp/Cli/Command/Deps.hs
View File

@ -8,8 +8,8 @@ import Control.Monad.IO.Class (liftIO)
import Wasp.AppSpec (AppSpec)
import qualified Wasp.AppSpec.App.Dependency as AS.Dependency
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Compile (defaultCompileOptions)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import Wasp.Cli.Terminal (title)
import qualified Wasp.Generator.NpmDependencies as N
import qualified Wasp.Generator.ServerGenerator as ServerGenerator
@ -19,7 +19,7 @@ import qualified Wasp.Util.Terminal as Term
deps :: Command ()
deps = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
appSpecOrAnalyzerErrors <- liftIO $ analyzeWaspProject waspProjectDir (defaultCompileOptions waspProjectDir)
appSpec <-
either

4
waspc/cli/src/Wasp/Cli/Command/Dockerfile.hs
View File

@ -7,13 +7,13 @@ import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Text.IO as T.IO
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Compile (defaultCompileOptions)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import Wasp.Project (compileAndRenderDockerfile)
printDockerfile :: Command ()
printDockerfile = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
dockerfileContentOrCompileErrors <- liftIO $ compileAndRenderDockerfile waspProjectDir (defaultCompileOptions waspProjectDir)
either
(throwError . CommandError "Displaying Dockerfile failed due to a compilation error in your Wasp project" . unwords)

7
waspc/cli/src/Wasp/Cli/Command/Info.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE TypeApplications #-}
module Wasp.Cli.Command.Info
( info,
)
@ -12,9 +10,10 @@ import StrongPath.Operations ()
import System.Directory (getFileSize)
import qualified Wasp.AppSpec.Valid as ASV
import Wasp.Cli.Command (Command)
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd, readWaspCompileInfo)
import Wasp.Cli.Command.Common (readWaspCompileInfo)
import Wasp.Cli.Command.Compile (analyze)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import Wasp.Cli.Command.Start.Db (getDbSystem)
import Wasp.Cli.Terminal (title)
import qualified Wasp.Message as Msg
@ -24,7 +23,7 @@ import qualified Wasp.Util.Terminal as Term
info :: Command ()
info = do
waspDir <- findWaspProjectRootDirFromCwd
InWaspProject waspDir <- require
compileInfo <- liftIO $ readWaspCompileInfo waspDir
projectSize <- liftIO $ readDirectorySizeMB waspDir

98
waspc/cli/src/Wasp/Cli/Command/Require.hs Normal file
View File

@ -0,0 +1,98 @@
module Wasp.Cli.Command.Require
( -- * Asserting Requirements
-- There are some requirements we want to assert in command code, such as
-- ensuring the command is being run inside a wasp project directory. We
-- might end up wanting to check each requirement multiple times, especially
-- if we want the value from it (like getting the wasp project directory),
-- but we also want to avoid duplicating work. Using 'require' results in
-- checked requirements being stored so they can be immediately retrieved
-- when checking the same requirements additional times.
--
-- For example, you can check if you are in a wasp project by doing
--
-- @
-- do
-- InWaspProject waspProjectDir <- require
-- @
--
-- See instances of 'Requirable' for what kinds of requirements are
-- supported. To implement a new requirable type, give your type an instance
-- of 'Requirable'.
require,
-- * Requirables
Requirable (checkRequirement),
DbConnectionEstablished (DbConnectionEstablished),
InWaspProject (InWaspProject),
)
where
import Control.Monad (unless, when)
import Control.Monad.Error.Class (throwError)
import Control.Monad.IO.Class (liftIO)
import Data.Data (Typeable)
import Data.Maybe (fromJust)
import qualified StrongPath as SP
import System.Directory (doesFileExist, doesPathExist, getCurrentDirectory)
import qualified System.FilePath as FP
import Wasp.Cli.Command (CommandError (CommandError), Requirable (checkRequirement), require)
import Wasp.Cli.Common (WaspProjectDir)
import qualified Wasp.Cli.Common as Cli.Common
import Wasp.Generator.DbGenerator.Operations (isDbRunning)
data DbConnectionEstablished = DbConnectionEstablished deriving (Typeable)
instance Requirable DbConnectionEstablished where
checkRequirement = do
-- NOTE: 'InWaspProject' does not depend on this requirement, so this
-- call to 'require' will not result in an infinite loop.
InWaspProject waspProjectDir <- require
let outDir = waspProjectDir SP.</> Cli.Common.dotWaspDirInWaspProjectDir SP.</> Cli.Common.generatedCodeDirInDotWaspDir
dbIsRunning <- liftIO $ isDbRunning outDir
if dbIsRunning
then return DbConnectionEstablished
else throwError noDbError
where
noDbError =
CommandError
"Can not connect to database"
( "The database needs to be running in order to execute this command."
++ " You can easily start a managed dev database with `wasp start db`."
)
-- | Require a Wasp project to exist near the current directory. Get the
-- project directory by pattern matching on the result of 'require':
--
-- @
-- do
-- InWaspProject waspProjectDir <- require
-- @
newtype InWaspProject = InWaspProject (SP.Path' SP.Abs (SP.Dir WaspProjectDir)) deriving (Typeable)
instance Requirable InWaspProject where
checkRequirement = do
-- Recursively searches up from CWD until @.wasproot@ file is found, or
-- throw an error if it is never found.
currentDir <- fromJust . SP.parseAbsDir <$> liftIO getCurrentDirectory
findWaspProjectRoot currentDir
where
findWaspProjectRoot currentDir = do
let absCurrentDirFp = SP.fromAbsDir currentDir
doesCurrentDirExist <- liftIO $ doesPathExist absCurrentDirFp
unless doesCurrentDirExist (throwError notFoundError)
let dotWaspRootFilePath = absCurrentDirFp FP.</> SP.fromRelFile Cli.Common.dotWaspRootFileInWaspProjectDir
isCurrentDirRoot <- liftIO $ doesFileExist dotWaspRootFilePath
if isCurrentDirRoot
then return $ InWaspProject $ SP.castDir currentDir
else do
let parentDir = SP.parent currentDir
when (parentDir == currentDir) (throwError notFoundError)
findWaspProjectRoot parentDir
notFoundError =
CommandError
"Wasp command failed"
( "Couldn't find wasp project root - make sure"
++ " you are running this command from a Wasp project."
)

6
waspc/cli/src/Wasp/Cli/Command/Start.hs
View File

@ -10,9 +10,9 @@ import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import StrongPath ((</>))
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Compile (compile, printWarningsAndErrorsIfAny)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (DbConnectionEstablished (DbConnectionEstablished), InWaspProject (InWaspProject), require)
import Wasp.Cli.Command.Watch (watch)
import qualified Wasp.Cli.Common as Common
import qualified Wasp.Generator
@ -23,13 +23,15 @@ import Wasp.Project (CompileError, CompileWarning)
-- It also listens for any file changes and recompiles and restarts generated project accordingly.
start :: Command ()
start = do
waspRoot <- findWaspProjectRootDirFromCwd
InWaspProject waspRoot <- require
let outDir = waspRoot </> Common.dotWaspDirInWaspProjectDir </> Common.generatedCodeDirInDotWaspDir
cliSendMessageC $ Msg.Start "Starting compilation and setup phase. Hold tight..."
warnings <- compile
DbConnectionEstablished <- require
cliSendMessageC $ Msg.Start "Listening for file changes..."
cliSendMessageC $ Msg.Start "Starting up generated project..."

5
waspc/cli/src/Wasp/Cli/Command/Start/Db.hs
View File

@ -18,9 +18,10 @@ import qualified Wasp.AppSpec.App as AS.App
import qualified Wasp.AppSpec.App.Db as AS.App.Db
import qualified Wasp.AppSpec.Valid as ASV
import Wasp.Cli.Command (Command, CommandError (CommandError))
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd, throwIfExeIsNotAvailable)
import Wasp.Cli.Command.Common (throwIfExeIsNotAvailable)
import Wasp.Cli.Command.Compile (analyze)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import Wasp.Cli.Common (WaspProjectDir)
import qualified Wasp.Message as Msg
import Wasp.Project.Db (databaseUrlEnvVarName)
@ -36,7 +37,7 @@ import qualified Wasp.Util.Network.Socket as Socket
-- in Wasp configuration and spins up a database of appropriate type.
start :: Command ()
start = do
waspProjectDir <- findWaspProjectRootDirFromCwd
InWaspProject waspProjectDir <- require
appSpec <- analyze waspProjectDir
throwIfCustomDbAlreadyInUse appSpec

6
waspc/cli/src/Wasp/Cli/Command/Telemetry/Project.hs
View File

@ -31,7 +31,7 @@ import qualified System.Environment as ENV
import qualified System.Info
import Wasp.Cli.Command (Command)
import qualified Wasp.Cli.Command.Call as Command.Call
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import Wasp.Cli.Command.Telemetry.Common (TelemetryCacheDir)
import Wasp.Cli.Command.Telemetry.User (UserSignature (..))
import Wasp.Util (ifM)
@ -100,7 +100,9 @@ checkIfEnvValueIsTruthy (Just v)
newtype ProjectHash = ProjectHash {_projectHashValue :: String} deriving (Show)
getWaspProjectPathHash :: Command ProjectHash
getWaspProjectPathHash = ProjectHash . take 16 . sha256 . SP.toFilePath <$> findWaspProjectRootDirFromCwd
getWaspProjectPathHash = do
InWaspProject waspRoot <- require
return . ProjectHash . take 16 . sha256 . SP.toFilePath $ waspRoot
where
sha256 :: String -> String
sha256 = show . hashWith SHA256 . ByteStringUTF8.fromString

4
waspc/cli/src/Wasp/Cli/Command/Test.hs
View File

@ -10,9 +10,9 @@ import Control.Monad.IO.Class (liftIO)
import StrongPath (Abs, Dir, (</>))
import StrongPath.Types (Path')
import Wasp.Cli.Command (Command, CommandError (..))
import Wasp.Cli.Command.Common (findWaspProjectRootDirFromCwd)
import Wasp.Cli.Command.Compile (compile)
import Wasp.Cli.Command.Message (cliSendMessageC)
import Wasp.Cli.Command.Require (InWaspProject (InWaspProject), require)
import Wasp.Cli.Command.Watch (watch)
import qualified Wasp.Cli.Common as Common
import qualified Wasp.Generator
@ -27,7 +27,7 @@ test _ = throwError $ CommandError "Invalid arguments" "Expected: wasp test clie
watchAndTest :: (Path' Abs (Dir ProjectRootDir) -> IO (Either String ())) -> Command ()
watchAndTest testRunner = do
waspRoot <- findWaspProjectRootDirFromCwd
InWaspProject waspRoot <- require
let outDir = waspRoot </> Common.dotWaspDirInWaspProjectDir </> Common.generatedCodeDirInDotWaspDir
cliSendMessageC $ Msg.Start "Starting compilation and setup phase. Hold tight..."

2
waspc/examples/todoApp/todoApp.wasp
View File

@ -46,7 +46,7 @@ app todoApp {
},
server: {
setupFn: import setup from "@server/serverSetup.js",
middlewareConfigFn: import { serverMiddlewareFn } from "@server/serverSetup.js"
middlewareConfigFn: import { serverMiddlewareFn } from "@server/serverSetup.js",
},
client: {
rootComponent: import { App } from "@client/App.tsx",

272
waspc/headless-test/package-lock.json generated
View File

@ -9,27 +9,15 @@
"version": "1.0.0",
"license": "ISC",
"dependencies": {
"@prisma/client": "^4.12.0"
"@prisma/client": "^4.12.0",
"linebyline": "^1.3.0"
},
"devDependencies": {
"@playwright/test": "^1.33.0",
"concurrently": "^8.0.1",
"prisma": "^4.12.0",
"wait-port": "^1.0.4"
}
},
"node_modules/@babel/runtime": {
"version": "7.21.5",
"resolved": "https://registry.npmjs.org/@babel/runtime/-/runtime-7.21.5.tgz",
"integrity": "sha512-8jI69toZqqcsnqGGqwGS4Qb1VwLOEp4hz+CXPywcvjs60u3B4Pom/U/7rm4W8tMOYEB+E9wgD0mW1l3r8qlI9Q==",
"dev": true,
"dependencies": {
"regenerator-runtime": "^0.13.11"
},
"engines": {
"node": ">=6.9.0"
}
},
"node_modules/@playwright/test": {
"version": "1.33.0",
"resolved": "https://registry.npmjs.org/@playwright/test/-/test-1.33.0.tgz",
@ -87,15 +75,6 @@
"integrity": "sha512-OPs5WnnT1xkCBiuQrZA4+YAV4HEJejmHneyraIaxsbev5yCEr6KMwINNFP9wQeFIw8FWcoTqF3vQsa5CDaI+8Q==",
"dev": true
},
"node_modules/ansi-regex": {
"version": "5.0.1",
"resolved": "https://registry.npmjs.org/ansi-regex/-/ansi-regex-5.0.1.tgz",
"integrity": "sha512-quJQXlTSUGL2LH9SUXo8VwsY4soanhgo6LNSm84E1LBcE8s3O0wpdiRzyR9z/ZZJMlMWv37qOOb9pdJlMUEKFQ==",
"dev": true,
"engines": {
"node": ">=8"
}
},
"node_modules/ansi-styles": {
"version": "4.3.0",
"resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-4.3.0.tgz",
@ -139,20 +118,6 @@
"node": ">=8"
}
},
"node_modules/cliui": {
"version": "8.0.1",
"resolved": "https://registry.npmjs.org/cliui/-/cliui-8.0.1.tgz",
"integrity": "sha512-BSeNnyus75C4//NQ9gQt1/csTXyo/8Sb+afLAkzAptFuMsod9HFokGNudZpi/oQV73hnVK+sR+5PVRMd+Dr7YQ==",
"dev": true,
"dependencies": {
"string-width": "^4.2.0",
"strip-ansi": "^6.0.1",
"wrap-ansi": "^7.0.0"
},
"engines": {
"node": ">=12"
}
},
"node_modules/color-convert": {
"version": "2.0.1",
"resolved": "https://registry.npmjs.org/color-convert/-/color-convert-2.0.1.tgz",
@ -180,49 +145,6 @@
"node": "^12.20.0 || >=14"
}
},
"node_modules/concurrently": {
"version": "8.0.1",
"resolved": "https://registry.npmjs.org/concurrently/-/concurrently-8.0.1.tgz",
"integrity": "sha512-Sh8bGQMEL0TAmAm2meAXMjcASHZa7V0xXQVDBLknCPa9TPtkY9yYs+0cnGGgfdkW0SV1Mlg+hVGfXcoI8d3MJA==",
"dev": true,
"dependencies": {
"chalk": "^4.1.2",
"date-fns": "^2.29.3",
"lodash": "^4.17.21",
"rxjs": "^7.8.0",
"shell-quote": "^1.8.0",
"spawn-command": "0.0.2-1",
"supports-color": "^8.1.1",
"tree-kill": "^1.2.2",
"yargs": "^17.7.1"
},
"bin": {
"conc": "dist/bin/concurrently.js",
"concurrently": "dist/bin/concurrently.js"
},
"engines": {
"node": "^14.13.0 || >=16.0.0"
},
"funding": {
"url": "https://github.com/open-cli-tools/concurrently?sponsor=1"
}
},
"node_modules/date-fns": {
"version": "2.30.0",
"resolved": "https://registry.npmjs.org/date-fns/-/date-fns-2.30.0.tgz",
"integrity": "sha512-fnULvOpxnC5/Vg3NCiWelDsLiUc9bRwAPs/+LfTLNvetFCtCTN+yQz15C/fs4AwX1R9K5GLtLfn8QW+dWisaAw==",
"dev": true,
"dependencies": {
"@babel/runtime": "^7.21.0"
},
"engines": {
"node": ">=0.11"
},
"funding": {
"type": "opencollective",
"url": "https://opencollective.com/date-fns"
}
},
"node_modules/debug": {
"version": "4.3.4",
"resolved": "https://registry.npmjs.org/debug/-/debug-4.3.4.tgz",
@ -240,21 +162,6 @@
}
}
},
"node_modules/emoji-regex": {
"version": "8.0.0",
"resolved": "https://registry.npmjs.org/emoji-regex/-/emoji-regex-8.0.0.tgz",
"integrity": "sha512-MSjYzcWNOA0ewAHpz0MxpYFvwg6yjy1NG3xteoqz644VCo/RPgnr1/GGt+ic3iJTzQ8Eu3TdM14SawnVUmGE6A==",
"dev": true
},
"node_modules/escalade": {
"version": "3.1.1",
"resolved": "https://registry.npmjs.org/escalade/-/escalade-3.1.1.tgz",
"integrity": "sha512-k0er2gUkLf8O0zKJiAhmkTnJlTvINGv7ygDNPbeIsX/TJjGJZHuh9B2UxbsaEkmlEo9MfhrSzmhIlhRlI2GXnw==",
"dev": true,
"engines": {
"node": ">=6"
}
},
"node_modules/fsevents": {
"version": "2.3.2",
"resolved": "https://registry.npmjs.org/fsevents/-/fsevents-2.3.2.tgz",
@ -269,15 +176,6 @@
"node": "^8.16.0 || ^10.6.0 || >=11.0.0"
}
},
"node_modules/get-caller-file": {
"version": "2.0.5",
"resolved": "https://registry.npmjs.org/get-caller-file/-/get-caller-file-2.0.5.tgz",
"integrity": "sha512-DyFP3BM/3YHTQOCUL/w0OZHR0lpKeGrxotcHWcqNEdnltqFwXVfhEBQ94eIo34AfQpo0rGki4cyIiftY06h2Fg==",
"dev": true,
"engines": {
"node": "6.* || 8.* || >= 10.*"
}
},
"node_modules/has-flag": {
"version": "4.0.0",
"resolved": "https://registry.npmjs.org/has-flag/-/has-flag-4.0.0.tgz",
@ -287,20 +185,10 @@
"node": ">=8"
}
},
"node_modules/is-fullwidth-code-point": {
"version": "3.0.0",
"resolved": "https://registry.npmjs.org/is-fullwidth-code-point/-/is-fullwidth-code-point-3.0.0.tgz",
"integrity": "sha512-zymm5+u+sCsSWyD9qNaejV3DFvhCKclKdizYaJUuHA83RLjb7nSuGnddCHGv0hk+KY7BMAlsWeK4Ueg6EV6XQg==",
"dev": true,
"engines": {
"node": ">=8"
}
},
"node_modules/lodash": {
"version": "4.17.21",
"resolved": "https://registry.npmjs.org/lodash/-/lodash-4.17.21.tgz",
"integrity": "sha512-v2kDEe57lecTulaDIuNTPy3Ry4gLGJ6Z1O3vE1krgXZNrsQ+LFTGHVxVjcXPs17LhbZVGedAJv8XZ1tvj5FvSg==",
"dev": true
"node_modules/linebyline": {
"version": "1.3.0",
"resolved": "https://registry.npmjs.org/linebyline/-/linebyline-1.3.0.tgz",
"integrity": "sha512-3fpIYMrSU77OCf89hjXKuCx6vGwgWEu4N5DDCGqgZ1BF0HYy9V8IbQb/3+VWIU17iBQ83qQoUokH0AhPMOTi7w=="
},
"node_modules/ms": {
"version": "2.1.2",
@ -337,101 +225,6 @@
"node": ">=14.17"
}
},
"node_modules/regenerator-runtime": {
"version": "0.13.11",
"resolved": "https://registry.npmjs.org/regenerator-runtime/-/regenerator-runtime-0.13.11.tgz",
"integrity": "sha512-kY1AZVr2Ra+t+piVaJ4gxaFaReZVH40AKNo7UCX6W+dEwBo/2oZJzqfuN1qLq1oL45o56cPaTXELwrTh8Fpggg==",
"dev": true
},
"node_modules/require-directory": {
"version": "2.1.1",
"resolved": "https://registry.npmjs.org/require-directory/-/require-directory-2.1.1.tgz",
"integrity": "sha512-fGxEI7+wsG9xrvdjsrlmL22OMTTiHRwAMroiEeMgq8gzoLC/PQr7RsRDSTLUg/bZAZtF+TVIkHc6/4RIKrui+Q==",
"dev": true,
"engines": {
"node": ">=0.10.0"
}
},
"node_modules/rxjs": {
"version": "7.8.1",
"resolved": "https://registry.npmjs.org/rxjs/-/rxjs-7.8.1.tgz",
"integrity": "sha512-AA3TVj+0A2iuIoQkWEK/tqFjBq2j+6PO6Y0zJcvzLAFhEFIO3HL0vls9hWLncZbAAbK0mar7oZ4V079I/qPMxg==",
"dev": true,
"dependencies": {
"tslib": "^2.1.0"
}
},
"node_modules/shell-quote": {
"version": "1.8.1",
"resolved": "https://registry.npmjs.org/shell-quote/-/shell-quote-1.8.1.tgz",
"integrity": "sha512-6j1W9l1iAs/4xYBI1SYOVZyFcCis9b4KCLQ8fgAGG07QvzaRLVVRQvAy85yNmmZSjYjg4MWh4gNvlPujU/5LpA==",
"dev": true,
"funding": {
"url": "https://github.com/sponsors/ljharb"
}
},
"node_modules/spawn-command": {
"version": "0.0.2-1",
"resolved": "https://registry.npmjs.org/spawn-command/-/spawn-command-0.0.2-1.tgz",
"integrity": "sha512-n98l9E2RMSJ9ON1AKisHzz7V42VDiBQGY6PB1BwRglz99wpVsSuGzQ+jOi6lFXBGVTCrRpltvjm+/XA+tpeJrg==",
"dev": true
},
"node_modules/string-width": {
"version": "4.2.3",
"resolved": "https://registry.npmjs.org/string-width/-/string-width-4.2.3.tgz",
"integrity": "sha512-wKyQRQpjJ0sIp62ErSZdGsjMJWsap5oRNihHhu6G7JVO/9jIB6UyevL+tXuOqrng8j/cxKTWyWUwvSTriiZz/g==",
"dev": true,
"dependencies": {
"emoji-regex": "^8.0.0",
"is-fullwidth-code-point": "^3.0.0",
"strip-ansi": "^6.0.1"
},
"engines": {
"node": ">=8"
}
},
"node_modules/strip-ansi": {
"version": "6.0.1",
"resolved": "https://registry.npmjs.org/strip-ansi/-/strip-ansi-6.0.1.tgz",
"integrity": "sha512-Y38VPSHcqkFrCpFnQ9vuSXmquuv5oXOKpGeT6aGrr3o3Gc9AlVa6JBfUSOCnbxGGZF+/0ooI7KrPuUSztUdU5A==",
"dev": true,
"dependencies": {
"ansi-regex": "^5.0.1"
},
"engines": {
"node": ">=8"
}
},
"node_modules/supports-color": {
"version": "8.1.1",
"resolved": "https://registry.npmjs.org/supports-color/-/supports-color-8.1.1.tgz",
"integrity": "sha512-MpUEN2OodtUzxvKQl72cUF7RQ5EiHsGvSsVG0ia9c5RbWGL2CI4C7EpPS8UTBIplnlzZiNuV56w+FuNxy3ty2Q==",
"dev": true,
"dependencies": {
"has-flag": "^4.0.0"
},
"engines": {
"node": ">=10"
},
"funding": {
"url": "https://github.com/chalk/supports-color?sponsor=1"
}
},
"node_modules/tree-kill": {
"version": "1.2.2",
"resolved": "https://registry.npmjs.org/tree-kill/-/tree-kill-1.2.2.tgz",
"integrity": "sha512-L0Orpi8qGpRG//Nd+H90vFB+3iHnue1zSSGmNOOCh1GLJ7rUKVwV2HvijphGQS2UmhUZewS9VgvxYIdgr+fG1A==",
"dev": true,
"bin": {
"tree-kill": "cli.js"
}
},
"node_modules/tslib": {
"version": "2.5.0",
"resolved": "https://registry.npmjs.org/tslib/-/tslib-2.5.0.tgz",
"integrity": "sha512-336iVw3rtn2BUK7ORdIAHTyxHGRIHVReokCR3XjbckJMK7ms8FysBfhLR8IXnAgy7T0PTPNBWKiH514FOW/WSg==",
"dev": true
},
"node_modules/wait-port": {
"version": "1.0.4",
"resolved": "https://registry.npmjs.org/wait-port/-/wait-port-1.0.4.tgz",
@ -448,59 +241,6 @@
"engines": {
"node": ">=10"
}
},
"node_modules/wrap-ansi": {
"version": "7.0.0",
"resolved": "https://registry.npmjs.org/wrap-ansi/-/wrap-ansi-7.0.0.tgz",
"integrity": "sha512-YVGIj2kamLSTxw6NsZjoBxfSwsn0ycdesmc4p+Q21c5zPuZ1pl+NfxVdxPtdHvmNVOQ6XSYG4AUtyt/Fi7D16Q==",
"dev": true,
"dependencies": {
"ansi-styles": "^4.0.0",
"string-width": "^4.1.0",
"strip-ansi": "^6.0.0"
},
"engines": {
"node": ">=10"
},
"funding": {
"url": "https://github.com/chalk/wrap-ansi?sponsor=1"
}
},
"node_modules/y18n": {
"version": "5.0.8",
"resolved": "https://registry.npmjs.org/y18n/-/y18n-5.0.8.tgz",
"integrity": "sha512-0pfFzegeDWJHJIAmTLRP2DwHjdF5s7jo9tuztdQxAhINCdvS+3nGINqPd00AphqJR/0LhANUS6/+7SCb98YOfA==",
"dev": true,
"engines": {
"node": ">=10"
}
},
"node_modules/yargs": {
"version": "17.7.2",
"resolved": "https://registry.npmjs.org/yargs/-/yargs-17.7.2.tgz",
"integrity": "sha512-7dSzzRQ++CKnNI/krKnYRV7JKKPUXMEh61soaHKg9mrWEhzFWhFnxPxGl+69cD1Ou63C13NUPCnmIcrvqCuM6w==",
"dev": true,
"dependencies": {
"cliui": "^8.0.1",
"escalade": "^3.1.1",
"get-caller-file": "^2.0.5",
"require-directory": "^2.1.1",
"string-width": "^4.2.3",
"y18n": "^5.0.5",
"yargs-parser": "^21.1.1"
},
"engines": {
"node": ">=12"
}
},
"node_modules/yargs-parser": {
"version": "21.1.1",
"resolved": "https://registry.npmjs.org/yargs-parser/-/yargs-parser-21.1.1.tgz",
"integrity": "sha512-tVpsJW7DdjecAiFpbIB1e3qxIQsE6NoPc5/eTdrbbIC4h0LVsWhnoa3g+m2HclBIujHzsxZ4VJVA+GUuc2/LBw==",
"dev": true,
"engines": {
"node": ">=12"
}
}
}
}

6
waspc/headless-test/package.json
View File

@ -4,7 +4,7 @@
"description": "",
"main": "index.js",
"scripts": {
"example-app:start": "concurrently \"npm:example-app:start-db\" \"npm:example-app:start-app\" --kill-others-on-fail",
"example-app:start": "node start.js",
"example-app:start-db": "npm run example-app:cleanup-db && cd ./examples/todoApp && cabal run wasp-cli start db",
"example-app:start-app": "npm run example-app:wait-for-db && cd ./examples/todoApp && cabal run wasp-cli db migrate-dev && cabal run wasp-cli start",
"example-app:wait-for-db": "sleep 5 && ./node_modules/.bin/wait-port 5432",
@ -15,9 +15,9 @@
"license": "ISC",
"devDependencies": {
"@playwright/test": "^1.33.0",
"concurrently": "^8.0.1",
"prisma": "^4.12.0",
"wait-port": "^1.0.4"
"wait-port": "^1.0.4",
"linebyline": "^1.3.0"
},
"dependencies": {
"@prisma/client": "^4.12.0"

31
waspc/headless-test/start.js Normal file
View File

@ -0,0 +1,31 @@
const cp = require('child_process');
const readline = require('linebyline');
function spawn(name, cmd, args, done) {
const spawnOptions = {
detached: true,
};
const proc = cp.spawn(cmd, args, spawnOptions);
// We close stdin stream on the new process because otherwise the start-app
// process hangs.
// See https://github.com/wasp-lang/wasp/pull/1218#issuecomment-1599098272.
proc.stdin.destroy();
readline(proc.stdout).on('line', data => {
console.log(`\x1b[0m\x1b[33m[${name}][out]\x1b[0m ${data}`);
});
readline(proc.stderr).on('line', data => {
console.log(`\x1b[0m\x1b[33m[${name}][err]\x1b[0m ${data}`);
});
proc.on('exit', done);
}
// Exit if either child fails
const cb = (code) => {
if (code !== 0) {
process.exit(code);
}
}
spawn('app', 'npm', ['run', 'example-app:start-app'], cb);
spawn('db', 'npm', ['run', 'example-app:start-db'], cb)

14
waspc/src/Wasp/Generator/DbGenerator/Jobs.hs
View File

@ -7,6 +7,7 @@ module Wasp.Generator.DbGenerator.Jobs
runStudio,
reset,
seed,
dbExecuteTest,
migrateStatus,
asPrismaCliArgs,
)
@ -113,6 +114,19 @@ seed projectDir seedName =
projectDir
(const ["db", "seed"])
-- | Checks if the DB is running and connectable by running
-- `prisma db execute --stdin --schema <path to db schema>`.
-- Runs the command in the generated server code directory so it has access to the database URL.
--
-- Since nothing is passed to stdin, `prisma db execute` just runs an empty
-- SQL command, which works perfectly for checking if the database is running.
dbExecuteTest :: Path' Abs (Dir ProjectRootDir) -> J.Job
dbExecuteTest projectDir =
let absSchemaPath = projectDir </> dbSchemaFileInProjectRootDir
in runPrismaCommandAsDbJob
projectDir
(const ["db", "execute", "--stdin", "--schema", SP.fromAbsFile absSchemaPath])
-- | Runs `prisma studio` - Prisma's db inspector.
runStudio :: Path' Abs (Dir ProjectRootDir) -> J.Job
runStudio projectDir = runPrismaCommandAsDbJob projectDir $ \schema ->

11
waspc/src/Wasp/Generator/DbGenerator/Operations.hs
View File

@ -6,6 +6,7 @@ module Wasp.Generator.DbGenerator.Operations
areAllMigrationsAppliedToDb,
dbReset,
dbSeed,
isDbRunning,
)
where
@ -134,6 +135,16 @@ dbSeed genProjectDir seedName = do
ExitSuccess -> Right ()
ExitFailure c -> Left $ "Failed with exit code " <> show c
isDbRunning ::
Path' Abs (Dir ProjectRootDir) ->
IO Bool
isDbRunning genProjectDir = do
chan <- newChan
exitCode <- DbJobs.dbExecuteTest genProjectDir chan
-- NOTE: We only care if the command succeeds or fails, so we don't look at
-- the exit code or stdout/stderr for the process.
return $ exitCode == ExitSuccess
generatePrismaClients :: Path' Abs (Dir ProjectRootDir) -> IO (Either String ())
generatePrismaClients projectRootDir = do
generateResult <- liftA2 (>>) generatePrismaClientForServer generatePrismaClientForWebApp projectRootDir

9
waspc/waspc.cabal
View File

@ -354,8 +354,13 @@ library waspls
Wasp.LSP.Handlers
Wasp.LSP.Diagnostic
Wasp.LSP.Completion
Wasp.LSP.Util
Wasp.LSP.Completions.Common
Wasp.LSP.Completions.DictKeyCompletion
Wasp.LSP.Completions.ExprCompletion
Wasp.LSP.SignatureHelp
Wasp.LSP.Syntax
Wasp.LSP.TypeInference
Wasp.LSP.Util
build-depends:
base
, aeson
@ -370,6 +375,7 @@ library waspls
, text
, transformers ^>=0.5.6.2
, utf8-string
, unordered-containers
, waspc
library cli-lib
@ -434,6 +440,7 @@ library cli-lib
Wasp.Cli.Command.Deploy
Wasp.Cli.Command.Dockerfile
Wasp.Cli.Command.Info
Wasp.Cli.Command.Require
Wasp.Cli.Command.Start
Wasp.Cli.Command.Start.Db
Wasp.Cli.Command.Telemetry

100
waspc/waspls/src/Wasp/LSP/Completion.hs
View File

@ -3,18 +3,18 @@ module Wasp.LSP.Completion
)
where
import Control.Lens ((?~), (^.))
import Control.Lens ((^.))
import Control.Monad.Log.Class (MonadLog (logM))
import Control.Monad.State.Class (MonadState, gets)
import Data.Maybe (maybeToList)
import qualified Data.Text as Text
import Data.List (sortOn)
import qualified Language.LSP.Types as LSP
import qualified Language.LSP.Types.Lens as LSP
import Wasp.Analyzer.Parser.CST (SyntaxNode)
import qualified Wasp.Analyzer.Parser.CST as S
import Wasp.Analyzer.Parser.CST.Traverse
import Wasp.LSP.ServerState
import Wasp.LSP.Syntax (findChild, isAtExprPlace, lexemeAt, lspPositionToOffset, showNeighborhood, toOffset)
import Wasp.Analyzer.Parser.CST.Traverse (fromSyntaxForest)
import Wasp.LSP.Completions.Common (CompletionContext (..), CompletionProvider)
import qualified Wasp.LSP.Completions.DictKeyCompletion as DictKeyCompletion
import qualified Wasp.LSP.Completions.ExprCompletion as ExprCompletion
import Wasp.LSP.ServerState (ServerState, cst, currentWaspSource)
import Wasp.LSP.Syntax (locationAtOffset, lspPositionToOffset, showNeighborhood)
-- | Get the list of completions at a (line, column) position in the source.
getCompletionsAtPosition ::
@ -30,76 +30,18 @@ getCompletionsAtPosition position = do
Just syntax -> do
let offset = lspPositionToOffset src position
-- 'location' is a traversal through the syntax tree that points to 'position'
let location = toOffset offset (fromSyntaxForest syntax)
let location = locationAtOffset offset (fromSyntaxForest syntax)
logM $ "[getCompletionsAtPosition] position=" ++ show position ++ " offset=" ++ show offset
logM $ "[getCompletionsAtPosition] neighborhood=\n" ++ showNeighborhood location
exprCompletions <-
if isAtExprPlace location
then do
logM $ "[getCompletionsAtPosition] offset=" ++ show offset ++ " position=" ++ show position ++ " atExpr=True"
getExprCompletions src syntax
else do
logM $ "[getCompletionsAtPosition] offset=" ++ show offset ++ " position=" ++ show position ++ " atExpr=False"
return []
let completions = exprCompletions
return completions
let completionContext = CompletionContext {_src = src, _cst = syntax}
let runCompletionProvider = \cp -> cp completionContext location
completionItems <- concat <$> mapM runCompletionProvider completionProviders
return $ sortOn (^. LSP.label) completionItems
-- | If the location is at an expression, find declaration names in the file
-- and return them as autocomplete suggestions
--
-- TODO: include completions for enum variants (use standard type defs from waspc)
getExprCompletions ::
(MonadLog m) =>
String ->
[SyntaxNode] ->
m [LSP.CompletionItem]
getExprCompletions src syntax = do
let declNames = findDeclNames src syntax
logM $ "[getExprCompletions] declnames=" ++ show declNames
return $
map
( \(name, typ) ->
makeBasicCompletionItem (Text.pack name)
& (LSP.kind ?~ LSP.CiVariable)
& (LSP.detail ?~ Text.pack (":: " ++ typ ++ " (declaration type)"))
)
declNames
-- | Search through the CST and collect all @(declName, declType)@ pairs.
findDeclNames :: String -> [SyntaxNode] -> [(String, String)]
findDeclNames src syntax = traverseForDeclNames $ fromSyntaxForest syntax
where
traverseForDeclNames :: Traversal -> [(String, String)]
traverseForDeclNames t = case kindAt t of
S.Program -> maybe [] traverseForDeclNames $ down t
S.Decl ->
let declNameAndType = maybeToList $ getDeclNameAndType t
in declNameAndType ++ maybe [] traverseForDeclNames (right t)
_ -> maybe [] traverseForDeclNames $ right t
getDeclNameAndType :: Traversal -> Maybe (String, String)
getDeclNameAndType t = do
nameT <- findChild S.DeclName t
typeT <- findChild S.DeclType t
return (lexemeAt src nameT, lexemeAt src typeT)
-- | Create a completion item containing only a label.
makeBasicCompletionItem :: Text.Text -> LSP.CompletionItem
makeBasicCompletionItem name =
LSP.CompletionItem
{ _label = name,
_kind = Nothing,
_tags = Nothing,
_detail = Nothing,
_documentation = Nothing,
_deprecated = Nothing,
_preselect = Nothing,
_sortText = Nothing,
_filterText = Nothing,
_insertText = Nothing,
_insertTextFormat = Nothing,
_insertTextMode = Nothing,
_textEdit = Nothing,
_additionalTextEdits = Nothing,
_commitCharacters = Nothing,
_command = Nothing,
_xdata = Nothing
}
-- | List of all 'CompletionProvider's to use. We break this up into separate
-- modules because the code for each can be pretty unrelated.
completionProviders :: (MonadLog m) => [CompletionProvider m]
completionProviders =
[ ExprCompletion.getCompletions,
DictKeyCompletion.getCompletions
]

51
waspc/waspls/src/Wasp/LSP/Completions/Common.hs Normal file
View File

@ -0,0 +1,51 @@
{-# LANGUAGE TemplateHaskell #-}
module Wasp.LSP.Completions.Common
( CompletionProvider,
CompletionContext (..),
src,
cst,
makeBasicCompletionItem,
)
where
import Control.Lens (makeClassy)
import qualified Data.Text as Text
import qualified Language.LSP.Types as LSP
import Wasp.Analyzer.Parser.CST (SyntaxNode)
import Wasp.Analyzer.Parser.CST.Traverse (Traversal)
-- | A function that providers 'LSP.CompletionItems' at a location.
type CompletionProvider m = CompletionContext -> Traversal -> m [LSP.CompletionItem]
data CompletionContext = CompletionContext
{ _src :: String,
_cst :: [SyntaxNode]
}
deriving (Eq, Show)
makeClassy 'CompletionContext
-- | Create a completion item containing only a label. Use lenses and 'Control.Lens.(?~)'
-- to set more fields, if desired.
makeBasicCompletionItem :: Text.Text -> LSP.CompletionItem
makeBasicCompletionItem name =
LSP.CompletionItem
{ _label = name,
_kind = Nothing,
_tags = Nothing,
_detail = Nothing,
_documentation = Nothing,
_deprecated = Nothing,
_preselect = Nothing,
_sortText = Nothing,
_filterText = Nothing,
_insertText = Nothing,
_insertTextFormat = Nothing,
_insertTextMode = Nothing,
_textEdit = Nothing,
_additionalTextEdits = Nothing,
_commitCharacters = Nothing,
_command = Nothing,
_xdata = Nothing
}

74
waspc/waspls/src/Wasp/LSP/Completions/DictKeyCompletion.hs Normal file
View File

@ -0,0 +1,74 @@
module Wasp.LSP.Completions.DictKeyCompletion
( getCompletions,
)
where
import Control.Lens ((?~), (^.))
import Control.Monad.Log.Class (MonadLog (logM))
import Data.Bifunctor (Bifunctor (second))
import qualified Data.HashMap.Strict as M
import qualified Data.Text as Text
import qualified Language.LSP.Types as LSP
import qualified Language.LSP.Types.Lens as LSP
import qualified Wasp.Analyzer.Parser.CST as S
import Wasp.Analyzer.Parser.CST.Traverse (Traversal)
import qualified Wasp.Analyzer.Parser.CST.Traverse as T
import Wasp.Analyzer.Type (Type)
import qualified Wasp.Analyzer.Type as Type
import Wasp.LSP.Completions.Common (CompletionProvider, makeBasicCompletionItem)
import qualified Wasp.LSP.Completions.Common as Ctx
import Wasp.LSP.Syntax (hasLeft, parentIs)
import Wasp.LSP.TypeInference (inferTypeAtLocation)
import Wasp.LSP.Util (allP, anyP)
-- | If the location is at a place where a dictionary key is expected, find
-- the list of keys that are allowed in the dictionary around the location and
-- return them as completion items.
--
-- The allowed keys are found by determining the expected type for the
-- dictionary and getting the keys from that, assuming it is a 'Type.DictType'.
-- No completions are made if there is no expected type or if the expected type
-- is not a 'Type.DictType'.
--
-- See 'Wasp.LSP.TypeHint' for how the expected type for the dictionary is
-- determined.
getCompletions :: (MonadLog m) => CompletionProvider m
getCompletions context location =
if not $ isDictKeyExpectedAtLocation location
then do
logM "[DictKeyCompletion] not at dict key"
return []
else do
logM "[DictKeyCompletion] at dict key"
getCompletionsAtDictKey
where
getCompletionsAtDictKey = case inferTypeAtLocation (context ^. Ctx.src) location of
Nothing -> do
logM "[DictKeyCompletion] no type hint, can not suggest keys"
return []
Just (Type.DictType fieldMap) -> do
logM "[DictKeyCompletion] found dict type hint"
return $ map completionItemFromDictField $ listDictFields fieldMap
Just _ -> do
logM "[DictKeyCompletion] found non-dict type hint, no keys to suggest"
return []
completionItemFromDictField (key, keyType) =
-- The user sees "key", but when they accept the completion "key: " is
-- inserted, via the @insertText@ field.
makeBasicCompletionItem (Text.pack key)
T.& (LSP.kind ?~ LSP.CiField)
T.& (LSP.detail ?~ Text.pack (":: " ++ show keyType))
T.& (LSP.insertText ?~ Text.pack (key ++ ": "))
isDictKeyExpectedAtLocation :: Traversal -> Bool
isDictKeyExpectedAtLocation =
anyP
[ parentIs S.Dict,
allP [parentIs S.DictEntry, not . hasLeft S.DictKey]
]
-- | List the (key, valuetype) pairs for a type. Returns an empty list for
-- everything except a 'Type.DictType'.
listDictFields :: M.HashMap String Type.DictEntryType -> [(String, Type)]
listDictFields fieldMap = map (second Type.dictEntryType) $ M.toList fieldMap

60
waspc/waspls/src/Wasp/LSP/Completions/ExprCompletion.hs Normal file
View File

@ -0,0 +1,60 @@
module Wasp.LSP.Completions.ExprCompletion
( getCompletions,
)
where
import Control.Lens ((?~), (^.))
import Control.Monad.Log.Class (MonadLog (logM))
import Data.Maybe (maybeToList)
import qualified Data.Text as Text
import qualified Language.LSP.Types as LSP
import qualified Language.LSP.Types.Lens as LSP
import Wasp.Analyzer.Parser.CST (SyntaxNode)
import qualified Wasp.Analyzer.Parser.CST as S
import Wasp.Analyzer.Parser.CST.Traverse
import Wasp.LSP.Completions.Common (CompletionProvider, makeBasicCompletionItem)
import qualified Wasp.LSP.Completions.Common as Ctx
import Wasp.LSP.Syntax (findChild, isAtExprPlace, lexemeAt)
-- | If the location is at an expression, find declaration names in the file
-- and return them as completion items.
--
-- TODO: include completions for enum variants (use standard type defs from waspc)
getCompletions :: (MonadLog m) => CompletionProvider m
getCompletions context location =
if not (isAtExprPlace location)
then do
logM "[ExprCompletion] not at expression"
return []
else do
logM "[ExprCompletion] at expression"
let declNames = getDeclNamesAndTypes (context ^. Ctx.src) (context ^. Ctx.cst)
logM $ "[ExprCompletion] declnames=" ++ show declNames
return $
map
( \(name, typ) ->
makeBasicCompletionItem (Text.pack name)
& (LSP.kind ?~ LSP.CiVariable)
& (LSP.detail ?~ Text.pack (":: " ++ typ ++ " (declaration type)"))
)
declNames
-- | Search through the CST and collect all @(declName, declType)@ pairs.
getDeclNamesAndTypes :: String -> [SyntaxNode] -> [(String, String)]
getDeclNamesAndTypes src syntax = traverseForDeclNames $ fromSyntaxForest syntax
where
traverseForDeclNames :: Traversal -> [(String, String)]
traverseForDeclNames t = case kindAt t of
S.Program -> maybe [] traverseForDeclNames $ down t
S.Decl ->
let declNameAndType = maybeToList $ getDeclNameAndType t
in declNameAndType ++ maybe [] traverseForDeclNames (right t)
_ -> maybe [] traverseForDeclNames $ right t
-- @getDeclNameAndType t@ expects 't' to be at a 'S.Decl' node. It finds the
-- lexemes for the 'S.DeclName' and 'S.DeclType'.
getDeclNameAndType :: Traversal -> Maybe (String, String)
getDeclNameAndType t = do
nameT <- findChild S.DeclName t
typeT <- findChild S.DeclType t
return (lexemeAt src nameT, lexemeAt src typeT)

11
waspc/waspls/src/Wasp/LSP/Handlers.hs
View File

@ -4,6 +4,7 @@ module Wasp.LSP.Handlers
didChangeHandler,
didSaveHandler,
completionHandler,
signatureHelpHandler,
)
where
@ -22,6 +23,7 @@ import Wasp.LSP.Completion (getCompletionsAtPosition)
import Wasp.LSP.Diagnostic (concreteParseErrorToDiagnostic, waspErrorToDiagnostic)
import Wasp.LSP.ServerM (ServerError (..), ServerM, Severity (..), gets, liftLSP, modify, throwError)
import Wasp.LSP.ServerState (cst, currentWaspSource, latestDiagnostics)
import Wasp.LSP.SignatureHelp (getSignatureHelpAtPosition)
-- LSP notification and request handlers
@ -65,6 +67,15 @@ completionHandler =
completions <- getCompletionsAtPosition $ request ^. LSP.params . LSP.position
respond $ Right $ LSP.InL $ LSP.List completions
signatureHelpHandler :: Handlers ServerM
signatureHelpHandler =
LSP.requestHandler LSP.STextDocumentSignatureHelp $ \request respond -> do
-- NOTE: lsp-types 1.4.0.1 forgot to add lenses for SignatureHelpParams so
-- we have to get the position out the painful way.
let LSP.SignatureHelpParams {_position = position} = request ^. LSP.params
signatureHelp <- getSignatureHelpAtPosition position
respond $ Right signatureHelp
-- | Does not directly handle a notification or event, but should be run when
-- text document content changes.
--

8
waspc/waspls/src/Wasp/LSP/Server.hs
View File

@ -20,6 +20,7 @@ import Wasp.LSP.Handlers
import Wasp.LSP.ServerConfig (ServerConfig)
import Wasp.LSP.ServerM (ServerError (..), ServerM, Severity (..), runServerM)
import Wasp.LSP.ServerState (ServerState)
import Wasp.LSP.SignatureHelp (signatureHelpRetriggerCharacters, signatureHelpTriggerCharacters)
lspServerHandlers :: LSP.Handlers ServerM
lspServerHandlers =
@ -28,7 +29,8 @@ lspServerHandlers =
didOpenHandler,
didSaveHandler,
didChangeHandler,
completionHandler
completionHandler,
signatureHelpHandler
]
serve :: Maybe FilePath -> IO ()
@ -100,7 +102,9 @@ lspServerOptions :: LSP.Options
lspServerOptions =
(def :: LSP.Options)
{ LSP.textDocumentSync = Just syncOptions,
LSP.completionTriggerCharacters = Just [':']
LSP.completionTriggerCharacters = Just [':', ' '],
LSP.signatureHelpTriggerCharacters = signatureHelpTriggerCharacters,
LSP.signatureHelpRetriggerCharacters = signatureHelpRetriggerCharacters
}
-- | Options to tell the client how to update the server about the state of text

257
waspc/waspls/src/Wasp/LSP/SignatureHelp.hs Normal file
View File

@ -0,0 +1,257 @@
module Wasp.LSP.SignatureHelp
( getSignatureHelpAtPosition,
signatureHelpTriggerCharacters,
signatureHelpRetriggerCharacters,
)
where
import Control.Applicative ((<|>))
import Control.Lens ((^.))
import Control.Monad (guard)
import Control.Monad.Log.Class (MonadLog, logM)
import Control.Monad.State.Class (MonadState, gets)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import qualified Data.HashMap.Strict as M
import Data.List (elemIndex, foldl', intersperse)
import Data.Maybe (mapMaybe)
import Data.String (IsString (fromString))
import qualified Data.Text as Text
import qualified Language.LSP.Types as LSP
import Text.Printf (printf)
import Wasp.Analyzer.Parser.CST.Traverse (Traversal, fromSyntaxForest)
import Wasp.Analyzer.Type (Type)
import qualified Wasp.Analyzer.Type as Type
import Wasp.LSP.ServerState (ServerState, cst, currentWaspSource)
import Wasp.LSP.Syntax (locationAtOffset, lspPositionToOffset)
import Wasp.LSP.TypeInference (ExprPathStep (DictKey, List, Tuple), findExprPathToLocation, findTypeForPath)
import Wasp.LSP.Util (hoistMaybe)
-- | Configuration for 'LSP.Options', used in "Wasp.LSP.Server".
--
-- When the client types one of these characters, it will send a SignatureHelp
-- request. It is configured so that signatures will display when starting a
-- dictionary, list, tuple, or starting a new field/value in the container.
signatureHelpTriggerCharacters :: Maybe [Char]
signatureHelpTriggerCharacters = Just "{[(:,"
-- | Configuration for 'LSP.Options', used in "Wasp.LSP.Server".
--
-- When a client is already displaying signature help, typing one of these
-- characters will cause it to update the displayed signature by sending a new
-- SignatureHelp request. It is configured so that signatures will update when
-- ending a dictionary, list, or tuple.
--
-- NOTE: 'signatureHelpTriggerCharacters' are also counted as retrigger characters.
signatureHelpRetriggerCharacters :: Maybe [Char]
signatureHelpRetriggerCharacters = Just "}])"
-- | Get 'LSP.SignatureHelp' at a position in the wasp file. The signature
-- displays the type of the "container" that the position is in, if any.
--
-- SignatureHelp is usually displayed as a popup near the text you are typing,
-- and highlights the part of the signature you are writing.
--
-- A container is an expression that holds other values, such as dictionaries
-- and lists.
--
-- The parameter field of the signature is used for which part of the container
-- the position is within, such as a key for a dictionary.
getSignatureHelpAtPosition ::
(MonadState ServerState m, MonadLog m) =>
LSP.Position ->
m LSP.SignatureHelp
getSignatureHelpAtPosition position = do
src <- gets (^. currentWaspSource)
gets (^. cst) >>= \case
Nothing ->
-- No CST in the server state, can't create a signature.
return emptyHelp
Just syntax ->
let offset = lspPositionToOffset src position
location = locationAtOffset offset (fromSyntaxForest syntax)
in getSignatureHelpAtLocation src location
where
getSignatureHelpAtLocation src location =
findSignatureAtLocation src location >>= \case
Nothing -> do
logM "[getSignatureHelpAtPosition] no signature found"
return emptyHelp
Just signature -> do
logM "[getSignatureHelpAtPosition] found a signature"
getLspSignatureFromSignature signature
getLspSignatureFromSignature signature = do
let signatureFragments = signatureToFragments signature
let params = getLspParamsInfoFromFragments signatureFragments
let activeParam = signatureParam signature >>= findActiveParameterIndex signatureFragments
logM $ "[getSignatureHelpAtPosition] at param idx = " ++ show activeParam ++ " params = " ++ show params
let signatureInformation =
LSP.SignatureInformation
{ _label = Text.pack $ showFragments signatureFragments,
_parameters = Just $ LSP.List params,
-- NOTE: VSCode highlights the 0th parameter if activeParameter, so
-- it's set to -1 when we don't want any parameter highlighted.
_activeParameter = activeParam <|> Just (-1),
_documentation = Nothing
}
return $
LSP.SignatureHelp
{ _signatures = LSP.List [signatureInformation],
_activeSignature = Just 0,
_activeParameter = Nothing
}
emptyHelp =
LSP.SignatureHelp
{ _signatures = LSP.List [],
_activeSignature = Nothing,
_activeParameter = Nothing
}
-- | 'Signature' describes the expected type at a specific location inside of
-- a container in a wasp file. Every signature includes the type of the container
-- surrounding the location. For example, the container type for a cursor
-- positioned inside of a dictionary would be the type of the dictionary.
--
-- When the location is at a more specific place inside of the container--for
-- example, immediately after @key: @ in a dictionary--then we say the location
-- is at a parameter, and the parameter is described in relation to the container
-- with an 'ExprPathStep'.
data Signature = Signature
{ signatureType :: !Type,
signatureParam :: !(Maybe ExprPathStep)
}
deriving (Eq, Show)
-- | @'findSignatureAtLocation' sourceCode location@ runs type inference at the
-- given location to try to find a 'Signature'.
--
-- To do this, two types are inferred: the /location type/ and the
-- /container type/. The location type is the type expected exactly at the given
-- location and the container type is the type of that contains the location
-- type. For example, if the cursor is at the 2nd entry of a tuple with type
-- @(string, number)@, then the tip type is @number@ and the parent type is
-- that tuple type.
--
-- Then we check if the cursor is just inside a container or at a parameter
-- inside a container. It's in a container when the location type is a container
-- or if there is no container type.
findSignatureAtLocation ::
(MonadLog m) =>
String ->
Traversal ->
m (Maybe Signature)
findSignatureAtLocation src location = runMaybeT $ do
exprPath <- hoistMaybe $ findExprPathToLocation src location
lift $ logM $ "[SignatureHelp] at expr path " ++ show exprPath
guard $ not $ null exprPath
case exprPath of
[path] -> do
containerType <- hoistMaybe (findTypeForPath [path])
return $ Signature containerType Nothing
path -> do
-- Using init/last here is OK since we know @path@ has at least 2 elements.
locationType <- hoistMaybe $ findTypeForPath path
if isContainerType locationType
then return $ Signature locationType Nothing
else do
containerType <- hoistMaybe $ findTypeForPath $ init path
return $ Signature containerType (Just $ last path)
where
isContainerType :: Type -> Bool
isContainerType (Type.DictType _) = True
isContainerType (Type.ListType _) = True
isContainerType Type.TupleType {} = True
isContainerType _ = False
-- | A fragment of the text representation of a signature, with information
-- for finding the spans of parameters inside of the text representation.
--
-- This is used as an intermediate form between 'Signature' and the response
-- format that the LSP specifies.
data SignatureFragment
= -- | A plaintext fragment of a signature.
PlaintextFragment !String
| -- | A fragment that contains the text for a parameter of the signature. The
-- parameter is identified by the 'ExprPathStep'.
ParamFragment !ExprPathStep !String
deriving (Eq, Show)
fragmentText :: SignatureFragment -> String
fragmentText (PlaintextFragment text) = text
fragmentText (ParamFragment _ text) = text
fragmentParam :: SignatureFragment -> Maybe ExprPathStep
fragmentParam (PlaintextFragment _) = Nothing
fragmentParam (ParamFragment key _) = Just key
instance IsString SignatureFragment where
fromString string = PlaintextFragment string
-- | Convert the container type of a signature to a list of fragments.
--
-- To avoid unreadably long signatures, dictionary types inside of the container
-- type are written as @{ ... }@.
signatureToFragments :: Signature -> [SignatureFragment]
signatureToFragments signature = case signatureType signature of
Type.DictType fieldMap
| M.null fieldMap -> ["{}"]
| otherwise ->
let fields = intersperse ",\n " (map fieldToFragment (M.toList fieldMap))
in concat [["{\n "], fields, ["\n}"]]
Type.ListType inner -> ["[", ParamFragment List (showInnerType inner), "]"]
Type.TupleType (a, b, cs) ->
let fieldTypes = a : b : cs
fields = intersperse ", " (zipWith (\n -> ParamFragment (Tuple n) . showInnerType) [0 ..] fieldTypes)
in concat [["("], fields, [")"]]
typ -> [fromString (show typ)]
where
showInnerType :: IsString s => Type -> s
showInnerType (Type.DictType _) = "{ ... }"
showInnerType typ = fromString (show typ)
fieldToFragment :: (String, Type.DictEntryType) -> SignatureFragment
fieldToFragment (key, Type.DictRequired typ) =
ParamFragment (DictKey key) $ printf "%s: %s" key (showInnerType typ :: String)
fieldToFragment (key, Type.DictOptional typ) =
ParamFragment (DictKey key) $ printf "%s?: %s" key (showInnerType typ :: String)
-- | Convert a list of fragments to a string by concatenating the text of each
-- fragment.
showFragments :: [SignatureFragment] -> String
showFragments = concatMap fragmentText
-- | Search through a list of fragments to find the parameters.
--
-- The LSP wants the starting and ending offset of each parameter in the signature
-- help text (computed in 'showFragments'), so this function also has to keep
-- track of the 0-based offset into the final text.
getLspParamsInfoFromFragments :: [SignatureFragment] -> [LSP.ParameterInformation]
getLspParamsInfoFromFragments fragments =
reverse $ map labelToInfo $ snd $ foldl' go (0, []) fragments
where
-- A left fold is used because offset needs to increase as you go right across
-- the list. This means the parameter list needs to be reversed after the fold
-- so that they are in the same order as the parameters in the fragments.
go :: (LSP.UInt, [LSP.ParameterLabel]) -> SignatureFragment -> (LSP.UInt, [LSP.ParameterLabel])
go (offset, labels) (PlaintextFragment text) = (offset + fromIntegral (length text), labels)
go (offset, labels) (ParamFragment _ text) =
let end = offset + fromIntegral (length text)
in (end, LSP.ParameterLabelOffset offset end : labels)
labelToInfo :: LSP.ParameterLabel -> LSP.ParameterInformation
labelToInfo label =
LSP.ParameterInformation
{ _label = label,
_documentation = Nothing
}
-- | Find the index of the active parameter in a list of fragments.
--
-- NOTE: This function computes the index into the parameter list, not the
-- fragment list. This is why 'PlaintextFragment's are filtered out of the
-- list before indexing (via @mapMaybe fragmentParam@).
findActiveParameterIndex :: [SignatureFragment] -> ExprPathStep -> Maybe LSP.UInt
findActiveParameterIndex fragments key =
fromIntegral <$> elemIndex key (mapMaybe fragmentParam fragments)

42
waspc/waspls/src/Wasp/LSP/Syntax.hs
View File

@ -3,7 +3,9 @@ module Wasp.LSP.Syntax
-- | Module with utilities for working with/looking for patterns in CSTs
lspPositionToOffset,
toOffset,
locationAtOffset,
parentIs,
hasLeft,
isAtExprPlace,
lexemeAt,
findChild,
@ -16,6 +18,7 @@ import Data.List (find, intercalate)
import qualified Language.LSP.Types as J
import qualified Wasp.Analyzer.Parser.CST as S
import Wasp.Analyzer.Parser.CST.Traverse
import Wasp.LSP.Util (allP, anyP)
-- | @lspPositionToOffset srcString position@ returns 0-based offset from the
-- start of @srcString@ to the specified line and column.
@ -27,21 +30,31 @@ lspPositionToOffset srcString (J.Position l c) =
-- | Move to the node containing the offset.
--
-- This tries to prefer non-trivia tokens where possible. If the offset falls
-- exactly between two tokens, it choses the left-most non-trivia token.
toOffset :: Int -> Traversal -> Traversal
toOffset targetOffset start = go $ bottom start
-- If the offset falls on the border between two nodes, it tries to first choose
-- the leftmost non-trivia token, and then the leftmost token.
locationAtOffset :: Int -> Traversal -> Traversal
locationAtOffset targetOffset start = go $ bottom start
where
go :: Traversal -> Traversal
go at
| offsetAt at == targetOffset = at
| offsetAfter at > targetOffset = at
| offsetAfter at == targetOffset && not (S.syntaxKindIsTrivia (kindAt at)) =
at
| offsetAfter at == targetOffset =
if not $ S.syntaxKindIsTrivia $ kindAt at
then at
else case at & next of
Just at' | not (S.syntaxKindIsTrivia (kindAt at')) -> at'
_ -> at
-- If @at & next@ fails, the input doesn't contain the offset, so just
-- return the last node instead.
| otherwise = maybe at go $ at & next
parentIs :: S.SyntaxKind -> Traversal -> Bool
parentIs k t = Just k == parentKind t
hasLeft :: S.SyntaxKind -> Traversal -> Bool
hasLeft k t = k `elem` map kindAt (leftSiblings t)
-- | Check whether a position in a CST is somewhere an expression belongs. These
-- locations (as of now) are:
--
@ -50,14 +63,13 @@ toOffset targetOffset start = go $ bottom start
-- - Parent is a List
-- - Parent is a Tuple
isAtExprPlace :: Traversal -> Bool
isAtExprPlace t =
(parentIs S.DictEntry && hasLeft S.DictKey)
|| parentIs S.List
|| (parentIs S.Decl && hasLeft S.DeclType && hasLeft S.DeclName)
|| parentIs S.Tuple
where
parentIs k = Just k == parentKind t
hasLeft k = k `elem` map kindAt (leftSiblings t)
isAtExprPlace =
anyP
[ allP [parentIs S.DictEntry, hasLeft S.DictKey],
allP [parentIs S.Decl, hasLeft S.DeclType, hasLeft S.DeclName],
parentIs S.List,
parentIs S.Tuple
]
-- | Show the nodes around the current position
--

124
waspc/waspls/src/Wasp/LSP/TypeInference.hs Normal file
View File

@ -0,0 +1,124 @@
module Wasp.LSP.TypeInference
( -- * Inferred types for CST locations
inferTypeAtLocation,
-- * Lower level pieces
ExprPath,
ExprPathStep (..),
findExprPathToLocation,
findTypeForPath,
)
where
import Control.Monad (guard)
import Data.Foldable (find)
import qualified Data.HashMap.Strict as M
import qualified Wasp.Analyzer.Parser.CST as S
import Wasp.Analyzer.Parser.CST.Traverse (Traversal)
import qualified Wasp.Analyzer.Parser.CST.Traverse as T
import Wasp.Analyzer.StdTypeDefinitions (stdTypes)
import Wasp.Analyzer.Type (Type)
import qualified Wasp.Analyzer.Type as Type
import Wasp.Analyzer.TypeDefinitions (DeclType (dtBodyType), getDeclType)
import Wasp.LSP.Syntax (lexemeAt)
inferTypeAtLocation :: String -> Traversal -> Maybe Type
inferTypeAtLocation src location = findExprPathToLocation src location >>= findTypeForPath
-- | A "path" through wasp expressions to a certain location.
--
-- === __Example__
-- For the code
--
-- @
-- app todoApp {
-- auth: {
-- usernameAndPassword: |
-- ^
-- }
-- }
-- @
--
-- The path to the cursor would be @[Decl "app", DictKey "auth", DictKey "usernameAndPassword"]@.
type ExprPath = [ExprPathStep]
data ExprPathStep
= -- | @Decl declType@. Enter a declaration of type @declType@.
Decl !String
| -- | @DictKey key@. Enter a dictionary *and* its key @key@.
DictKey !String
| -- | Enter a value inside a list.
List
| -- | @Tuple idx@. Enter the @idx@-th value inside of a tuple.
Tuple !Int
deriving (Eq, Show)
-- | This function only depends on the syntax to the left of the location, and
-- tries to be as lenient as possible in finding paths.
findExprPathToLocation :: String -> Traversal -> Maybe ExprPath
findExprPathToLocation src location = reverse <$> go location
where
-- Recursively travel up the syntax tree, accumlating a path in reverse
-- order. Each recursion adds at most one new path component.
go :: Traversal -> Maybe ExprPath
go t = case T.up t of
Nothing -> Just [] -- Top level of the syntax reached.
Just t' -> case T.kindAt t' of
S.Program -> Just []
S.Decl -> do
typLoc <- find ((== S.DeclType) . T.kindAt) $ T.leftSiblings t
let typ = lexemeAt src typLoc
-- Stop recursion after finding a Decl
return [Decl typ]
S.DictEntry -> case find ((== S.DictKey) . T.kindAt) $ T.leftSiblings t of
Just keyLoc -> do
-- There is a key to the left, so @t@ is the value for that key.
let key = lexemeAt src keyLoc
t'' <- T.up t'
guard $ T.kindAt t'' == S.Dict
(DictKey key :) <$> go t''
Nothing -> go t'
S.List -> (List :) <$> go t' -- Inside a list.
S.Tuple -> do
-- Inside a tuple, number of expression nodes to the left is the tuple
-- index that @t@ is part of.
let nExprsBefore = length $ filter (S.syntaxKindIsExpr . T.kindAt) $ T.leftSiblings t
(Tuple nExprsBefore :) <$> go t'
_ -> go t' -- Found some other node, just ignore it and continue the tree.
-- | Get the type in 'stdTypes' for the expression path. The path must start
-- with a 'Decl', otherwise 'Nothing' is returned. If the path's decl does not
-- exist in 'stdTypes', 'Nothing' is returned.
--
-- === __Example__
-- >>> findTypeForPath [Dict "app", Key "auth", Key "methods", Key "usernameAndPassword"]
-- Just (Type.DictType { fields = M.fromList [("configFn", Type.DictOptional { dictEntryType = Type.ExtImportType })] })
findTypeForPath :: ExprPath -> Maybe Type
findTypeForPath (Decl declType : originalPath) = do
topType <- getDeclType declType stdTypes
go (dtBodyType topType) originalPath
where
-- @go parentType path@ returns the result of following @path@ starting at
-- @parentType@.
go :: Type -> ExprPath -> Maybe Type
go typ [] = Just typ
go _ (Decl _ : _) = Nothing -- Can't follow a decl in the middle of a path.
go typ (DictKey key : path) =
case typ of
Type.DictType fields -> do
-- Get the type of the field corresponding to the key.
typ' <- Type.dictEntryType <$> fields M.!? key
go typ' path
_ -> Nothing -- Not a dict type, can't use Key here.
go typ (List : path) = case typ of
Type.ListType typ' -> go typ' path -- Use the inner type of the list.
_ -> Nothing -- Not a list type, can't use List here.
go typ (Tuple idx : path) = case typ of
Type.TupleType (a, b, cs) -> case idx of
-- Follow the current type (by index) of the tuple.
0 -> go a path
1 -> go b path
n | n < length cs + 2 -> go (cs !! (n - 2)) path
_ -> Nothing -- Index is too large for the tuple type.
_ -> Nothing -- Not a tuple type, can't use Tuple here.
findTypeForPath _ = Nothing -- Doesn't start with a Decl.

22
waspc/waspls/src/Wasp/LSP/Util.hs
View File

@ -1,6 +1,14 @@
module Wasp.LSP.Util (waspSourceRegionToLspRange, waspPositionToLspPosition) where
module Wasp.LSP.Util
( allP,
anyP,
hoistMaybe,
waspSourceRegionToLspRange,
waspPositionToLspPosition,
)
where
import Control.Lens ((+~))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
import Data.Function ((&))
import qualified Language.LSP.Types as LSP
import qualified Language.LSP.Types.Lens as LSP
@ -20,3 +28,15 @@ waspPositionToLspPosition (W.SourcePosition ln col) =
{ _line = fromIntegral ln - 1,
_character = fromIntegral col - 1
}
-- | Check if all the supplied predicates are true.
allP :: Foldable f => f (a -> Bool) -> a -> Bool
allP preds x = all ($ x) preds
-- | Check if any of the supplied predicates are true.
anyP :: Foldable f => f (a -> Bool) -> a -> Bool
anyP preds x = any ($ x) preds
-- | Lift a 'Maybe' into a 'MaybeT' monad transformer.
hoistMaybe :: Applicative m => Maybe a -> MaybeT m a
hoistMaybe = MaybeT . pure

17
waspc/waspls/test/Wasp/LSP/CompletionTest.hs
View File

@ -106,12 +106,19 @@ runCompletionTest testInput =
fmtedCompletionItems = map fmtCompletionItem completionItems
fmtCompletionItem :: LSP.CompletionItem -> String
fmtCompletionItem item =
unwords
[ printf "label={%s}" (show $ item ^. LSP.label),
printf "kind={%s}" (show $ item ^. LSP.kind),
printf "detail={%s}" (show $ item ^. LSP.detail)
fmtCompletionItem item = unwords fields
where
fields =
concat
[ field "label" LSP.label,
optionalField "kind" LSP.kind,
optionalField "detail" LSP.detail,
optionalField "insertText" LSP.insertText
]
field label getter = [printf "%s={%s}" (label :: String) (show $ item ^. getter)]
optionalField label getter = case item ^. getter of
Nothing -> []
Just v -> [printf "%s={%s}" (label :: String) (show v)]
in "Completion items:\n" ++ unlines (map (" " <>) fmtedCompletionItems)
-- | Parses a completion test case into a pair of the wasp source code to

2
waspc/waspls/test/Wasp/LSP/completionTests/at_dict_key.golden
View File

@ -1 +1,3 @@
Completion items:
label={"path"} kind={CiField} detail={":: string"} insertText={"path: "}
label={"to"} kind={CiField} detail={":: page (declaration type)"} insertText={"to: "}

2
waspc/waspls/test/Wasp/LSP/completionTests/at_dict_key.wasp
View File

@ -6,7 +6,7 @@ app todoApp {
title: "todo!",
}
route MainRoute { path: "/", | }
route MainRoute { | }
^
page MainPage {
component: import { MainPage } from "@client/MainPage.jsx",

3
waspc/waspls/test/Wasp/LSP/completionTests/dict_key_duplicate.golden Normal file
View File

@ -0,0 +1,3 @@
Completion items:
label={"path"} kind={CiField} detail={":: string"} insertText={"path: "}
label={"to"} kind={CiField} detail={":: page (declaration type)"} insertText={"to: "}

14
waspc/waspls/test/Wasp/LSP/completionTests/dict_key_duplicate.wasp Normal file
View File

@ -0,0 +1,14 @@
//! test/completion
app todoApp {
wasp: {
version: "^0.10.5",
},
title: "todo!",
}
// we suggest all keys of a dictionary, even when some are already used
route MainRoute { path: "/", | }
^
page MainPage {
component: import { MainPage } from "@client/MainPage.jsx",
}

6
waspc/waspls/test/Wasp/LSP/completionTests/route_to.golden
View File

@ -1,4 +1,4 @@
Completion items:
label={"todoApp"} kind={Just CiVariable} detail={Just ":: app (declaration type)"}
label={"MainRoute"} kind={Just CiVariable} detail={Just ":: route (declaration type)"}
label={"MainPage"} kind={Just CiVariable} detail={Just ":: page (declaration type)"}
label={"MainPage"} kind={CiVariable} detail={":: page (declaration type)"}
label={"MainRoute"} kind={CiVariable} detail={":: route (declaration type)"}
label={"todoApp"} kind={CiVariable} detail={":: app (declaration type)"}