From 1219a57bc927656ec4180ea946149fa1055215f0 Mon Sep 17 00:00:00 2001 From: Martin Sosic Date: Wed, 28 Apr 2021 17:36:00 +0200 Subject: [PATCH] Formatted whole codebase with ormolu. --- waspc/Setup.hs | 1 + waspc/cli/Cli/Common.hs | 37 +- waspc/cli/Command.hs | 25 +- waspc/cli/Command/Build.hs | 63 ++- waspc/cli/Command/Call.hs | 19 +- waspc/cli/Command/Clean.hs | 42 +- waspc/cli/Command/Compile.hs | 85 +-- waspc/cli/Command/Db.hs | 82 +-- waspc/cli/Command/Db/Migrate.hs | 159 +++--- waspc/cli/Command/Start.hs | 83 +-- waspc/cli/Command/Telemetry.hs | 77 +-- waspc/cli/Command/Telemetry/Common.hs | 29 +- waspc/cli/Command/Telemetry/Project.hs | 203 +++---- waspc/cli/Command/Telemetry/User.hs | 43 +- waspc/cli/Command/Watch.hs | 102 ++-- waspc/cli/Main.hs | 179 +++--- waspc/src/Common.hs | 5 +- waspc/src/CompileOptions.hs | 16 +- waspc/src/Data.hs | 13 +- waspc/src/ExternalCode.hs | 108 ++-- waspc/src/Generator.hs | 59 +- waspc/src/Generator/Common.hs | 12 +- waspc/src/Generator/DbGenerator.hs | 76 +-- waspc/src/Generator/DbGenerator/Jobs.hs | 61 +- waspc/src/Generator/DbGenerator/Operations.hs | 38 +- waspc/src/Generator/DockerGenerator.hs | 45 +- waspc/src/Generator/ExternalCodeGenerator.hs | 43 +- .../Generator/ExternalCodeGenerator/Common.hs | 32 +- .../src/Generator/ExternalCodeGenerator/Js.hs | 39 +- waspc/src/Generator/FileDraft.hs | 83 +-- .../src/Generator/FileDraft/CopyFileDraft.hs | 79 +-- .../Generator/FileDraft/TemplateFileDraft.hs | 47 +- .../src/Generator/FileDraft/TextFileDraft.hs | 30 +- waspc/src/Generator/FileDraft/Writeable.hs | 19 +- .../src/Generator/FileDraft/WriteableMonad.hs | 104 ++-- waspc/src/Generator/Job.hs | 35 +- waspc/src/Generator/Job/IO.hs | 86 +-- waspc/src/Generator/Job/Process.hs | 194 ++++--- waspc/src/Generator/PackageJsonGenerator.hs | 59 +- waspc/src/Generator/ServerGenerator.hs | 258 +++++---- waspc/src/Generator/ServerGenerator/AuthG.hs | 97 ++-- waspc/src/Generator/ServerGenerator/Common.hs | 85 +-- .../src/Generator/ServerGenerator/ConfigG.hs | 26 +- .../ServerGenerator/ExternalCodeGenerator.hs | 30 +- .../Generator/ServerGenerator/OperationsG.hs | 100 ++-- .../ServerGenerator/OperationsRoutesG.hs | 104 ++-- waspc/src/Generator/ServerGenerator/Setup.hs | 18 +- waspc/src/Generator/ServerGenerator/Start.hs | 18 +- waspc/src/Generator/Setup.hs | 80 +-- waspc/src/Generator/Start.hs | 33 +- waspc/src/Generator/Templates.hs | 86 +-- waspc/src/Generator/WebAppGenerator.hs | 192 ++++--- waspc/src/Generator/WebAppGenerator/AuthG.hs | 48 +- waspc/src/Generator/WebAppGenerator/Common.hs | 64 ++- .../WebAppGenerator/ExternalCodeGenerator.hs | 30 +- .../WebAppGenerator/OperationsGenerator.hs | 91 +-- .../OperationsGenerator/ResourcesG.hs | 17 +- .../WebAppGenerator/RouterGenerator.hs | 165 +++--- waspc/src/Generator/WebAppGenerator/Setup.hs | 18 +- waspc/src/Generator/WebAppGenerator/Start.hs | 18 +- waspc/src/Lexer.hs | 49 +- waspc/src/Lib.hs | 97 ++-- waspc/src/NpmDependency.hs | 26 +- waspc/src/Parser.hs | 57 +- waspc/src/Parser/Action.hs | 36 +- waspc/src/Parser/App.hs | 46 +- waspc/src/Parser/Auth.hs | 56 +- waspc/src/Parser/Common.hs | 127 +++-- waspc/src/Parser/Db.hs | 44 +- waspc/src/Parser/Entity.hs | 89 +-- waspc/src/Parser/ExternalCode.hs | 28 +- waspc/src/Parser/JsCode.hs | 8 +- waspc/src/Parser/JsImport.hs | 41 +- waspc/src/Parser/NpmDependencies.hs | 46 +- waspc/src/Parser/Operation.hs | 39 +- waspc/src/Parser/Page.hs | 45 +- waspc/src/Parser/Query.hs | 36 +- waspc/src/Parser/Route.hs | 32 +- waspc/src/Parser/Style.hs | 11 +- waspc/src/Path/Extra.hs | 16 +- waspc/src/Psl/Ast/Model.hs | 77 +-- waspc/src/Psl/Generator/Model.hs | 60 +- waspc/src/Psl/Parser/Model.hs | 219 ++++---- waspc/src/StrongPath.hs | 495 ++++++++++------- waspc/src/StrongPath/Internal.hs | 140 ++--- waspc/src/Util.hs | 32 +- waspc/src/Util/Fib.hs | 7 +- waspc/src/Util/IO.hs | 59 +- waspc/src/Util/Terminal.hs | 49 +- waspc/src/Wasp.hs | 222 ++++---- waspc/src/Wasp/Action.hs | 29 +- waspc/src/Wasp/App.hs | 26 +- waspc/src/Wasp/Auth.hs | 20 +- waspc/src/Wasp/Db.hs | 18 +- waspc/src/Wasp/Entity.hs | 76 +-- waspc/src/Wasp/JsCode.hs | 9 +- waspc/src/Wasp/JsImport.hs | 35 +- waspc/src/Wasp/NpmDependencies.hs | 26 +- waspc/src/Wasp/Operation.hs | 20 +- waspc/src/Wasp/Page.hs | 26 +- waspc/src/Wasp/Query.hs | 29 +- waspc/src/Wasp/Route.hs | 23 +- waspc/src/Wasp/Style.hs | 26 +- waspc/src/WaspignoreFile.hs | 50 +- waspc/test/Fixtures.hs | 22 +- .../Generator/ExternalCodeGenerator/JsTest.hs | 22 +- .../Generator/FileDraft/CopyFileDraftTest.hs | 46 +- .../FileDraft/TemplateFileDraftTest.hs | 65 ++- waspc/test/Generator/MockWriteableMonad.hs | 146 ++--- .../Generator/PackageJsonGeneratorTest.hs | 54 +- waspc/test/Generator/WebAppGeneratorTest.hs | 104 ++-- waspc/test/Parser/ActionTest.hs | 62 ++- waspc/test/Parser/CommonTest.hs | 170 +++--- waspc/test/Parser/DbTest.hs | 29 +- waspc/test/Parser/ExternalCodeTest.hs | 27 +- waspc/test/Parser/JsImportTest.hs | 65 ++- waspc/test/Parser/NpmDependenciesTest.hs | 40 +- waspc/test/Parser/OperationTest.hs | 56 +- waspc/test/Parser/PageTest.hs | 86 +-- waspc/test/Parser/ParserTest.hs | 195 ++++--- waspc/test/Parser/QueryTest.hs | 65 +-- waspc/test/Parser/RouteTest.hs | 34 +- waspc/test/Parser/StyleTest.hs | 33 +- waspc/test/Path/ExtraTest.hs | 14 +- waspc/test/Psl/Common/ModelTest.hs | 163 +++--- waspc/test/Psl/Generator/ModelTest.hs | 150 ++--- waspc/test/Psl/Parser/ModelTest.hs | 94 ++-- waspc/test/StrongPathTest.hs | 521 +++++++++--------- waspc/test/Test/Util.hs | 29 +- waspc/test/Util/FibTest.hs | 1 - waspc/test/UtilTest.hs | 79 ++- waspc/test/WaspignoreFileTest.hs | 62 ++- waspc/testEnv.hs | 5 +- 133 files changed, 4841 insertions(+), 4390 deletions(-) diff --git a/waspc/Setup.hs b/waspc/Setup.hs index 9a994af67..e8ef27dbb 100644 --- a/waspc/Setup.hs +++ b/waspc/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/waspc/cli/Cli/Common.hs b/waspc/cli/Cli/Common.hs index 953355f8c..b0edfd8fe 100644 --- a/waspc/cli/Cli/Common.hs +++ b/waspc/cli/Cli/Common.hs @@ -1,28 +1,27 @@ module Cli.Common - ( WaspProjectDir - , DotWaspDir - , CliTemplatesDir - , dotWaspDirInWaspProjectDir - , dotWaspRootFileInWaspProjectDir - , extCodeDirInWaspProjectDir - , generatedCodeDirInDotWaspDir - , buildDirInDotWaspDir - , waspSays - ) where + ( WaspProjectDir, + DotWaspDir, + CliTemplatesDir, + dotWaspDirInWaspProjectDir, + dotWaspRootFileInWaspProjectDir, + extCodeDirInWaspProjectDir, + generatedCodeDirInDotWaspDir, + buildDirInDotWaspDir, + waspSays, + ) +where -import qualified Path as P - -import Common (WaspProjectDir) -import ExternalCode (SourceExternalCodeDir) +import Common (WaspProjectDir) +import ExternalCode (SourceExternalCodeDir) import qualified Generator.Common -import StrongPath (Dir, File, Path, Rel) -import qualified StrongPath as SP -import qualified Util.Terminal as Term - +import qualified Path as P +import StrongPath (Dir, File, Path, Rel) +import qualified StrongPath as SP +import qualified Util.Terminal as Term data DotWaspDir -- Here we put everything that wasp generates. -data CliTemplatesDir +data CliTemplatesDir -- TODO: SHould this be renamed to include word "root"? dotWaspDirInWaspProjectDir :: Path (Rel WaspProjectDir) (Dir DotWaspDir) diff --git a/waspc/cli/Command.hs b/waspc/cli/Command.hs index d7a34299e..42232e6b5 100644 --- a/waspc/cli/Command.hs +++ b/waspc/cli/Command.hs @@ -1,24 +1,25 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Command - ( Command - , runCommand - , CommandError(..) - ) where + ( Command, + runCommand, + CommandError (..), + ) +where import Control.Monad.Except (ExceptT, MonadError, runExceptT) import Control.Monad.IO.Class (MonadIO) - -newtype Command a = Command { _runCommand :: ExceptT CommandError IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError CommandError) +newtype Command a = Command {_runCommand :: ExceptT CommandError IO a} + deriving (Functor, Applicative, Monad, MonadIO, MonadError CommandError) runCommand :: Command a -> IO () runCommand cmd = do - errorOrResult <- runExceptT $ _runCommand cmd - case errorOrResult of - Left cmdError -> putStrLn $ "Error: " ++ _errorMsg cmdError - Right _ -> return () + errorOrResult <- runExceptT $ _runCommand cmd + case errorOrResult of + Left cmdError -> putStrLn $ "Error: " ++ _errorMsg cmdError + Right _ -> return () -- 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 { _errorMsg :: !String } +data CommandError = CommandError {_errorMsg :: !String} diff --git a/waspc/cli/Command/Build.hs b/waspc/cli/Command/Build.hs index 2f054bb46..93cacfecc 100644 --- a/waspc/cli/Command/Build.hs +++ b/waspc/cli/Command/Build.hs @@ -1,38 +1,43 @@ module Command.Build - ( build - ) where + ( build, + ) +where -import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (liftIO) - -import qualified Cli.Common as Common -import Command (Command, CommandError (..)) -import Command.Common (alphaWarningMessage, - findWaspProjectRootDirFromCwd) -import Command.Compile (compileIOWithOptions) -import CompileOptions (CompileOptions (..)) +import qualified Cli.Common as Common +import Command (Command, CommandError (..)) +import Command.Common + ( alphaWarningMessage, + findWaspProjectRootDirFromCwd, + ) +import Command.Compile (compileIOWithOptions) +import CompileOptions (CompileOptions (..)) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) import qualified Lib -import StrongPath (Abs, Dir, Path, ()) +import StrongPath (Abs, Dir, Path, ()) build :: Command () build = do - waspProjectDir <- findWaspProjectRootDirFromCwd - let outDir = waspProjectDir Common.dotWaspDirInWaspProjectDir - Common.buildDirInDotWaspDir + waspProjectDir <- findWaspProjectRootDirFromCwd + let outDir = + waspProjectDir Common.dotWaspDirInWaspProjectDir + Common.buildDirInDotWaspDir - liftIO $ putStrLn "Building wasp project..." - buildResult <- liftIO $ buildIO waspProjectDir outDir - case buildResult of - Left compileError -> throwError $ CommandError $ "Build failed: " ++ compileError - Right () -> liftIO $ putStrLn "Code has been successfully built! Check it out in .wasp/build directory.\n" - liftIO $ putStrLn alphaWarningMessage + liftIO $ putStrLn "Building wasp project..." + buildResult <- liftIO $ buildIO waspProjectDir outDir + case buildResult of + Left compileError -> throwError $ CommandError $ "Build failed: " ++ compileError + Right () -> liftIO $ putStrLn "Code has been successfully built! Check it out in .wasp/build directory.\n" + liftIO $ putStrLn alphaWarningMessage -buildIO :: Path Abs (Dir Common.WaspProjectDir) - -> Path Abs (Dir Lib.ProjectRootDir) - -> IO (Either String ()) +buildIO :: + Path Abs (Dir Common.WaspProjectDir) -> + Path Abs (Dir Lib.ProjectRootDir) -> + IO (Either String ()) buildIO waspProjectDir outDir = compileIOWithOptions options waspProjectDir outDir - where - options = CompileOptions - { externalCodeDirPath = waspProjectDir Common.extCodeDirInWaspProjectDir - , isBuild = True - } + where + options = + CompileOptions + { externalCodeDirPath = waspProjectDir Common.extCodeDirInWaspProjectDir, + isBuild = True + } diff --git a/waspc/cli/Command/Call.hs b/waspc/cli/Command/Call.hs index f7c3be117..b2f16e32e 100644 --- a/waspc/cli/Command/Call.hs +++ b/waspc/cli/Command/Call.hs @@ -1,11 +1,12 @@ module Command.Call where -data Call = New String -- project name - | Start - | Clean - | Compile - | Db [String] -- db args - | Build - | Version - | Telemetry - | Unknown [String] -- all args +data Call + = New String -- project name + | Start + | Clean + | Compile + | Db [String] -- db args + | Build + | Version + | Telemetry + | Unknown [String] -- all args diff --git a/waspc/cli/Command/Clean.hs b/waspc/cli/Command/Clean.hs index d9fff10ed..771269a49 100644 --- a/waspc/cli/Command/Clean.hs +++ b/waspc/cli/Command/Clean.hs @@ -1,25 +1,27 @@ module Command.Clean - ( clean - ) where + ( clean, + ) +where -import Control.Monad.IO.Class (liftIO) -import System.Directory (doesDirectoryExist, - removeDirectoryRecursive) -import System.IO (hFlush, stdout) - -import qualified Cli.Common as Common -import Command (Command) -import Command.Common (findWaspProjectRootDirFromCwd) -import qualified StrongPath as SP +import qualified Cli.Common as Common +import Command (Command) +import Command.Common (findWaspProjectRootDirFromCwd) +import Control.Monad.IO.Class (liftIO) +import qualified StrongPath as SP +import System.Directory + ( doesDirectoryExist, + removeDirectoryRecursive, + ) +import System.IO (hFlush, stdout) clean :: Command () clean = do - waspProjectDir <- findWaspProjectRootDirFromCwd - let dotWaspDirFp = SP.toFilePath $ waspProjectDir SP. Common.dotWaspDirInWaspProjectDir - liftIO $ putStrLn "Deleting .wasp/ directory..." >> hFlush stdout - doesDotWaspDirExist <- liftIO $ doesDirectoryExist dotWaspDirFp - if doesDotWaspDirExist - then liftIO $ do removeDirectoryRecursive dotWaspDirFp - putStrLn "Deleted .wasp/ directory." - else liftIO $ putStrLn "Nothing to delete: .wasp directory does not exist." - + waspProjectDir <- findWaspProjectRootDirFromCwd + let dotWaspDirFp = SP.toFilePath $ waspProjectDir SP. Common.dotWaspDirInWaspProjectDir + liftIO $ putStrLn "Deleting .wasp/ directory..." >> hFlush stdout + doesDotWaspDirExist <- liftIO $ doesDirectoryExist dotWaspDirFp + if doesDotWaspDirExist + then liftIO $ do + removeDirectoryRecursive dotWaspDirFp + putStrLn "Deleted .wasp/ directory." + else liftIO $ putStrLn "Nothing to delete: .wasp directory does not exist." diff --git a/waspc/cli/Command/Compile.hs b/waspc/cli/Command/Compile.hs index 96bd55f69..548f7b060 100644 --- a/waspc/cli/Command/Compile.hs +++ b/waspc/cli/Command/Compile.hs @@ -1,55 +1,62 @@ module Command.Compile - ( compileIO - , compile - , compileIOWithOptions - ) where - -import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.IO.Class (liftIO) + ( compileIO, + compile, + compileIOWithOptions, + ) +where import qualified Cli.Common -import Command (Command, CommandError (..)) -import Command.Common (findWaspProjectRootDirFromCwd, - waspSaysC) -import Command.Db.Migrate (MigrationDirCopyDirection (..), - copyDbMigrationsDir) -import Common (WaspProjectDir) -import CompileOptions (CompileOptions (..)) +import Command (Command, CommandError (..)) +import Command.Common + ( findWaspProjectRootDirFromCwd, + waspSaysC, + ) +import Command.Db.Migrate + ( MigrationDirCopyDirection (..), + copyDbMigrationsDir, + ) +import Common (WaspProjectDir) +import CompileOptions (CompileOptions (..)) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.IO.Class (liftIO) import qualified Lib -import StrongPath (Abs, Dir, Path, ()) - +import StrongPath (Abs, Dir, Path, ()) compile :: Command () compile = do - waspProjectDir <- findWaspProjectRootDirFromCwd - let outDir = waspProjectDir Cli.Common.dotWaspDirInWaspProjectDir - Cli.Common.generatedCodeDirInDotWaspDir + waspProjectDir <- findWaspProjectRootDirFromCwd + let outDir = + waspProjectDir Cli.Common.dotWaspDirInWaspProjectDir + Cli.Common.generatedCodeDirInDotWaspDir - waspSaysC "Compiling wasp code..." - compilationResult <- liftIO $ compileIO waspProjectDir outDir - case compilationResult of - Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError - Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n" + waspSaysC "Compiling wasp code..." + compilationResult <- liftIO $ compileIO waspProjectDir outDir + case compilationResult of + Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError + Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n" -- | Compiles Wasp source code in waspProjectDir directory and generates a project -- in given outDir directory. -compileIO :: Path Abs (Dir WaspProjectDir) - -> Path Abs (Dir Lib.ProjectRootDir) - -> IO (Either String ()) +compileIO :: + Path Abs (Dir WaspProjectDir) -> + Path Abs (Dir Lib.ProjectRootDir) -> + IO (Either String ()) compileIO waspProjectDir outDir = compileIOWithOptions options waspProjectDir outDir where - options = CompileOptions - { externalCodeDirPath = waspProjectDir Cli.Common.extCodeDirInWaspProjectDir - , isBuild = False + options = + CompileOptions + { externalCodeDirPath = waspProjectDir Cli.Common.extCodeDirInWaspProjectDir, + isBuild = False } -compileIOWithOptions :: CompileOptions - -> Path Abs (Dir Cli.Common.WaspProjectDir) - -> Path Abs (Dir Lib.ProjectRootDir) - -> IO (Either String ()) +compileIOWithOptions :: + CompileOptions -> + Path Abs (Dir Cli.Common.WaspProjectDir) -> + Path Abs (Dir Lib.ProjectRootDir) -> + IO (Either String ()) compileIOWithOptions options waspProjectDir outDir = runExceptT $ do - -- TODO: Use throwIO instead of Either to return exceptions? - liftIO (Lib.compile waspProjectDir outDir options) - >>= either throwError return - liftIO (copyDbMigrationsDir CopyMigDirDown waspProjectDir outDir) - >>= maybe (return ()) (throwError . ("Copying migration folder failed: " ++)) + -- TODO: Use throwIO instead of Either to return exceptions? + liftIO (Lib.compile waspProjectDir outDir options) + >>= either throwError return + liftIO (copyDbMigrationsDir CopyMigDirDown waspProjectDir outDir) + >>= maybe (return ()) (throwError . ("Copying migration folder failed: " ++)) diff --git a/waspc/cli/Command/Db.hs b/waspc/cli/Command/Db.hs index 672cd9114..64608d707 100644 --- a/waspc/cli/Command/Db.hs +++ b/waspc/cli/Command/Db.hs @@ -1,22 +1,22 @@ module Command.Db - ( runDbCommand - , studio - ) where + ( runDbCommand, + studio, + ) +where -import Control.Concurrent.Async (concurrently) +import qualified Cli.Common as Common +import Command (Command, CommandError (..), runCommand) +import Command.Common (findWaspProjectRootDirFromCwd, waspSaysC) +import Command.Compile (compile) import Control.Concurrent (newChan) -import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.Async (concurrently) import Control.Monad.Except (throwError) -import System.Exit (ExitCode (..)) - -import StrongPath (()) -import Generator.ServerGenerator.Setup (setupServer) +import Control.Monad.IO.Class (liftIO) import Generator.DbGenerator.Jobs (runStudio) import Generator.Job.IO (readJobMessagesAndPrintThemPrefixed) -import Command (Command, CommandError(..), runCommand) -import Command.Compile (compile) -import Command.Common (findWaspProjectRootDirFromCwd, waspSaysC) -import qualified Cli.Common as Common +import Generator.ServerGenerator.Setup (setupServer) +import StrongPath (()) +import System.Exit (ExitCode (..)) runDbCommand :: Command a -> IO () runDbCommand = runCommand . makeDbCommand @@ -27,38 +27,40 @@ runDbCommand = runCommand . makeDbCommand -- All the commands that operate on db should be created using this function. makeDbCommand :: Command a -> Command a makeDbCommand cmd = do - waspRoot <- findWaspProjectRootDirFromCwd - let genProjectDir = waspRoot Common.dotWaspDirInWaspProjectDir - Common.generatedCodeDirInDotWaspDir + waspRoot <- findWaspProjectRootDirFromCwd + let genProjectDir = + waspRoot Common.dotWaspDirInWaspProjectDir + Common.generatedCodeDirInDotWaspDir - -- NOTE(matija): First we need make sure the code is generated. - compile + -- NOTE(matija): First we need make sure the code is generated. + compile - waspSaysC "\nSetting up database..." - chan <- liftIO newChan - -- NOTE(matija): What we do here is make sure that Prisma CLI is installed because db commands - -- (e.g. migrate) depend on it. We run setupServer which does even more than that, so we could make - -- this function more lightweight if needed. - (_, dbSetupResult) <- liftIO (concurrently (readJobMessagesAndPrintThemPrefixed chan) (setupServer genProjectDir chan)) - case dbSetupResult of - ExitSuccess -> waspSaysC "\nDatabase successfully set up!" >> cmd - exitCode -> throwError $ CommandError $ dbSetupFailedMessage exitCode - - where - dbSetupFailedMessage exitCode = "\nDatabase setup failed" ++ - case exitCode of - ExitFailure code -> ": " ++ show code - _ -> "" + waspSaysC "\nSetting up database..." + chan <- liftIO newChan + -- NOTE(matija): What we do here is make sure that Prisma CLI is installed because db commands + -- (e.g. migrate) depend on it. We run setupServer which does even more than that, so we could make + -- this function more lightweight if needed. + (_, dbSetupResult) <- liftIO (concurrently (readJobMessagesAndPrintThemPrefixed chan) (setupServer genProjectDir chan)) + case dbSetupResult of + ExitSuccess -> waspSaysC "\nDatabase successfully set up!" >> cmd + exitCode -> throwError $ CommandError $ dbSetupFailedMessage exitCode + where + dbSetupFailedMessage exitCode = + "\nDatabase setup failed" + ++ case exitCode of + ExitFailure code -> ": " ++ show code + _ -> "" -- TODO(matija): should we extract this into a separate file, like we did for migrate? studio :: Command () studio = do - waspProjectDir <- findWaspProjectRootDirFromCwd - let genProjectDir = waspProjectDir Common.dotWaspDirInWaspProjectDir - Common.generatedCodeDirInDotWaspDir + waspProjectDir <- findWaspProjectRootDirFromCwd + let genProjectDir = + waspProjectDir Common.dotWaspDirInWaspProjectDir + Common.generatedCodeDirInDotWaspDir - waspSaysC "Running studio..." - chan <- liftIO newChan + waspSaysC "Running studio..." + chan <- liftIO newChan - _ <- liftIO $ concurrently (readJobMessagesAndPrintThemPrefixed chan) (runStudio genProjectDir chan) - error "This should never happen, studio should never stop." + _ <- liftIO $ concurrently (readJobMessagesAndPrintThemPrefixed chan) (runStudio genProjectDir chan) + error "This should never happen, studio should never stop." diff --git a/waspc/cli/Command/Db/Migrate.hs b/waspc/cli/Command/Db/Migrate.hs index 86d538533..78274ed14 100644 --- a/waspc/cli/Command/Db/Migrate.hs +++ b/waspc/cli/Command/Db/Migrate.hs @@ -1,100 +1,107 @@ module Command.Db.Migrate - ( migrateDev - , copyDbMigrationsDir - , MigrationDirCopyDirection(..) - ) where + ( migrateDev, + copyDbMigrationsDir, + MigrationDirCopyDirection (..), + ) +where -import Control.Monad.Catch (catch) -import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (liftIO) -import qualified Path as P -import qualified Path.IO as PathIO - -import Command (Command, CommandError (..)) -import Command.Common (findWaspProjectRootDirFromCwd, - waspSaysC) -import Common (WaspProjectDir) import qualified Cli.Common -import StrongPath (Abs, Dir, Path, ()) -import qualified StrongPath as SP - +import Command (Command, CommandError (..)) +import Command.Common + ( findWaspProjectRootDirFromCwd, + waspSaysC, + ) +import Common (WaspProjectDir) +import Control.Monad.Catch (catch) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) -- Wasp generator interface. -import Generator.Common (ProjectRootDir) -import Generator.DbGenerator (dbRootDirInProjectRootDir) +import Generator.Common (ProjectRootDir) +import Generator.DbGenerator (dbRootDirInProjectRootDir) import qualified Generator.DbGenerator.Operations as DbOps - +import qualified Path as P +import qualified Path.IO as PathIO +import StrongPath (Abs, Dir, Path, ()) +import qualified StrongPath as SP migrateDev :: Command () migrateDev = do - waspProjectDir <- findWaspProjectRootDirFromCwd - let genProjectRootDir = waspProjectDir - Cli.Common.dotWaspDirInWaspProjectDir - Cli.Common.generatedCodeDirInDotWaspDir + waspProjectDir <- findWaspProjectRootDirFromCwd + let genProjectRootDir = + waspProjectDir + Cli.Common.dotWaspDirInWaspProjectDir + Cli.Common.generatedCodeDirInDotWaspDir - -- TODO(matija): It might make sense that this (copying migrations folder from source to - -- the generated proejct) is responsibility of the generator. Since migrations can also be - -- considered part of a "source" code, then generator could take care of it and this command - -- wouldn't have to deal with it. We opened an issue on Github about this. - -- - -- NOTE(matija): we need to copy migrations down before running "migrate dev" to make sure - -- all the latest migrations are in the generated project (e.g. Wasp dev checked out something - -- new) - otherwise "dev" would create a new migration for that and we would end up with two - -- migrations doing the same thing (which might result in conflict, e.g. during db creation). - waspSaysC "Copying migrations folder from Wasp to Prisma project..." - copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirDown + -- TODO(matija): It might make sense that this (copying migrations folder from source to + -- the generated proejct) is responsibility of the generator. Since migrations can also be + -- considered part of a "source" code, then generator could take care of it and this command + -- wouldn't have to deal with it. We opened an issue on Github about this. + -- + -- NOTE(matija): we need to copy migrations down before running "migrate dev" to make sure + -- all the latest migrations are in the generated project (e.g. Wasp dev checked out something + -- new) - otherwise "dev" would create a new migration for that and we would end up with two + -- migrations doing the same thing (which might result in conflict, e.g. during db creation). + waspSaysC "Copying migrations folder from Wasp to Prisma project..." + copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirDown - waspSaysC "Performing migration..." - migrateResult <- liftIO $ DbOps.migrateDev genProjectRootDir - case migrateResult of - Left migrateError -> - throwError $ CommandError $ "Migrate dev failed: " <> migrateError - Right () -> waspSaysC "Migration done." + waspSaysC "Performing migration..." + migrateResult <- liftIO $ DbOps.migrateDev genProjectRootDir + case migrateResult of + Left migrateError -> + throwError $ CommandError $ "Migrate dev failed: " <> migrateError + Right () -> waspSaysC "Migration done." - waspSaysC "Copying migrations folder from Prisma to Wasp project..." - copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirUp + waspSaysC "Copying migrations folder from Prisma to Wasp project..." + copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirUp - waspSaysC "All done!" + waspSaysC "All done!" where copyDbMigrationDir waspProjectDir genProjectRootDir copyDirection = do - copyDbMigDirResult <- - liftIO $ copyDbMigrationsDir copyDirection waspProjectDir genProjectRootDir - case copyDbMigDirResult of - Nothing -> waspSaysC "Done copying migrations folder." - Just err -> throwError $ CommandError $ "Copying migration folder failed: " ++ err - + copyDbMigDirResult <- + liftIO $ copyDbMigrationsDir copyDirection waspProjectDir genProjectRootDir + case copyDbMigDirResult of + Nothing -> waspSaysC "Done copying migrations folder." + Just err -> throwError $ CommandError $ "Copying migration folder failed: " ++ err data MigrationDirCopyDirection = CopyMigDirUp | CopyMigDirDown deriving (Eq) -- | Copy migrations directory between Wasp source and the generated project. -copyDbMigrationsDir - :: MigrationDirCopyDirection -- ^ Copy direction (source -> gen or gen-> source) - -> Path Abs (Dir WaspProjectDir) - -> Path Abs (Dir ProjectRootDir) - -> IO (Maybe String) +copyDbMigrationsDir :: + -- | Copy direction (source -> gen or gen-> source) + MigrationDirCopyDirection -> + Path Abs (Dir WaspProjectDir) -> + Path Abs (Dir ProjectRootDir) -> + IO (Maybe String) copyDbMigrationsDir copyDirection waspProjectDir genProjectRootDir = do - let dbMigrationsDirInDbRootDir = SP.fromPathRelDir [P.reldir|migrations|] + let dbMigrationsDirInDbRootDir = SP.fromPathRelDir [P.reldir|migrations|] - -- Migration folder in Wasp source (seen by Wasp dev and versioned). - let dbMigrationsDirInWaspProjectDirAbs = waspProjectDir dbMigrationsDirInDbRootDir + -- Migration folder in Wasp source (seen by Wasp dev and versioned). + let dbMigrationsDirInWaspProjectDirAbs = waspProjectDir dbMigrationsDirInDbRootDir - -- Migration folder in the generated code. - let dbMigrationsDirInGenProjectDirAbs = genProjectRootDir dbRootDirInProjectRootDir - dbMigrationsDirInDbRootDir + -- Migration folder in the generated code. + let dbMigrationsDirInGenProjectDirAbs = + genProjectRootDir dbRootDirInProjectRootDir + dbMigrationsDirInDbRootDir - let src = if copyDirection == CopyMigDirUp - then dbMigrationsDirInGenProjectDirAbs - else dbMigrationsDirInWaspProjectDirAbs + let src = + if copyDirection == CopyMigDirUp + then dbMigrationsDirInGenProjectDirAbs + else dbMigrationsDirInWaspProjectDirAbs - let target = if copyDirection == CopyMigDirUp - then dbMigrationsDirInWaspProjectDirAbs - else dbMigrationsDirInGenProjectDirAbs - - doesSrcDirExist <- PathIO.doesDirExist (SP.toPathAbsDir src) - if doesSrcDirExist - then ((PathIO.copyDirRecur (SP.toPathAbsDir src) - (SP.toPathAbsDir target)) - >> return Nothing) - `catch` (\e -> return $ Just $ show (e :: P.PathException)) - `catch` (\e -> return $ Just $ show (e :: IOError)) - else return Nothing + let target = + if copyDirection == CopyMigDirUp + then dbMigrationsDirInWaspProjectDirAbs + else dbMigrationsDirInGenProjectDirAbs + doesSrcDirExist <- PathIO.doesDirExist (SP.toPathAbsDir src) + if doesSrcDirExist + then + ( ( PathIO.copyDirRecur + (SP.toPathAbsDir src) + (SP.toPathAbsDir target) + ) + >> return Nothing + ) + `catch` (\e -> return $ Just $ show (e :: P.PathException)) + `catch` (\e -> return $ Just $ show (e :: IOError)) + else return Nothing diff --git a/waspc/cli/Command/Start.hs b/waspc/cli/Command/Start.hs index bbf14a5d7..a8aa364ad 100644 --- a/waspc/cli/Command/Start.hs +++ b/waspc/cli/Command/Start.hs @@ -1,52 +1,53 @@ module Command.Start - ( start - ) where + ( start, + ) +where -import Control.Concurrent.Async (race) -import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (liftIO) - -import qualified Cli.Common as Common -import Command (Command, CommandError (..)) -import Command.Common (findWaspProjectRootDirFromCwd, - waspSaysC) -import Command.Compile (compileIO) -import Command.Watch (watch) +import qualified Cli.Common as Common +import Command (Command, CommandError (..)) +import Command.Common + ( findWaspProjectRootDirFromCwd, + waspSaysC, + ) +import Command.Compile (compileIO) +import Command.Watch (watch) +import Control.Concurrent.Async (race) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) import qualified Lib -import StrongPath (()) - +import StrongPath (()) -- | Does initial compile of wasp code and then runs the generated project. -- It also listens for any file changes and recompiles and restarts generated project accordingly. start :: Command () start = do - waspRoot <- findWaspProjectRootDirFromCwd - let outDir = waspRoot Common.dotWaspDirInWaspProjectDir Common.generatedCodeDirInDotWaspDir + waspRoot <- findWaspProjectRootDirFromCwd + let outDir = waspRoot Common.dotWaspDirInWaspProjectDir Common.generatedCodeDirInDotWaspDir - waspSaysC "Compiling wasp code..." - compilationResult <- liftIO $ compileIO waspRoot outDir - case compilationResult of - Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError - Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n" + waspSaysC "Compiling wasp code..." + compilationResult <- liftIO $ compileIO waspRoot outDir + case compilationResult of + Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError + Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n" - -- TODO: Do smart install -> if we need to install stuff, install it, otherwise don't. - -- This should be responsibility of Generator, it should tell us how to install stuff. - -- But who checks out if stuff needs to be installed at all? That should probably be - -- Generator again. After installation, it should return some kind of data that describes that installation. - -- Then, next time, we give it data we have about last installation, and it uses that - -- to decide if installation needs to happen or not. If it happens, it returnes new data again. - -- Right now we have setup/installation being called, but it has not support for being "smart" yet. - waspSaysC "Setting up generated project..." - setupResult <- liftIO $ Lib.setup outDir - case setupResult of - Left setupError -> throwError $ CommandError $ "\nSetup failed: " ++ setupError - Right () -> waspSaysC "\nSetup successful.\n" + -- TODO: Do smart install -> if we need to install stuff, install it, otherwise don't. + -- This should be responsibility of Generator, it should tell us how to install stuff. + -- But who checks out if stuff needs to be installed at all? That should probably be + -- Generator again. After installation, it should return some kind of data that describes that installation. + -- Then, next time, we give it data we have about last installation, and it uses that + -- to decide if installation needs to happen or not. If it happens, it returnes new data again. + -- Right now we have setup/installation being called, but it has not support for being "smart" yet. + waspSaysC "Setting up generated project..." + setupResult <- liftIO $ Lib.setup outDir + case setupResult of + Left setupError -> throwError $ CommandError $ "\nSetup failed: " ++ setupError + Right () -> waspSaysC "\nSetup successful.\n" - waspSaysC "\nListening for file changes..." - waspSaysC "Starting up generated project..." - watchOrStartResult <- liftIO $ race (watch waspRoot outDir) (Lib.start outDir) - case watchOrStartResult of - Left () -> error "This should never happen, listening for file changes should never end but it did." - Right startResult -> case startResult of - Left startError -> throwError $ CommandError $ "Start failed: " ++ startError - Right () -> error "This should never happen, start should never end but it did." + waspSaysC "\nListening for file changes..." + waspSaysC "Starting up generated project..." + watchOrStartResult <- liftIO $ race (watch waspRoot outDir) (Lib.start outDir) + case watchOrStartResult of + Left () -> error "This should never happen, listening for file changes should never end but it did." + Right startResult -> case startResult of + Left startError -> throwError $ CommandError $ "Start failed: " ++ startError + Right () -> error "This should never happen, start should never end but it did." diff --git a/waspc/cli/Command/Telemetry.hs b/waspc/cli/Command/Telemetry.hs index 9c5d32901..9c44ef981 100644 --- a/waspc/cli/Command/Telemetry.hs +++ b/waspc/cli/Command/Telemetry.hs @@ -1,22 +1,22 @@ module Command.Telemetry - ( considerSendingData - , telemetry - ) where + ( considerSendingData, + telemetry, + ) +where -import Control.Monad (when, unless) -import Control.Monad.Except (catchError, throwError) -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (isJust) -import Data.Foldable (for_) -import qualified System.Environment as ENV - -import Command (Command, CommandError (..)) -import Command.Common (waspSaysC) +import Command (Command, CommandError (..)) import qualified Command.Call -import Command.Telemetry.Common (ensureTelemetryCacheDirExists) +import Command.Common (waspSaysC) +import Command.Telemetry.Common (ensureTelemetryCacheDirExists) import qualified Command.Telemetry.Project as TlmProject -import qualified Command.Telemetry.User as TlmUser -import qualified StrongPath as SP +import qualified Command.Telemetry.User as TlmUser +import Control.Monad (unless, when) +import Control.Monad.Except (catchError, throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (for_) +import Data.Maybe (isJust) +import qualified StrongPath as SP +import qualified System.Environment as ENV isTelemetryDisabled :: IO Bool isTelemetryDisabled = isJust <$> ENV.lookupEnv "WASP_TELEMETRY_DISABLE" @@ -24,24 +24,27 @@ isTelemetryDisabled = isJust <$> ENV.lookupEnv "WASP_TELEMETRY_DISABLE" -- | Prints basic information about the stauts of telemetry. telemetry :: Command () telemetry = do - telemetryDisabled <- liftIO isTelemetryDisabled - waspSaysC $ "Telemetry is currently: " <> (if telemetryDisabled - then "DISABLED" - else "ENABLED") + telemetryDisabled <- liftIO isTelemetryDisabled + waspSaysC $ + "Telemetry is currently: " + <> ( if telemetryDisabled + then "DISABLED" + else "ENABLED" + ) - unless telemetryDisabled $ do - telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists - waspSaysC $ "Telemetry cache directory: " ++ SP.toFilePath telemetryCacheDirPath + unless telemetryDisabled $ do + telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists + waspSaysC $ "Telemetry cache directory: " ++ SP.toFilePath telemetryCacheDirPath - maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing) - for_ maybeProjectHash $ \projectHash -> do - maybeProjectCache <- liftIO $ TlmProject.readProjectTelemetryFile telemetryCacheDirPath projectHash - for_ maybeProjectCache $ \projectCache -> do - let maybeTimeOfLastSending = TlmProject.getTimeOfLastTelemetryDataSent projectCache - for_ maybeTimeOfLastSending $ \timeOfLastSending -> do - waspSaysC $ "Last time telemetry data was sent for this project: " ++ show timeOfLastSending + maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing) + for_ maybeProjectHash $ \projectHash -> do + maybeProjectCache <- liftIO $ TlmProject.readProjectTelemetryFile telemetryCacheDirPath projectHash + for_ maybeProjectCache $ \projectCache -> do + let maybeTimeOfLastSending = TlmProject.getTimeOfLastTelemetryDataSent projectCache + for_ maybeTimeOfLastSending $ \timeOfLastSending -> do + waspSaysC $ "Last time telemetry data was sent for this project: " ++ show timeOfLastSending - waspSaysC "Our telemetry is anonymized and very limited in its scope: check https://wasp-lang.dev/docs/telemetry for more details." + waspSaysC "Our telemetry is anonymized and very limited in its scope: check https://wasp-lang.dev/docs/telemetry for more details." -- | Sends telemetry data about the current Wasp project, if conditions are met. -- If we are not in the Wasp project at the moment, nothing happens. @@ -49,13 +52,13 @@ telemetry = do -- If env var WASP_TELEMETRY_DISABLE is set, nothing happens. considerSendingData :: Command.Call.Call -> Command () considerSendingData cmdCall = (`catchError` const (return ())) $ do - telemetryDisabled <- liftIO isTelemetryDisabled - when telemetryDisabled $ throwError $ CommandError "Telemetry disabled by user." + telemetryDisabled <- liftIO isTelemetryDisabled + when telemetryDisabled $ throwError $ CommandError "Telemetry disabled by user." - telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists + telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists - userSignature <- liftIO $ TlmUser.readOrCreateUserSignatureFile telemetryCacheDirPath + userSignature <- liftIO $ TlmUser.readOrCreateUserSignatureFile telemetryCacheDirPath - maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing) - for_ maybeProjectHash $ \projectHash -> do - liftIO $ TlmProject.considerSendingData telemetryCacheDirPath userSignature projectHash cmdCall + maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing) + for_ maybeProjectHash $ \projectHash -> do + liftIO $ TlmProject.considerSendingData telemetryCacheDirPath userSignature projectHash cmdCall diff --git a/waspc/cli/Command/Telemetry/Common.hs b/waspc/cli/Command/Telemetry/Common.hs index e6887162e..bfe9853c4 100644 --- a/waspc/cli/Command/Telemetry/Common.hs +++ b/waspc/cli/Command/Telemetry/Common.hs @@ -1,15 +1,14 @@ module Command.Telemetry.Common - ( TelemetryCacheDir - , ensureTelemetryCacheDirExists - , getTelemetryCacheDirPath - ) where - -import Path (reldir) -import qualified System.Directory as SD - -import StrongPath (Abs, Dir, Path) -import qualified StrongPath as SP + ( TelemetryCacheDir, + ensureTelemetryCacheDirExists, + getTelemetryCacheDirPath, + ) +where +import Path (reldir) +import StrongPath (Abs, Dir, Path) +import qualified StrongPath as SP +import qualified System.Directory as SD data UserCacheDir @@ -20,11 +19,11 @@ data TelemetryCacheDir ensureTelemetryCacheDirExists :: IO (Path Abs (Dir TelemetryCacheDir)) ensureTelemetryCacheDirExists = do - userCacheDirPath <- getUserCacheDirPath - SD.createDirectoryIfMissing False $ SP.toFilePath userCacheDirPath - let telemetryCacheDirPath = getTelemetryCacheDirPath userCacheDirPath - SD.createDirectoryIfMissing True $ SP.toFilePath telemetryCacheDirPath - return telemetryCacheDirPath + userCacheDirPath <- getUserCacheDirPath + SD.createDirectoryIfMissing False $ SP.toFilePath userCacheDirPath + let telemetryCacheDirPath = getTelemetryCacheDirPath userCacheDirPath + SD.createDirectoryIfMissing True $ SP.toFilePath telemetryCacheDirPath + return telemetryCacheDirPath getTelemetryCacheDirPath :: Path Abs (Dir UserCacheDir) -> Path Abs (Dir TelemetryCacheDir) getTelemetryCacheDirPath userCacheDirPath = userCacheDirPath SP. SP.fromPathRelDir [reldir|wasp/telemetry|] diff --git a/waspc/cli/Command/Telemetry/Project.hs b/waspc/cli/Command/Telemetry/Project.hs index 78bcd4695..855f94a8f 100644 --- a/waspc/cli/Command/Telemetry/Project.hs +++ b/waspc/cli/Command/Telemetry/Project.hs @@ -1,73 +1,74 @@ {-# LANGUAGE DeriveGeneric #-} module Command.Telemetry.Project - ( getWaspProjectPathHash - , considerSendingData - , readProjectTelemetryFile - , getTimeOfLastTelemetryDataSent - ) where + ( getWaspProjectPathHash, + considerSendingData, + readProjectTelemetryFile, + getTimeOfLastTelemetryDataSent, + ) +where -import Command.Common (findWaspProjectRootDirFromCwd) -import Control.Monad (void, when) -import Crypto.Hash (SHA256 (..), hashWith) -import Data.Aeson ((.=)) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy.UTF8 as ByteStringLazyUTF8 -import qualified Data.ByteString.UTF8 as ByteStringUTF8 -import Data.Maybe (fromJust) -import qualified Data.Time as T -import Data.Version (showVersion) -import GHC.Generics -import qualified Network.HTTP.Simple as HTTP -import Paths_waspc (version) -import qualified System.Directory as SD -import qualified System.Info - -import Command (Command) +import Command (Command) import qualified Command.Call -import Command.Telemetry.Common (TelemetryCacheDir) -import Command.Telemetry.User (UserSignature (..)) -import StrongPath (Abs, Dir, File, Path) -import qualified StrongPath as SP - +import Command.Common (findWaspProjectRootDirFromCwd) +import Command.Telemetry.Common (TelemetryCacheDir) +import Command.Telemetry.User (UserSignature (..)) +import Control.Monad (void, when) +import Crypto.Hash (SHA256 (..), hashWith) +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.UTF8 as ByteStringLazyUTF8 +import qualified Data.ByteString.UTF8 as ByteStringUTF8 +import Data.Maybe (fromJust) +import qualified Data.Time as T +import Data.Version (showVersion) +import GHC.Generics +import qualified Network.HTTP.Simple as HTTP +import Paths_waspc (version) +import StrongPath (Abs, Dir, File, Path) +import qualified StrongPath as SP +import qualified System.Directory as SD +import qualified System.Info considerSendingData :: Path Abs (Dir TelemetryCacheDir) -> UserSignature -> ProjectHash -> Command.Call.Call -> IO () considerSendingData telemetryCacheDirPath userSignature projectHash cmdCall = do - projectCache <- readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash + projectCache <- readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash - let relevantLastCheckIn = case cmdCall of - Command.Call.Build -> _lastCheckInBuild projectCache - _ -> _lastCheckIn projectCache + let relevantLastCheckIn = case cmdCall of + Command.Call.Build -> _lastCheckInBuild projectCache + _ -> _lastCheckIn projectCache - shouldSendData <- case relevantLastCheckIn of - Nothing -> return True - Just lastCheckIn -> isOlderThan12Hours lastCheckIn + shouldSendData <- case relevantLastCheckIn of + Nothing -> return True + Just lastCheckIn -> isOlderThan12Hours lastCheckIn - when shouldSendData $ do - sendTelemetryData $ getProjectTelemetryData userSignature projectHash cmdCall - projectCache' <- newProjectCache projectCache - writeProjectTelemetryFile telemetryCacheDirPath projectHash projectCache' + when shouldSendData $ do + sendTelemetryData $ getProjectTelemetryData userSignature projectHash cmdCall + projectCache' <- newProjectCache projectCache + writeProjectTelemetryFile telemetryCacheDirPath projectHash projectCache' where - isOlderThan12Hours :: T.UTCTime -> IO Bool - isOlderThan12Hours time = do - now <- T.getCurrentTime - let secondsSinceLastCheckIn = T.nominalDiffTimeToSeconds (now `T.diffUTCTime` time) - return $ let numSecondsInHour = 3600 - in secondsSinceLastCheckIn > 12 * numSecondsInHour + isOlderThan12Hours :: T.UTCTime -> IO Bool + isOlderThan12Hours time = do + now <- T.getCurrentTime + let secondsSinceLastCheckIn = T.nominalDiffTimeToSeconds (now `T.diffUTCTime` time) + return $ + let numSecondsInHour = 3600 + in secondsSinceLastCheckIn > 12 * numSecondsInHour - newProjectCache :: ProjectTelemetryCache -> IO ProjectTelemetryCache - newProjectCache currentProjectCache = do - now <- T.getCurrentTime - return currentProjectCache - { _lastCheckIn = Just now - , _lastCheckInBuild = case cmdCall of - Command.Call.Build -> Just now - _ -> _lastCheckInBuild currentProjectCache - } + newProjectCache :: ProjectTelemetryCache -> IO ProjectTelemetryCache + newProjectCache currentProjectCache = do + now <- T.getCurrentTime + return + currentProjectCache + { _lastCheckIn = Just now, + _lastCheckInBuild = case cmdCall of + Command.Call.Build -> Just now + _ -> _lastCheckInBuild currentProjectCache + } -- * Project hash. -newtype ProjectHash = ProjectHash { _projectHashValue :: String } deriving (Show) +newtype ProjectHash = ProjectHash {_projectHashValue :: String} deriving (Show) getWaspProjectPathHash :: Command ProjectHash getWaspProjectPathHash = ProjectHash . take 16 . sha256 . SP.toFilePath <$> findWaspProjectRootDirFromCwd @@ -78,16 +79,17 @@ getWaspProjectPathHash = ProjectHash . take 16 . sha256 . SP.toFilePath <$> find -- * Project telemetry cache. data ProjectTelemetryCache = ProjectTelemetryCache - { _lastCheckIn :: Maybe T.UTCTime -- Last time when CLI was called for this project, any command. - , _lastCheckInBuild :: Maybe T.UTCTime -- Last time when CLI was called for this project, with Build command. - } - deriving (Generic, Show) + { _lastCheckIn :: Maybe T.UTCTime, -- Last time when CLI was called for this project, any command. + _lastCheckInBuild :: Maybe T.UTCTime -- Last time when CLI was called for this project, with Build command. + } + deriving (Generic, Show) instance Aeson.ToJSON ProjectTelemetryCache + instance Aeson.FromJSON ProjectTelemetryCache initialCache :: ProjectTelemetryCache -initialCache = ProjectTelemetryCache { _lastCheckIn = Nothing, _lastCheckInBuild = Nothing } +initialCache = ProjectTelemetryCache {_lastCheckIn = Nothing, _lastCheckInBuild = Nothing} -- * Project telemetry cache file. @@ -96,66 +98,71 @@ getTimeOfLastTelemetryDataSent cache = maximum [_lastCheckIn cache, _lastCheckIn readProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> IO (Maybe ProjectTelemetryCache) readProjectTelemetryFile telemetryCacheDirPath projectHash = do - fileExists <- SD.doesFileExist filePathFP - if fileExists then readCacheFile else return Nothing + fileExists <- SD.doesFileExist filePathFP + if fileExists then readCacheFile else return Nothing where - filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash - readCacheFile = Aeson.decode . ByteStringLazyUTF8.fromString <$> readFile filePathFP + filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash + readCacheFile = Aeson.decode . ByteStringLazyUTF8.fromString <$> readFile filePathFP readOrCreateProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> IO ProjectTelemetryCache readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash = do - maybeProjectTelemetryCache <- readProjectTelemetryFile telemetryCacheDirPath projectHash - case maybeProjectTelemetryCache of - Just cache -> return cache - Nothing -> writeProjectTelemetryFile telemetryCacheDirPath projectHash initialCache >> return initialCache + maybeProjectTelemetryCache <- readProjectTelemetryFile telemetryCacheDirPath projectHash + case maybeProjectTelemetryCache of + Just cache -> return cache + Nothing -> writeProjectTelemetryFile telemetryCacheDirPath projectHash initialCache >> return initialCache writeProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> ProjectTelemetryCache -> IO () writeProjectTelemetryFile telemetryCacheDirPath projectHash cache = do - writeFile filePathFP (ByteStringLazyUTF8.toString $ Aeson.encode cache) + writeFile filePathFP (ByteStringLazyUTF8.toString $ Aeson.encode cache) where filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash getProjectTelemetryFilePath :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> Path Abs File getProjectTelemetryFilePath telemetryCacheDir (ProjectHash projectHash) = - telemetryCacheDir SP. fromJust (SP.parseRelFile $ "project-" ++ projectHash) + telemetryCacheDir SP. fromJust (SP.parseRelFile $ "project-" ++ projectHash) -- * Telemetry data. data ProjectTelemetryData = ProjectTelemetryData - { _userSignature :: UserSignature - , _projectHash :: ProjectHash - , _waspVersion :: String - , _os :: String - , _isBuild :: Bool - } deriving (Show) + { _userSignature :: UserSignature, + _projectHash :: ProjectHash, + _waspVersion :: String, + _os :: String, + _isBuild :: Bool + } + deriving (Show) getProjectTelemetryData :: UserSignature -> ProjectHash -> Command.Call.Call -> ProjectTelemetryData -getProjectTelemetryData userSignature projectHash cmdCall = ProjectTelemetryData - { _userSignature = userSignature - , _projectHash = projectHash - , _waspVersion = showVersion version - , _os = System.Info.os - , _isBuild = case cmdCall of - Command.Call.Build -> True - _ -> False +getProjectTelemetryData userSignature projectHash cmdCall = + ProjectTelemetryData + { _userSignature = userSignature, + _projectHash = projectHash, + _waspVersion = showVersion version, + _os = System.Info.os, + _isBuild = case cmdCall of + Command.Call.Build -> True + _ -> False } sendTelemetryData :: ProjectTelemetryData -> IO () sendTelemetryData telemetryData = do - let reqBodyJson = Aeson.object - [ -- PostHog api_key is public so it is ok that we have it here. - "api_key" .= ("CdDd2A0jKTI2vFAsrI9JWm3MqpOcgHz1bMyogAcwsE4" :: String) - , "event" .= ("cli" :: String) - , "properties" .= Aeson.object + let reqBodyJson = + Aeson.object + [ -- PostHog api_key is public so it is ok that we have it here. + "api_key" .= ("CdDd2A0jKTI2vFAsrI9JWm3MqpOcgHz1bMyogAcwsE4" :: String), + "event" .= ("cli" :: String), + "properties" + .= Aeson.object [ -- distinct_id is special PostHog value, used as user id. - "distinct_id" .= _userSignatureValue (_userSignature telemetryData) - -- Following are our custom metrics: - , "project_hash" .= _projectHashValue (_projectHash telemetryData) - , "wasp_version" .= _waspVersion telemetryData - , "os" .= _os telemetryData - , "is_build" .= _isBuild telemetryData + "distinct_id" .= _userSignatureValue (_userSignature telemetryData), + -- Following are our custom metrics: + "project_hash" .= _projectHashValue (_projectHash telemetryData), + "wasp_version" .= _waspVersion telemetryData, + "os" .= _os telemetryData, + "is_build" .= _isBuild telemetryData ] - ] - request = HTTP.setRequestBodyJSON reqBodyJson $ - HTTP.parseRequest_ "POST https://app.posthog.com/capture" - void $ HTTP.httpNoBody request + ] + request = + HTTP.setRequestBodyJSON reqBodyJson $ + HTTP.parseRequest_ "POST https://app.posthog.com/capture" + void $ HTTP.httpNoBody request diff --git a/waspc/cli/Command/Telemetry/User.hs b/waspc/cli/Command/Telemetry/User.hs index 6d6b24489..f786276ca 100644 --- a/waspc/cli/Command/Telemetry/User.hs +++ b/waspc/cli/Command/Telemetry/User.hs @@ -1,34 +1,33 @@ {-# LANGUAGE DeriveGeneric #-} module Command.Telemetry.User - ( UserSignature(..) - , readOrCreateUserSignatureFile - ) where - -import qualified Data.UUID.V4 as UUID -import Path (relfile) -import qualified System.Directory as SD - -import Command.Telemetry.Common (TelemetryCacheDir) -import StrongPath (Abs, Dir, File, Path) -import qualified StrongPath as SP - + ( UserSignature (..), + readOrCreateUserSignatureFile, + ) +where +import Command.Telemetry.Common (TelemetryCacheDir) +import qualified Data.UUID.V4 as UUID +import Path (relfile) +import StrongPath (Abs, Dir, File, Path) +import qualified StrongPath as SP +import qualified System.Directory as SD -- Random, non-identifyable UUID used to represent user in analytics. -newtype UserSignature = UserSignature { _userSignatureValue :: String } deriving (Show) +newtype UserSignature = UserSignature {_userSignatureValue :: String} deriving (Show) readOrCreateUserSignatureFile :: Path Abs (Dir TelemetryCacheDir) -> IO UserSignature readOrCreateUserSignatureFile telemetryCacheDirPath = do - let filePath = getUserSignatureFilePath telemetryCacheDirPath - let filePathFP = SP.toFilePath filePath - fileExists <- SD.doesFileExist filePathFP - UserSignature <$> if fileExists - then readFile filePathFP - else do userSignature <- show <$> UUID.nextRandom - writeFile filePathFP userSignature - return userSignature + let filePath = getUserSignatureFilePath telemetryCacheDirPath + let filePathFP = SP.toFilePath filePath + fileExists <- SD.doesFileExist filePathFP + UserSignature + <$> if fileExists + then readFile filePathFP + else do + userSignature <- show <$> UUID.nextRandom + writeFile filePathFP userSignature + return userSignature getUserSignatureFilePath :: Path Abs (Dir TelemetryCacheDir) -> Path Abs File getUserSignatureFilePath telemetryCacheDir = telemetryCacheDir SP. SP.fromPathRelFile [relfile|signature|] - diff --git a/waspc/cli/Command/Watch.hs b/waspc/cli/Command/Watch.hs index e9e4bda86..15b91af63 100644 --- a/waspc/cli/Command/Watch.hs +++ b/waspc/cli/Command/Watch.hs @@ -1,20 +1,19 @@ module Command.Watch - ( watch - ) where + ( watch, + ) +where -import Control.Concurrent.Chan (Chan, newChan, readChan) -import Data.List (isSuffixOf) -import Data.Time.Clock (UTCTime, getCurrentTime) -import qualified System.FilePath as FP -import qualified System.FSNotify as FSN - -import Cli.Common (waspSays) -import qualified Cli.Common as Common -import Command.Compile (compileIO) +import Cli.Common (waspSays) +import qualified Cli.Common as Common +import Command.Compile (compileIO) +import Control.Concurrent.Chan (Chan, newChan, readChan) +import Data.List (isSuffixOf) +import Data.Time.Clock (UTCTime, getCurrentTime) import qualified Lib -import StrongPath (Abs, Dir, Path, ()) -import qualified StrongPath as SP - +import StrongPath (Abs, Dir, Path, ()) +import qualified StrongPath as SP +import qualified System.FSNotify as FSN +import qualified System.FilePath as FP -- TODO: Another possible problem: on re-generation, wasp re-generates a lot of files, even those that should not -- be generated again, since it is not smart enough yet to know which files do not need to be regenerated. @@ -27,47 +26,48 @@ import qualified StrongPath as SP -- TODO: Idea: Read .gitignore file, and ignore everything from it. This will then also cover the -- .wasp dir, and users can easily add any custom stuff they want ignored. But, we also have to -- be ready for the case when there is no .gitignore, that could be possible. + -- | Forever listens for any file changes in waspProjectDir, and if there is a change, -- compiles Wasp source files in waspProjectDir and regenerates files in outDir. watch :: Path Abs (Dir Common.WaspProjectDir) -> Path Abs (Dir Lib.ProjectRootDir) -> IO () watch waspProjectDir outDir = FSN.withManager $ \mgr -> do - currentTime <- getCurrentTime - chan <- newChan - _ <- FSN.watchDirChan mgr (SP.toFilePath waspProjectDir) eventFilter chan - _ <- FSN.watchTreeChan mgr (SP.toFilePath $ waspProjectDir Common.extCodeDirInWaspProjectDir) eventFilter chan - listenForEvents chan currentTime + currentTime <- getCurrentTime + chan <- newChan + _ <- FSN.watchDirChan mgr (SP.toFilePath waspProjectDir) eventFilter chan + _ <- FSN.watchTreeChan mgr (SP.toFilePath $ waspProjectDir Common.extCodeDirInWaspProjectDir) eventFilter chan + listenForEvents chan currentTime where - listenForEvents :: Chan FSN.Event -> UTCTime -> IO () - listenForEvents chan lastCompileTime = do - event <- readChan chan - let eventTime = FSN.eventTime event - if eventTime < lastCompileTime - -- If event happened before last compilation started, skip it. - then listenForEvents chan lastCompileTime - else do - currentTime <- getCurrentTime - recompile - listenForEvents chan currentTime + listenForEvents :: Chan FSN.Event -> UTCTime -> IO () + listenForEvents chan lastCompileTime = do + event <- readChan chan + let eventTime = FSN.eventTime event + if eventTime < lastCompileTime + then -- If event happened before last compilation started, skip it. + listenForEvents chan lastCompileTime + else do + currentTime <- getCurrentTime + recompile + listenForEvents chan currentTime - recompile :: IO () - recompile = do - waspSays "Recompiling on file change..." - compilationResult <- compileIO waspProjectDir outDir - case compilationResult of - Left err -> waspSays $ "Recompilation on file change failed: " ++ err - Right () -> waspSays "Recompilation on file change succeeded." - return () + recompile :: IO () + recompile = do + waspSays "Recompiling on file change..." + compilationResult <- compileIO waspProjectDir outDir + case compilationResult of + Left err -> waspSays $ "Recompilation on file change failed: " ++ err + Right () -> waspSays "Recompilation on file change succeeded." + return () - -- TODO: This is a hardcoded approach to ignoring most of the common tmp files that editors - -- create next to the source code. Bad thing here is that users can't modify this, - -- so better approach would be probably to use information from .gitignore instead, or - -- maybe combining the two somehow. - eventFilter :: FSN.Event -> Bool - eventFilter event = - let filename = FP.takeFileName $ FSN.eventPath event - in not (null filename) - && not (take 2 filename == ".#") -- Ignore emacs lock files. - && not (head filename == '#' && last filename == '#') -- Ignore emacs auto-save files. - && not (last filename == '~') -- Ignore emacs and vim backup files. - && not (head filename == '.' && ".swp" `isSuffixOf` filename) -- Ignore vim swp files. - && not (head filename == '.' && ".un~" `isSuffixOf` filename) -- Ignore vim undo files. + -- TODO: This is a hardcoded approach to ignoring most of the common tmp files that editors + -- create next to the source code. Bad thing here is that users can't modify this, + -- so better approach would be probably to use information from .gitignore instead, or + -- maybe combining the two somehow. + eventFilter :: FSN.Event -> Bool + eventFilter event = + let filename = FP.takeFileName $ FSN.eventPath event + in not (null filename) + && not (take 2 filename == ".#") -- Ignore emacs lock files. + && not (head filename == '#' && last filename == '#') -- Ignore emacs auto-save files. + && not (last filename == '~') -- Ignore emacs and vim backup files. + && not (head filename == '.' && ".swp" `isSuffixOf` filename) -- Ignore vim swp files. + && not (head filename == '.' && ".un~" `isSuffixOf` filename) -- Ignore vim undo files. diff --git a/waspc/cli/Main.hs b/waspc/cli/Main.hs index b35aa701c..842a7c4f3 100644 --- a/waspc/cli/Main.hs +++ b/waspc/cli/Main.hs @@ -1,84 +1,85 @@ module Main where -import Control.Concurrent (threadDelay) -import qualified Control.Concurrent.Async as Async -import Control.Monad (void) -import Data.Char (isSpace) -import Data.Version (showVersion) -import Paths_waspc (version) -import System.Environment - -import Command (runCommand) -import Command.Build (build) +import Command (runCommand) +import Command.Build (build) import qualified Command.Call -import Command.Clean (clean) -import Command.Compile (compile) -import Command.CreateNewProject (createNewProject) -import Command.Db (runDbCommand, studio) +import Command.Clean (clean) +import Command.Compile (compile) +import Command.CreateNewProject (createNewProject) +import Command.Db (runDbCommand, studio) import qualified Command.Db.Migrate -import Command.Start (start) -import qualified Command.Telemetry as Telemetry -import qualified Util.Terminal as Term - +import Command.Start (start) +import qualified Command.Telemetry as Telemetry +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.Async as Async +import Control.Monad (void) +import Data.Char (isSpace) +import Data.Version (showVersion) +import Paths_waspc (version) +import System.Environment +import qualified Util.Terminal as Term main :: IO () main = do - args <- getArgs - let commandCall = case args of - ["new", projectName] -> Command.Call.New projectName - ["start"] -> Command.Call.Start - ["clean"] -> Command.Call.Clean - ["compile"] -> Command.Call.Compile - ("db":dbArgs) -> Command.Call.Db dbArgs - ["version"] -> Command.Call.Version - ["build"] -> Command.Call.Build - ["telemetry"] -> Command.Call.Telemetry - _ -> Command.Call.Unknown args + args <- getArgs + let commandCall = case args of + ["new", projectName] -> Command.Call.New projectName + ["start"] -> Command.Call.Start + ["clean"] -> Command.Call.Clean + ["compile"] -> Command.Call.Compile + ("db" : dbArgs) -> Command.Call.Db dbArgs + ["version"] -> Command.Call.Version + ["build"] -> Command.Call.Build + ["telemetry"] -> Command.Call.Telemetry + _ -> Command.Call.Unknown args - telemetryThread <- Async.async $ runCommand $ Telemetry.considerSendingData commandCall + telemetryThread <- Async.async $ runCommand $ Telemetry.considerSendingData commandCall - case commandCall of - Command.Call.New projectName -> runCommand $ createNewProject projectName - Command.Call.Start -> runCommand start - Command.Call.Clean -> runCommand clean - Command.Call.Compile -> runCommand compile - Command.Call.Db dbArgs -> dbCli dbArgs - Command.Call.Version -> printVersion - Command.Call.Build -> runCommand build - Command.Call.Telemetry -> runCommand Telemetry.telemetry - Command.Call.Unknown _ -> printUsage + case commandCall of + Command.Call.New projectName -> runCommand $ createNewProject projectName + Command.Call.Start -> runCommand start + Command.Call.Clean -> runCommand clean + Command.Call.Compile -> runCommand compile + Command.Call.Db dbArgs -> dbCli dbArgs + Command.Call.Version -> printVersion + Command.Call.Build -> runCommand build + Command.Call.Telemetry -> runCommand Telemetry.telemetry + Command.Call.Unknown _ -> printUsage - -- If sending of telemetry data is still not done 1 second since commmand finished, abort it. - -- We also make sure here to catch all errors that might get thrown and silence them. - void $ Async.race (threadDelaySeconds 1) (Async.waitCatch telemetryThread) + -- If sending of telemetry data is still not done 1 second since commmand finished, abort it. + -- We also make sure here to catch all errors that might get thrown and silence them. + void $ Async.race (threadDelaySeconds 1) (Async.waitCatch telemetryThread) where - threadDelaySeconds = let microsecondsInASecond = 1000000 - in threadDelay . (* microsecondsInASecond) + threadDelaySeconds = + let microsecondsInASecond = 1000000 + in threadDelay . (* microsecondsInASecond) printUsage :: IO () -printUsage = putStrLn $ unlines - [ title "USAGE" - , " wasp [command-args]" - , "" - , title "COMMANDS" - , title " GENERAL" - , cmd " new Creates new Wasp project." - , cmd " version Prints current version of CLI." - , title " IN PROJECT" - , cmd " start Runs Wasp app in development mode, watching for file changes." - , cmd " db [args] Executes a database command. Run 'wasp db' for more info." - , cmd " clean Deletes all generated code and other cached artifacts. Wasp equivalent of 'have you tried closing and opening it again?'." - , cmd " build Generates full web app code, ready for deployment. Use when deploying or ejecting." - , cmd " telemetry Prints telemetry status." - , "" - , title "EXAMPLES" - , " wasp new MyApp" - , " wasp start" - , " wasp db migrate-dev" - , "" - , Term.applyStyles [Term.Green] "Docs:" ++ " https://wasp-lang.dev/docs" - , Term.applyStyles [Term.Magenta] "Discord (chat):" ++ " https://discord.gg/rzdnErX" - ] +printUsage = + putStrLn $ + unlines + [ title "USAGE", + " wasp [command-args]", + "", + title "COMMANDS", + title " GENERAL", + cmd " new Creates new Wasp project.", + cmd " version Prints current version of CLI.", + title " IN PROJECT", + cmd " start Runs Wasp app in development mode, watching for file changes.", + cmd " db [args] Executes a database command. Run 'wasp db' for more info.", + cmd " clean Deletes all generated code and other cached artifacts. Wasp equivalent of 'have you tried closing and opening it again?'.", + cmd " build Generates full web app code, ready for deployment. Use when deploying or ejecting.", + cmd " telemetry Prints telemetry status.", + "", + title "EXAMPLES", + " wasp new MyApp", + " wasp start", + " wasp db migrate-dev", + "", + Term.applyStyles [Term.Green] "Docs:" ++ " https://wasp-lang.dev/docs", + Term.applyStyles [Term.Magenta] "Discord (chat):" ++ " https://discord.gg/rzdnErX" + ] printVersion :: IO () printVersion = putStrLn $ showVersion version @@ -86,27 +87,29 @@ printVersion = putStrLn $ showVersion version -- TODO(matija): maybe extract to a separate module, e.g. DbCli.hs? dbCli :: [String] -> IO () dbCli args = case args of - ["migrate-dev"] -> runDbCommand Command.Db.Migrate.migrateDev - ["studio"] -> runDbCommand studio - _ -> printDbUsage + ["migrate-dev"] -> runDbCommand Command.Db.Migrate.migrateDev + ["studio"] -> runDbCommand studio + _ -> printDbUsage printDbUsage :: IO () -printDbUsage = putStrLn $ unlines - [ title "USAGE" - , " wasp db [command-args]" - , "" - , title "COMMANDS" - , cmd ( - " migrate-dev Ensures dev database corresponds to the current state of schema(entities):\n" <> - " - Generates a new migration if there are changes in the schema.\n" <> - " - Applies any pending migrations to the database." - ) - , cmd " studio GUI for inspecting your database." - , "" - , title "EXAMPLES" - , " wasp db migrate-dev" - , " wasp db studio" - ] +printDbUsage = + putStrLn $ + unlines + [ title "USAGE", + " wasp db [command-args]", + "", + title "COMMANDS", + cmd + ( " migrate-dev Ensures dev database corresponds to the current state of schema(entities):\n" + <> " - Generates a new migration if there are changes in the schema.\n" + <> " - Applies any pending migrations to the database." + ), + cmd " studio GUI for inspecting your database.", + "", + title "EXAMPLES", + " wasp db migrate-dev", + " wasp db studio" + ] title :: String -> String title = Term.applyStyles [Term.Bold] @@ -118,4 +121,4 @@ mapFirstWord :: (String -> String) -> String -> String mapFirstWord f s = beforeFirstWord ++ f firstWord ++ afterFirstWord where (beforeFirstWord, firstWordAndAfter) = span isSpace s - (firstWord, afterFirstWord) = break isSpace firstWordAndAfter + (firstWord, afterFirstWord) = break isSpace firstWordAndAfter diff --git a/waspc/src/Common.hs b/waspc/src/Common.hs index 00166ead4..8ec23e51c 100644 --- a/waspc/src/Common.hs +++ b/waspc/src/Common.hs @@ -1,5 +1,6 @@ module Common - ( WaspProjectDir - ) where + ( WaspProjectDir, + ) +where data WaspProjectDir -- Root dir of Wasp project, containing source files. diff --git a/waspc/src/CompileOptions.hs b/waspc/src/CompileOptions.hs index e9102b52f..14a26d88c 100644 --- a/waspc/src/CompileOptions.hs +++ b/waspc/src/CompileOptions.hs @@ -1,15 +1,15 @@ module CompileOptions - ( CompileOptions(..) - ) where - -import StrongPath (Path, Abs, Dir) -import ExternalCode(SourceExternalCodeDir) + ( CompileOptions (..), + ) +where +import ExternalCode (SourceExternalCodeDir) +import StrongPath (Abs, Dir, Path) -- TODO(martin): Should these be merged with Wasp data? Is it really a separate thing or not? -- It would be easier to pass around if it is part of Wasp data. But is it semantically correct? -- Maybe it is, even more than this! data CompileOptions = CompileOptions - { externalCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir)) - , isBuild :: !Bool - } + { externalCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir)), + isBuild :: !Bool + } diff --git a/waspc/src/Data.hs b/waspc/src/Data.hs index c674e2c42..903eddeef 100644 --- a/waspc/src/Data.hs +++ b/waspc/src/Data.hs @@ -1,13 +1,12 @@ module Data - ( DataDir - , getAbsDataDirPath - ) where - -import StrongPath (Abs, Dir, Path) -import qualified StrongPath as SP + ( DataDir, + getAbsDataDirPath, + ) +where import qualified Paths_waspc - +import StrongPath (Abs, Dir, Path) +import qualified StrongPath as SP data DataDir diff --git a/waspc/src/ExternalCode.hs b/waspc/src/ExternalCode.hs index 5189992e6..d1cf417a1 100644 --- a/waspc/src/ExternalCode.hs +++ b/waspc/src/ExternalCode.hs @@ -1,39 +1,40 @@ module ExternalCode - ( File - , filePathInExtCodeDir - , fileAbsPath - , fileText - , readFiles - , SourceExternalCodeDir - ) where + ( File, + filePathInExtCodeDir, + fileAbsPath, + fileText, + readFiles, + SourceExternalCodeDir, + ) +where -import UnliftIO.Exception (catch, throwIO) -import System.IO.Error (isDoesNotExistError) -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.IO as TextL.IO import Data.Maybe (catMaybes) import Data.Text (Text) +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.IO as TextL.IO import qualified Path as P - -import qualified Util.IO -import StrongPath (Path, Abs, Rel, Dir, ()) +import StrongPath (Abs, Dir, Path, Rel, ()) import qualified StrongPath as SP -import WaspignoreFile (readWaspignoreFile, ignores) +import System.IO.Error (isDoesNotExistError) +import UnliftIO.Exception (catch, throwIO) +import qualified Util.IO +import WaspignoreFile (ignores, readWaspignoreFile) -- | External code directory in Wasp source, from which external code files are read. data SourceExternalCodeDir data File = File - { _pathInExtCodeDir :: !(Path (Rel SourceExternalCodeDir) SP.File) - , _extCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir)) - , _text :: TextL.Text -- ^ File content. It will throw error when evaluated if file is not textual file. - } + { _pathInExtCodeDir :: !(Path (Rel SourceExternalCodeDir) SP.File), + _extCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir)), + -- | File content. It will throw error when evaluated if file is not textual file. + _text :: TextL.Text + } instance Show File where - show = show . _pathInExtCodeDir + show = show . _pathInExtCodeDir instance Eq File where - f1 == f2 = _pathInExtCodeDir f1 == _pathInExtCodeDir f2 + f1 == f2 = _pathInExtCodeDir f1 == _pathInExtCodeDir f2 -- | Returns path relative to the external code directory. filePathInExtCodeDir :: File -> Path (Rel SourceExternalCodeDir) SP.File @@ -54,33 +55,38 @@ waspignorePathInExtCodeDir = SP.fromPathRelFile [P.relfile|.waspignore|] -- except files ignores by the specified waspignore file. readFiles :: Path Abs (Dir SourceExternalCodeDir) -> IO [File] readFiles extCodeDirPath = do - let waspignoreFilePath = extCodeDirPath waspignorePathInExtCodeDir - waspignoreFile <- readWaspignoreFile waspignoreFilePath - relFilePaths <- filter (not . ignores waspignoreFile . SP.toFilePath) . - map SP.fromPathRelFile <$> - Util.IO.listDirectoryDeep (SP.toPathAbsDir extCodeDirPath) - let absFilePaths = map (extCodeDirPath ) relFilePaths - -- NOTE: We read text from all the files, regardless if they are text files or not, because - -- we don't know if they are a text file or not. - -- Since we do lazy reading (Text.Lazy), this is not a problem as long as we don't try to use - -- text of a file that is actually not a text file -> then we will get an error when Haskell - -- actually tries to read that file. - -- TODO: We are doing lazy IO here, and there is an idea of it being a thing to avoid, due to no - -- control over when resources are released and similar. - -- If we do figure out that this is causing us problems, we could do the following refactoring: - -- Don't read files at this point, just list them, and Wasp will contain just list of filepaths. - -- Modify TextFileDraft so that it also takes text transformation function (Text -> Text), - -- or create new file draft that will support that. - -- In generator, when creating TextFileDraft, give it function/logic for text transformation, - -- and it will be taken care of when draft will be written to the disk. - fileTexts <- catMaybes <$> mapM (tryReadFile . SP.toFilePath) absFilePaths - let files = map (\(path, text) -> File path extCodeDirPath text) (zip relFilePaths fileTexts) - return files - where - -- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed - -- but then got deleted before actual reading was invoked. - -- That would make this function crash, so we just ignore those errors. - tryReadFile :: FilePath -> IO (Maybe TextL.Text) - tryReadFile fp = (Just <$> TextL.IO.readFile fp) `catch` (\e -> if isDoesNotExistError e - then return Nothing - else throwIO e) + let waspignoreFilePath = extCodeDirPath waspignorePathInExtCodeDir + waspignoreFile <- readWaspignoreFile waspignoreFilePath + relFilePaths <- + filter (not . ignores waspignoreFile . SP.toFilePath) + . map SP.fromPathRelFile + <$> Util.IO.listDirectoryDeep (SP.toPathAbsDir extCodeDirPath) + let absFilePaths = map (extCodeDirPath ) relFilePaths + -- NOTE: We read text from all the files, regardless if they are text files or not, because + -- we don't know if they are a text file or not. + -- Since we do lazy reading (Text.Lazy), this is not a problem as long as we don't try to use + -- text of a file that is actually not a text file -> then we will get an error when Haskell + -- actually tries to read that file. + -- TODO: We are doing lazy IO here, and there is an idea of it being a thing to avoid, due to no + -- control over when resources are released and similar. + -- If we do figure out that this is causing us problems, we could do the following refactoring: + -- Don't read files at this point, just list them, and Wasp will contain just list of filepaths. + -- Modify TextFileDraft so that it also takes text transformation function (Text -> Text), + -- or create new file draft that will support that. + -- In generator, when creating TextFileDraft, give it function/logic for text transformation, + -- and it will be taken care of when draft will be written to the disk. + fileTexts <- catMaybes <$> mapM (tryReadFile . SP.toFilePath) absFilePaths + let files = map (\(path, text) -> File path extCodeDirPath text) (zip relFilePaths fileTexts) + return files + where + -- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed + -- but then got deleted before actual reading was invoked. + -- That would make this function crash, so we just ignore those errors. + tryReadFile :: FilePath -> IO (Maybe TextL.Text) + tryReadFile fp = + (Just <$> TextL.IO.readFile fp) + `catch` ( \e -> + if isDoesNotExistError e + then return Nothing + else throwIO e + ) diff --git a/waspc/src/Generator.hs b/waspc/src/Generator.hs index 964da869e..168453c52 100644 --- a/waspc/src/Generator.hs +++ b/waspc/src/Generator.hs @@ -1,30 +1,29 @@ module Generator - ( writeWebAppCode - , Generator.Setup.setup - , Generator.Start.start - ) where + ( writeWebAppCode, + Generator.Setup.setup, + Generator.Start.start, + ) +where +import CompileOptions (CompileOptions) import qualified Data.Text import qualified Data.Text.IO -import Data.Time.Clock +import Data.Time.Clock import qualified Data.Version -import qualified Path as P -import qualified Paths_waspc - -import CompileOptions (CompileOptions) -import Generator.Common (ProjectRootDir) -import Generator.DbGenerator (genDb) -import Generator.FileDraft (FileDraft, write) -import Generator.ServerGenerator (genServer) +import Generator.Common (ProjectRootDir) +import Generator.DbGenerator (genDb) +import Generator.DockerGenerator (genDockerFiles) +import Generator.FileDraft (FileDraft, write) +import Generator.ServerGenerator (genServer) import qualified Generator.ServerGenerator as ServerGenerator -import Generator.DockerGenerator (genDockerFiles) import qualified Generator.Setup import qualified Generator.Start -import Generator.WebAppGenerator (generateWebApp) -import StrongPath (Abs, Dir, Path, ()) -import qualified StrongPath as SP -import Wasp (Wasp) - +import Generator.WebAppGenerator (generateWebApp) +import qualified Path as P +import qualified Paths_waspc +import StrongPath (Abs, Dir, Path, ()) +import qualified StrongPath as SP +import Wasp (Wasp) -- | Generates web app code from given Wasp and writes it to given destination directory. -- If dstDir does not exist yet, it will be created. @@ -33,12 +32,12 @@ import Wasp (Wasp) -- from user's machine. Maybe we just overwrite and we are good? writeWebAppCode :: Wasp -> Path Abs (Dir ProjectRootDir) -> CompileOptions -> IO () writeWebAppCode wasp dstDir compileOptions = do - writeFileDrafts dstDir (generateWebApp wasp compileOptions) - ServerGenerator.preCleanup wasp dstDir compileOptions - writeFileDrafts dstDir (genServer wasp compileOptions) - writeFileDrafts dstDir (genDb wasp compileOptions) - writeFileDrafts dstDir (genDockerFiles wasp compileOptions) - writeDotWaspInfo dstDir + writeFileDrafts dstDir (generateWebApp wasp compileOptions) + ServerGenerator.preCleanup wasp dstDir compileOptions + writeFileDrafts dstDir (genServer wasp compileOptions) + writeFileDrafts dstDir (genDb wasp compileOptions) + writeFileDrafts dstDir (genDockerFiles wasp compileOptions) + writeDotWaspInfo dstDir -- | Writes file drafts while using given destination dir as root dir. -- TODO(martin): We could/should parallelize this. @@ -49,8 +48,8 @@ writeFileDrafts dstDir = mapM_ (write dstDir) -- | Writes .waspinfo, which contains some basic metadata about how/when wasp generated the code. writeDotWaspInfo :: Path Abs (Dir ProjectRootDir) -> IO () writeDotWaspInfo dstDir = do - currentTime <- getCurrentTime - let version = Data.Version.showVersion Paths_waspc.version - let content = "Generated on " ++ (show currentTime) ++ " by waspc version " ++ (show version) ++ " ." - let dstPath = dstDir SP.fromPathRelFile [P.relfile|.waspinfo|] - Data.Text.IO.writeFile (SP.toFilePath dstPath) (Data.Text.pack content) + currentTime <- getCurrentTime + let version = Data.Version.showVersion Paths_waspc.version + let content = "Generated on " ++ (show currentTime) ++ " by waspc version " ++ (show version) ++ " ." + let dstPath = dstDir SP.fromPathRelFile [P.relfile|.waspinfo|] + Data.Text.IO.writeFile (SP.toFilePath dstPath) (Data.Text.pack content) diff --git a/waspc/src/Generator/Common.hs b/waspc/src/Generator/Common.hs index 734e6a4ed..42348304c 100644 --- a/waspc/src/Generator/Common.hs +++ b/waspc/src/Generator/Common.hs @@ -1,8 +1,9 @@ module Generator.Common - ( ProjectRootDir - , nodeVersion - , nodeVersionAsText - ) where + ( ProjectRootDir, + nodeVersion, + nodeVersionAsText, + ) +where import Text.Printf (printf) @@ -16,4 +17,5 @@ nodeVersion = (12, 18, 0) -- Latest LTS version. nodeVersionAsText :: String nodeVersionAsText = printf "%d.%d.%d" major minor patch - where (major, minor, patch) = nodeVersion + where + (major, minor, patch) = nodeVersion diff --git a/waspc/src/Generator/DbGenerator.hs b/waspc/src/Generator/DbGenerator.hs index 63750d8af..633b8eec5 100644 --- a/waspc/src/Generator/DbGenerator.hs +++ b/waspc/src/Generator/DbGenerator.hs @@ -1,30 +1,31 @@ module Generator.DbGenerator - ( genDb - , dbRootDirInProjectRootDir - , dbSchemaFileInProjectRootDir - ) where + ( genDb, + dbRootDirInProjectRootDir, + dbSchemaFileInProjectRootDir, + ) +where -import Data.Aeson (object, (.=)) -import qualified Path as P -import Data.Maybe (fromMaybe) - -import CompileOptions (CompileOptions) -import Generator.Common (ProjectRootDir) -import Generator.FileDraft (FileDraft, createTemplateFileDraft) -import Generator.Templates (TemplatesDir) +import CompileOptions (CompileOptions) +import Data.Aeson (object, (.=)) +import Data.Maybe (fromMaybe) +import Generator.Common (ProjectRootDir) +import Generator.FileDraft (FileDraft, createTemplateFileDraft) +import Generator.Templates (TemplatesDir) +import qualified Path as P import qualified Psl.Ast.Model import qualified Psl.Generator.Model -import StrongPath (Dir, File, Path, Rel, ()) -import qualified StrongPath as SP -import Wasp (Wasp) +import StrongPath (Dir, File, Path, Rel, ()) +import qualified StrongPath as SP +import Wasp (Wasp) import qualified Wasp import qualified Wasp.Db -import Wasp.Entity (Entity) +import Wasp.Entity (Entity) import qualified Wasp.Entity -- * Path definitions data DbRootDir + data DbTemplatesDir dbRootDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir DbRootDir) @@ -48,29 +49,32 @@ dbSchemaFileInProjectRootDir = dbRootDirInProjectRootDir dbSchemaFileInDbRoo genDb :: Wasp -> CompileOptions -> [FileDraft] genDb wasp _ = - [ genPrismaSchema wasp - ] + [ genPrismaSchema wasp + ] genPrismaSchema :: Wasp -> FileDraft genPrismaSchema wasp = createTemplateFileDraft dstPath tmplSrcPath (Just templateData) - where - dstPath = dbSchemaFileInProjectRootDir - tmplSrcPath = dbTemplatesDirInTemplatesDir dbSchemaFileInDbTemplatesDir + where + dstPath = dbSchemaFileInProjectRootDir + tmplSrcPath = dbTemplatesDirInTemplatesDir dbSchemaFileInDbTemplatesDir - templateData = object - [ "modelSchemas" .= map entityToPslModelSchema (Wasp.getPSLEntities wasp) - , "datasourceProvider" .= (datasourceProvider :: String) - , "datasourceUrl" .= (datasourceUrl :: String) - ] + templateData = + object + [ "modelSchemas" .= map entityToPslModelSchema (Wasp.getPSLEntities wasp), + "datasourceProvider" .= (datasourceProvider :: String), + "datasourceUrl" .= (datasourceUrl :: String) + ] - dbSystem = fromMaybe Wasp.Db.SQLite $ Wasp.Db._system <$> Wasp.getDb wasp - (datasourceProvider, datasourceUrl) = case dbSystem of - Wasp.Db.PostgreSQL -> ("postgresql", "env(\"DATABASE_URL\")") - -- TODO: Report this error with some better mechanism, not `error`. - Wasp.Db.SQLite -> if Wasp.getIsBuild wasp - then error "SQLite is not supported in production. Set db.system to smth else." - else ("sqlite", "\"file:./dev.db\"") + dbSystem = fromMaybe Wasp.Db.SQLite $ Wasp.Db._system <$> Wasp.getDb wasp + (datasourceProvider, datasourceUrl) = case dbSystem of + Wasp.Db.PostgreSQL -> ("postgresql", "env(\"DATABASE_URL\")") + -- TODO: Report this error with some better mechanism, not `error`. + Wasp.Db.SQLite -> + if Wasp.getIsBuild wasp + then error "SQLite is not supported in production. Set db.system to smth else." + else ("sqlite", "\"file:./dev.db\"") - entityToPslModelSchema :: Entity -> String - entityToPslModelSchema entity = Psl.Generator.Model.generateModel $ - Psl.Ast.Model.Model (Wasp.Entity._name entity) (Wasp.Entity._pslModelBody entity) + entityToPslModelSchema :: Entity -> String + entityToPslModelSchema entity = + Psl.Generator.Model.generateModel $ + Psl.Ast.Model.Model (Wasp.Entity._name entity) (Wasp.Entity._pslModelBody entity) diff --git a/waspc/src/Generator/DbGenerator/Jobs.hs b/waspc/src/Generator/DbGenerator/Jobs.hs index c1bd72357..7181430d6 100644 --- a/waspc/src/Generator/DbGenerator/Jobs.hs +++ b/waspc/src/Generator/DbGenerator/Jobs.hs @@ -1,36 +1,47 @@ module Generator.DbGenerator.Jobs - ( migrateDev - , runStudio - ) where - -import Generator.Common (ProjectRootDir) -import qualified Generator.Job as J -import Generator.Job.Process (runNodeCommandAsJob) -import StrongPath (Abs, Dir, Path, ()) -import qualified StrongPath as SP -import Generator.ServerGenerator.Common (serverRootDirInProjectRootDir) -import Generator.DbGenerator (dbSchemaFileInProjectRootDir) + ( migrateDev, + runStudio, + ) +where +import Generator.Common (ProjectRootDir) +import Generator.DbGenerator (dbSchemaFileInProjectRootDir) +import qualified Generator.Job as J +import Generator.Job.Process (runNodeCommandAsJob) +import Generator.ServerGenerator.Common (serverRootDirInProjectRootDir) +import StrongPath (Abs, Dir, Path, ()) +import qualified StrongPath as SP migrateDev :: Path Abs (Dir ProjectRootDir) -> J.Job migrateDev projectDir = do - let serverDir = projectDir serverRootDirInProjectRootDir - let schemaFile = projectDir dbSchemaFileInProjectRootDir + let serverDir = projectDir serverRootDirInProjectRootDir + let schemaFile = projectDir dbSchemaFileInProjectRootDir - -- NOTE(matija): We are running this command from server's root dir since that is where - -- Prisma packages (cli and client) are currently installed. - runNodeCommandAsJob serverDir "npx" - [ "prisma", "migrate", "dev" - , "--schema", SP.toFilePath schemaFile - ] J.Db + -- NOTE(matija): We are running this command from server's root dir since that is where + -- Prisma packages (cli and client) are currently installed. + runNodeCommandAsJob + serverDir + "npx" + [ "prisma", + "migrate", + "dev", + "--schema", + SP.toFilePath schemaFile + ] + J.Db -- | Runs `prisma studio` - Prisma's db inspector. runStudio :: Path Abs (Dir ProjectRootDir) -> J.Job runStudio projectDir = do - let serverDir = projectDir serverRootDirInProjectRootDir - let schemaFile = projectDir dbSchemaFileInProjectRootDir + let serverDir = projectDir serverRootDirInProjectRootDir + let schemaFile = projectDir dbSchemaFileInProjectRootDir - runNodeCommandAsJob serverDir "npx" - [ "prisma", "studio" - , "--schema", SP.toFilePath schemaFile - ] J.Db + runNodeCommandAsJob + serverDir + "npx" + [ "prisma", + "studio", + "--schema", + SP.toFilePath schemaFile + ] + J.Db diff --git a/waspc/src/Generator/DbGenerator/Operations.hs b/waspc/src/Generator/DbGenerator/Operations.hs index 208afb07b..392d064eb 100644 --- a/waspc/src/Generator/DbGenerator/Operations.hs +++ b/waspc/src/Generator/DbGenerator/Operations.hs @@ -1,30 +1,32 @@ module Generator.DbGenerator.Operations - ( migrateDev - ) where + ( migrateDev, + ) +where import Control.Concurrent (Chan, newChan, readChan) import Control.Concurrent.Async (concurrently) -import System.Exit (ExitCode (..)) - -import StrongPath (Abs, Dir, Path) import Generator.Common (ProjectRootDir) -import Generator.Job.IO (printJobMessage) -import qualified Generator.Job as J -import Generator.Job (JobMessage) import qualified Generator.DbGenerator.Jobs as DbJobs +import Generator.Job (JobMessage) +import qualified Generator.Job as J +import Generator.Job.IO (printJobMessage) +import StrongPath (Abs, Dir, Path) +import System.Exit (ExitCode (..)) printJobMsgsUntilExitReceived :: Chan JobMessage -> IO () printJobMsgsUntilExitReceived chan = do - jobMsg <- readChan chan - case J._data jobMsg of - J.JobOutput {} -> printJobMessage jobMsg >> printJobMsgsUntilExitReceived chan - J.JobExit {} -> return () + jobMsg <- readChan chan + case J._data jobMsg of + J.JobOutput {} -> printJobMessage jobMsg >> printJobMsgsUntilExitReceived chan + J.JobExit {} -> return () migrateDev :: Path Abs (Dir ProjectRootDir) -> IO (Either String ()) migrateDev projectDir = do - chan <- newChan - (_, dbExitCode) <- concurrently (printJobMsgsUntilExitReceived chan) - (DbJobs.migrateDev projectDir chan) - case dbExitCode of - ExitSuccess -> return (Right ()) - ExitFailure code -> return $ Left $ "Migrate (dev) failed with exit code: " ++ show code + chan <- newChan + (_, dbExitCode) <- + concurrently + (printJobMsgsUntilExitReceived chan) + (DbJobs.migrateDev projectDir chan) + case dbExitCode of + ExitSuccess -> return (Right ()) + ExitFailure code -> return $ Left $ "Migrate (dev) failed with exit code: " ++ show code diff --git a/waspc/src/Generator/DockerGenerator.hs b/waspc/src/Generator/DockerGenerator.hs index afad08dd3..c2f1715b6 100644 --- a/waspc/src/Generator/DockerGenerator.hs +++ b/waspc/src/Generator/DockerGenerator.hs @@ -1,36 +1,41 @@ module Generator.DockerGenerator - ( genDockerFiles - ) where + ( genDockerFiles, + ) +where -import Data.Aeson (object, (.=)) -import qualified Path as P -import StrongPath (File, Path, Rel) -import qualified StrongPath as SP - -import CompileOptions (CompileOptions) -import Generator.Common (ProjectRootDir) -import Generator.FileDraft (FileDraft, createTemplateFileDraft) -import Generator.Templates (TemplatesDir) -import Wasp (Wasp) +import CompileOptions (CompileOptions) +import Data.Aeson (object, (.=)) +import Generator.Common (ProjectRootDir) +import Generator.FileDraft (FileDraft, createTemplateFileDraft) +import Generator.Templates (TemplatesDir) +import qualified Path as P +import StrongPath (File, Path, Rel) +import qualified StrongPath as SP +import Wasp (Wasp) import qualified Wasp genDockerFiles :: Wasp -> CompileOptions -> [FileDraft] -genDockerFiles wasp _ = concat - [ [genDockerfile wasp] - , [genDockerignore wasp] +genDockerFiles wasp _ = + concat + [ [genDockerfile wasp], + [genDockerignore wasp] ] -- TODO: Inject paths to server and db files/dirs, right now they are hardcoded in the templates. genDockerfile :: Wasp -> FileDraft -genDockerfile wasp = createTemplateFileDraft +genDockerfile wasp = + createTemplateFileDraft (SP.fromPathRelFile [P.relfile|Dockerfile|] :: Path (Rel ProjectRootDir) File) (SP.fromPathRelFile [P.relfile|Dockerfile|] :: Path (Rel TemplatesDir) File) - (Just $ object - [ "usingPrisma" .= not (null $ Wasp.getPSLEntities wasp) - ]) + ( Just $ + object + [ "usingPrisma" .= not (null $ Wasp.getPSLEntities wasp) + ] + ) genDockerignore :: Wasp -> FileDraft -genDockerignore _ = createTemplateFileDraft +genDockerignore _ = + createTemplateFileDraft (SP.fromPathRelFile [P.relfile|.dockerignore|] :: Path (Rel ProjectRootDir) File) (SP.fromPathRelFile [P.relfile|dockerignore|] :: Path (Rel TemplatesDir) File) Nothing diff --git a/waspc/src/Generator/ExternalCodeGenerator.hs b/waspc/src/Generator/ExternalCodeGenerator.hs index e68f85a31..5db0d771a 100644 --- a/waspc/src/Generator/ExternalCodeGenerator.hs +++ b/waspc/src/Generator/ExternalCodeGenerator.hs @@ -1,39 +1,38 @@ module Generator.ExternalCodeGenerator - ( generateExternalCodeDir - ) where + ( generateExternalCodeDir, + ) +where -import qualified System.FilePath as FP - -import StrongPath (Path, Rel, File, ()) -import qualified StrongPath as SP -import Wasp (Wasp) -import qualified Wasp import qualified ExternalCode as EC -import qualified Generator.FileDraft as FD import qualified Generator.ExternalCodeGenerator.Common as C import Generator.ExternalCodeGenerator.Js (generateJsFile) - +import qualified Generator.FileDraft as FD +import StrongPath (File, Path, Rel, ()) +import qualified StrongPath as SP +import qualified System.FilePath as FP +import Wasp (Wasp) +import qualified Wasp -- | Takes external code files from Wasp and generates them in new location as part of the generated project. -- It might not just copy them but also do some changes on them, as needed. -generateExternalCodeDir :: C.ExternalCodeGeneratorStrategy - -> Wasp - -> [FD.FileDraft] +generateExternalCodeDir :: + C.ExternalCodeGeneratorStrategy -> + Wasp -> + [FD.FileDraft] generateExternalCodeDir strategy wasp = - map (generateFile strategy) (Wasp.getExternalCodeFiles wasp) + map (generateFile strategy) (Wasp.getExternalCodeFiles wasp) generateFile :: C.ExternalCodeGeneratorStrategy -> EC.File -> FD.FileDraft generateFile strategy file - | extension `elem` [".js", ".jsx"] = generateJsFile strategy file - | otherwise = let relDstPath = (C._extCodeDirInProjectRootDir strategy) - dstPathInGenExtCodeDir - absSrcPath = EC.fileAbsPath file - in FD.createCopyFileDraft relDstPath absSrcPath + | extension `elem` [".js", ".jsx"] = generateJsFile strategy file + | otherwise = + let relDstPath = + (C._extCodeDirInProjectRootDir strategy) + dstPathInGenExtCodeDir + absSrcPath = EC.fileAbsPath file + in FD.createCopyFileDraft relDstPath absSrcPath where dstPathInGenExtCodeDir :: Path (Rel C.GeneratedExternalCodeDir) File dstPathInGenExtCodeDir = C.castRelPathFromSrcToGenExtCodeDir $ EC.filePathInExtCodeDir file extension = FP.takeExtension $ SP.toFilePath $ EC.filePathInExtCodeDir file - - - diff --git a/waspc/src/Generator/ExternalCodeGenerator/Common.hs b/waspc/src/Generator/ExternalCodeGenerator/Common.hs index c6682ac23..f45e4afe7 100644 --- a/waspc/src/Generator/ExternalCodeGenerator/Common.hs +++ b/waspc/src/Generator/ExternalCodeGenerator/Common.hs @@ -1,17 +1,17 @@ module Generator.ExternalCodeGenerator.Common - ( ExternalCodeGeneratorStrategy(..) - , GeneratedExternalCodeDir - , castRelPathFromSrcToGenExtCodeDir - , asGenExtFile - ) where + ( ExternalCodeGeneratorStrategy (..), + GeneratedExternalCodeDir, + castRelPathFromSrcToGenExtCodeDir, + asGenExtFile, + ) +where import Data.Text (Text) -import qualified Path as P - -import StrongPath (Path, Rel, File, Dir) -import qualified StrongPath as SP -import Generator.Common (ProjectRootDir) import ExternalCode (SourceExternalCodeDir) +import Generator.Common (ProjectRootDir) +import qualified Path as P +import StrongPath (Dir, File, Path, Rel) +import qualified StrongPath as SP -- | Path to the directory where ext code will be generated. data GeneratedExternalCodeDir @@ -23,9 +23,9 @@ castRelPathFromSrcToGenExtCodeDir :: Path (Rel SourceExternalCodeDir) a -> Path castRelPathFromSrcToGenExtCodeDir = SP.castRel data ExternalCodeGeneratorStrategy = ExternalCodeGeneratorStrategy - { -- | Takes a path where the external code js file will be generated. - -- Also takes text of the file. Returns text where special @wasp imports have been replaced with - -- imports that will work. - _resolveJsFileWaspImports :: Path (Rel GeneratedExternalCodeDir) File -> Text -> Text - , _extCodeDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir GeneratedExternalCodeDir) - } + { -- | Takes a path where the external code js file will be generated. + -- Also takes text of the file. Returns text where special @wasp imports have been replaced with + -- imports that will work. + _resolveJsFileWaspImports :: Path (Rel GeneratedExternalCodeDir) File -> Text -> Text, + _extCodeDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir GeneratedExternalCodeDir) + } diff --git a/waspc/src/Generator/ExternalCodeGenerator/Js.hs b/waspc/src/Generator/ExternalCodeGenerator/Js.hs index 2fbee7075..eb88307b5 100644 --- a/waspc/src/Generator/ExternalCodeGenerator/Js.hs +++ b/waspc/src/Generator/ExternalCodeGenerator/Js.hs @@ -1,20 +1,19 @@ module Generator.ExternalCodeGenerator.Js - ( generateJsFile - , resolveJsFileWaspImportsForExtCodeDir - ) where + ( generateJsFile, + resolveJsFileWaspImportsForExtCodeDir, + ) +where -import qualified Data.Text as T -import qualified Text.Regex.TDFA as TR import Data.Text (Text, unpack) - -import StrongPath (Path, Rel, File, Dir, ()) -import qualified StrongPath as SP -import Path.Extra (reversePosixPath, toPosixFilePath) -import qualified Generator.FileDraft as FD +import qualified Data.Text as T import qualified ExternalCode as EC import Generator.ExternalCodeGenerator.Common (GeneratedExternalCodeDir) import qualified Generator.ExternalCodeGenerator.Common as C - +import qualified Generator.FileDraft as FD +import Path.Extra (reversePosixPath, toPosixFilePath) +import StrongPath (Dir, File, Path, Rel, ()) +import qualified StrongPath as SP +import qualified Text.Regex.TDFA as TR generateJsFile :: C.ExternalCodeGeneratorStrategy -> EC.File -> FD.FileDraft generateJsFile strategy file = FD.createTextFileDraft dstPath text' @@ -29,14 +28,18 @@ generateJsFile strategy file = FD.createTextFileDraft dstPath text' dstPath = (C._extCodeDirInProjectRootDir strategy) filePathInGenExtCodeDir -- | Replaces imports that start with "@wasp/" with imports that start from the src dir of the app. -resolveJsFileWaspImportsForExtCodeDir - :: Path (Rel ()) (Dir GeneratedExternalCodeDir) -- ^ Relative path of ext code dir in src dir of app (web app, server (app), ...) - -> Path (Rel GeneratedExternalCodeDir) File -- ^ Path where this JS file will be generated. - -> Text -- ^ Original text of the file. - -> Text -- ^ Text of the file with special "@wasp" imports resolved (replaced with normal JS imports). +resolveJsFileWaspImportsForExtCodeDir :: + -- | Relative path of ext code dir in src dir of app (web app, server (app), ...) + Path (Rel ()) (Dir GeneratedExternalCodeDir) -> + -- | Path where this JS file will be generated. + Path (Rel GeneratedExternalCodeDir) File -> + -- | Original text of the file. + Text -> + -- | Text of the file with special "@wasp" imports resolved (replaced with normal JS imports). + Text resolveJsFileWaspImportsForExtCodeDir extCodeDirInAppSrcDir jsFileDstPathInExtCodeDir jsFileText = - let matches = concat (unpack jsFileText TR.=~ ("(from +['\"]@wasp/)" :: String) :: [[String]]) - in foldr replaceFromWasp jsFileText matches + let matches = concat (unpack jsFileText TR.=~ ("(from +['\"]@wasp/)" :: String) :: [[String]]) + in foldr replaceFromWasp jsFileText matches where replaceFromWasp fromWasp = T.replace (T.pack fromWasp) (T.pack $ transformFromWasp fromWasp) transformFromWasp fromWasp = (reverse $ drop (length ("@wasp/" :: String)) $ reverse fromWasp) ++ pathPrefix ++ "/" diff --git a/waspc/src/Generator/FileDraft.hs b/waspc/src/Generator/FileDraft.hs index 0a0b6a969..1cca1b951 100644 --- a/waspc/src/Generator/FileDraft.hs +++ b/waspc/src/Generator/FileDraft.hs @@ -1,65 +1,68 @@ module Generator.FileDraft - ( FileDraft(..) - , Writeable(..) - , createTemplateFileDraft - , createCopyFileDraft - , createCopyFileDraftIfExists - , createTextFileDraft - ) where + ( FileDraft (..), + Writeable (..), + createTemplateFileDraft, + createCopyFileDraft, + createCopyFileDraftIfExists, + createTextFileDraft, + ) +where import qualified Data.Aeson as Aeson import Data.Text (Text) - -import StrongPath (Path, Abs, Rel, File) -import Generator.Templates (TemplatesDir) import Generator.Common (ProjectRootDir) -import Generator.FileDraft.Writeable -import qualified Generator.FileDraft.TemplateFileDraft as TmplFD import qualified Generator.FileDraft.CopyFileDraft as CopyFD +import qualified Generator.FileDraft.TemplateFileDraft as TmplFD import qualified Generator.FileDraft.TextFileDraft as TextFD - +import Generator.FileDraft.Writeable +import Generator.Templates (TemplatesDir) +import StrongPath (Abs, File, Path, Rel) -- | FileDraft unites different file draft types into a single type, -- so that in the rest of the system they can be passed around as heterogeneous -- collection when needed. data FileDraft - = FileDraftTemplateFd TmplFD.TemplateFileDraft - | FileDraftCopyFd CopyFD.CopyFileDraft - | FileDraftTextFd TextFD.TextFileDraft - deriving (Show, Eq) + = FileDraftTemplateFd TmplFD.TemplateFileDraft + | FileDraftCopyFd CopyFD.CopyFileDraft + | FileDraftTextFd TextFD.TextFileDraft + deriving (Show, Eq) instance Writeable FileDraft where - write dstDir (FileDraftTemplateFd draft) = write dstDir draft - write dstDir (FileDraftCopyFd draft) = write dstDir draft - write dstDir (FileDraftTextFd draft) = write dstDir draft + write dstDir (FileDraftTemplateFd draft) = write dstDir draft + write dstDir (FileDraftCopyFd draft) = write dstDir draft + write dstDir (FileDraftTextFd draft) = write dstDir draft - -createTemplateFileDraft :: Path (Rel ProjectRootDir) File - -> Path (Rel TemplatesDir) File - -> Maybe Aeson.Value - -> FileDraft +createTemplateFileDraft :: + Path (Rel ProjectRootDir) File -> + Path (Rel TemplatesDir) File -> + Maybe Aeson.Value -> + FileDraft createTemplateFileDraft dstPath tmplSrcPath tmplData = - FileDraftTemplateFd $ TmplFD.TemplateFileDraft { TmplFD._dstPath = dstPath - , TmplFD._srcPathInTmplDir = tmplSrcPath - , TmplFD._tmplData = tmplData - } + FileDraftTemplateFd $ + TmplFD.TemplateFileDraft + { TmplFD._dstPath = dstPath, + TmplFD._srcPathInTmplDir = tmplSrcPath, + TmplFD._tmplData = tmplData + } createCopyFileDraft :: Path (Rel ProjectRootDir) File -> Path Abs File -> FileDraft createCopyFileDraft dstPath srcPath = - FileDraftCopyFd $ CopyFD.CopyFileDraft - { CopyFD._dstPath = dstPath - , CopyFD._srcPath = srcPath - , CopyFD._failIfSrcDoesNotExist = True - } + FileDraftCopyFd $ + CopyFD.CopyFileDraft + { CopyFD._dstPath = dstPath, + CopyFD._srcPath = srcPath, + CopyFD._failIfSrcDoesNotExist = True + } createCopyFileDraftIfExists :: Path (Rel ProjectRootDir) File -> Path Abs File -> FileDraft createCopyFileDraftIfExists dstPath srcPath = - FileDraftCopyFd $ CopyFD.CopyFileDraft - { CopyFD._dstPath = dstPath - , CopyFD._srcPath = srcPath - , CopyFD._failIfSrcDoesNotExist = False - } + FileDraftCopyFd $ + CopyFD.CopyFileDraft + { CopyFD._dstPath = dstPath, + CopyFD._srcPath = srcPath, + CopyFD._failIfSrcDoesNotExist = False + } createTextFileDraft :: Path (Rel ProjectRootDir) File -> Text -> FileDraft createTextFileDraft dstPath content = - FileDraftTextFd $ TextFD.TextFileDraft { TextFD._dstPath = dstPath, TextFD._content = content} + FileDraftTextFd $ TextFD.TextFileDraft {TextFD._dstPath = dstPath, TextFD._content = content} diff --git a/waspc/src/Generator/FileDraft/CopyFileDraft.hs b/waspc/src/Generator/FileDraft/CopyFileDraft.hs index f12375c4e..683edbf51 100644 --- a/waspc/src/Generator/FileDraft/CopyFileDraft.hs +++ b/waspc/src/Generator/FileDraft/CopyFileDraft.hs @@ -1,44 +1,49 @@ module Generator.FileDraft.CopyFileDraft - ( CopyFileDraft(..) - ) where - -import Control.Monad (when) -import System.IO.Error (doesNotExistErrorType, mkIOError) - -import Generator.Common (ProjectRootDir) -import Generator.FileDraft.Writeable -import Generator.FileDraft.WriteableMonad -import StrongPath (Abs, File, Path, Rel, - ()) -import qualified StrongPath as SP + ( CopyFileDraft (..), + ) +where +import Control.Monad (when) +import Generator.Common (ProjectRootDir) +import Generator.FileDraft.Writeable +import Generator.FileDraft.WriteableMonad +import StrongPath + ( Abs, + File, + Path, + Rel, + (), + ) +import qualified StrongPath as SP +import System.IO.Error (doesNotExistErrorType, mkIOError) -- | File draft based purely on another file, that is just copied. data CopyFileDraft = CopyFileDraft - { -- | Path where the file will be copied to. - _dstPath :: !(Path (Rel ProjectRootDir) File) - -- | Absolute path of source file to copy. - , _srcPath :: !(Path Abs File) - , _failIfSrcDoesNotExist :: Bool - } - deriving (Show, Eq) + { -- | Path where the file will be copied to. + _dstPath :: !(Path (Rel ProjectRootDir) File), + -- | Absolute path of source file to copy. + _srcPath :: !(Path Abs File), + _failIfSrcDoesNotExist :: Bool + } + deriving (Show, Eq) instance Writeable CopyFileDraft where - write absDstDirPath draft = do - srcFileExists <- doesFileExist srcFilePath - if srcFileExists - then do - createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath) - copyFile srcFilePath (SP.toFilePath absDraftDstPath) - else - when - (_failIfSrcDoesNotExist draft) - (throwIO $ mkIOError - doesNotExistErrorType - "Source file of CopyFileDraft does not exist." - Nothing - (Just srcFilePath) - ) - where - srcFilePath = SP.toFilePath $ _srcPath draft - absDraftDstPath = absDstDirPath _dstPath draft + write absDstDirPath draft = do + srcFileExists <- doesFileExist srcFilePath + if srcFileExists + then do + createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath) + copyFile srcFilePath (SP.toFilePath absDraftDstPath) + else + when + (_failIfSrcDoesNotExist draft) + ( throwIO $ + mkIOError + doesNotExistErrorType + "Source file of CopyFileDraft does not exist." + Nothing + (Just srcFilePath) + ) + where + srcFilePath = SP.toFilePath $ _srcPath draft + absDraftDstPath = absDstDirPath _dstPath draft diff --git a/waspc/src/Generator/FileDraft/TemplateFileDraft.hs b/waspc/src/Generator/FileDraft/TemplateFileDraft.hs index ed4a4c2ca..eacc20d92 100644 --- a/waspc/src/Generator/FileDraft/TemplateFileDraft.hs +++ b/waspc/src/Generator/FileDraft/TemplateFileDraft.hs @@ -1,34 +1,37 @@ module Generator.FileDraft.TemplateFileDraft - ( TemplateFileDraft(..) - ) where + ( TemplateFileDraft (..), + ) +where import qualified Data.Aeson as Aeson - -import StrongPath (Path, Abs, Rel, File, ()) -import qualified StrongPath as SP import Generator.Common (ProjectRootDir) import Generator.FileDraft.Writeable import Generator.FileDraft.WriteableMonad import Generator.Templates (TemplatesDir) +import StrongPath (Abs, File, Path, Rel, ()) +import qualified StrongPath as SP -- | File draft based on template file that gets combined with data. data TemplateFileDraft = TemplateFileDraft - { _dstPath :: !(Path (Rel ProjectRootDir) File) -- ^ Path where file will be generated. - , _srcPathInTmplDir :: !(Path (Rel TemplatesDir) File) -- ^ Path of template source file. - , _tmplData :: Maybe Aeson.Value -- ^ Data to be fed to the template while rendering it. - } - deriving (Show, Eq) + { -- | Path where file will be generated. + _dstPath :: !(Path (Rel ProjectRootDir) File), + -- | Path of template source file. + _srcPathInTmplDir :: !(Path (Rel TemplatesDir) File), + -- | Data to be fed to the template while rendering it. + _tmplData :: Maybe Aeson.Value + } + deriving (Show, Eq) instance Writeable TemplateFileDraft where - write absDstDirPath draft = do - createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath) - case _tmplData draft of - Nothing -> do - absDraftSrcPath <- getTemplateFileAbsPath (_srcPathInTmplDir draft) - copyFile (SP.toFilePath absDraftSrcPath) (SP.toFilePath absDraftDstPath) - Just tmplData -> do - content <- compileAndRenderTemplate (_srcPathInTmplDir draft) tmplData - writeFileFromText (SP.toFilePath absDraftDstPath) content - where - absDraftDstPath :: Path Abs File - absDraftDstPath = absDstDirPath (_dstPath draft) + write absDstDirPath draft = do + createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath) + case _tmplData draft of + Nothing -> do + absDraftSrcPath <- getTemplateFileAbsPath (_srcPathInTmplDir draft) + copyFile (SP.toFilePath absDraftSrcPath) (SP.toFilePath absDraftDstPath) + Just tmplData -> do + content <- compileAndRenderTemplate (_srcPathInTmplDir draft) tmplData + writeFileFromText (SP.toFilePath absDraftDstPath) content + where + absDraftDstPath :: Path Abs File + absDraftDstPath = absDstDirPath (_dstPath draft) diff --git a/waspc/src/Generator/FileDraft/TextFileDraft.hs b/waspc/src/Generator/FileDraft/TextFileDraft.hs index 83e8d85da..f1ed29c67 100644 --- a/waspc/src/Generator/FileDraft/TextFileDraft.hs +++ b/waspc/src/Generator/FileDraft/TextFileDraft.hs @@ -1,26 +1,26 @@ module Generator.FileDraft.TextFileDraft - ( TextFileDraft(..) - ) where + ( TextFileDraft (..), + ) +where import Data.Text (Text) - -import StrongPath (Path, Rel, File, ()) -import qualified StrongPath as SP import Generator.Common (ProjectRootDir) import Generator.FileDraft.Writeable import Generator.FileDraft.WriteableMonad - +import StrongPath (File, Path, Rel, ()) +import qualified StrongPath as SP -- | File draft based on text, that is to be written to file when time comes. data TextFileDraft = TextFileDraft - { _dstPath :: !(Path (Rel ProjectRootDir) File) -- ^ Path where file will be generated. - , _content :: Text - } - deriving (Show, Eq) + { -- | Path where file will be generated. + _dstPath :: !(Path (Rel ProjectRootDir) File), + _content :: Text + } + deriving (Show, Eq) instance Writeable TextFileDraft where - write dstDir draft = do - createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath) - writeFileFromText (SP.toFilePath absDraftDstPath) (_content draft) - where - absDraftDstPath = dstDir (_dstPath draft) + write dstDir draft = do + createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath) + writeFileFromText (SP.toFilePath absDraftDstPath) (_content draft) + where + absDraftDstPath = dstDir (_dstPath draft) diff --git a/waspc/src/Generator/FileDraft/Writeable.hs b/waspc/src/Generator/FileDraft/Writeable.hs index 916a217a0..b831bea47 100644 --- a/waspc/src/Generator/FileDraft/Writeable.hs +++ b/waspc/src/Generator/FileDraft/Writeable.hs @@ -1,15 +1,16 @@ module Generator.FileDraft.Writeable - ( Writeable(..) - ) where + ( Writeable (..), + ) +where -import StrongPath (Path, Abs, Dir) import Generator.Common (ProjectRootDir) import Generator.FileDraft.WriteableMonad - +import StrongPath (Abs, Dir, Path) class Writeable w where - -- | Write file somewhere in the provided project root directory. - write :: (WriteableMonad m) - => Path Abs (Dir ProjectRootDir) - -> w - -> m () + -- | Write file somewhere in the provided project root directory. + write :: + (WriteableMonad m) => + Path Abs (Dir ProjectRootDir) -> + w -> + m () diff --git a/waspc/src/Generator/FileDraft/WriteableMonad.hs b/waspc/src/Generator/FileDraft/WriteableMonad.hs index dd608b6d1..4d0526e8b 100644 --- a/waspc/src/Generator/FileDraft/WriteableMonad.hs +++ b/waspc/src/Generator/FileDraft/WriteableMonad.hs @@ -1,67 +1,77 @@ module Generator.FileDraft.WriteableMonad - ( WriteableMonad(..) - ) where + ( WriteableMonad (..), + ) +where -import Control.Monad.IO.Class (MonadIO) -import Data.Aeson as Aeson -import Data.Text (Text) +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson as Aeson +import Data.Text (Text) import qualified Data.Text.IO +import qualified Generator.Templates as Templates +import StrongPath (Abs, Dir, File, Path, Rel) import qualified System.Directory -import System.IO.Error (isDoesNotExistError) -import UnliftIO.Exception (Exception, catch) -import qualified UnliftIO.Exception as E - -import qualified Generator.Templates as Templates -import StrongPath (Abs, Dir, File, Path, Rel) - +import System.IO.Error (isDoesNotExistError) +import UnliftIO.Exception (Exception, catch) +import qualified UnliftIO.Exception as E -- TODO: Should we use DI via data instead of typeclasses? -- https://news.ycombinator.com/item?id=10392044 -- | Describes effects needed by File Drafts. class (MonadIO m) => WriteableMonad m where - createDirectoryIfMissing - :: Bool -- ^ True if parents should also be created. - -> FilePath -- ^ Path to the directory to create. - -> m () + createDirectoryIfMissing :: + -- | True if parents should also be created. + Bool -> + -- | Path to the directory to create. + FilePath -> + m () - copyFile - :: FilePath -- ^ Src path. - -> FilePath -- ^ Dst path. - -> m () + copyFile :: + -- | Src path. + FilePath -> + -- | Dst path. + FilePath -> + m () - doesFileExist :: FilePath -> m Bool + doesFileExist :: FilePath -> m Bool - writeFileFromText :: FilePath -> Text -> m () + writeFileFromText :: FilePath -> Text -> m () - getTemplateFileAbsPath - :: Path (Rel Templates.TemplatesDir) File -- ^ Template file path. - -> m (Path Abs File) + getTemplateFileAbsPath :: + -- | Template file path. + Path (Rel Templates.TemplatesDir) File -> + m (Path Abs File) - getTemplatesDirAbsPath :: m (Path Abs (Dir Templates.TemplatesDir)) + getTemplatesDirAbsPath :: m (Path Abs (Dir Templates.TemplatesDir)) - compileAndRenderTemplate - :: Path (Rel Templates.TemplatesDir) File -- ^ Template file path. - -> Aeson.Value -- ^ JSON to be provided as template data. - -> m Text + compileAndRenderTemplate :: + -- | Template file path. + Path (Rel Templates.TemplatesDir) File -> + -- | JSON to be provided as template data. + Aeson.Value -> + m Text - throwIO :: (Exception e) => e -> m a + throwIO :: (Exception e) => e -> m a instance WriteableMonad IO where - createDirectoryIfMissing = System.Directory.createDirectoryIfMissing - -- TODO(matija): we should rename this function to make it clear it won't throw an exception when - -- a file does not exist. - copyFile src dst = do - -- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed - -- when the filedraft was created but then got deleted before actual copying was invoked. - -- That would make this function crash, so we just ignore those errors. - System.Directory.copyFile src dst `catch` (\e -> if isDoesNotExistError e - then return () - else throwIO e) + createDirectoryIfMissing = System.Directory.createDirectoryIfMissing - doesFileExist = System.Directory.doesFileExist - writeFileFromText = Data.Text.IO.writeFile - getTemplateFileAbsPath = Templates.getTemplateFileAbsPath - getTemplatesDirAbsPath = Templates.getTemplatesDirAbsPath - compileAndRenderTemplate = Templates.compileAndRenderTemplate - throwIO = E.throwIO + -- TODO(matija): we should rename this function to make it clear it won't throw an exception when + -- a file does not exist. + copyFile src dst = do + -- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed + -- when the filedraft was created but then got deleted before actual copying was invoked. + -- That would make this function crash, so we just ignore those errors. + System.Directory.copyFile src dst + `catch` ( \e -> + if isDoesNotExistError e + then return () + else throwIO e + ) + + doesFileExist = System.Directory.doesFileExist + writeFileFromText = Data.Text.IO.writeFile + getTemplateFileAbsPath = Templates.getTemplateFileAbsPath + getTemplatesDirAbsPath = Templates.getTemplatesDirAbsPath + compileAndRenderTemplate = Templates.compileAndRenderTemplate + throwIO = E.throwIO diff --git a/waspc/src/Generator/Job.hs b/waspc/src/Generator/Job.hs index 1e71e23df..f612fd521 100644 --- a/waspc/src/Generator/Job.hs +++ b/waspc/src/Generator/Job.hs @@ -1,29 +1,30 @@ module Generator.Job - ( Job - , JobMessage (..) - , JobMessageData (..) - , JobOutputType (..) - , JobType (..) - ) where - -import Control.Concurrent (Chan) -import Data.Text (Text) -import System.Exit (ExitCode) + ( Job, + JobMessage (..), + JobMessageData (..), + JobOutputType (..), + JobType (..), + ) +where +import Control.Concurrent (Chan) +import Data.Text (Text) +import System.Exit (ExitCode) -- | Job is an IO action that communicates progress by writing messages to given channel -- until it is done, when it returns exit code. type Job = Chan JobMessage -> IO ExitCode data JobMessage = JobMessage - { _data :: JobMessageData - , _jobType :: JobType - } - deriving (Show) + { _data :: JobMessageData, + _jobType :: JobType + } + deriving (Show) -data JobMessageData = JobOutput Text JobOutputType - | JobExit ExitCode - deriving (Show) +data JobMessageData + = JobOutput Text JobOutputType + | JobExit ExitCode + deriving (Show) data JobOutputType = Stdout | Stderr deriving (Show, Eq) diff --git a/waspc/src/Generator/Job/IO.hs b/waspc/src/Generator/Job/IO.hs index 185724148..783f71ea6 100644 --- a/waspc/src/Generator/Job/IO.hs +++ b/waspc/src/Generator/Job/IO.hs @@ -1,67 +1,67 @@ module Generator.Job.IO - ( readJobMessagesAndPrintThemPrefixed - , printPrefixedJobMessage - , printJobMessage - ) where + ( readJobMessagesAndPrintThemPrefixed, + printPrefixedJobMessage, + printJobMessage, + ) +where -import Control.Concurrent (Chan, readChan) -import qualified Data.Text as T -import qualified Data.Text.IO as T.IO -import System.Exit (ExitCode (..)) -import System.IO (Handle, hFlush, stderr, stdout) - -import qualified Generator.Job as J -import qualified Util.Terminal as Term +import Control.Concurrent (Chan, readChan) +import qualified Data.Text as T +import qualified Data.Text.IO as T.IO +import qualified Generator.Job as J +import System.Exit (ExitCode (..)) +import System.IO (Handle, hFlush, stderr, stdout) +import qualified Util.Terminal as Term readJobMessagesAndPrintThemPrefixed :: Chan J.JobMessage -> IO () readJobMessagesAndPrintThemPrefixed = - let go prevJobMsg chan = do - jobMsg <- readChan chan - case J._data jobMsg of - J.JobOutput {} -> printPrefixedJobMessage prevJobMsg jobMsg >> go (Just jobMsg) chan - J.JobExit {} -> return () - in go Nothing + let go prevJobMsg chan = do + jobMsg <- readChan chan + case J._data jobMsg of + J.JobOutput {} -> printPrefixedJobMessage prevJobMsg jobMsg >> go (Just jobMsg) chan + J.JobExit {} -> return () + in go Nothing printPrefixedJobMessage :: Maybe J.JobMessage -> J.JobMessage -> IO () printPrefixedJobMessage maybePrevJobMessage jobMessage = do - let outHandle = getJobMessageOutHandle jobMessage - prefix = makeJobMessagePrefix jobMessage - content = getJobMessageContent jobMessage + let outHandle = getJobMessageOutHandle jobMessage + prefix = makeJobMessagePrefix jobMessage + content = getJobMessageContent jobMessage - let maybeAddPrefixAtStart = - ((if (J._jobType <$> maybePrevJobMessage) /= Just (J._jobType jobMessage) then "\n" <> prefix else "") <>) - addPrefixAfterSubstr substr = T.intercalate (substr <> prefix) . T.splitOn substr - addPrefix = maybeAddPrefixAtStart . addPrefixAfterSubstr "\n" . addPrefixAfterSubstr "\r" + let maybeAddPrefixAtStart = + ((if (J._jobType <$> maybePrevJobMessage) /= Just (J._jobType jobMessage) then "\n" <> prefix else "") <>) + addPrefixAfterSubstr substr = T.intercalate (substr <> prefix) . T.splitOn substr + addPrefix = maybeAddPrefixAtStart . addPrefixAfterSubstr "\n" . addPrefixAfterSubstr "\r" - T.IO.hPutStr outHandle $ addPrefix content - hFlush outHandle + T.IO.hPutStr outHandle $ addPrefix content + hFlush outHandle printJobMessage :: J.JobMessage -> IO () printJobMessage jobMsg = do - let outHandle = getJobMessageOutHandle jobMsg - let message = getJobMessageContent jobMsg - T.IO.hPutStr outHandle message - hFlush outHandle + let outHandle = getJobMessageOutHandle jobMsg + let message = getJobMessageContent jobMsg + T.IO.hPutStr outHandle message + hFlush outHandle makeJobMessagePrefix :: J.JobMessage -> T.Text makeJobMessagePrefix jobMsg = - case J._jobType jobMsg of - J.Server -> T.pack $ Term.applyStyles [Term.Magenta] "Server" - J.WebApp -> T.pack $ Term.applyStyles [Term.Cyan] "Web app" - J.Db -> T.pack $ Term.applyStyles [Term.White] "Db" + case J._jobType jobMsg of + J.Server -> T.pack $ Term.applyStyles [Term.Magenta] "Server" + J.WebApp -> T.pack $ Term.applyStyles [Term.Cyan] "Web app" + J.Db -> T.pack $ Term.applyStyles [Term.White] "Db" <> (if getJobMessageOutHandle jobMsg == stderr then " (stderr)" else "") <> ": " getJobMessageOutHandle :: J.JobMessage -> Handle getJobMessageOutHandle jobMsg = case J._data jobMsg of - J.JobOutput _ outputType -> - case outputType of - J.Stdout -> stdout - J.Stderr -> stderr - J.JobExit _ -> stdout + J.JobOutput _ outputType -> + case outputType of + J.Stdout -> stdout + J.Stderr -> stderr + J.JobExit _ -> stdout getJobMessageContent :: J.JobMessage -> T.Text getJobMessageContent jobMsg = case J._data jobMsg of - J.JobOutput output _ -> output - J.JobExit ExitSuccess -> "Job exited successfully." - J.JobExit (ExitFailure exitCode) -> T.pack $ "Job failed with exit code " <> show exitCode + J.JobOutput output _ -> output + J.JobExit ExitSuccess -> "Job exited successfully." + J.JobExit (ExitFailure exitCode) -> T.pack $ "Job failed with exit code " <> show exitCode diff --git a/waspc/src/Generator/Job/Process.hs b/waspc/src/Generator/Job/Process.hs index dcb1e3c41..e23bcd245 100644 --- a/waspc/src/Generator/Job/Process.hs +++ b/waspc/src/Generator/Job/Process.hs @@ -1,28 +1,28 @@ {-# LANGUAGE ScopedTypeVariables #-} module Generator.Job.Process - ( runProcessAsJob - , runNodeCommandAsJob - ) where + ( runProcessAsJob, + runNodeCommandAsJob, + ) +where -import Control.Concurrent (writeChan) -import Control.Concurrent.Async (Concurrently (..)) -import UnliftIO.Exception (bracket) -import Data.Conduit (runConduit, (.|)) -import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Process as CP -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import System.Exit (ExitCode (..)) -import System.IO.Error (catchIOError, isDoesNotExistError) -import qualified System.Process as P -import Text.Read (readMaybe) -import qualified Text.Regex.TDFA as R - -import qualified Generator.Common as C -import qualified Generator.Job as J -import StrongPath (Abs, Dir, Path) -import qualified StrongPath as SP +import Control.Concurrent (writeChan) +import Control.Concurrent.Async (Concurrently (..)) +import Data.Conduit (runConduit, (.|)) +import qualified Data.Conduit.List as CL +import qualified Data.Conduit.Process as CP +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import qualified Generator.Common as C +import qualified Generator.Job as J +import StrongPath (Abs, Dir, Path) +import qualified StrongPath as SP +import System.Exit (ExitCode (..)) +import System.IO.Error (catchIOError, isDoesNotExistError) +import qualified System.Process as P +import Text.Read (readMaybe) +import qualified Text.Regex.TDFA as R +import UnliftIO.Exception (bracket) -- TODO: -- Switch from Data.Conduit.Process to Data.Conduit.Process.Typed. @@ -32,78 +32,118 @@ import qualified StrongPath as SP -- Returns exit code of the process once it finishes, and also sends it to the channel. -- Makes sure to terminate the process if exception occurs. runProcessAsJob :: P.CreateProcess -> J.JobType -> J.Job -runProcessAsJob process jobType chan = bracket +runProcessAsJob process jobType chan = + bracket (CP.streamingProcess process) (\(_, _, _, sph) -> terminateStreamingProcess sph) runStreamingProcessAsJob where runStreamingProcessAsJob (CP.Inherited, stdoutStream, stderrStream, processHandle) = do - let forwardStdoutToChan = runConduit $ stdoutStream .| CL.mapM_ - (\bs -> writeChan chan $ J.JobMessage { J._data = J.JobOutput (decodeUtf8 bs) J.Stdout - , J._jobType = jobType }) + let forwardStdoutToChan = + runConduit $ + stdoutStream + .| CL.mapM_ + ( \bs -> + writeChan chan $ + J.JobMessage + { J._data = J.JobOutput (decodeUtf8 bs) J.Stdout, + J._jobType = jobType + } + ) - let forwardStderrToChan = runConduit $ stderrStream .| CL.mapM_ - (\bs -> writeChan chan $ J.JobMessage { J._data = J.JobOutput (decodeUtf8 bs) J.Stderr - , J._jobType = jobType }) + let forwardStderrToChan = + runConduit $ + stderrStream + .| CL.mapM_ + ( \bs -> + writeChan chan $ + J.JobMessage + { J._data = J.JobOutput (decodeUtf8 bs) J.Stderr, + J._jobType = jobType + } + ) - exitCode <- runConcurrently $ - Concurrently forwardStdoutToChan *> - Concurrently forwardStderrToChan *> - Concurrently (CP.waitForStreamingProcess processHandle) + exitCode <- + runConcurrently $ + Concurrently forwardStdoutToChan + *> Concurrently forwardStderrToChan + *> Concurrently (CP.waitForStreamingProcess processHandle) - writeChan chan $ J.JobMessage { J._data = J.JobExit exitCode - , J._jobType = jobType } + writeChan chan $ + J.JobMessage + { J._data = J.JobExit exitCode, + J._jobType = jobType + } return exitCode terminateStreamingProcess streamingProcessHandle = do - let processHandle = CP.streamingProcessHandleRaw streamingProcessHandle - P.terminateProcess processHandle - return $ ExitFailure 1 + let processHandle = CP.streamingProcessHandleRaw streamingProcessHandle + P.terminateProcess processHandle + return $ ExitFailure 1 runNodeCommandAsJob :: Path Abs (Dir a) -> String -> [String] -> J.JobType -> J.Job runNodeCommandAsJob fromDir command args jobType chan = do - errorOrNodeVersion <- getNodeVersion - case errorOrNodeVersion of - Left errorMsg -> exitWithError (ExitFailure 1) (T.pack errorMsg) - Right nodeVersion -> if nodeVersion < C.nodeVersion - then exitWithError (ExitFailure 1) - (T.pack $ "Your node version is too low. " ++ waspNodeRequirementMessage) - else do - let process = (P.proc command args) { P.cwd = Just $ SP.toFilePath fromDir } - runProcessAsJob process jobType chan + errorOrNodeVersion <- getNodeVersion + case errorOrNodeVersion of + Left errorMsg -> exitWithError (ExitFailure 1) (T.pack errorMsg) + Right nodeVersion -> + if nodeVersion < C.nodeVersion + then + exitWithError + (ExitFailure 1) + (T.pack $ "Your node version is too low. " ++ waspNodeRequirementMessage) + else do + let process = (P.proc command args) {P.cwd = Just $ SP.toFilePath fromDir} + runProcessAsJob process jobType chan where - exitWithError exitCode errorMsg = do - writeChan chan $ J.JobMessage - { J._data = J.JobOutput errorMsg J.Stderr - , J._jobType = jobType } - writeChan chan $ J.JobMessage { J._data = J.JobExit exitCode - , J._jobType = jobType } - return exitCode + exitWithError exitCode errorMsg = do + writeChan chan $ + J.JobMessage + { J._data = J.JobOutput errorMsg J.Stderr, + J._jobType = jobType + } + writeChan chan $ + J.JobMessage + { J._data = J.JobExit exitCode, + J._jobType = jobType + } + return exitCode - getNodeVersion :: IO (Either String (Int, Int, Int)) - getNodeVersion = do - (exitCode, stdout, stderr) <- P.readProcessWithExitCode "node" ["--version"] "" - `catchIOError` (\e -> if isDoesNotExistError e - then return (ExitFailure 1, "", "Command 'node' not found.") - else ioError e) - return $ case exitCode of - ExitFailure _ -> Left ("Running 'node --version' failed: " ++ stderr - ++ " " ++ waspNodeRequirementMessage) - ExitSuccess -> case parseNodeVersion stdout of - Nothing -> Left ("Wasp failed to parse node version." - ++ " This is most likely a bug in Wasp, please file an issue.") - Just version -> Right version + getNodeVersion :: IO (Either String (Int, Int, Int)) + getNodeVersion = do + (exitCode, stdout, stderr) <- + P.readProcessWithExitCode "node" ["--version"] "" + `catchIOError` ( \e -> + if isDoesNotExistError e + then return (ExitFailure 1, "", "Command 'node' not found.") + else ioError e + ) + return $ case exitCode of + ExitFailure _ -> + Left + ( "Running 'node --version' failed: " ++ stderr + ++ " " + ++ waspNodeRequirementMessage + ) + ExitSuccess -> case parseNodeVersion stdout of + Nothing -> + Left + ( "Wasp failed to parse node version." + ++ " This is most likely a bug in Wasp, please file an issue." + ) + Just version -> Right version - parseNodeVersion :: String -> Maybe (Int, Int, Int) - parseNodeVersion nodeVersionStr = - case nodeVersionStr R.=~ ("v([^\\.]+).([^\\.]+).(.+)" :: String) of - ((_ , _, _, [majorStr, minorStr, patchStr]) :: (String, String, String, [String])) -> do - major <- readMaybe majorStr - minor <- readMaybe minorStr - patch <- readMaybe patchStr - return (major, minor, patch) - _ -> Nothing + parseNodeVersion :: String -> Maybe (Int, Int, Int) + parseNodeVersion nodeVersionStr = + case nodeVersionStr R.=~ ("v([^\\.]+).([^\\.]+).(.+)" :: String) of + ((_, _, _, [majorStr, minorStr, patchStr]) :: (String, String, String, [String])) -> do + major <- readMaybe majorStr + minor <- readMaybe minorStr + patch <- readMaybe patchStr + return (major, minor, patch) + _ -> Nothing - waspNodeRequirementMessage = "Wasp requires node >= " ++ C.nodeVersionAsText ++ " ." - ++ " Check Wasp docs for more details: https://wasp-lang.dev/docs#requirements ." + waspNodeRequirementMessage = + "Wasp requires node >= " ++ C.nodeVersionAsText ++ " ." + ++ " Check Wasp docs for more details: https://wasp-lang.dev/docs#requirements ." diff --git a/waspc/src/Generator/PackageJsonGenerator.hs b/waspc/src/Generator/PackageJsonGenerator.hs index b54f1f526..b189ed114 100644 --- a/waspc/src/Generator/PackageJsonGenerator.hs +++ b/waspc/src/Generator/PackageJsonGenerator.hs @@ -1,14 +1,13 @@ module Generator.PackageJsonGenerator - ( resolveNpmDeps - , toPackageJsonDependenciesString - ) where - -import Data.List (find, intercalate) -import Data.Maybe (fromJust, isJust) + ( resolveNpmDeps, + toPackageJsonDependenciesString, + ) +where +import Data.List (find, intercalate) +import Data.Maybe (fromJust, isJust) import qualified NpmDependency as ND - type NpmDependenciesConflictError = String -- | Takes wasp npm dependencies and user npm dependencies and figures out how to @@ -18,41 +17,49 @@ type NpmDependenciesConflictError = String -- be different. -- On error (Left), returns list of conflicting user deps together with the error message -- explaining what the error is. -resolveNpmDeps - :: [ND.NpmDependency] - -> [ND.NpmDependency] - -> Either [(ND.NpmDependency, NpmDependenciesConflictError)] - ([ND.NpmDependency], [ND.NpmDependency]) -resolveNpmDeps waspDeps userDeps = if null conflictingUserDeps +resolveNpmDeps :: + [ND.NpmDependency] -> + [ND.NpmDependency] -> + Either + [(ND.NpmDependency, NpmDependenciesConflictError)] + ([ND.NpmDependency], [ND.NpmDependency]) +resolveNpmDeps waspDeps userDeps = + if null conflictingUserDeps then Right (waspDeps, userDepsNotInWaspDeps) else Left conflictingUserDeps where conflictingUserDeps :: [(ND.NpmDependency, NpmDependenciesConflictError)] - conflictingUserDeps = map (\(dep, err) -> (dep, fromJust err)) - $ filter (isJust . snd) - $ map (\dep -> (dep, checkIfConflictingUserDep dep)) userDeps + conflictingUserDeps = + map (\(dep, err) -> (dep, fromJust err)) $ + filter (isJust . snd) $ + map (\dep -> (dep, checkIfConflictingUserDep dep)) userDeps checkIfConflictingUserDep :: ND.NpmDependency -> Maybe NpmDependenciesConflictError checkIfConflictingUserDep userDep = - let attachErrorMessage dep = "Error: Dependency conflict for user npm dependency (" - ++ ND._name dep ++ ", " ++ ND._version dep ++ "): " - ++ "Version must be set to the exactly the same version as" - ++ " the one wasp is using: " - ++ ND._version dep - in attachErrorMessage <$> find (areTwoDepsInConflict userDep) waspDeps + let attachErrorMessage dep = + "Error: Dependency conflict for user npm dependency (" + ++ ND._name dep + ++ ", " + ++ ND._version dep + ++ "): " + ++ "Version must be set to the exactly the same version as" + ++ " the one wasp is using: " + ++ ND._version dep + in attachErrorMessage <$> find (areTwoDepsInConflict userDep) waspDeps areTwoDepsInConflict :: ND.NpmDependency -> ND.NpmDependency -> Bool - areTwoDepsInConflict d1 d2 = ND._name d1 == ND._name d2 - && ND._version d1 /= ND._version d2 + areTwoDepsInConflict d1 d2 = + ND._name d1 == ND._name d2 + && ND._version d1 /= ND._version d2 userDepsNotInWaspDeps :: [ND.NpmDependency] userDepsNotInWaspDeps = filter (not . isDepWithNameInWaspDeps . ND._name) userDeps isDepWithNameInWaspDeps :: String -> Bool - isDepWithNameInWaspDeps name = any ((name ==). ND._name) waspDeps + isDepWithNameInWaspDeps name = any ((name ==) . ND._name) waspDeps toPackageJsonDependenciesString :: [ND.NpmDependency] -> String toPackageJsonDependenciesString deps = - "\"dependencies\": {" + "\"dependencies\": {" ++ intercalate ",\n " (map (\dep -> "\"" ++ ND._name dep ++ "\": \"" ++ ND._version dep ++ "\"") deps) ++ "\n}" diff --git a/waspc/src/Generator/ServerGenerator.hs b/waspc/src/Generator/ServerGenerator.hs index 6c6246a83..a3730c6ea 100644 --- a/waspc/src/Generator/ServerGenerator.hs +++ b/waspc/src/Generator/ServerGenerator.hs @@ -1,52 +1,58 @@ module Generator.ServerGenerator - ( genServer - , preCleanup - , operationsRouteInRootRouter - ) where + ( genServer, + preCleanup, + operationsRouteInRootRouter, + ) +where -import Data.Aeson (object, (.=)) -import Data.List (intercalate) -import Data.Maybe (fromJust, - isJust) -import qualified Path as P -import StrongPath ((), Path, Rel, File, Abs, Dir) -import qualified StrongPath as SP -import System.Directory (removeFile) -import UnliftIO.Exception (catch, throwIO) -import System.IO.Error (isDoesNotExistError) -import Control.Monad (when) - -import CompileOptions (CompileOptions) -import Generator.Common (nodeVersionAsText, ProjectRootDir) -import Generator.ExternalCodeGenerator (generateExternalCodeDir) -import Generator.FileDraft (FileDraft, createCopyFileDraft) -import Generator.PackageJsonGenerator (resolveNpmDeps, - toPackageJsonDependenciesString) -import Generator.ServerGenerator.AuthG (genAuth) -import Generator.ServerGenerator.Common (asServerFile, - asTmplFile) -import qualified Generator.ServerGenerator.Common as C -import Generator.ServerGenerator.ConfigG (genConfigFile) +import CompileOptions (CompileOptions) +import Control.Monad (when) +import Data.Aeson (object, (.=)) +import Data.List (intercalate) +import Data.Maybe + ( fromJust, + isJust, + ) +import Generator.Common (ProjectRootDir, nodeVersionAsText) +import Generator.ExternalCodeGenerator (generateExternalCodeDir) +import Generator.FileDraft (FileDraft, createCopyFileDraft) +import Generator.PackageJsonGenerator + ( resolveNpmDeps, + toPackageJsonDependenciesString, + ) +import Generator.ServerGenerator.AuthG (genAuth) +import Generator.ServerGenerator.Common + ( asServerFile, + asTmplFile, + ) +import qualified Generator.ServerGenerator.Common as C +import Generator.ServerGenerator.ConfigG (genConfigFile) import qualified Generator.ServerGenerator.ExternalCodeGenerator as ServerExternalCodeGenerator -import Generator.ServerGenerator.OperationsG (genOperations) -import Generator.ServerGenerator.OperationsRoutesG (genOperationsRoutes) -import qualified NpmDependency as ND -import Wasp (Wasp, getAuth) +import Generator.ServerGenerator.OperationsG (genOperations) +import Generator.ServerGenerator.OperationsRoutesG (genOperationsRoutes) +import qualified NpmDependency as ND +import qualified Path as P +import StrongPath (Abs, Dir, File, Path, Rel, ()) +import qualified StrongPath as SP +import System.Directory (removeFile) +import System.IO.Error (isDoesNotExistError) +import UnliftIO.Exception (catch, throwIO) +import Wasp (Wasp, getAuth) import qualified Wasp import qualified Wasp.Auth -import qualified Wasp.NpmDependencies as WND - +import qualified Wasp.NpmDependencies as WND genServer :: Wasp -> CompileOptions -> [FileDraft] -genServer wasp _ = concat - [ [genReadme wasp] - , [genPackageJson wasp waspNpmDeps] - , [genNpmrc wasp] - , [genNvmrc wasp] - , [genGitignore wasp] - , genSrcDir wasp - , generateExternalCodeDir ServerExternalCodeGenerator.generatorStrategy wasp - , genDotEnv wasp +genServer wasp _ = + concat + [ [genReadme wasp], + [genPackageJson wasp waspNpmDeps], + [genNpmrc wasp], + [genNvmrc wasp], + [genGitignore wasp], + genSrcDir wasp, + generateExternalCodeDir ServerExternalCodeGenerator.generatorStrategy wasp, + genDotEnv wasp ] -- Cleanup to be performed before generating new server code. @@ -56,22 +62,22 @@ genServer wasp _ = concat -- for progress of this. preCleanup :: Wasp -> Path Abs (Dir ProjectRootDir) -> CompileOptions -> IO () preCleanup _ outDir _ = do - -- If .env gets removed but there is old .env file in generated project from previous attempts, - -- we need to make sure we remove it. - removeFile dotEnvAbsFilePath - `catch` \e -> when (not $ isDoesNotExistError e) $ throwIO e + -- If .env gets removed but there is old .env file in generated project from previous attempts, + -- we need to make sure we remove it. + removeFile dotEnvAbsFilePath + `catch` \e -> when (not $ isDoesNotExistError e) $ throwIO e where - dotEnvAbsFilePath = SP.toFilePath $ outDir C.serverRootDirInProjectRootDir dotEnvInServerRootDir + dotEnvAbsFilePath = SP.toFilePath $ outDir C.serverRootDirInProjectRootDir dotEnvInServerRootDir genDotEnv :: Wasp -> [FileDraft] genDotEnv wasp = - case Wasp.getDotEnvFile wasp of - Just srcFilePath -> - [ createCopyFileDraft - (C.serverRootDirInProjectRootDir dotEnvInServerRootDir) - srcFilePath - ] - Nothing -> [] + case Wasp.getDotEnvFile wasp of + Just srcFilePath -> + [ createCopyFileDraft + (C.serverRootDirInProjectRootDir dotEnvInServerRootDir) + srcFilePath + ] + Nothing -> [] dotEnvInServerRootDir :: Path (Rel C.ServerRootDir) File dotEnvInServerRootDir = asServerFile [P.relfile|.env|] @@ -80,101 +86,115 @@ genReadme :: Wasp -> FileDraft genReadme _ = C.copyTmplAsIs (asTmplFile [P.relfile|README.md|]) genPackageJson :: Wasp -> [ND.NpmDependency] -> FileDraft -genPackageJson wasp waspDeps = C.makeTemplateFD +genPackageJson wasp waspDeps = + C.makeTemplateFD (asTmplFile [P.relfile|package.json|]) (asServerFile [P.relfile|package.json|]) - (Just $ object - [ "wasp" .= wasp - , "depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps) - , "nodeVersion" .= nodeVersionAsText - , "startProductionScript" .= concat - [ if not (null $ Wasp.getPSLEntities wasp) then "npm run db-migrate-prod && " else "" - , "NODE_ENV=production node ./src/server.js" - ] - ]) + ( Just $ + object + [ "wasp" .= wasp, + "depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps), + "nodeVersion" .= nodeVersionAsText, + "startProductionScript" + .= concat + [ if not (null $ Wasp.getPSLEntities wasp) then "npm run db-migrate-prod && " else "", + "NODE_ENV=production node ./src/server.js" + ] + ] + ) where (resolvedWaspDeps, resolvedUserDeps) = - case resolveNpmDeps waspDeps userDeps of - Right deps -> deps - Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors + case resolveNpmDeps waspDeps userDeps of + Right deps -> deps + Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors userDeps :: [ND.NpmDependency] userDeps = WND._dependencies $ Wasp.getNpmDependencies wasp waspNpmDeps :: [ND.NpmDependency] -waspNpmDeps = ND.fromList - [ ("cookie-parser", "~1.4.4") - , ("cors", "^2.8.5") - , ("debug", "~2.6.9") - , ("express", "~4.16.1") - , ("morgan", "~1.9.1") - , ("@prisma/client", "2.21.0") - , ("jsonwebtoken", "^8.5.1") - , ("secure-password", "^4.0.0") - , ("dotenv", "8.2.0") +waspNpmDeps = + ND.fromList + [ ("cookie-parser", "~1.4.4"), + ("cors", "^2.8.5"), + ("debug", "~2.6.9"), + ("express", "~4.16.1"), + ("morgan", "~1.9.1"), + ("@prisma/client", "2.21.0"), + ("jsonwebtoken", "^8.5.1"), + ("secure-password", "^4.0.0"), + ("dotenv", "8.2.0") ] -- TODO: Also extract devDependencies like we did dependencies (waspNpmDeps). genNpmrc :: Wasp -> FileDraft -genNpmrc _ = C.makeTemplateFD (asTmplFile [P.relfile|npmrc|]) - (asServerFile [P.relfile|.npmrc|]) - Nothing +genNpmrc _ = + C.makeTemplateFD + (asTmplFile [P.relfile|npmrc|]) + (asServerFile [P.relfile|.npmrc|]) + Nothing genNvmrc :: Wasp -> FileDraft -genNvmrc _ = C.makeTemplateFD (asTmplFile [P.relfile|nvmrc|]) - (asServerFile [P.relfile|.nvmrc|]) - (Just (object ["nodeVersion" .= ('v' : nodeVersionAsText)])) +genNvmrc _ = + C.makeTemplateFD + (asTmplFile [P.relfile|nvmrc|]) + (asServerFile [P.relfile|.nvmrc|]) + (Just (object ["nodeVersion" .= ('v' : nodeVersionAsText)])) genGitignore :: Wasp -> FileDraft -genGitignore _ = C.makeTemplateFD (asTmplFile [P.relfile|gitignore|]) - (asServerFile [P.relfile|.gitignore|]) - Nothing +genGitignore _ = + C.makeTemplateFD + (asTmplFile [P.relfile|gitignore|]) + (asServerFile [P.relfile|.gitignore|]) + Nothing genSrcDir :: Wasp -> [FileDraft] -genSrcDir wasp = concat - [ [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|app.js|]] - , [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|server.js|]] - , [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|utils.js|]] - , [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|core/HttpError.js|]] - , [genDbClient wasp] - , [genConfigFile wasp] - , genRoutesDir wasp - , genOperationsRoutes wasp - , genOperations wasp - , genAuth wasp +genSrcDir wasp = + concat + [ [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|app.js|]], + [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|server.js|]], + [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|utils.js|]], + [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|core/HttpError.js|]], + [genDbClient wasp], + [genConfigFile wasp], + genRoutesDir wasp, + genOperationsRoutes wasp, + genOperations wasp, + genAuth wasp ] genDbClient :: Wasp -> FileDraft genDbClient wasp = C.makeTemplateFD tmplFile dstFile (Just tmplData) - where - maybeAuth = getAuth wasp + where + maybeAuth = getAuth wasp - dbClientRelToSrcP = [P.relfile|dbClient.js|] - tmplFile = C.asTmplFile $ [P.reldir|src|] P. dbClientRelToSrcP - dstFile = C.serverSrcDirInServerRootDir C.asServerSrcFile dbClientRelToSrcP + dbClientRelToSrcP = [P.relfile|dbClient.js|] + tmplFile = C.asTmplFile $ [P.reldir|src|] P. dbClientRelToSrcP + dstFile = C.serverSrcDirInServerRootDir C.asServerSrcFile dbClientRelToSrcP - tmplData = - if isJust maybeAuth - then object - [ "isAuthEnabled" .= True - , "userEntityUpper" .= Wasp.Auth._userEntity (fromJust maybeAuth) - ] - else object [] + tmplData = + if isJust maybeAuth + then + object + [ "isAuthEnabled" .= True, + "userEntityUpper" .= Wasp.Auth._userEntity (fromJust maybeAuth) + ] + else object [] genRoutesDir :: Wasp -> [FileDraft] genRoutesDir wasp = - -- TODO(martin): We will probably want to extract "routes" path here same as we did with "src", to avoid hardcoding, - -- but I did not bother with it yet since it is used only here for now. - [ C.makeTemplateFD - (asTmplFile [P.relfile|src/routes/index.js|]) - (asServerFile [P.relfile|src/routes/index.js|]) - (Just $ object - [ "operationsRouteInRootRouter" .= operationsRouteInRootRouter - , "isAuthEnabled" .= isJust (getAuth wasp) + -- TODO(martin): We will probably want to extract "routes" path here same as we did with "src", to avoid hardcoding, + -- but I did not bother with it yet since it is used only here for now. + [ C.makeTemplateFD + (asTmplFile [P.relfile|src/routes/index.js|]) + (asServerFile [P.relfile|src/routes/index.js|]) + ( Just $ + object + [ "operationsRouteInRootRouter" .= operationsRouteInRootRouter, + "isAuthEnabled" .= isJust (getAuth wasp) ] - ) - ] + ) + ] operationsRouteInRootRouter :: String operationsRouteInRootRouter = "operations" diff --git a/waspc/src/Generator/ServerGenerator/AuthG.hs b/waspc/src/Generator/ServerGenerator/AuthG.hs index 07b78f6b5..3b54b3332 100644 --- a/waspc/src/Generator/ServerGenerator/AuthG.hs +++ b/waspc/src/Generator/ServerGenerator/AuthG.hs @@ -1,41 +1,44 @@ module Generator.ServerGenerator.AuthG - ( genAuth - ) where + ( genAuth, + ) +where +import Data.Aeson (object, (.=)) +import Generator.FileDraft (FileDraft) +import qualified Generator.ServerGenerator.Common as C import qualified Path as P -import Data.Aeson (object, (.=)) - +import StrongPath (()) import qualified Util import Wasp (Wasp, getAuth) import qualified Wasp.Auth -import Generator.FileDraft (FileDraft) -import qualified Generator.ServerGenerator.Common as C -import StrongPath (()) genAuth :: Wasp -> [FileDraft] genAuth wasp = case maybeAuth of - Just auth -> [ genCoreAuth auth - -- Auth routes - , genAuthRoutesIndex - , genLoginRoute auth - , genSignupRoute auth - , genMeRoute auth - ] - Nothing -> [] - where - maybeAuth = getAuth wasp + Just auth -> + [ genCoreAuth auth, + -- Auth routes + genAuthRoutesIndex, + genLoginRoute auth, + genSignupRoute auth, + genMeRoute auth + ] + Nothing -> [] + where + maybeAuth = getAuth wasp -- | Generates core/auth file which contains auth middleware and createUser() function. genCoreAuth :: Wasp.Auth.Auth -> FileDraft genCoreAuth auth = C.makeTemplateFD tmplFile dstFile (Just tmplData) - where - coreAuthRelToSrc = [P.relfile|core/auth.js|] - tmplFile = C.asTmplFile $ [P.reldir|src|] P. coreAuthRelToSrc - dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile coreAuthRelToSrc) + where + coreAuthRelToSrc = [P.relfile|core/auth.js|] + tmplFile = C.asTmplFile $ [P.reldir|src|] P. coreAuthRelToSrc + dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile coreAuthRelToSrc) - tmplData = let userEntity = (Wasp.Auth._userEntity auth) in object - [ "userEntityUpper" .= userEntity - , "userEntityLower" .= Util.toLowerFirst userEntity + tmplData = + let userEntity = (Wasp.Auth._userEntity auth) + in object + [ "userEntityUpper" .= userEntity, + "userEntityLower" .= Util.toLowerFirst userEntity ] genAuthRoutesIndex :: FileDraft @@ -43,34 +46,38 @@ genAuthRoutesIndex = C.copySrcTmplAsIs (C.asTmplSrcFile [P.relfile|routes/auth/i genLoginRoute :: Wasp.Auth.Auth -> FileDraft genLoginRoute auth = C.makeTemplateFD tmplFile dstFile (Just tmplData) - where - loginRouteRelToSrc = [P.relfile|routes/auth/login.js|] - tmplFile = C.asTmplFile $ [P.reldir|src|] P. loginRouteRelToSrc - dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile loginRouteRelToSrc) + where + loginRouteRelToSrc = [P.relfile|routes/auth/login.js|] + tmplFile = C.asTmplFile $ [P.reldir|src|] P. loginRouteRelToSrc + dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile loginRouteRelToSrc) - tmplData = let userEntity = (Wasp.Auth._userEntity auth) in object - [ "userEntityUpper" .= userEntity - , "userEntityLower" .= Util.toLowerFirst userEntity + tmplData = + let userEntity = (Wasp.Auth._userEntity auth) + in object + [ "userEntityUpper" .= userEntity, + "userEntityLower" .= Util.toLowerFirst userEntity ] genSignupRoute :: Wasp.Auth.Auth -> FileDraft genSignupRoute auth = C.makeTemplateFD tmplFile dstFile (Just tmplData) - where - signupRouteRelToSrc = [P.relfile|routes/auth/signup.js|] - tmplFile = C.asTmplFile $ [P.reldir|src|] P. signupRouteRelToSrc - dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile signupRouteRelToSrc) + where + signupRouteRelToSrc = [P.relfile|routes/auth/signup.js|] + tmplFile = C.asTmplFile $ [P.reldir|src|] P. signupRouteRelToSrc + dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile signupRouteRelToSrc) - tmplData = object - [ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth) - ] + tmplData = + object + [ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth) + ] genMeRoute :: Wasp.Auth.Auth -> FileDraft genMeRoute auth = C.makeTemplateFD tmplFile dstFile (Just tmplData) - where - meRouteRelToSrc = [P.relfile|routes/auth/me.js|] - tmplFile = C.asTmplFile $ [P.reldir|src|] P. meRouteRelToSrc - dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile meRouteRelToSrc) + where + meRouteRelToSrc = [P.relfile|routes/auth/me.js|] + tmplFile = C.asTmplFile $ [P.reldir|src|] P. meRouteRelToSrc + dstFile = C.serverSrcDirInServerRootDir (C.asServerSrcFile meRouteRelToSrc) - tmplData = object - [ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth) - ] + tmplData = + object + [ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth) + ] diff --git a/waspc/src/Generator/ServerGenerator/Common.hs b/waspc/src/Generator/ServerGenerator/Common.hs index a1b7763fb..0970ceaf0 100644 --- a/waspc/src/Generator/ServerGenerator/Common.hs +++ b/waspc/src/Generator/ServerGenerator/Common.hs @@ -1,38 +1,39 @@ module Generator.ServerGenerator.Common - ( serverRootDirInProjectRootDir - , serverSrcDirInServerRootDir - , serverSrcDirInProjectRootDir - , copyTmplAsIs - , makeSimpleTemplateFD - , makeTemplateFD - , copySrcTmplAsIs - , srcDirInServerTemplatesDir - , asTmplFile - , asTmplSrcFile - , asServerFile - , asServerSrcFile - , ServerRootDir - , ServerSrcDir - , ServerTemplatesDir - , ServerTemplatesSrcDir - ) where + ( serverRootDirInProjectRootDir, + serverSrcDirInServerRootDir, + serverSrcDirInProjectRootDir, + copyTmplAsIs, + makeSimpleTemplateFD, + makeTemplateFD, + copySrcTmplAsIs, + srcDirInServerTemplatesDir, + asTmplFile, + asTmplSrcFile, + asServerFile, + asServerSrcFile, + ServerRootDir, + ServerSrcDir, + ServerTemplatesDir, + ServerTemplatesSrcDir, + ) +where import qualified Data.Aeson as Aeson +import Generator.Common (ProjectRootDir) +import Generator.FileDraft (FileDraft, createTemplateFileDraft) +import Generator.Templates (TemplatesDir) import qualified Path as P - -import StrongPath (Path, Rel, File, Dir, ()) +import StrongPath (Dir, File, Path, Rel, ()) import qualified StrongPath as SP import Wasp (Wasp) -import Generator.FileDraft (FileDraft, createTemplateFileDraft) -import Generator.Common (ProjectRootDir) -import Generator.Templates (TemplatesDir) - data ServerRootDir -data ServerSrcDir -data ServerTemplatesDir -data ServerTemplatesSrcDir +data ServerSrcDir + +data ServerTemplatesDir + +data ServerTemplatesSrcDir asTmplFile :: P.Path P.Rel P.File -> Path (Rel ServerTemplatesDir) File asTmplFile = SP.fromPathRelFile @@ -59,32 +60,36 @@ serverSrcDirInServerRootDir = SP.fromPathRelDir [P.reldir|src|] serverSrcDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir ServerSrcDir) serverSrcDirInProjectRootDir = serverRootDirInProjectRootDir serverSrcDirInServerRootDir - -- * Templates copyTmplAsIs :: Path (Rel ServerTemplatesDir) File -> FileDraft copyTmplAsIs srcPath = makeTemplateFD srcPath dstPath Nothing - where dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File + where + dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File makeSimpleTemplateFD :: Path (Rel ServerTemplatesDir) File -> Wasp -> FileDraft makeSimpleTemplateFD srcPath wasp = makeTemplateFD srcPath dstPath (Just $ Aeson.toJSON wasp) - where dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File + where + dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File -makeTemplateFD :: Path (Rel ServerTemplatesDir) File - -> Path (Rel ServerRootDir) File - -> Maybe Aeson.Value - -> FileDraft +makeTemplateFD :: + Path (Rel ServerTemplatesDir) File -> + Path (Rel ServerRootDir) File -> + Maybe Aeson.Value -> + FileDraft makeTemplateFD relSrcPath relDstPath tmplData = - createTemplateFileDraft - (serverRootDirInProjectRootDir relDstPath) - (serverTemplatesDirInTemplatesDir relSrcPath) - tmplData + createTemplateFileDraft + (serverRootDirInProjectRootDir relDstPath) + (serverTemplatesDirInTemplatesDir relSrcPath) + tmplData copySrcTmplAsIs :: Path (Rel ServerTemplatesSrcDir) File -> FileDraft copySrcTmplAsIs pathInTemplatesSrcDir = makeTemplateFD srcPath dstPath Nothing - where srcPath = srcDirInServerTemplatesDir pathInTemplatesSrcDir - dstPath = serverSrcDirInServerRootDir - ((SP.castRel pathInTemplatesSrcDir) :: Path (Rel ServerSrcDir) File) + where + srcPath = srcDirInServerTemplatesDir pathInTemplatesSrcDir + dstPath = + serverSrcDirInServerRootDir + ((SP.castRel pathInTemplatesSrcDir) :: Path (Rel ServerSrcDir) File) -- | Path where server app templates reside. serverTemplatesDirInTemplatesDir :: Path (Rel TemplatesDir) (Dir ServerTemplatesDir) diff --git a/waspc/src/Generator/ServerGenerator/ConfigG.hs b/waspc/src/Generator/ServerGenerator/ConfigG.hs index fc7a7c1d1..3a80a4ab8 100644 --- a/waspc/src/Generator/ServerGenerator/ConfigG.hs +++ b/waspc/src/Generator/ServerGenerator/ConfigG.hs @@ -1,25 +1,25 @@ module Generator.ServerGenerator.ConfigG - ( genConfigFile - , configFileInSrcDir - ) where + ( genConfigFile, + configFileInSrcDir, + ) +where -import Data.Aeson (object, (.=)) -import Data.Maybe (isJust) -import qualified Path as P -import StrongPath (File, Path, Rel, ()) -import qualified StrongPath as SP - -import Generator.FileDraft (FileDraft) +import Data.Aeson (object, (.=)) +import Data.Maybe (isJust) +import Generator.FileDraft (FileDraft) import qualified Generator.ServerGenerator.Common as C -import Wasp (Wasp, getAuth) - +import qualified Path as P +import StrongPath (File, Path, Rel, ()) +import qualified StrongPath as SP +import Wasp (Wasp, getAuth) genConfigFile :: Wasp -> FileDraft genConfigFile wasp = C.makeTemplateFD tmplFile dstFile (Just tmplData) where tmplFile = C.srcDirInServerTemplatesDir SP.castRel configFileInSrcDir dstFile = C.serverSrcDirInServerRootDir configFileInSrcDir - tmplData = object + tmplData = + object [ "isAuthEnabled" .= isJust (getAuth wasp) ] diff --git a/waspc/src/Generator/ServerGenerator/ExternalCodeGenerator.hs b/waspc/src/Generator/ServerGenerator/ExternalCodeGenerator.hs index 973b35d98..aa01105e2 100644 --- a/waspc/src/Generator/ServerGenerator/ExternalCodeGenerator.hs +++ b/waspc/src/Generator/ServerGenerator/ExternalCodeGenerator.hs @@ -1,24 +1,26 @@ module Generator.ServerGenerator.ExternalCodeGenerator - ( extCodeDirInServerSrcDir - , generatorStrategy - ) where + ( extCodeDirInServerSrcDir, + generatorStrategy, + ) +where -import qualified Path as P - -import StrongPath (Path, Rel, Dir, ()) -import qualified StrongPath as SP -import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy(..), GeneratedExternalCodeDir) -import qualified Generator.ServerGenerator.Common as C +import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy (..), GeneratedExternalCodeDir) import Generator.ExternalCodeGenerator.Js (resolveJsFileWaspImportsForExtCodeDir) +import qualified Generator.ServerGenerator.Common as C +import qualified Path as P +import StrongPath (Dir, Path, Rel, ()) +import qualified StrongPath as SP -- | Relative path to directory where external code will be generated. extCodeDirInServerSrcDir :: Path (Rel C.ServerSrcDir) (Dir GeneratedExternalCodeDir) extCodeDirInServerSrcDir = SP.fromPathRelDir [P.reldir|ext-src|] generatorStrategy :: ExternalCodeGeneratorStrategy -generatorStrategy = ExternalCodeGeneratorStrategy - { _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInServerSrcDir) - , _extCodeDirInProjectRootDir = C.serverRootDirInProjectRootDir - C.serverSrcDirInServerRootDir - extCodeDirInServerSrcDir +generatorStrategy = + ExternalCodeGeneratorStrategy + { _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInServerSrcDir), + _extCodeDirInProjectRootDir = + C.serverRootDirInProjectRootDir + C.serverSrcDirInServerRootDir + extCodeDirInServerSrcDir } diff --git a/waspc/src/Generator/ServerGenerator/OperationsG.hs b/waspc/src/Generator/ServerGenerator/OperationsG.hs index 4fc6f8d0d..54074dd8b 100644 --- a/waspc/src/Generator/ServerGenerator/OperationsG.hs +++ b/waspc/src/Generator/ServerGenerator/OperationsG.hs @@ -1,41 +1,43 @@ module Generator.ServerGenerator.OperationsG - ( genOperations - , queryFileInSrcDir - , actionFileInSrcDir - , operationFileInSrcDir - ) where + ( genOperations, + queryFileInSrcDir, + actionFileInSrcDir, + operationFileInSrcDir, + ) +where -import Data.Aeson (object, (.=)) -import qualified Data.Aeson as Aeson -import Data.Char (toLower) -import Data.Maybe (fromJust, fromMaybe) -import qualified Path as P - -import Generator.FileDraft (FileDraft) +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as Aeson +import Data.Char (toLower) +import Data.Maybe (fromJust, fromMaybe) +import Generator.FileDraft (FileDraft) import qualified Generator.ServerGenerator.Common as C -import StrongPath (File, Path, Rel, ()) -import qualified StrongPath as SP -import Wasp (Wasp) +import qualified Path as P +import StrongPath (File, Path, Rel, ()) +import qualified StrongPath as SP +import Wasp (Wasp) import qualified Wasp import qualified Wasp.Action import qualified Wasp.JsImport import qualified Wasp.Operation import qualified Wasp.Query - genOperations :: Wasp -> [FileDraft] -genOperations wasp = concat - [ genQueries wasp - , genActions wasp +genOperations wasp = + concat + [ genQueries wasp, + genActions wasp ] genQueries :: Wasp -> [FileDraft] -genQueries wasp = concat +genQueries wasp = + concat [ map (genQuery wasp) (Wasp.getQueries wasp) ] genActions :: Wasp -> [FileDraft] -genActions wasp = concat +genActions wasp = + concat [ map (genAction wasp) (Wasp.getActions wasp) ] @@ -60,16 +62,18 @@ genAction _ action = C.makeTemplateFD tmplFile dstFile (Just tmplData) tmplData = operationTmplData operation queryFileInSrcDir :: Wasp.Query.Query -> Path (Rel C.ServerSrcDir) File -queryFileInSrcDir query = SP.fromPathRelFile $ +queryFileInSrcDir query = + SP.fromPathRelFile $ [P.reldir|queries|] - -- TODO: fromJust here could fail if there is some problem with the name, we should handle this. - P. fromJust (P.parseRelFile $ Wasp.Query._name query ++ ".js") + -- TODO: fromJust here could fail if there is some problem with the name, we should handle this. + P. fromJust (P.parseRelFile $ Wasp.Query._name query ++ ".js") actionFileInSrcDir :: Wasp.Action.Action -> Path (Rel C.ServerSrcDir) File -actionFileInSrcDir action = SP.fromPathRelFile $ +actionFileInSrcDir action = + SP.fromPathRelFile $ [P.reldir|actions|] - -- TODO: fromJust here could fail if there is some problem with the name, we should handle this. - P. fromJust (P.parseRelFile $ Wasp.Action._name action ++ ".js") + -- TODO: fromJust here could fail if there is some problem with the name, we should handle this. + P. fromJust (P.parseRelFile $ Wasp.Action._name action ++ ".js") operationFileInSrcDir :: Wasp.Operation.Operation -> Path (Rel C.ServerSrcDir) File operationFileInSrcDir (Wasp.Operation.QueryOp query) = queryFileInSrcDir query @@ -80,35 +84,39 @@ relPosixPathFromOperationFileToExtSrcDir :: FilePath -- Posix relPosixPathFromOperationFileToExtSrcDir = "../ext-src/" operationTmplData :: Wasp.Operation.Operation -> Aeson.Value -operationTmplData operation = object - [ "jsFnImportStatement" .= importStmt - , "jsFnIdentifier" .= importIdentifier - , "entities" .= map buildEntityData (fromMaybe [] $ Wasp.Operation.getEntities operation) +operationTmplData operation = + object + [ "jsFnImportStatement" .= importStmt, + "jsFnIdentifier" .= importIdentifier, + "entities" .= map buildEntityData (fromMaybe [] $ Wasp.Operation.getEntities operation) ] where (importIdentifier, importStmt) = - getImportDetailsForOperationUserJsFn operation relPosixPathFromOperationFileToExtSrcDir + getImportDetailsForOperationUserJsFn operation relPosixPathFromOperationFileToExtSrcDir buildEntityData :: String -> Aeson.Value - buildEntityData entityName = object [ "name" .= entityName - , "prismaIdentifier" .= (toLower (head entityName) : tail entityName) - ] + buildEntityData entityName = + object + [ "name" .= entityName, + "prismaIdentifier" .= (toLower (head entityName) : tail entityName) + ] -- | Given Wasp operation, it returns details on how to import its user js function and use it, -- "user js function" meaning the one provided by user directly to wasp, untouched. -getImportDetailsForOperationUserJsFn - :: Wasp.Operation.Operation - -> FilePath -- ^ Relative posix path from js file where you want to do importing to generated ext code dir. - -- | (importIdentifier, importStmt) - -- - importIdentifier -> Identifier via which you can access js function after you import it with importStmt. - -- - importStmt -> Import statement via which you should do the import. - -> (String, String) +getImportDetailsForOperationUserJsFn :: + Wasp.Operation.Operation -> + -- | Relative posix path from js file where you want to do importing to generated ext code dir. + -- | (importIdentifier, importStmt) + -- - importIdentifier -> Identifier via which you can access js function after you import it with importStmt. + -- - importStmt -> Import statement via which you should do the import. + FilePath -> + (String, String) getImportDetailsForOperationUserJsFn operation relPosixPathToExtCodeDir = (importIdentifier, importStmt) where importStmt = "import " ++ importWhat ++ " from '" ++ importFrom ++ "'" importFrom = relPosixPathToExtCodeDir ++ SP.toFilePath (Wasp.JsImport._from jsImport) (importIdentifier, importWhat) = - case (Wasp.JsImport._defaultImport jsImport, Wasp.JsImport._namedImports jsImport) of - (Just defaultImport, []) -> (defaultImport, defaultImport) - (Nothing, [namedImport]) -> (namedImport, "{ " ++ namedImport ++ " }") - _ -> error "Expected either default import or single named import for operation (query/action) js function." + case (Wasp.JsImport._defaultImport jsImport, Wasp.JsImport._namedImports jsImport) of + (Just defaultImport, []) -> (defaultImport, defaultImport) + (Nothing, [namedImport]) -> (namedImport, "{ " ++ namedImport ++ " }") + _ -> error "Expected either default import or single named import for operation (query/action) js function." jsImport = Wasp.Operation.getJsFn operation diff --git a/waspc/src/Generator/ServerGenerator/OperationsRoutesG.hs b/waspc/src/Generator/ServerGenerator/OperationsRoutesG.hs index 9f3d6f956..19e8dc107 100644 --- a/waspc/src/Generator/ServerGenerator/OperationsRoutesG.hs +++ b/waspc/src/Generator/ServerGenerator/OperationsRoutesG.hs @@ -1,63 +1,74 @@ module Generator.ServerGenerator.OperationsRoutesG - ( genOperationsRoutes - , operationRouteInOperationsRouter - ) where + ( genOperationsRoutes, + operationRouteInOperationsRouter, + ) +where -import Data.Aeson (object, (.=)) -import qualified Data.Aeson as Aeson -import Data.Maybe (fromJust, isJust) -import qualified Path as P +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as Aeson +import Data.Maybe (fromJust, isJust) +import Generator.FileDraft (FileDraft) +import qualified Generator.ServerGenerator.Common as C +import Generator.ServerGenerator.OperationsG (operationFileInSrcDir) +import qualified Path as P +import StrongPath + ( Dir, + File, + Path, + Rel, + (), + ) +import qualified StrongPath as SP import qualified System.FilePath.Posix as FPPosix - -import Generator.FileDraft (FileDraft) -import qualified Generator.ServerGenerator.Common as C -import Generator.ServerGenerator.OperationsG (operationFileInSrcDir) -import StrongPath (Dir, File, Path, Rel, - ()) -import qualified StrongPath as SP -import qualified Util as U -import Wasp (Wasp, getAuth) +import qualified Util as U +import Wasp (Wasp, getAuth) import qualified Wasp import qualified Wasp.Action +import qualified Wasp.Auth import qualified Wasp.Operation import qualified Wasp.Query -import qualified Wasp.Auth - genOperationsRoutes :: Wasp -> [FileDraft] -genOperationsRoutes wasp = concat - [ map (genActionRoute wasp) (Wasp.getActions wasp) - , map (genQueryRoute wasp) (Wasp.getQueries wasp) - , [genOperationsRouter wasp] +genOperationsRoutes wasp = + concat + [ map (genActionRoute wasp) (Wasp.getActions wasp), + map (genQueryRoute wasp) (Wasp.getQueries wasp), + [genOperationsRouter wasp] ] genActionRoute :: Wasp -> Wasp.Action.Action -> FileDraft genActionRoute wasp action = genOperationRoute wasp op tmplFile - where op = Wasp.Operation.ActionOp action - tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_action.js|] + where + op = Wasp.Operation.ActionOp action + tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_action.js|] genQueryRoute :: Wasp -> Wasp.Query.Query -> FileDraft genQueryRoute wasp query = genOperationRoute wasp op tmplFile - where op = Wasp.Operation.QueryOp query - tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_query.js|] + where + op = Wasp.Operation.QueryOp query + tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_query.js|] genOperationRoute :: Wasp -> Wasp.Operation.Operation -> Path (Rel C.ServerTemplatesDir) File -> FileDraft genOperationRoute wasp operation tmplFile = C.makeTemplateFD tmplFile dstFile (Just tmplData) where dstFile = operationsRoutesDirInServerRootDir operationRouteFileInOperationsRoutesDir operation - baseTmplData = object - [ "operationImportPath" .= operationImportPath - , "operationName" .= Wasp.Operation.getName operation + baseTmplData = + object + [ "operationImportPath" .= operationImportPath, + "operationName" .= Wasp.Operation.getName operation ] tmplData = case (Wasp.getAuth wasp) of - Nothing -> baseTmplData - Just auth -> U.jsonSet ("userEntityLower") - (Aeson.toJSON (U.toLowerFirst $ Wasp.Auth._userEntity auth)) - baseTmplData + Nothing -> baseTmplData + Just auth -> + U.jsonSet + ("userEntityLower") + (Aeson.toJSON (U.toLowerFirst $ Wasp.Auth._userEntity auth)) + baseTmplData - operationImportPath = relPosixPathFromOperationsRoutesDirToSrcDir + operationImportPath = + relPosixPathFromOperationsRoutesDirToSrcDir FPPosix. SP.toFilePath (SP.relFileToPosix' $ operationFileInSrcDir operation) data OperationsRoutesDir @@ -75,25 +86,26 @@ operationRouteFileInOperationsRoutesDir operation = fromJust $ SP.parseRelFile $ relPosixPathFromOperationsRoutesDirToSrcDir :: FilePath -- Posix relPosixPathFromOperationsRoutesDirToSrcDir = "../.." - genOperationsRouter :: Wasp -> FileDraft genOperationsRouter wasp = C.makeTemplateFD tmplFile dstFile (Just tmplData) where tmplFile = C.asTmplFile [P.relfile|src/routes/operations/index.js|] dstFile = operationsRoutesDirInServerRootDir SP.fromPathRelFile [P.relfile|index.js|] - operations = map Wasp.Operation.ActionOp (Wasp.getActions wasp) - ++ map Wasp.Operation.QueryOp (Wasp.getQueries wasp) - tmplData = object - [ "operationRoutes" .= map makeOperationRoute operations - , "isAuthEnabled" .= (isJust $ getAuth wasp) + operations = + map Wasp.Operation.ActionOp (Wasp.getActions wasp) + ++ map Wasp.Operation.QueryOp (Wasp.getQueries wasp) + tmplData = + object + [ "operationRoutes" .= map makeOperationRoute operations, + "isAuthEnabled" .= (isJust $ getAuth wasp) ] makeOperationRoute operation = - let operationName = Wasp.Operation.getName operation - in object - [ "importIdentifier" .= operationName - , "importPath" .= ("./" ++ SP.toFilePath (SP.relFileToPosix' $ operationRouteFileInOperationsRoutesDir operation)) - , "routePath" .= ("/" ++ operationRouteInOperationsRouter operation) - ] + let operationName = Wasp.Operation.getName operation + in object + [ "importIdentifier" .= operationName, + "importPath" .= ("./" ++ SP.toFilePath (SP.relFileToPosix' $ operationRouteFileInOperationsRoutesDir operation)), + "routePath" .= ("/" ++ operationRouteInOperationsRouter operation) + ] operationRouteInOperationsRouter :: Wasp.Operation.Operation -> String operationRouteInOperationsRouter = U.camelToKebabCase . Wasp.Operation.getName diff --git a/waspc/src/Generator/ServerGenerator/Setup.hs b/waspc/src/Generator/ServerGenerator/Setup.hs index f13e326d9..37dfd8176 100644 --- a/waspc/src/Generator/ServerGenerator/Setup.hs +++ b/waspc/src/Generator/ServerGenerator/Setup.hs @@ -1,15 +1,15 @@ module Generator.ServerGenerator.Setup - ( setupServer - ) where + ( setupServer, + ) +where -import Generator.Common (ProjectRootDir) -import qualified Generator.Job as J -import Generator.Job.Process (runNodeCommandAsJob) +import Generator.Common (ProjectRootDir) +import qualified Generator.Job as J +import Generator.Job.Process (runNodeCommandAsJob) import qualified Generator.ServerGenerator.Common as Common -import StrongPath (Abs, Dir, Path, ()) - +import StrongPath (Abs, Dir, Path, ()) setupServer :: Path Abs (Dir ProjectRootDir) -> J.Job setupServer projectDir = do - let serverDir = projectDir Common.serverRootDirInProjectRootDir - runNodeCommandAsJob serverDir "npm" ["install"] J.Server + let serverDir = projectDir Common.serverRootDirInProjectRootDir + runNodeCommandAsJob serverDir "npm" ["install"] J.Server diff --git a/waspc/src/Generator/ServerGenerator/Start.hs b/waspc/src/Generator/ServerGenerator/Start.hs index be4251b8d..7e2503c42 100644 --- a/waspc/src/Generator/ServerGenerator/Start.hs +++ b/waspc/src/Generator/ServerGenerator/Start.hs @@ -1,15 +1,15 @@ module Generator.ServerGenerator.Start - ( startServer - ) where + ( startServer, + ) +where -import Generator.Common (ProjectRootDir) -import qualified Generator.Job as J -import Generator.Job.Process (runNodeCommandAsJob) +import Generator.Common (ProjectRootDir) +import qualified Generator.Job as J +import Generator.Job.Process (runNodeCommandAsJob) import qualified Generator.ServerGenerator.Common as Common -import StrongPath (Abs, Dir, Path, ()) - +import StrongPath (Abs, Dir, Path, ()) startServer :: Path Abs (Dir ProjectRootDir) -> J.Job startServer projectDir = do - let serverDir = projectDir Common.serverRootDirInProjectRootDir - runNodeCommandAsJob serverDir "npm" ["start"] J.Server + let serverDir = projectDir Common.serverRootDirInProjectRootDir + runNodeCommandAsJob serverDir "npm" ["start"] J.Server diff --git a/waspc/src/Generator/Setup.hs b/waspc/src/Generator/Setup.hs index 993ac271f..f7a378672 100644 --- a/waspc/src/Generator/Setup.hs +++ b/waspc/src/Generator/Setup.hs @@ -1,47 +1,47 @@ module Generator.Setup - ( setup - ) where - -import Control.Concurrent (Chan, newChan, readChan) -import Control.Concurrent.Async (concurrently) -import System.Exit (ExitCode (..)) - -import Generator.Common (ProjectRootDir) -import qualified Generator.Job as J -import Generator.Job.IO (printPrefixedJobMessage) -import Generator.ServerGenerator.Setup (setupServer) -import Generator.WebAppGenerator.Setup (setupWebApp) -import StrongPath (Abs, Dir, Path) + ( setup, + ) +where +import Control.Concurrent (Chan, newChan, readChan) +import Control.Concurrent.Async (concurrently) +import Generator.Common (ProjectRootDir) +import qualified Generator.Job as J +import Generator.Job.IO (printPrefixedJobMessage) +import Generator.ServerGenerator.Setup (setupServer) +import Generator.WebAppGenerator.Setup (setupWebApp) +import StrongPath (Abs, Dir, Path) +import System.Exit (ExitCode (..)) setup :: Path Abs (Dir ProjectRootDir) -> IO (Either String ()) setup projectDir = do - chan <- newChan - let runSetupJobs = concurrently (setupServer projectDir chan) (setupWebApp projectDir chan) - (_, result) <- concurrently (handleJobMessages chan) runSetupJobs - case result of - (ExitSuccess, ExitSuccess) -> return $ Right () - exitCodes -> return $ Left $ setupFailedMessage exitCodes + chan <- newChan + let runSetupJobs = concurrently (setupServer projectDir chan) (setupWebApp projectDir chan) + (_, result) <- concurrently (handleJobMessages chan) runSetupJobs + case result of + (ExitSuccess, ExitSuccess) -> return $ Right () + exitCodes -> return $ Left $ setupFailedMessage exitCodes where - handleJobMessages = go Nothing (False, False) - where - go :: Maybe J.JobMessage -> (Bool, Bool) -> Chan J.JobMessage -> IO () - go _ (True, True) _ = return () - go prevJobMsg (isWebAppDone, isServerDone) chan = do - jobMsg <- readChan chan - case J._data jobMsg of - J.JobOutput {} -> printPrefixedJobMessage prevJobMsg jobMsg - >> go (Just jobMsg) (isWebAppDone, isServerDone) chan - J.JobExit {} -> case J._jobType jobMsg of - J.WebApp -> go (Just jobMsg) (True, isServerDone) chan - J.Server -> go (Just jobMsg) (isWebAppDone, True) chan - J.Db -> error "This should never happen. No db job should be active." + handleJobMessages = go Nothing (False, False) + where + go :: Maybe J.JobMessage -> (Bool, Bool) -> Chan J.JobMessage -> IO () + go _ (True, True) _ = return () + go prevJobMsg (isWebAppDone, isServerDone) chan = do + jobMsg <- readChan chan + case J._data jobMsg of + J.JobOutput {} -> + printPrefixedJobMessage prevJobMsg jobMsg + >> go (Just jobMsg) (isWebAppDone, isServerDone) chan + J.JobExit {} -> case J._jobType jobMsg of + J.WebApp -> go (Just jobMsg) (True, isServerDone) chan + J.Server -> go (Just jobMsg) (isWebAppDone, True) chan + J.Db -> error "This should never happen. No db job should be active." - setupFailedMessage (serverExitCode, webAppExitCode) = - let serverErrorMessage = case serverExitCode of - ExitFailure code -> " Server setup failed with exit code " ++ show code ++ "." - _ -> "" - webAppErrorMessage = case webAppExitCode of - ExitFailure code -> " Web app setup failed with exit code " ++ show code ++ "." - _ -> "" - in "Setup failed!" ++ serverErrorMessage ++ webAppErrorMessage + setupFailedMessage (serverExitCode, webAppExitCode) = + let serverErrorMessage = case serverExitCode of + ExitFailure code -> " Server setup failed with exit code " ++ show code ++ "." + _ -> "" + webAppErrorMessage = case webAppExitCode of + ExitFailure code -> " Web app setup failed with exit code " ++ show code ++ "." + _ -> "" + in "Setup failed!" ++ serverErrorMessage ++ webAppErrorMessage diff --git a/waspc/src/Generator/Start.hs b/waspc/src/Generator/Start.hs index dd81cede0..f5c88bce0 100644 --- a/waspc/src/Generator/Start.hs +++ b/waspc/src/Generator/Start.hs @@ -1,24 +1,23 @@ module Generator.Start - ( start - ) where - -import Control.Concurrent (newChan) -import Control.Concurrent.Async (race, concurrently) - -import Generator.Common (ProjectRootDir) -import Generator.Job.IO (readJobMessagesAndPrintThemPrefixed) -import Generator.ServerGenerator.Start (startServer) -import Generator.WebAppGenerator.Start (startWebApp) -import StrongPath (Abs, Dir, Path) + ( start, + ) +where +import Control.Concurrent (newChan) +import Control.Concurrent.Async (concurrently, race) +import Generator.Common (ProjectRootDir) +import Generator.Job.IO (readJobMessagesAndPrintThemPrefixed) +import Generator.ServerGenerator.Start (startServer) +import Generator.WebAppGenerator.Start (startWebApp) +import StrongPath (Abs, Dir, Path) -- | This is a blocking action, that will start the processes that run web app and server. -- It will run as long as one of those processes does not fail. start :: Path Abs (Dir ProjectRootDir) -> IO (Either String ()) start projectDir = do - chan <- newChan - let runStartJobs = race (startServer projectDir chan) (startWebApp projectDir chan) - (_, serverOrWebExitCode) <- concurrently (readJobMessagesAndPrintThemPrefixed chan) runStartJobs - case serverOrWebExitCode of - Left serverExitCode -> return $ Left $ "Server failed with exit code " ++ show serverExitCode ++ "." - Right webAppExitCode -> return $ Left $ "Web app failed with exit code " ++ show webAppExitCode ++ "." + chan <- newChan + let runStartJobs = race (startServer projectDir chan) (startWebApp projectDir chan) + (_, serverOrWebExitCode) <- concurrently (readJobMessagesAndPrintThemPrefixed chan) runStartJobs + case serverOrWebExitCode of + Left serverExitCode -> return $ Left $ "Server failed with exit code " ++ show serverExitCode ++ "." + Right webAppExitCode -> return $ Left $ "Web app failed with exit code " ++ show webAppExitCode ++ "." diff --git a/waspc/src/Generator/Templates.hs b/waspc/src/Generator/Templates.hs index 920e94217..a3359724e 100644 --- a/waspc/src/Generator/Templates.hs +++ b/waspc/src/Generator/Templates.hs @@ -1,21 +1,20 @@ module Generator.Templates - ( getTemplatesDirAbsPath - , getTemplateFileAbsPath - , compileAndRenderTemplate - , TemplatesDir - ) where - -import qualified Text.Mustache as Mustache -import Text.Mustache.Render (SubstitutionError(..)) -import qualified Data.Aeson as Aeson -import Data.Text (Text) -import Text.Printf (printf) -import qualified Path as P + ( getTemplatesDirAbsPath, + getTemplateFileAbsPath, + compileAndRenderTemplate, + TemplatesDir, + ) +where import qualified Data -import StrongPath (Path, File, Dir, Abs, Rel, ()) +import qualified Data.Aeson as Aeson +import Data.Text (Text) +import qualified Path as P +import StrongPath (Abs, Dir, File, Path, Rel, ()) import qualified StrongPath as SP - +import qualified Text.Mustache as Mustache +import Text.Mustache.Render (SubstitutionError (..)) +import Text.Printf (printf) -- TODO: Write tests for this file! But first we need to decouple logic from IO -- so that we can mock it. @@ -34,44 +33,49 @@ getTemplateFileAbsPath relTmplFilePath = ( relTmplFilePath) <$> getTemplatesD templatesDirPathInDataDir :: Path (Rel Data.DataDir) (Dir TemplatesDir) templatesDirPathInDataDir = SP.fromPathRelDir [P.reldir|Generator/templates|] - -compileAndRenderTemplate - :: Path (Rel TemplatesDir) File -- ^ Path to the template file. - -> Aeson.Value -- ^ JSON to be provided as template data. - -> IO Text +compileAndRenderTemplate :: + -- | Path to the template file. + Path (Rel TemplatesDir) File -> + -- | JSON to be provided as template data. + Aeson.Value -> + IO Text compileAndRenderTemplate relTmplPath tmplData = do - mustacheTemplate <- compileMustacheTemplate relTmplPath - renderMustacheTemplate mustacheTemplate tmplData + mustacheTemplate <- compileMustacheTemplate relTmplPath + renderMustacheTemplate mustacheTemplate tmplData -compileMustacheTemplate - :: Path (Rel TemplatesDir) File -- ^ Path to the template file. - -> IO Mustache.Template +compileMustacheTemplate :: + -- | Path to the template file. + Path (Rel TemplatesDir) File -> + IO Mustache.Template compileMustacheTemplate relTmplPath = do - templatesDirAbsPath <- getTemplatesDirAbsPath - absTmplPath <- getTemplateFileAbsPath relTmplPath - eitherTemplate <- Mustache.automaticCompile [SP.toFilePath templatesDirAbsPath] - (SP.toFilePath absTmplPath) - return $ either raiseCompileError id eitherTemplate + templatesDirAbsPath <- getTemplatesDirAbsPath + absTmplPath <- getTemplateFileAbsPath relTmplPath + eitherTemplate <- + Mustache.automaticCompile + [SP.toFilePath templatesDirAbsPath] + (SP.toFilePath absTmplPath) + return $ either raiseCompileError id eitherTemplate where - raiseCompileError err = error $ -- TODO: Handle these errors better? + raiseCompileError err = + error $ -- TODO: Handle these errors better? printf "Compilation of template %s failed. %s" (show relTmplPath) (show err) areAllErrorsSectionDataNotFound :: [SubstitutionError] -> Bool areAllErrorsSectionDataNotFound = all isSectionDataNotFoundError where isSectionDataNotFoundError e = case e of - SectionTargetNotFound _ -> True - _ -> False + SectionTargetNotFound _ -> True + _ -> False renderMustacheTemplate :: Mustache.Template -> Aeson.Value -> IO Text renderMustacheTemplate mustacheTemplate templateData = do - let mustacheTemplateData = Mustache.toMustache templateData - let (errors, fileText) = - Mustache.checkedSubstituteValue mustacheTemplate mustacheTemplateData + let mustacheTemplateData = Mustache.toMustache templateData + let (errors, fileText) = + Mustache.checkedSubstituteValue mustacheTemplate mustacheTemplateData - -- NOTE(matija): Mustache reports errors when object does - -- not have a property specified in the template, which we use to implement - -- conditionals. This is why we ignore these errors. - if null errors || areAllErrorsSectionDataNotFound errors - then return fileText - else error $ "Unexpected errors occured while rendering template: " ++ show errors + -- NOTE(matija): Mustache reports errors when object does + -- not have a property specified in the template, which we use to implement + -- conditionals. This is why we ignore these errors. + if null errors || areAllErrorsSectionDataNotFound errors + then return fileText + else error $ "Unexpected errors occured while rendering template: " ++ show errors diff --git a/waspc/src/Generator/WebAppGenerator.hs b/waspc/src/Generator/WebAppGenerator.hs index dca9316de..92a114f51 100644 --- a/waspc/src/Generator/WebAppGenerator.hs +++ b/waspc/src/Generator/WebAppGenerator.hs @@ -1,103 +1,123 @@ module Generator.WebAppGenerator - ( generateWebApp - ) where + ( generateWebApp, + ) +where -import Data.Aeson (ToJSON (..), - object, (.=)) -import Data.List (intercalate) -import qualified Path as P - -import CompileOptions (CompileOptions) -import Generator.ExternalCodeGenerator (generateExternalCodeDir) -import Generator.FileDraft -import Generator.PackageJsonGenerator (resolveNpmDeps, - toPackageJsonDependenciesString) -import qualified Generator.WebAppGenerator.AuthG as AuthG -import Generator.WebAppGenerator.Common (asTmplFile, - asWebAppFile, - asWebAppSrcFile) -import qualified Generator.WebAppGenerator.Common as C +import CompileOptions (CompileOptions) +import Data.Aeson + ( ToJSON (..), + object, + (.=), + ) +import Data.List (intercalate) +import Generator.ExternalCodeGenerator (generateExternalCodeDir) +import Generator.FileDraft +import Generator.PackageJsonGenerator + ( resolveNpmDeps, + toPackageJsonDependenciesString, + ) +import qualified Generator.WebAppGenerator.AuthG as AuthG +import Generator.WebAppGenerator.Common + ( asTmplFile, + asWebAppFile, + asWebAppSrcFile, + ) +import qualified Generator.WebAppGenerator.Common as C import qualified Generator.WebAppGenerator.ExternalCodeGenerator as WebAppExternalCodeGenerator -import Generator.WebAppGenerator.OperationsGenerator (genOperations) -import qualified Generator.WebAppGenerator.RouterGenerator as RouterGenerator -import qualified NpmDependency as ND -import StrongPath (Dir, Path, - Rel, ()) +import Generator.WebAppGenerator.OperationsGenerator (genOperations) +import qualified Generator.WebAppGenerator.RouterGenerator as RouterGenerator +import qualified NpmDependency as ND +import qualified Path as P +import StrongPath + ( Dir, + Path, + Rel, + (), + ) import qualified StrongPath as SP -import Wasp +import Wasp import qualified Wasp.App -import qualified Wasp.NpmDependencies as WND - +import qualified Wasp.NpmDependencies as WND generateWebApp :: Wasp -> CompileOptions -> [FileDraft] -generateWebApp wasp _ = concat - [ [generateReadme wasp] - , [genPackageJson wasp waspNpmDeps] - , [generateGitignore wasp] - , generatePublicDir wasp - , generateSrcDir wasp - , generateExternalCodeDir WebAppExternalCodeGenerator.generatorStrategy wasp - , [C.makeSimpleTemplateFD (asTmplFile [P.relfile|netlify.toml|]) wasp] +generateWebApp wasp _ = + concat + [ [generateReadme wasp], + [genPackageJson wasp waspNpmDeps], + [generateGitignore wasp], + generatePublicDir wasp, + generateSrcDir wasp, + generateExternalCodeDir WebAppExternalCodeGenerator.generatorStrategy wasp, + [C.makeSimpleTemplateFD (asTmplFile [P.relfile|netlify.toml|]) wasp] ] generateReadme :: Wasp -> FileDraft generateReadme wasp = C.makeSimpleTemplateFD (asTmplFile [P.relfile|README.md|]) wasp genPackageJson :: Wasp -> [ND.NpmDependency] -> FileDraft -genPackageJson wasp waspDeps = C.makeTemplateFD +genPackageJson wasp waspDeps = + C.makeTemplateFD (C.asTmplFile [P.relfile|package.json|]) (C.asWebAppFile [P.relfile|package.json|]) - (Just $ object - [ "wasp" .= wasp - , "depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps) - ]) + ( Just $ + object + [ "wasp" .= wasp, + "depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps) + ] + ) where (resolvedWaspDeps, resolvedUserDeps) = - case resolveNpmDeps waspDeps userDeps of - Right deps -> deps - Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors + case resolveNpmDeps waspDeps userDeps of + Right deps -> deps + Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors userDeps :: [ND.NpmDependency] userDeps = WND._dependencies $ Wasp.getNpmDependencies wasp waspNpmDeps :: [ND.NpmDependency] -waspNpmDeps = ND.fromList - [ ("axios", "^0.21.1") - , ("lodash", "^4.17.15") - , ("react", "^16.12.0") - , ("react-dom", "^16.12.0") - , ("react-query", "^2.14.1") - , ("react-router-dom", "^5.1.2") - , ("react-scripts", "4.0.3") - , ("uuid", "^3.4.0") +waspNpmDeps = + ND.fromList + [ ("axios", "^0.21.1"), + ("lodash", "^4.17.15"), + ("react", "^16.12.0"), + ("react-dom", "^16.12.0"), + ("react-query", "^2.14.1"), + ("react-router-dom", "^5.1.2"), + ("react-scripts", "4.0.3"), + ("uuid", "^3.4.0") ] -- TODO: Also extract devDependencies like we did dependencies (waspNpmDeps). generateGitignore :: Wasp -> FileDraft -generateGitignore wasp = C.makeTemplateFD (asTmplFile [P.relfile|gitignore|]) - (asWebAppFile [P.relfile|.gitignore|]) - (Just $ toJSON wasp) +generateGitignore wasp = + C.makeTemplateFD + (asTmplFile [P.relfile|gitignore|]) + (asWebAppFile [P.relfile|.gitignore|]) + (Just $ toJSON wasp) generatePublicDir :: Wasp -> [FileDraft] generatePublicDir wasp = - C.copyTmplAsIs (asTmplFile [P.relfile|public/favicon.ico|]) - : generatePublicIndexHtml wasp - : map (\path -> C.makeSimpleTemplateFD (asTmplFile $ [P.reldir|public|] P. path) wasp) - [ [P.relfile|manifest.json|] - ] + C.copyTmplAsIs (asTmplFile [P.relfile|public/favicon.ico|]) : + generatePublicIndexHtml wasp : + map + (\path -> C.makeSimpleTemplateFD (asTmplFile $ [P.reldir|public|] P. path) wasp) + [ [P.relfile|manifest.json|] + ] generatePublicIndexHtml :: Wasp -> FileDraft -generatePublicIndexHtml wasp = C.makeTemplateFD - (asTmplFile $ [P.relfile|public/index.html|]) +generatePublicIndexHtml wasp = + C.makeTemplateFD + (asTmplFile $ [P.relfile|public/index.html|]) targetPath (Just templateData) - where - targetPath = SP.fromPathRelFile [P.relfile|public/index.html|] - templateData = object - [ "title" .= (Wasp.App.appTitle $ getApp wasp) - , "head" .= (maybe "" (intercalate "\n") (Wasp.App.appHead $ getApp wasp)) - ] + where + targetPath = SP.fromPathRelFile [P.relfile|public/index.html|] + templateData = + object + [ "title" .= (Wasp.App.appTitle $ getApp wasp), + "head" .= (maybe "" (intercalate "\n") (Wasp.App.appHead $ getApp wasp)) + ] -- * Src dir @@ -108,28 +128,34 @@ srcDir = C.webAppSrcDirInWebAppRootDir -- although they are not used anywhere outside. -- We could further "templatize" this file so only what is needed is generated. -- + -- | Generates api.js file which contains token management and configured api (e.g. axios) instance. genApi :: FileDraft genApi = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/api.js|]) generateSrcDir :: Wasp -> [FileDraft] -generateSrcDir wasp - = generateLogo - : RouterGenerator.generateRouter wasp - : genApi - : map makeSimpleSrcTemplateFD - [ [P.relfile|index.js|] - , [P.relfile|index.css|] - , [P.relfile|serviceWorker.js|] - , [P.relfile|config.js|] - , [P.relfile|queryCache.js|] - ] +generateSrcDir wasp = + generateLogo : + RouterGenerator.generateRouter wasp : + genApi : + map + makeSimpleSrcTemplateFD + [ [P.relfile|index.js|], + [P.relfile|index.css|], + [P.relfile|serviceWorker.js|], + [P.relfile|config.js|], + [P.relfile|queryCache.js|] + ] ++ genOperations wasp ++ AuthG.genAuth wasp where - generateLogo = C.makeTemplateFD (asTmplFile [P.relfile|src/logo.png|]) - (srcDir asWebAppSrcFile [P.relfile|logo.png|]) - Nothing - makeSimpleSrcTemplateFD path = C.makeTemplateFD (asTmplFile $ [P.reldir|src|] P. path) - (srcDir asWebAppSrcFile path) - (Just $ toJSON wasp) + generateLogo = + C.makeTemplateFD + (asTmplFile [P.relfile|src/logo.png|]) + (srcDir asWebAppSrcFile [P.relfile|logo.png|]) + Nothing + makeSimpleSrcTemplateFD path = + C.makeTemplateFD + (asTmplFile $ [P.reldir|src|] P. path) + (srcDir asWebAppSrcFile path) + (Just $ toJSON wasp) diff --git a/waspc/src/Generator/WebAppGenerator/AuthG.hs b/waspc/src/Generator/WebAppGenerator/AuthG.hs index 1b65b3ddc..772d60252 100644 --- a/waspc/src/Generator/WebAppGenerator/AuthG.hs +++ b/waspc/src/Generator/WebAppGenerator/AuthG.hs @@ -1,28 +1,29 @@ module Generator.WebAppGenerator.AuthG - ( genAuth - ) where + ( genAuth, + ) +where import Data.Aeson (object, (.=)) +import Generator.FileDraft (FileDraft) +import Generator.WebAppGenerator.Common as C import qualified Path as P - import StrongPath (()) import Wasp (Wasp, getAuth) import qualified Wasp.Auth -import Generator.FileDraft (FileDraft) -import Generator.WebAppGenerator.Common as C genAuth :: Wasp -> [FileDraft] genAuth wasp = case maybeAuth of - Just auth -> [ genSignup - , genLogin - , genLogout - , genUseAuth - , genCreateAuthRequiredPage auth - ] - ++ genAuthForms - Nothing -> [] - where - maybeAuth = getAuth wasp + Just auth -> + [ genSignup, + genLogin, + genLogout, + genUseAuth, + genCreateAuthRequiredPage auth + ] + ++ genAuthForms + Nothing -> [] + where + maybeAuth = getAuth wasp -- | Generates file with signup function to be used by Wasp developer. genSignup :: FileDraft @@ -38,14 +39,15 @@ genLogout = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/auth/logout.js|]) -- | Generates HOC that handles auth for the given page. genCreateAuthRequiredPage :: Wasp.Auth.Auth -> FileDraft -genCreateAuthRequiredPage auth = C.makeTemplateFD +genCreateAuthRequiredPage auth = + C.makeTemplateFD (asTmplFile $ [P.reldir|src|] P. authReqPagePath) targetPath (Just templateData) - where - authReqPagePath = [P.relfile|auth/pages/createAuthRequiredPage.js|] - targetPath = C.webAppSrcDirInWebAppRootDir (asWebAppSrcFile authReqPagePath) - templateData = object [ "onAuthFailedRedirectTo" .= (Wasp.Auth._onAuthFailedRedirectTo auth) ] + where + authReqPagePath = [P.relfile|auth/pages/createAuthRequiredPage.js|] + targetPath = C.webAppSrcDirInWebAppRootDir (asWebAppSrcFile authReqPagePath) + templateData = object ["onAuthFailedRedirectTo" .= (Wasp.Auth._onAuthFailedRedirectTo auth)] -- | Generates React hook that Wasp developer can use in a component to get -- access to the currently logged in user (and check whether user is logged in @@ -55,9 +57,9 @@ genUseAuth = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/auth/useAuth.js|]) genAuthForms :: [FileDraft] genAuthForms = - [ genLoginForm - , genSignupForm - ] + [ genLoginForm, + genSignupForm + ] genLoginForm :: FileDraft genLoginForm = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/auth/forms/Login.js|]) diff --git a/waspc/src/Generator/WebAppGenerator/Common.hs b/waspc/src/Generator/WebAppGenerator/Common.hs index 3eb99d78a..608814f38 100644 --- a/waspc/src/Generator/WebAppGenerator/Common.hs +++ b/waspc/src/Generator/WebAppGenerator/Common.hs @@ -1,34 +1,34 @@ module Generator.WebAppGenerator.Common - ( webAppRootDirInProjectRootDir - , webAppSrcDirInWebAppRootDir - , copyTmplAsIs - , makeSimpleTemplateFD - , makeTemplateFD - , webAppSrcDirInProjectRootDir - , webAppTemplatesDirInTemplatesDir - , asTmplFile - , asWebAppFile - , asWebAppSrcFile - , WebAppRootDir - , WebAppSrcDir - , WebAppTemplatesDir - ) where + ( webAppRootDirInProjectRootDir, + webAppSrcDirInWebAppRootDir, + copyTmplAsIs, + makeSimpleTemplateFD, + makeTemplateFD, + webAppSrcDirInProjectRootDir, + webAppTemplatesDirInTemplatesDir, + asTmplFile, + asWebAppFile, + asWebAppSrcFile, + WebAppRootDir, + WebAppSrcDir, + WebAppTemplatesDir, + ) +where import qualified Data.Aeson as Aeson -import qualified Path as P - -import StrongPath (Path, Rel, Dir, File, ()) -import qualified StrongPath as SP -import Wasp (Wasp) import Generator.Common (ProjectRootDir) import Generator.FileDraft (FileDraft, createTemplateFileDraft) import Generator.Templates (TemplatesDir) - +import qualified Path as P +import StrongPath (Dir, File, Path, Rel, ()) +import qualified StrongPath as SP +import Wasp (Wasp) data WebAppRootDir -data WebAppSrcDir -data WebAppTemplatesDir +data WebAppSrcDir + +data WebAppTemplatesDir asTmplFile :: P.Path P.Rel P.File -> Path (Rel WebAppTemplatesDir) File asTmplFile = SP.fromPathRelFile @@ -39,7 +39,6 @@ asWebAppFile = SP.fromPathRelFile asWebAppSrcFile :: P.Path P.Rel P.File -> Path (Rel WebAppSrcDir) File asWebAppSrcFile = SP.fromPathRelFile - -- * Paths -- | Path where web app root dir is generated, relative to the root directory of the whole generated project. @@ -53,7 +52,6 @@ webAppSrcDirInWebAppRootDir = SP.fromPathRelDir [P.reldir|src|] webAppSrcDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir WebAppSrcDir) webAppSrcDirInProjectRootDir = webAppRootDirInProjectRootDir webAppSrcDirInWebAppRootDir - -- * Templates -- | Path in templates directory where web app templates reside. @@ -66,13 +64,13 @@ copyTmplAsIs path = makeTemplateFD path (SP.castRel path) Nothing makeSimpleTemplateFD :: Path (Rel WebAppTemplatesDir) File -> Wasp -> FileDraft makeSimpleTemplateFD path wasp = makeTemplateFD path (SP.castRel path) (Just $ Aeson.toJSON wasp) -makeTemplateFD - :: Path (Rel WebAppTemplatesDir) File - -> Path (Rel WebAppRootDir) File - -> Maybe Aeson.Value - -> FileDraft +makeTemplateFD :: + Path (Rel WebAppTemplatesDir) File -> + Path (Rel WebAppRootDir) File -> + Maybe Aeson.Value -> + FileDraft makeTemplateFD srcPathInWebAppTemplatesDir dstPathInWebAppRootDir tmplData = - createTemplateFileDraft - (webAppRootDirInProjectRootDir dstPathInWebAppRootDir) - (webAppTemplatesDirInTemplatesDir srcPathInWebAppTemplatesDir) - tmplData + createTemplateFileDraft + (webAppRootDirInProjectRootDir dstPathInWebAppRootDir) + (webAppTemplatesDirInTemplatesDir srcPathInWebAppTemplatesDir) + tmplData diff --git a/waspc/src/Generator/WebAppGenerator/ExternalCodeGenerator.hs b/waspc/src/Generator/WebAppGenerator/ExternalCodeGenerator.hs index 35b7121fb..9dc2c6696 100644 --- a/waspc/src/Generator/WebAppGenerator/ExternalCodeGenerator.hs +++ b/waspc/src/Generator/WebAppGenerator/ExternalCodeGenerator.hs @@ -1,15 +1,15 @@ module Generator.WebAppGenerator.ExternalCodeGenerator - ( extCodeDirInWebAppSrcDir - , generatorStrategy - ) where + ( extCodeDirInWebAppSrcDir, + generatorStrategy, + ) +where -import qualified Path as P - -import StrongPath (Path, Rel, Dir, ()) -import qualified StrongPath as SP -import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy(..), GeneratedExternalCodeDir) -import qualified Generator.WebAppGenerator.Common as C +import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy (..), GeneratedExternalCodeDir) import Generator.ExternalCodeGenerator.Js (resolveJsFileWaspImportsForExtCodeDir) +import qualified Generator.WebAppGenerator.Common as C +import qualified Path as P +import StrongPath (Dir, Path, Rel, ()) +import qualified StrongPath as SP -- | Relative path to directory where external code will be generated. -- Relative to web app src dir. @@ -17,9 +17,11 @@ extCodeDirInWebAppSrcDir :: Path (Rel C.WebAppSrcDir) (Dir GeneratedExternalCode extCodeDirInWebAppSrcDir = SP.fromPathRelDir [P.reldir|ext-src|] generatorStrategy :: ExternalCodeGeneratorStrategy -generatorStrategy = ExternalCodeGeneratorStrategy - { _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInWebAppSrcDir) - , _extCodeDirInProjectRootDir = C.webAppRootDirInProjectRootDir - C.webAppSrcDirInWebAppRootDir - extCodeDirInWebAppSrcDir +generatorStrategy = + ExternalCodeGeneratorStrategy + { _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInWebAppSrcDir), + _extCodeDirInProjectRootDir = + C.webAppRootDirInProjectRootDir + C.webAppSrcDirInWebAppRootDir + extCodeDirInWebAppSrcDir } diff --git a/waspc/src/Generator/WebAppGenerator/OperationsGenerator.hs b/waspc/src/Generator/WebAppGenerator/OperationsGenerator.hs index f79c0cd3f..2724ec2fd 100644 --- a/waspc/src/Generator/WebAppGenerator/OperationsGenerator.hs +++ b/waspc/src/Generator/WebAppGenerator/OperationsGenerator.hs @@ -1,42 +1,48 @@ module Generator.WebAppGenerator.OperationsGenerator - ( genOperations - ) where + ( genOperations, + ) +where -import Data.Aeson (object, - (.=)) -import Data.List (intercalate) -import Data.Maybe (fromJust, - fromMaybe) -import qualified Path as P - -import Generator.FileDraft (FileDraft) -import qualified Generator.ServerGenerator as ServerGenerator -import qualified Generator.ServerGenerator.OperationsRoutesG as ServerOperationsRoutesG -import qualified Generator.WebAppGenerator.Common as C +import Data.Aeson + ( object, + (.=), + ) +import Data.List (intercalate) +import Data.Maybe + ( fromJust, + fromMaybe, + ) +import Generator.FileDraft (FileDraft) +import qualified Generator.ServerGenerator as ServerGenerator +import qualified Generator.ServerGenerator.OperationsRoutesG as ServerOperationsRoutesG +import qualified Generator.WebAppGenerator.Common as C import qualified Generator.WebAppGenerator.OperationsGenerator.ResourcesG as Resources -import Wasp (Wasp) +import qualified Path as P +import Wasp (Wasp) import qualified Wasp import qualified Wasp.Action import qualified Wasp.Operation import qualified Wasp.Query - genOperations :: Wasp -> [FileDraft] -genOperations wasp = concat - [ genQueries wasp - , genActions wasp - , [C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/operations/index.js|]) wasp] - , Resources.genResources wasp +genOperations wasp = + concat + [ genQueries wasp, + genActions wasp, + [C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/operations/index.js|]) wasp], + Resources.genResources wasp ] genQueries :: Wasp -> [FileDraft] -genQueries wasp = concat - [ map (genQuery wasp) (Wasp.getQueries wasp) - , [C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/queries/index.js|]) wasp] +genQueries wasp = + concat + [ map (genQuery wasp) (Wasp.getQueries wasp), + [C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/queries/index.js|]) wasp] ] genActions :: Wasp -> [FileDraft] -genActions wasp = concat +genActions wasp = + concat [ map (genAction wasp) (Wasp.getActions wasp) ] @@ -44,14 +50,17 @@ genQuery :: Wasp -> Wasp.Query.Query -> FileDraft genQuery _ query = C.makeTemplateFD tmplFile dstFile (Just tmplData) where tmplFile = C.asTmplFile [P.relfile|src/queries/_query.js|] - -- | TODO: fromJust here could fail if there is some problem with the name, we should handle this. + dstFile = C.asWebAppFile $ [P.reldir|src/queries/|] P. fromJust (getOperationDstFileName operation) - tmplData = object - [ "queryFnName" .= Wasp.Query._name query - , "queryRoute" .= - (ServerGenerator.operationsRouteInRootRouter - ++ "/" ++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation) - , "entitiesArray" .= makeJsArrayOfEntityNames operation + tmplData = + object + [ "queryFnName" .= Wasp.Query._name query, + "queryRoute" + .= ( ServerGenerator.operationsRouteInRootRouter + ++ "/" + ++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation + ), + "entitiesArray" .= makeJsArrayOfEntityNames operation ] operation = Wasp.Operation.QueryOp query @@ -59,14 +68,17 @@ genAction :: Wasp -> Wasp.Action.Action -> FileDraft genAction _ action = C.makeTemplateFD tmplFile dstFile (Just tmplData) where tmplFile = C.asTmplFile [P.relfile|src/actions/_action.js|] - -- | TODO: fromJust here could fail if there is some problem with the name, we should handle this. + dstFile = C.asWebAppFile $ [P.reldir|src/actions/|] P. fromJust (getOperationDstFileName operation) - tmplData = object - [ "actionFnName" .= Wasp.Action._name action - , "actionRoute" .= - (ServerGenerator.operationsRouteInRootRouter - ++ "/" ++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation) - , "entitiesArray" .= makeJsArrayOfEntityNames operation + tmplData = + object + [ "actionFnName" .= Wasp.Action._name action, + "actionRoute" + .= ( ServerGenerator.operationsRouteInRootRouter + ++ "/" + ++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation + ), + "entitiesArray" .= makeJsArrayOfEntityNames operation ] operation = Wasp.Operation.ActionOp action @@ -74,7 +86,8 @@ genAction _ action = C.makeTemplateFD tmplFile dstFile (Just tmplData) -- E.g. "['Task', 'Project']" makeJsArrayOfEntityNames :: Wasp.Operation.Operation -> String makeJsArrayOfEntityNames operation = "[" ++ intercalate ", " entityStrings ++ "]" - where entityStrings = map (\x -> "'" ++ x ++ "'") $ fromMaybe [] $ Wasp.Operation.getEntities operation + where + entityStrings = map (\x -> "'" ++ x ++ "'") $ fromMaybe [] $ Wasp.Operation.getEntities operation getOperationDstFileName :: Wasp.Operation.Operation -> Maybe (P.Path P.Rel P.File) getOperationDstFileName operation = P.parseRelFile (Wasp.Operation.getName operation ++ ".js") diff --git a/waspc/src/Generator/WebAppGenerator/OperationsGenerator/ResourcesG.hs b/waspc/src/Generator/WebAppGenerator/OperationsGenerator/ResourcesG.hs index 40cdf75ca..f5b3f1842 100644 --- a/waspc/src/Generator/WebAppGenerator/OperationsGenerator/ResourcesG.hs +++ b/waspc/src/Generator/WebAppGenerator/OperationsGenerator/ResourcesG.hs @@ -1,14 +1,13 @@ module Generator.WebAppGenerator.OperationsGenerator.ResourcesG - ( genResources - ) where - -import Data.Aeson (object) -import qualified Path as P - -import Generator.FileDraft (FileDraft) -import qualified Generator.WebAppGenerator.Common as C -import Wasp (Wasp) + ( genResources, + ) +where +import Data.Aeson (object) +import Generator.FileDraft (FileDraft) +import qualified Generator.WebAppGenerator.Common as C +import qualified Path as P +import Wasp (Wasp) genResources :: Wasp -> [FileDraft] genResources _ = [C.makeTemplateFD tmplFile dstFile (Just tmplData)] diff --git a/waspc/src/Generator/WebAppGenerator/RouterGenerator.hs b/waspc/src/Generator/WebAppGenerator/RouterGenerator.hs index 299ad0bca..9d222a0b1 100644 --- a/waspc/src/Generator/WebAppGenerator/RouterGenerator.hs +++ b/waspc/src/Generator/WebAppGenerator/RouterGenerator.hs @@ -1,118 +1,123 @@ module Generator.WebAppGenerator.RouterGenerator - ( generateRouter - ) where + ( generateRouter, + ) +where -import Data.Aeson (ToJSON (..), object, (.=)) -import Data.Maybe (isJust) -import qualified Path as P - -import Generator.FileDraft (FileDraft) -import Generator.WebAppGenerator.Common (asTmplFile, asWebAppSrcFile) +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Maybe (isJust) +import Generator.FileDraft (FileDraft) +import Generator.WebAppGenerator.Common (asTmplFile, asWebAppSrcFile) import qualified Generator.WebAppGenerator.Common as C -import StrongPath (()) -import qualified StrongPath as SP -import Wasp (Wasp) +import qualified Path as P +import StrongPath (()) +import qualified StrongPath as SP +import Wasp (Wasp) import qualified Wasp import qualified Wasp.JsImport import qualified Wasp.Page import qualified Wasp.Route - data RouterTemplateData = RouterTemplateData - { _routes :: ![RouteTemplateData] - , _pagesToImport :: ![PageTemplateData] - , _isAuthEnabled :: Bool - } + { _routes :: ![RouteTemplateData], + _pagesToImport :: ![PageTemplateData], + _isAuthEnabled :: Bool + } instance ToJSON RouterTemplateData where - toJSON routerTD = object - [ "routes" .= _routes routerTD - , "pagesToImport" .= _pagesToImport routerTD - , "isAuthEnabled" .= _isAuthEnabled routerTD - ] + toJSON routerTD = + object + [ "routes" .= _routes routerTD, + "pagesToImport" .= _pagesToImport routerTD, + "isAuthEnabled" .= _isAuthEnabled routerTD + ] data RouteTemplateData = RouteTemplateData - { _urlPath :: !String - , _targetComponent :: !String - } + { _urlPath :: !String, + _targetComponent :: !String + } instance ToJSON RouteTemplateData where - toJSON routeTD = object - [ "urlPath" .= _urlPath routeTD - , "targetComponent" .= _targetComponent routeTD - ] + toJSON routeTD = + object + [ "urlPath" .= _urlPath routeTD, + "targetComponent" .= _targetComponent routeTD + ] data PageTemplateData = PageTemplateData - { _importWhat :: !String - , _importFrom :: !String - } deriving (Show, Eq) + { _importWhat :: !String, + _importFrom :: !String + } + deriving (Show, Eq) instance ToJSON PageTemplateData where - toJSON pageTD = object - [ "importWhat" .= _importWhat pageTD - , "importFrom" .= _importFrom pageTD - ] + toJSON pageTD = + object + [ "importWhat" .= _importWhat pageTD, + "importFrom" .= _importFrom pageTD + ] generateRouter :: Wasp -> FileDraft -generateRouter wasp = C.makeTemplateFD +generateRouter wasp = + C.makeTemplateFD (asTmplFile $ [P.reldir|src|] P. routerPath) targetPath (Just $ toJSON templateData) - where - routerPath = [P.relfile|router.js|] - templateData = createRouterTemplateData wasp - targetPath = C.webAppSrcDirInWebAppRootDir asWebAppSrcFile routerPath + where + routerPath = [P.relfile|router.js|] + templateData = createRouterTemplateData wasp + targetPath = C.webAppSrcDirInWebAppRootDir asWebAppSrcFile routerPath createRouterTemplateData :: Wasp -> RouterTemplateData -createRouterTemplateData wasp = RouterTemplateData - { _routes = routes - , _pagesToImport = pages - , _isAuthEnabled = isJust $ Wasp.getAuth wasp +createRouterTemplateData wasp = + RouterTemplateData + { _routes = routes, + _pagesToImport = pages, + _isAuthEnabled = isJust $ Wasp.getAuth wasp } - where - routes = map (createRouteTemplateData wasp) $ Wasp.getRoutes wasp - pages = map createPageTemplateData $ Wasp.getPages wasp + where + routes = map (createRouteTemplateData wasp) $ Wasp.getRoutes wasp + pages = map createPageTemplateData $ Wasp.getPages wasp createRouteTemplateData :: Wasp -> Wasp.Route.Route -> RouteTemplateData -createRouteTemplateData wasp route = RouteTemplateData - { _urlPath = Wasp.Route._urlPath route - , _targetComponent = determineRouteTargetComponent wasp route +createRouteTemplateData wasp route = + RouteTemplateData + { _urlPath = Wasp.Route._urlPath route, + _targetComponent = determineRouteTargetComponent wasp route } determineRouteTargetComponent :: Wasp -> Wasp.Route.Route -> String determineRouteTargetComponent wasp route = - maybe - targetPageName - determineRouteTargetComponent' - (Wasp.Page._authRequired targetPage) - where - targetPageName = Wasp.Route._targetPage route - -- NOTE(matija): if no page with the name specified in the route, head will fail. - targetPage = head $ filter ((==) targetPageName . Wasp.Page._name) (Wasp.getPages wasp) - - -- | Applied if authRequired property is present. - determineRouteTargetComponent' :: Bool -> String - determineRouteTargetComponent' authRequired = - if authRequired - -- TODO(matija): would be nicer if this function name wasn't hardcoded here. - then "createAuthRequiredPage(" ++ targetPageName ++ ")" - else targetPageName - + maybe + targetPageName + determineRouteTargetComponent' + (Wasp.Page._authRequired targetPage) + where + targetPageName = Wasp.Route._targetPage route + -- NOTE(matija): if no page with the name specified in the route, head will fail. + targetPage = head $ filter ((==) targetPageName . Wasp.Page._name) (Wasp.getPages wasp) + determineRouteTargetComponent' :: Bool -> String + determineRouteTargetComponent' authRequired = + if authRequired + then -- TODO(matija): would be nicer if this function name wasn't hardcoded here. + "createAuthRequiredPage(" ++ targetPageName ++ ")" + else targetPageName createPageTemplateData :: Wasp.Page.Page -> PageTemplateData -createPageTemplateData page = PageTemplateData - { _importFrom = relPathToExtSrcDir ++ - SP.toFilePath (SP.relFileToPosix' $ Wasp.JsImport._from pageComponent) - , _importWhat = case Wasp.JsImport._namedImports pageComponent of - -- If no named imports, we go with the default import. - [] -> pageName - [namedImport] -> "{ " ++ namedImport ++ " as " ++ pageName ++ " }" - _ -> error "Only one named import can be provided for a page." +createPageTemplateData page = + PageTemplateData + { _importFrom = + relPathToExtSrcDir + ++ SP.toFilePath (SP.relFileToPosix' $ Wasp.JsImport._from pageComponent), + _importWhat = case Wasp.JsImport._namedImports pageComponent of + -- If no named imports, we go with the default import. + [] -> pageName + [namedImport] -> "{ " ++ namedImport ++ " as " ++ pageName ++ " }" + _ -> error "Only one named import can be provided for a page." } - where - relPathToExtSrcDir :: FilePath - relPathToExtSrcDir = "./ext-src/" + where + relPathToExtSrcDir :: FilePath + relPathToExtSrcDir = "./ext-src/" - pageName = Wasp.Page._name page - pageComponent = Wasp.Page._component page + pageName = Wasp.Page._name page + pageComponent = Wasp.Page._component page diff --git a/waspc/src/Generator/WebAppGenerator/Setup.hs b/waspc/src/Generator/WebAppGenerator/Setup.hs index e4c7b2d9a..ae5c678b9 100644 --- a/waspc/src/Generator/WebAppGenerator/Setup.hs +++ b/waspc/src/Generator/WebAppGenerator/Setup.hs @@ -1,15 +1,15 @@ module Generator.WebAppGenerator.Setup - ( setupWebApp - ) where + ( setupWebApp, + ) +where -import Generator.Common (ProjectRootDir) -import qualified Generator.Job as J -import Generator.Job.Process (runNodeCommandAsJob) +import Generator.Common (ProjectRootDir) +import qualified Generator.Job as J +import Generator.Job.Process (runNodeCommandAsJob) import qualified Generator.WebAppGenerator.Common as Common -import StrongPath (Abs, Dir, Path, ()) - +import StrongPath (Abs, Dir, Path, ()) setupWebApp :: Path Abs (Dir ProjectRootDir) -> J.Job setupWebApp projectDir = do - let webAppDir = projectDir Common.webAppRootDirInProjectRootDir - runNodeCommandAsJob webAppDir "npm" ["install"] J.WebApp + let webAppDir = projectDir Common.webAppRootDirInProjectRootDir + runNodeCommandAsJob webAppDir "npm" ["install"] J.WebApp diff --git a/waspc/src/Generator/WebAppGenerator/Start.hs b/waspc/src/Generator/WebAppGenerator/Start.hs index 83bb46368..d83542e9c 100644 --- a/waspc/src/Generator/WebAppGenerator/Start.hs +++ b/waspc/src/Generator/WebAppGenerator/Start.hs @@ -1,15 +1,15 @@ module Generator.WebAppGenerator.Start - ( startWebApp - ) where + ( startWebApp, + ) +where -import Generator.Common (ProjectRootDir) -import qualified Generator.Job as J -import Generator.Job.Process (runNodeCommandAsJob) +import Generator.Common (ProjectRootDir) +import qualified Generator.Job as J +import Generator.Job.Process (runNodeCommandAsJob) import qualified Generator.WebAppGenerator.Common as Common -import StrongPath (Abs, Dir, Path, ()) - +import StrongPath (Abs, Dir, Path, ()) startWebApp :: Path Abs (Dir ProjectRootDir) -> J.Job startWebApp projectDir = do - let webAppDir = projectDir Common.webAppRootDirInProjectRootDir - runNodeCommandAsJob webAppDir "npm" ["start"] J.WebApp + let webAppDir = projectDir Common.webAppRootDirInProjectRootDir + runNodeCommandAsJob webAppDir "npm" ["start"] J.WebApp diff --git a/waspc/src/Lexer.hs b/waspc/src/Lexer.hs index 7db028525..08f913376 100644 --- a/waspc/src/Lexer.hs +++ b/waspc/src/Lexer.hs @@ -1,8 +1,8 @@ module Lexer where -import Text.Parsec (letter, alphaNum, (<|>), char, between) -import Text.Parsec.String (Parser) +import Text.Parsec (alphaNum, between, char, letter, (<|>)) import Text.Parsec.Language (emptyDef) +import Text.Parsec.String (Parser) import qualified Text.Parsec.Token as Token reservedNameImport :: String @@ -56,32 +56,33 @@ reservedNameBooleanFalse = "false" reservedNames :: [String] reservedNames = - [ reservedNameImport - , reservedNameFrom + [ reservedNameImport, + reservedNameFrom, -- Wasp element types - , reservedNameApp - , reservedNameDependencies - , reservedNamePage - , reservedNameRoute - , reservedNameEntity - , reservedNameAuth - , reservedNameQuery - , reservedNameAction + reservedNameApp, + reservedNameDependencies, + reservedNamePage, + reservedNameRoute, + reservedNameEntity, + reservedNameAuth, + reservedNameQuery, + reservedNameAction, -- Data types - , reservedNameString - , reservedNameBoolean - , reservedNameBooleanTrue - , reservedNameBooleanFalse - ] + reservedNameString, + reservedNameBoolean, + reservedNameBooleanTrue, + reservedNameBooleanFalse + ] waspLanguageDef :: Token.LanguageDef () -waspLanguageDef = emptyDef - { Token.commentLine = "//" - , Token.reservedNames = reservedNames - , Token.caseSensitive = True - -- Identifier - , Token.identStart = letter - , Token.identLetter = alphaNum <|> char '_' +waspLanguageDef = + emptyDef + { Token.commentLine = "//", + Token.reservedNames = reservedNames, + Token.caseSensitive = True, + -- Identifier + Token.identStart = letter, + Token.identLetter = alphaNum <|> char '_' } waspLexer :: Token.TokenParser () diff --git a/waspc/src/Lib.hs b/waspc/src/Lib.hs index fdf1e89b0..9bd3375f8 100644 --- a/waspc/src/Lib.hs +++ b/waspc/src/Lib.hs @@ -1,72 +1,75 @@ module Lib - ( compile - , Generator.setup - , Generator.start - , ProjectRootDir - ) where + ( compile, + Generator.setup, + Generator.start, + ProjectRootDir, + ) +where -import qualified Path as P -import System.Directory (doesFileExist) - -import Common (WaspProjectDir) -import CompileOptions (CompileOptions) +import Common (WaspProjectDir) +import CompileOptions (CompileOptions) import qualified CompileOptions -import Control.Monad.IO.Class (liftIO) -import Data.List (find, isSuffixOf) +import Control.Monad.IO.Class (liftIO) +import Data.List (find, isSuffixOf) import qualified ExternalCode import qualified Generator -import Generator.Common (ProjectRootDir) +import Generator.Common (ProjectRootDir) import qualified Parser -import StrongPath (Abs, Dir, Path) -import qualified StrongPath as SP +import qualified Path as P +import StrongPath (Abs, Dir, Path) +import qualified StrongPath as SP +import System.Directory (doesFileExist) import qualified Util.IO -import Wasp (Wasp) +import Wasp (Wasp) import qualified Wasp - type CompileError = String -compile :: Path Abs (Dir WaspProjectDir) - -> Path Abs (Dir ProjectRootDir) - -> CompileOptions - -> IO (Either CompileError ()) +compile :: + Path Abs (Dir WaspProjectDir) -> + Path Abs (Dir ProjectRootDir) -> + CompileOptions -> + IO (Either CompileError ()) compile waspDir outDir options = do - maybeWaspFile <- findWaspFile waspDir - case maybeWaspFile of - Nothing -> return $ Left "Couldn't find a single *.wasp file." - Just waspFile -> do - waspStr <- readFile (SP.toFilePath waspFile) + maybeWaspFile <- findWaspFile waspDir + case maybeWaspFile of + Nothing -> return $ Left "Couldn't find a single *.wasp file." + Just waspFile -> do + waspStr <- readFile (SP.toFilePath waspFile) - case Parser.parseWasp waspStr of - Left err -> return $ Left (show err) - Right wasp -> do - maybeDotEnvFile <- findDotEnvFile waspDir - (wasp - `Wasp.setDotEnvFile` maybeDotEnvFile - `enrichWaspASTBasedOnCompileOptions` options - ) >>= generateCode + case Parser.parseWasp waspStr of + Left err -> return $ Left (show err) + Right wasp -> do + maybeDotEnvFile <- findDotEnvFile waspDir + ( wasp + `Wasp.setDotEnvFile` maybeDotEnvFile + `enrichWaspASTBasedOnCompileOptions` options + ) + >>= generateCode where generateCode wasp = Generator.writeWebAppCode wasp outDir options >> return (Right ()) enrichWaspASTBasedOnCompileOptions :: Wasp -> CompileOptions -> IO Wasp enrichWaspASTBasedOnCompileOptions wasp options = do - externalCodeFiles <- ExternalCode.readFiles (CompileOptions.externalCodeDirPath options) - return (wasp - `Wasp.setExternalCodeFiles` externalCodeFiles - `Wasp.setIsBuild` CompileOptions.isBuild options - ) + externalCodeFiles <- ExternalCode.readFiles (CompileOptions.externalCodeDirPath options) + return + ( wasp + `Wasp.setExternalCodeFiles` externalCodeFiles + `Wasp.setIsBuild` CompileOptions.isBuild options + ) findWaspFile :: Path Abs (Dir WaspProjectDir) -> IO (Maybe (Path Abs SP.File)) findWaspFile waspDir = do - (files, _) <- liftIO $ Util.IO.listDirectory (SP.toPathAbsDir waspDir) - return $ (waspDir SP.) . SP.fromPathRelFile <$> find isWaspFile files + (files, _) <- liftIO $ Util.IO.listDirectory (SP.toPathAbsDir waspDir) + return $ (waspDir SP.) . SP.fromPathRelFile <$> find isWaspFile files where - isWaspFile :: P.Path P.Rel P.File -> Bool - isWaspFile path = ".wasp" `isSuffixOf` P.toFilePath path - && (length (P.toFilePath path) > length (".wasp" :: String)) + isWaspFile :: P.Path P.Rel P.File -> Bool + isWaspFile path = + ".wasp" `isSuffixOf` P.toFilePath path + && (length (P.toFilePath path) > length (".wasp" :: String)) findDotEnvFile :: Path Abs (Dir WaspProjectDir) -> IO (Maybe (Path Abs SP.File)) findDotEnvFile waspDir = do - let dotEnvAbsPath = waspDir SP. SP.fromPathRelFile [P.relfile|.env|] - dotEnvExists <- doesFileExist (SP.toFilePath dotEnvAbsPath) - return $ if dotEnvExists then Just dotEnvAbsPath else Nothing + let dotEnvAbsPath = waspDir SP. SP.fromPathRelFile [P.relfile|.env|] + dotEnvExists <- doesFileExist (SP.toFilePath dotEnvAbsPath) + return $ if dotEnvExists then Just dotEnvAbsPath else Nothing diff --git a/waspc/src/NpmDependency.hs b/waspc/src/NpmDependency.hs index 343b8462c..8487a2357 100644 --- a/waspc/src/NpmDependency.hs +++ b/waspc/src/NpmDependency.hs @@ -1,21 +1,23 @@ module NpmDependency - ( NpmDependency (..) - , fromList - ) where - -import Data.Aeson (ToJSON (..), object, (.=)) + ( NpmDependency (..), + fromList, + ) +where +import Data.Aeson (ToJSON (..), object, (.=)) data NpmDependency = NpmDependency - { _name :: !String - , _version :: !String } + { _name :: !String, + _version :: !String + } deriving (Show, Eq) fromList :: [(String, String)] -> [NpmDependency] -fromList = map (\(name, version) -> NpmDependency { _name = name, _version = version }) +fromList = map (\(name, version) -> NpmDependency {_name = name, _version = version}) instance ToJSON NpmDependency where - toJSON npmDep = object - [ "name" .= _name npmDep - , "version" .= _version npmDep - ] + toJSON npmDep = + object + [ "name" .= _name npmDep, + "version" .= _version npmDep + ] diff --git a/waspc/src/Parser.hs b/waspc/src/Parser.hs index 01ee58099..c4a450c46 100644 --- a/waspc/src/Parser.hs +++ b/waspc/src/Parser.hs @@ -1,30 +1,27 @@ module Parser - ( parseWasp - ) where - -import Text.Parsec (ParseError, (<|>), many1, eof, many) -import Text.Parsec.String (Parser) - -import qualified Wasp + ( parseWasp, + ) +where import Lexer - +import qualified Parser.Action import Parser.App (app) import Parser.Auth (auth) -import Parser.Db (db) -import Parser.Route (route) -import Parser.Page (page) -import Parser.Entity (entity) - -import Parser.JsImport (jsImport) import Parser.Common (runWaspParser) -import qualified Parser.Query -import qualified Parser.Action +import Parser.Db (db) +import Parser.Entity (entity) +import Parser.JsImport (jsImport) import qualified Parser.NpmDependencies +import Parser.Page (page) +import qualified Parser.Query +import Parser.Route (route) +import Text.Parsec (ParseError, eof, many, many1, (<|>)) +import Text.Parsec.String (Parser) +import qualified Wasp waspElement :: Parser Wasp.WaspElement -waspElement - = waspElementApp +waspElement = + waspElementApp <|> waspElementAuth <|> waspElementPage <|> waspElementDb @@ -52,7 +49,6 @@ waspElementRoute = Wasp.WaspElementRoute <$> route waspElementEntity :: Parser Wasp.WaspElement waspElementEntity = Wasp.WaspElementEntity <$> entity - waspElementQuery :: Parser Wasp.WaspElement waspElementQuery = Wasp.WaspElementQuery <$> Parser.Query.query @@ -62,26 +58,25 @@ waspElementAction = Wasp.WaspElementAction <$> Parser.Action.action waspElementNpmDependencies :: Parser Wasp.WaspElement waspElementNpmDependencies = Wasp.WaspElementNpmDependencies <$> Parser.NpmDependencies.npmDependencies - -- | Top level parser, produces Wasp. waspParser :: Parser Wasp.Wasp waspParser = do - -- NOTE(matija): this is the only place we need to use whiteSpace, to skip empty lines - -- and comments in the beginning of file. All other used parsers are lexeme parsers - -- so they do it themselves. - whiteSpace + -- NOTE(matija): this is the only place we need to use whiteSpace, to skip empty lines + -- and comments in the beginning of file. All other used parsers are lexeme parsers + -- so they do it themselves. + whiteSpace - jsImports <- many jsImport + jsImports <- many jsImport - waspElems <- many1 waspElement + waspElems <- many1 waspElement - eof + eof - -- TODO(matija): after we parsed everything, we should do semantic analysis - -- e.g. check there is only 1 title - if not, throw a meaningful error. - -- Also, check there is at least one Page defined. + -- TODO(matija): after we parsed everything, we should do semantic analysis + -- e.g. check there is only 1 title - if not, throw a meaningful error. + -- Also, check there is at least one Page defined. - return $ Wasp.fromWaspElems waspElems `Wasp.setJsImports` jsImports + return $ Wasp.fromWaspElems waspElems `Wasp.setJsImports` jsImports -- | Top level parser executor. parseWasp :: String -> Either ParseError Wasp.Wasp diff --git a/waspc/src/Parser/Action.hs b/waspc/src/Parser/Action.hs index c916be893..195fdcae5 100644 --- a/waspc/src/Parser/Action.hs +++ b/waspc/src/Parser/Action.hs @@ -1,23 +1,23 @@ module Parser.Action - ( action - ) where - -import Data.Maybe (fromMaybe) -import Text.Parsec.String (Parser) - -import qualified Lexer as L -import qualified Parser.Common as C -import qualified Parser.Operation as Operation -import Wasp.Action (Action) -import qualified Wasp.Action as Action + ( action, + ) +where +import Data.Maybe (fromMaybe) +import qualified Lexer as L +import qualified Parser.Common as C +import qualified Parser.Operation as Operation +import Text.Parsec.String (Parser) +import Wasp.Action (Action) +import qualified Wasp.Action as Action action :: Parser Action action = do - (name, props) <- C.waspElementNameAndClosureContent L.reservedNameAction Operation.properties - return Action.Action - { Action._name = name - , Action._jsFunction = - fromMaybe (error "Action js function is missing.") (Operation.getJsFunctionFromProps props) - , Action._entities = Operation.getEntitiesFromProps props - } + (name, props) <- C.waspElementNameAndClosureContent L.reservedNameAction Operation.properties + return + Action.Action + { Action._name = name, + Action._jsFunction = + fromMaybe (error "Action js function is missing.") (Operation.getJsFunctionFromProps props), + Action._entities = Operation.getEntitiesFromProps props + } diff --git a/waspc/src/Parser/App.hs b/waspc/src/Parser/App.hs index eb384b1df..f4dd6d024 100644 --- a/waspc/src/Parser/App.hs +++ b/waspc/src/Parser/App.hs @@ -1,29 +1,30 @@ module Parser.App - ( app - ) where + ( app, + ) +where +import Data.Maybe (listToMaybe) +import Lexer +import qualified Lexer as L +import Parser.Common import Text.Parsec import Text.Parsec.String (Parser) -import Data.Maybe (listToMaybe) - -import Lexer import qualified Wasp.App as App -import Parser.Common -import qualified Lexer as L -- | A type that describes supported app properties. data AppProperty - = Title !String - | Favicon !String - | Head [String] - deriving (Show, Eq) + = Title !String + | Favicon !String + | Head [String] + deriving (Show, Eq) -- | Parses supported app properties, expects format "key1: value1, key2: value2, ..." appProperties :: Parser [AppProperty] -appProperties = commaSep1 - $ appPropertyTitle - <|> appPropertyFavicon - <|> appPropertyHead +appProperties = + commaSep1 $ + appPropertyTitle + <|> appPropertyFavicon + <|> appPropertyHead appPropertyTitle :: Parser AppProperty appPropertyTitle = Title <$> waspPropertyStringLiteral "title" @@ -45,11 +46,12 @@ getAppHead ps = listToMaybe [hs | Head hs <- ps] -- | Top level parser, parses App. app :: Parser App.App app = do - (appName, appProps) <- waspElementNameAndClosureContent reservedNameApp appProperties + (appName, appProps) <- waspElementNameAndClosureContent reservedNameApp appProperties - return App.App - { App.appName = appName - , App.appTitle = getAppTitle appProps - , App.appHead = getAppHead appProps - -- TODO(matija): add favicon. - } + return + App.App + { App.appName = appName, + App.appTitle = getAppTitle appProps, + App.appHead = getAppHead appProps + -- TODO(matija): add favicon. + } diff --git a/waspc/src/Parser/Auth.hs b/waspc/src/Parser/Auth.hs index 2cd2227ff..b1d26c710 100644 --- a/waspc/src/Parser/Auth.hs +++ b/waspc/src/Parser/Auth.hs @@ -1,45 +1,47 @@ module Parser.Auth - ( auth - ) where + ( auth, + ) +where -import Text.Parsec.String (Parser) -import Text.Parsec ((<|>)) import Control.Monad (when) - -import qualified Wasp.Auth -import qualified Parser.Common as P import qualified Lexer as L +import qualified Parser.Common as P +import Text.Parsec ((<|>)) +import Text.Parsec.String (Parser) +import qualified Wasp.Auth auth :: Parser Wasp.Auth.Auth auth = do - L.reserved L.reservedNameAuth - authProperties <- P.waspClosure (L.commaSep1 authProperty) + L.reserved L.reservedNameAuth + authProperties <- P.waspClosure (L.commaSep1 authProperty) - let userEntityProps = [s | AuthPropertyUserEntity s <- authProperties] - failIfPropMissing propUserEntityName userEntityProps + let userEntityProps = [s | AuthPropertyUserEntity s <- authProperties] + failIfPropMissing propUserEntityName userEntityProps - let methodsProps = [ms | AuthPropertyMethods ms <- authProperties] - failIfPropMissing propMethodsName methodsProps + let methodsProps = [ms | AuthPropertyMethods ms <- authProperties] + failIfPropMissing propMethodsName methodsProps - let redirectProps = [r | AuthPropertyOnAuthFailedRedirectTo r <- authProperties] - failIfPropMissing propOnAuthFailedRedirectToName redirectProps + let redirectProps = [r | AuthPropertyOnAuthFailedRedirectTo r <- authProperties] + failIfPropMissing propOnAuthFailedRedirectToName redirectProps - return Wasp.Auth.Auth - { Wasp.Auth._userEntity = head userEntityProps - , Wasp.Auth._methods = head methodsProps - , Wasp.Auth._onAuthFailedRedirectTo = head redirectProps - } + return + Wasp.Auth.Auth + { Wasp.Auth._userEntity = head userEntityProps, + Wasp.Auth._methods = head methodsProps, + Wasp.Auth._onAuthFailedRedirectTo = head redirectProps + } -- TODO(matija): this should be extracted if we want to use in other places too. failIfPropMissing :: (Applicative m, MonadFail m) => String -> [p] -> m () failIfPropMissing propName ps = when (null ps) $ fail errorMsg - where errorMsg = propName ++ " is required!" + where + errorMsg = propName ++ " is required!" -- Auxiliary data structure used by parser. data AuthProperty - = AuthPropertyUserEntity String - | AuthPropertyMethods [Wasp.Auth.AuthMethod] - | AuthPropertyOnAuthFailedRedirectTo String + = AuthPropertyUserEntity String + | AuthPropertyMethods [Wasp.Auth.AuthMethod] + | AuthPropertyOnAuthFailedRedirectTo String propUserEntityName :: String propUserEntityName = "userEntity" @@ -53,14 +55,14 @@ propOnAuthFailedRedirectToName = "onAuthFailedRedirectTo" -- Sub-parsers authProperty :: Parser AuthProperty -authProperty - = authPropertyUserEntity +authProperty = + authPropertyUserEntity <|> authPropertyMethods <|> authPropertyOnAuthFailedRedirectTo authPropertyOnAuthFailedRedirectTo :: Parser AuthProperty authPropertyOnAuthFailedRedirectTo = - AuthPropertyOnAuthFailedRedirectTo <$> (P.waspPropertyStringLiteral "onAuthFailedRedirectTo") + AuthPropertyOnAuthFailedRedirectTo <$> (P.waspPropertyStringLiteral "onAuthFailedRedirectTo") authPropertyUserEntity :: Parser AuthProperty authPropertyUserEntity = AuthPropertyUserEntity <$> (P.waspProperty "userEntity" L.identifier) diff --git a/waspc/src/Parser/Common.hs b/waspc/src/Parser/Common.hs index 36537ad0b..55c62ce00 100644 --- a/waspc/src/Parser/Common.hs +++ b/waspc/src/Parser/Common.hs @@ -4,15 +4,19 @@ module Parser.Common where -import qualified Data.Text as T -import qualified Path as P -import qualified Path.Posix as PPosix -import Text.Parsec (ParseError, anyChar, manyTill, parse, try, - unexpected) -import Text.Parsec.String (Parser) - -import qualified Lexer as L - +import qualified Data.Text as T +import qualified Lexer as L +import qualified Path as P +import qualified Path.Posix as PPosix +import Text.Parsec + ( ParseError, + anyChar, + manyTill, + parse, + try, + unexpected, + ) +import Text.Parsec.String (Parser) -- | Runs given wasp parser on a specified input. runWaspParser :: Parser a -> String -> Either ParseError a @@ -24,33 +28,40 @@ runWaspParser waspParser input = parse waspParser sourceName input sourceName = "" -- TODO(matija): rename to just "waspElement"? + -- | Parses declaration of a wasp element (e.g. App or Page) and the closure content. -waspElementNameAndClosureContent - :: String -- ^ Type of the wasp element (e.g. "app" or "page"). - -> Parser a -- ^ Parser to be used for parsing closure content of the wasp element. - -> Parser (String, a) -- ^ Name of the element and parsed closure content. +waspElementNameAndClosureContent :: + -- | Type of the wasp element (e.g. "app" or "page"). + String -> + -- | Parser to be used for parsing closure content of the wasp element. + Parser a -> + -- | Name of the element and parsed closure content. + Parser (String, a) waspElementNameAndClosureContent elementType closureContent = - waspElementNameAndClosure elementType (waspClosure closureContent) + waspElementNameAndClosure elementType (waspClosure closureContent) -- | Parses declaration of a wasp element (e.g. App or Page) and the belonging closure. -waspElementNameAndClosure - :: String -- ^ Element type - -> Parser a -- ^ Closure parser (needs to parse braces as well, not just the content) - -> Parser (String, a) -- ^ Name of the element and parsed closure content. +waspElementNameAndClosure :: + -- | Element type + String -> + -- | Closure parser (needs to parse braces as well, not just the content) + Parser a -> + -- | Name of the element and parsed closure content. + Parser (String, a) waspElementNameAndClosure elementType closure = - -- NOTE(matija): It is important to have `try` here because we don't want to consume the - -- content intended for other parsers. - -- E.g. if we tried to parse "entity-form" this parser would have been tried first for - -- "entity" and would consume "entity", so entity-form parser would also fail. - -- This way when entity parser fails, it will backtrack and allow - -- entity-form parser to succeed. - -- - -- TODO(matija): should I push this try higher, to the specific case of entity parser - -- which is causing the trouble? - -- This way try will be executed in more cases where it is not neccessary, this - -- might not be the best for the performance and the clarity of error messages. - -- On the other hand, it is safer? - try $ do + -- NOTE(matija): It is important to have `try` here because we don't want to consume the + -- content intended for other parsers. + -- E.g. if we tried to parse "entity-form" this parser would have been tried first for + -- "entity" and would consume "entity", so entity-form parser would also fail. + -- This way when entity parser fails, it will backtrack and allow + -- entity-form parser to succeed. + -- + -- TODO(matija): should I push this try higher, to the specific case of entity parser + -- which is causing the trouble? + -- This way try will be executed in more cases where it is not neccessary, this + -- might not be the best for the performance and the clarity of error messages. + -- On the other hand, it is safer? + try $ do L.reserved elementType elementName <- L.identifier closureContent <- closure @@ -59,16 +70,19 @@ waspElementNameAndClosure elementType closure = -- | Parses declaration of a wasp element linked to an entity. -- E.g. "entity-form ..." or "action ..." -waspElementLinkedToEntity - :: String -- ^ Type of the linked wasp element (e.g. "entity-form"). - -> Parser a -- ^ Parser to be used for parsing body of the wasp element. - -> Parser (String, String, a) -- ^ Name of the linked entity, element name and body. +waspElementLinkedToEntity :: + -- | Type of the linked wasp element (e.g. "entity-form"). + String -> + -- | Parser to be used for parsing body of the wasp element. + Parser a -> + -- | Name of the linked entity, element name and body. + Parser (String, String, a) waspElementLinkedToEntity elementType bodyParser = do - L.reserved elementType - linkedEntityName <- L.angles L.identifier - elementName <- L.identifier - body <- bodyParser - return (linkedEntityName, elementName, body) + L.reserved elementType + linkedEntityName <- L.angles L.identifier + elementName <- L.identifier + body <- bodyParser + return (linkedEntityName, elementName, body) -- | Parses wasp property along with the key, "key: value". waspProperty :: String -> Parser a -> Parser a @@ -88,10 +102,10 @@ waspPropertyBool key = waspProperty key L.bool -- form "FIELD_NAME: {...}" -> FIELD_NAME is then an identifier we need. waspPropertyWithIdentifierAsKey :: Parser a -> Parser (String, a) waspPropertyWithIdentifierAsKey valueP = do - identifier <- L.identifier <* L.colon - value <- valueP + identifier <- L.identifier <* L.colon + value <- valueP - return (identifier, value) + return (identifier, value) -- | Parses wasp closure, which is {...}. Returns parsed content within the closure. waspClosure :: Parser a -> Parser a @@ -128,14 +142,15 @@ waspCssClosure :: Parser String waspCssClosure = waspNamedClosure "css" -- TODO(martin): write tests and comments. + -- | Parses named wasp closure, which is {=name...name=}. Returns content within the closure. waspNamedClosure :: String -> Parser String waspNamedClosure name = do - _ <- closureStart - strip <$> manyTill anyChar (try closureEnd) + _ <- closureStart + strip <$> manyTill anyChar (try closureEnd) where - closureStart = L.symbol ("{=" ++ name) - closureEnd = L.symbol (name ++ "=}") + closureStart = L.symbol ("{=" ++ name) + closureEnd = L.symbol (name ++ "=}") -- | Parses a list of items that can be parsed with given parser. -- For example, `waspList L.identifier` will parse "[foo, bar, t]" into ["foo", "bar", "t"]. @@ -149,15 +164,17 @@ strip = T.unpack . T.strip . T.pack -- | Parses relative file path, e.g. "my/file.txt". relFilePathString :: Parser (P.Path P.Rel P.File) relFilePathString = do - path <- L.stringLiteral - maybe (unexpected $ "string \"" ++ path ++ "\": Expected relative file path.") - return - (P.parseRelFile path) + path <- L.stringLiteral + maybe + (unexpected $ "string \"" ++ path ++ "\": Expected relative file path.") + return + (P.parseRelFile path) -- | Parses relative posix file path, e.g. "my/file.txt". relPosixFilePathString :: Parser (PPosix.Path PPosix.Rel PPosix.File) relPosixFilePathString = do - path <- L.stringLiteral - maybe (unexpected $ "string \"" ++ path ++ "\": Expected relative file path.") - return - (PPosix.parseRelFile path) + path <- L.stringLiteral + maybe + (unexpected $ "string \"" ++ path ++ "\": Expected relative file path.") + return + (PPosix.parseRelFile path) diff --git a/waspc/src/Parser/Db.hs b/waspc/src/Parser/Db.hs index b6f846427..1fd5e45b5 100644 --- a/waspc/src/Parser/Db.hs +++ b/waspc/src/Parser/Db.hs @@ -1,36 +1,40 @@ module Parser.Db - ( db - ) where + ( db, + ) +where -import Text.Parsec.String (Parser) -import Text.Parsec ((<|>), try) -import Data.Maybe (listToMaybe, fromMaybe) - -import qualified Wasp.Db -import qualified Parser.Common as P +import Data.Maybe (fromMaybe, listToMaybe) import qualified Lexer as L +import qualified Parser.Common as P +import Text.Parsec (try, (<|>)) +import Text.Parsec.String (Parser) +import qualified Wasp.Db db :: Parser Wasp.Db.Db db = do - L.reserved L.reservedNameDb - dbProperties <- P.waspClosure (L.commaSep1 dbProperty) + L.reserved L.reservedNameDb + dbProperties <- P.waspClosure (L.commaSep1 dbProperty) - system <- fromMaybe (fail "'system' property is required!") $ return <$> - listToMaybe [p | DbPropertySystem p <- dbProperties] + system <- + fromMaybe (fail "'system' property is required!") $ + return + <$> listToMaybe [p | DbPropertySystem p <- dbProperties] - return Wasp.Db.Db - { Wasp.Db._system = system - } + return + Wasp.Db.Db + { Wasp.Db._system = system + } data DbProperty - = DbPropertySystem Wasp.Db.DbSystem + = DbPropertySystem Wasp.Db.DbSystem dbProperty :: Parser DbProperty -dbProperty - = dbPropertySystem +dbProperty = + dbPropertySystem dbPropertySystem :: Parser DbProperty dbPropertySystem = DbPropertySystem <$> (P.waspProperty "system" dbPropertySystemValue) where - dbPropertySystemValue = try (L.symbol "PostgreSQL" >> return Wasp.Db.PostgreSQL) - <|> try (L.symbol "SQLite" >> return Wasp.Db.SQLite) + dbPropertySystemValue = + try (L.symbol "PostgreSQL" >> return Wasp.Db.PostgreSQL) + <|> try (L.symbol "SQLite" >> return Wasp.Db.SQLite) diff --git a/waspc/src/Parser/Entity.hs b/waspc/src/Parser/Entity.hs index 06391cbc6..ad53dda9c 100644 --- a/waspc/src/Parser/Entity.hs +++ b/waspc/src/Parser/Entity.hs @@ -1,27 +1,28 @@ module Parser.Entity - ( entity - ) where + ( entity, + ) +where -import Text.Parsec.String (Parser) - -import qualified Lexer as L -import qualified Psl.Ast.Model as PslModel +import qualified Lexer as L +import qualified Psl.Ast.Model as PslModel import qualified Psl.Parser.Model -import qualified Wasp.Entity as Entity +import Text.Parsec.String (Parser) +import qualified Wasp.Entity as Entity entity :: Parser Entity.Entity entity = do - _ <- L.reserved L.reservedNameEntity - name <- L.identifier - _ <- L.symbol "{=psl" - pslModelBody <- Psl.Parser.Model.body - _ <- L.symbol "psl=}" + _ <- L.reserved L.reservedNameEntity + name <- L.identifier + _ <- L.symbol "{=psl" + pslModelBody <- Psl.Parser.Model.body + _ <- L.symbol "psl=}" - return Entity.Entity - { Entity._name = name - , Entity._fields = getEntityFields pslModelBody - , Entity._pslModelBody = pslModelBody - } + return + Entity.Entity + { Entity._name = name, + Entity._fields = getEntityFields pslModelBody, + Entity._pslModelBody = pslModelBody + } getEntityFields :: PslModel.Body -> [Entity.Field] getEntityFields (PslModel.Body pslElements) = map pslFieldToEntityField pslFields @@ -29,35 +30,37 @@ getEntityFields (PslModel.Body pslElements) = map pslFieldToEntityField pslField pslFields = [field | (PslModel.ElementField field) <- pslElements] pslFieldToEntityField :: PslModel.Field -> Entity.Field - pslFieldToEntityField pslField = Entity.Field - { Entity._fieldName = PslModel._name pslField - , Entity._fieldType = pslFieldTypeToEntityFieldType - (PslModel._type pslField) - (PslModel._typeModifiers pslField) + pslFieldToEntityField pslField = + Entity.Field + { Entity._fieldName = PslModel._name pslField, + Entity._fieldType = + pslFieldTypeToEntityFieldType + (PslModel._type pslField) + (PslModel._typeModifiers pslField) } - pslFieldTypeToEntityFieldType - :: PslModel.FieldType - -> [PslModel.FieldTypeModifier] - -> Entity.FieldType + pslFieldTypeToEntityFieldType :: + PslModel.FieldType -> + [PslModel.FieldTypeModifier] -> + Entity.FieldType pslFieldTypeToEntityFieldType fType fTypeModifiers = - let scalar = pslFieldTypeToScalar fType - in case fTypeModifiers of - [] -> Entity.FieldTypeScalar scalar - [PslModel.List] -> Entity.FieldTypeComposite $ Entity.List scalar - [PslModel.Optional] -> Entity.FieldTypeComposite $ Entity.Optional scalar - _ -> error "Not a valid list of modifiers." + let scalar = pslFieldTypeToScalar fType + in case fTypeModifiers of + [] -> Entity.FieldTypeScalar scalar + [PslModel.List] -> Entity.FieldTypeComposite $ Entity.List scalar + [PslModel.Optional] -> Entity.FieldTypeComposite $ Entity.Optional scalar + _ -> error "Not a valid list of modifiers." pslFieldTypeToScalar :: PslModel.FieldType -> Entity.Scalar pslFieldTypeToScalar fType = case fType of - PslModel.String -> Entity.String - PslModel.Boolean -> Entity.Boolean - PslModel.Int -> Entity.Int - PslModel.BigInt -> Entity.BigInt - PslModel.Float -> Entity.Float - PslModel.Decimal -> Entity.Decimal - PslModel.DateTime -> Entity.DateTime - PslModel.Json -> Entity.Json - PslModel.Bytes -> Entity.Bytes - PslModel.UserType typeName -> Entity.UserType typeName - PslModel.Unsupported typeName -> Entity.Unsupported typeName + PslModel.String -> Entity.String + PslModel.Boolean -> Entity.Boolean + PslModel.Int -> Entity.Int + PslModel.BigInt -> Entity.BigInt + PslModel.Float -> Entity.Float + PslModel.Decimal -> Entity.Decimal + PslModel.DateTime -> Entity.DateTime + PslModel.Json -> Entity.Json + PslModel.Bytes -> Entity.Bytes + PslModel.UserType typeName -> Entity.UserType typeName + PslModel.Unsupported typeName -> Entity.Unsupported typeName diff --git a/waspc/src/Parser/ExternalCode.hs b/waspc/src/Parser/ExternalCode.hs index 85fa6279b..9c732027c 100644 --- a/waspc/src/Parser/ExternalCode.hs +++ b/waspc/src/Parser/ExternalCode.hs @@ -1,23 +1,23 @@ module Parser.ExternalCode - ( extCodeFilePathString - ) where + ( extCodeFilePathString, + ) +where -import qualified Path.Posix as PPosix -import Text.Parsec (unexpected) -import Text.Parsec.String (Parser) - -import ExternalCode (SourceExternalCodeDir) +import ExternalCode (SourceExternalCodeDir) import qualified Parser.Common -import StrongPath (File, Path', Posix, Rel) -import qualified StrongPath as SP - +import qualified Path.Posix as PPosix +import StrongPath (File, Path', Posix, Rel) +import qualified StrongPath as SP +import Text.Parsec (unexpected) +import Text.Parsec.String (Parser) -- Parses string literal that is file path to file in source external code dir. -- Returns file path relative to the external code dir. -- Example of input: "@ext/some/file.txt". Output would be: "some/file.txt". extCodeFilePathString :: Parser (Path' Posix (Rel SourceExternalCodeDir) File) extCodeFilePathString = do - path <- Parser.Common.relPosixFilePathString - maybe (unexpected $ "string \"" ++ show path ++ "\": External code file path should start with \"@ext/\".") - (return . SP.fromPathRelFileP) - (PPosix.stripProperPrefix [PPosix.reldir|@ext|] path) + path <- Parser.Common.relPosixFilePathString + maybe + (unexpected $ "string \"" ++ show path ++ "\": External code file path should start with \"@ext/\".") + (return . SP.fromPathRelFileP) + (PPosix.stripProperPrefix [PPosix.reldir|@ext|] path) diff --git a/waspc/src/Parser/JsCode.hs b/waspc/src/Parser/JsCode.hs index 65713ca13..84e4da483 100644 --- a/waspc/src/Parser/JsCode.hs +++ b/waspc/src/Parser/JsCode.hs @@ -1,11 +1,11 @@ module Parser.JsCode - ( jsCode - ) where + ( jsCode, + ) +where -import Text.Parsec.String (Parser) import qualified Data.Text as Text - import qualified Parser.Common as P +import Text.Parsec.String (Parser) import qualified Wasp.JsCode as WJS jsCode :: Parser WJS.JsCode diff --git a/waspc/src/Parser/JsImport.hs b/waspc/src/Parser/JsImport.hs index 8dddccade..dddc1011a 100644 --- a/waspc/src/Parser/JsImport.hs +++ b/waspc/src/Parser/JsImport.hs @@ -1,31 +1,32 @@ module Parser.JsImport - ( jsImport - ) where + ( jsImport, + ) +where +import qualified Lexer as L +import qualified Parser.ExternalCode import Text.Parsec ((<|>)) import Text.Parsec.String (Parser) - -import qualified Parser.ExternalCode -import qualified Lexer as L import qualified Wasp.JsImport - -- | Parses subset of JS import statement (only default or single named import, and only external code files): -- import from "@ext/..." -- import { } from "@ext/..." jsImport :: Parser Wasp.JsImport.JsImport jsImport = do - L.whiteSpace - _ <- L.reserved L.reservedNameImport - -- For now we support only default import or one named import. - (defaultImport, namedImports) <- ((\i -> (Just i, [])) <$> L.identifier) - <|> ((\i -> (Nothing, [i])) <$> L.braces L.identifier) - _ <- L.reserved L.reservedNameFrom - -- TODO: For now we only support double quotes here, we should also support single quotes. - -- We would need to write this from scratch, with single quote escaping enabled. - from <- Parser.ExternalCode.extCodeFilePathString - return Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = defaultImport - , Wasp.JsImport._namedImports = namedImports - , Wasp.JsImport._from = from - } + L.whiteSpace + _ <- L.reserved L.reservedNameImport + -- For now we support only default import or one named import. + (defaultImport, namedImports) <- + ((\i -> (Just i, [])) <$> L.identifier) + <|> ((\i -> (Nothing, [i])) <$> L.braces L.identifier) + _ <- L.reserved L.reservedNameFrom + -- TODO: For now we only support double quotes here, we should also support single quotes. + -- We would need to write this from scratch, with single quote escaping enabled. + from <- Parser.ExternalCode.extCodeFilePathString + return + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = defaultImport, + Wasp.JsImport._namedImports = namedImports, + Wasp.JsImport._from = from + } diff --git a/waspc/src/Parser/NpmDependencies.hs b/waspc/src/Parser/NpmDependencies.hs index d614de2b9..13b7489b3 100644 --- a/waspc/src/Parser/NpmDependencies.hs +++ b/waspc/src/Parser/NpmDependencies.hs @@ -1,31 +1,31 @@ module Parser.NpmDependencies - ( npmDependencies - ) where + ( npmDependencies, + ) +where -import qualified Data.Aeson as Aeson +import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy.UTF8 as BLU -import qualified Data.HashMap.Strict as M -import Text.Parsec (try) -import Text.Parsec.String (Parser) - -import qualified Lexer as L -import qualified NpmDependency as ND -import qualified Parser.Common as P -import Wasp.NpmDependencies (NpmDependencies) -import qualified Wasp.NpmDependencies as NpmDependencies - +import qualified Data.HashMap.Strict as M +import qualified Lexer as L +import qualified NpmDependency as ND +import qualified Parser.Common as P +import Text.Parsec (try) +import Text.Parsec.String (Parser) +import Wasp.NpmDependencies (NpmDependencies) +import qualified Wasp.NpmDependencies as NpmDependencies npmDependencies :: Parser NpmDependencies npmDependencies = try $ do - L.reserved L.reservedNameDependencies - closureContent <- P.waspNamedClosure "json" - let jsonBytestring = BLU.fromString $ "{ " ++ closureContent ++ " }" - npmDeps <- case Aeson.eitherDecode' jsonBytestring :: Either String (M.HashMap String String) of - Left errorMessage -> fail $ "Failed to parse dependencies JSON: " ++ errorMessage - Right rawDeps -> return $ map rawDepToNpmDep (M.toList rawDeps) - return NpmDependencies.NpmDependencies - { NpmDependencies._dependencies = npmDeps - } + L.reserved L.reservedNameDependencies + closureContent <- P.waspNamedClosure "json" + let jsonBytestring = BLU.fromString $ "{ " ++ closureContent ++ " }" + npmDeps <- case Aeson.eitherDecode' jsonBytestring :: Either String (M.HashMap String String) of + Left errorMessage -> fail $ "Failed to parse dependencies JSON: " ++ errorMessage + Right rawDeps -> return $ map rawDepToNpmDep (M.toList rawDeps) + return + NpmDependencies.NpmDependencies + { NpmDependencies._dependencies = npmDeps + } where rawDepToNpmDep :: (String, String) -> ND.NpmDependency - rawDepToNpmDep (name, version) = ND.NpmDependency { ND._name = name, ND._version = version } + rawDepToNpmDep (name, version) = ND.NpmDependency {ND._name = name, ND._version = version} diff --git a/waspc/src/Parser/Operation.hs b/waspc/src/Parser/Operation.hs index 33f559670..467109680 100644 --- a/waspc/src/Parser/Operation.hs +++ b/waspc/src/Parser/Operation.hs @@ -1,31 +1,32 @@ module Parser.Operation - ( jsFunctionPropParser - , entitiesPropParser - , getJsFunctionFromProps - , getEntitiesFromProps - , properties + ( jsFunctionPropParser, + entitiesPropParser, + getJsFunctionFromProps, + getEntitiesFromProps, + properties, -- FOR TESTS: - , Property(..) - ) where + Property (..), + ) +where -import Data.Maybe (listToMaybe) -import Text.Parsec ((<|>)) -import Text.Parsec.String (Parser) - -import qualified Lexer as L -import qualified Parser.Common as C +import Data.Maybe (listToMaybe) +import qualified Lexer as L +import qualified Parser.Common as C import qualified Parser.JsImport +import Text.Parsec ((<|>)) +import Text.Parsec.String (Parser) import qualified Wasp.JsImport - -data Property = JsFunction !Wasp.JsImport.JsImport - | Entities ![String] - deriving (Show, Eq) +data Property + = JsFunction !Wasp.JsImport.JsImport + | Entities ![String] + deriving (Show, Eq) properties :: Parser [Property] -properties = L.commaSep1 $ +properties = + L.commaSep1 $ jsFunctionPropParser - <|> entitiesPropParser + <|> entitiesPropParser jsFunctionPropParser :: Parser Property jsFunctionPropParser = JsFunction <$> C.waspProperty "fn" Parser.JsImport.jsImport diff --git a/waspc/src/Parser/Page.hs b/waspc/src/Parser/Page.hs index a8c5869cb..9cb467e2a 100644 --- a/waspc/src/Parser/Page.hs +++ b/waspc/src/Parser/Page.hs @@ -1,30 +1,30 @@ module Parser.Page - ( page - ) where - -import Text.Parsec -import Text.Parsec.String (Parser) -import Data.Maybe (listToMaybe, fromMaybe) - -import qualified Wasp.Page as Page -import Wasp.JsImport (JsImport) + ( page, + ) +where +import Data.Maybe (fromMaybe, listToMaybe) import Lexer import Parser.Common import qualified Parser.JsImport +import Text.Parsec +import Text.Parsec.String (Parser) +import Wasp.JsImport (JsImport) +import qualified Wasp.Page as Page data PageProperty - = Title !String - | Component !JsImport - | AuthRequired !Bool - deriving (Show, Eq) + = Title !String + | Component !JsImport + | AuthRequired !Bool + deriving (Show, Eq) -- | Parses Page properties, separated by a comma. pageProperties :: Parser [PageProperty] -pageProperties = commaSep1 $ +pageProperties = + commaSep1 $ pagePropertyTitle - <|> pagePropertyComponent - <|> pagePropertyAuthRequired + <|> pagePropertyComponent + <|> pagePropertyAuthRequired -- NOTE(matija): this is currently unused? pagePropertyTitle :: Parser PageProperty @@ -45,10 +45,11 @@ getPageComponent ps = listToMaybe [c | Component c <- ps] -- | Top level parser, parses Page. page :: Parser Page.Page page = do - (pageName, pageProps) <- waspElementNameAndClosureContent reservedNamePage pageProperties + (pageName, pageProps) <- waspElementNameAndClosureContent reservedNamePage pageProperties - return Page.Page - { Page._name = pageName - , Page._component = fromMaybe (error "Page component is missing.") (getPageComponent pageProps) - , Page._authRequired = getPageAuthRequired pageProps - } + return + Page.Page + { Page._name = pageName, + Page._component = fromMaybe (error "Page component is missing.") (getPageComponent pageProps), + Page._authRequired = getPageAuthRequired pageProps + } diff --git a/waspc/src/Parser/Query.hs b/waspc/src/Parser/Query.hs index 20789adbb..65e4f9523 100644 --- a/waspc/src/Parser/Query.hs +++ b/waspc/src/Parser/Query.hs @@ -1,23 +1,23 @@ module Parser.Query - ( query - ) where - -import Data.Maybe (fromMaybe) -import Text.Parsec.String (Parser) - -import qualified Lexer as L -import qualified Parser.Common as C -import qualified Parser.Operation as Operation -import Wasp.Query (Query) -import qualified Wasp.Query as Query + ( query, + ) +where +import Data.Maybe (fromMaybe) +import qualified Lexer as L +import qualified Parser.Common as C +import qualified Parser.Operation as Operation +import Text.Parsec.String (Parser) +import Wasp.Query (Query) +import qualified Wasp.Query as Query query :: Parser Query query = do - (name, props) <- C.waspElementNameAndClosureContent L.reservedNameQuery Operation.properties - return Query.Query - { Query._name = name - , Query._jsFunction = - fromMaybe (error "Query js function is missing.") (Operation.getJsFunctionFromProps props) - , Query._entities = Operation.getEntitiesFromProps props - } + (name, props) <- C.waspElementNameAndClosureContent L.reservedNameQuery Operation.properties + return + Query.Query + { Query._name = name, + Query._jsFunction = + fromMaybe (error "Query js function is missing.") (Operation.getJsFunctionFromProps props), + Query._entities = Operation.getEntitiesFromProps props + } diff --git a/waspc/src/Parser/Route.hs b/waspc/src/Parser/Route.hs index d8bda58dd..6fef8f79a 100644 --- a/waspc/src/Parser/Route.hs +++ b/waspc/src/Parser/Route.hs @@ -1,26 +1,26 @@ module Parser.Route - ( route - ) where - -import Text.Parsec.String (Parser) + ( route, + ) +where import qualified Lexer as L +import Text.Parsec.String (Parser) import qualified Wasp.Route as Route -- | Top level parser, parses route Wasp element. route :: Parser Route.Route route = do - -- route "some/url/path" - L.reserved L.reservedNameRoute - urlPath <- L.stringLiteral + -- route "some/url/path" + L.reserved L.reservedNameRoute + urlPath <- L.stringLiteral - -- -> page somePage - L.reserved "->" - L.reserved L.reservedNamePage - targetPage <- L.identifier - - return Route.Route - { Route._urlPath = urlPath - , Route._targetPage = targetPage - } + -- -> page somePage + L.reserved "->" + L.reserved L.reservedNamePage + targetPage <- L.identifier + return + Route.Route + { Route._urlPath = urlPath, + Route._targetPage = targetPage + } diff --git a/waspc/src/Parser/Style.hs b/waspc/src/Parser/Style.hs index d6ccb60bb..38523efbd 100644 --- a/waspc/src/Parser/Style.hs +++ b/waspc/src/Parser/Style.hs @@ -1,16 +1,15 @@ module Parser.Style - ( style - ) where + ( style, + ) +where -import Text.Parsec ((<|>)) -import Text.Parsec.String (Parser) import qualified Data.Text as Text - import qualified Parser.Common import qualified Parser.ExternalCode +import Text.Parsec ((<|>)) +import Text.Parsec.String (Parser) import qualified Wasp.Style - style :: Parser Wasp.Style.Style style = cssFile <|> cssCode diff --git a/waspc/src/Path/Extra.hs b/waspc/src/Path/Extra.hs index ad9ca5c13..2c4ed8396 100644 --- a/waspc/src/Path/Extra.hs +++ b/waspc/src/Path/Extra.hs @@ -1,11 +1,12 @@ module Path.Extra - ( reversePosixPath - , toPosixFilePath - ) where + ( reversePosixPath, + toPosixFilePath, + ) +where import Control.Exception (assert) -import qualified System.FilePath.Posix as FPP import Path +import qualified System.FilePath.Posix as FPP -- | For given posix path P, returns posix path P', such that (terminal pseudocode incoming) -- `pwd == (cd P && cd P' && pwd)`, or to put it differently, such that @@ -14,9 +15,10 @@ import Path -- (e.g. reversePath "foo/bar" == "../.."). reversePosixPath :: FilePath -> FilePath reversePosixPath path - | null parts = "." - | otherwise = assert (".." `notElem` parts) $ - FPP.joinPath $ map (const "..") parts + | null parts = "." + | otherwise = + assert (".." `notElem` parts) $ + FPP.joinPath $ map (const "..") parts where parts :: [String] parts = filter (/= ".") $ FPP.splitDirectories path diff --git a/waspc/src/Psl/Ast/Model.hs b/waspc/src/Psl/Ast/Model.hs index 3de589659..f4bfefdcd 100644 --- a/waspc/src/Psl/Ast/Model.hs +++ b/waspc/src/Psl/Ast/Model.hs @@ -1,42 +1,45 @@ module Psl.Ast.Model where -data Model = Model - String -- ^ Name of the model - Body - deriving (Show, Eq) +data Model + = Model + String + -- ^ Name of the model + Body + deriving (Show, Eq) newtype Body = Body [Element] - deriving (Show, Eq) + deriving (Show, Eq) data Element = ElementField Field | ElementBlockAttribute Attribute - deriving (Show, Eq) + deriving (Show, Eq) -- TODO: To support attributes before the field, -- we could just have `attrsBefore :: [[Attr]]`, -- which represents lines, each one with list of attributes. data Field = Field - { _name :: String - , _type :: FieldType - , _typeModifiers :: [FieldTypeModifier] - , _attrs :: [Attribute] - } - deriving (Show, Eq) + { _name :: String, + _type :: FieldType, + _typeModifiers :: [FieldTypeModifier], + _attrs :: [Attribute] + } + deriving (Show, Eq) -data FieldType = String - | Boolean - | Int - | BigInt - | Float - | Decimal - | DateTime - | Json - | Bytes - | Unsupported String - | UserType String - deriving (Show, Eq) +data FieldType + = String + | Boolean + | Int + | BigInt + | Float + | Decimal + | DateTime + | Json + | Bytes + | Unsupported String + | UserType String + deriving (Show, Eq) data FieldTypeModifier = List | Optional - deriving (Show, Eq) + deriving (Show, Eq) -- NOTE: We don't differentiate "native database type" attributes from normal attributes right now, -- they are all represented with `data Attribute`. @@ -44,19 +47,19 @@ data FieldTypeModifier = List | Optional -- TODO: In the future, we might want to be "smarter" about this and actually have a special representation -- for them -> but let's see if that will be needed. data Attribute = Attribute - { _attrName :: String - , _attrArgs :: [AttributeArg] - } - deriving (Show, Eq) + { _attrName :: String, + _attrArgs :: [AttributeArg] + } + deriving (Show, Eq) data AttributeArg = AttrArgNamed String AttrArgValue | AttrArgUnnamed AttrArgValue - deriving (Show, Eq) + deriving (Show, Eq) data AttrArgValue - = AttrArgString String - | AttrArgIdentifier String - | AttrArgFunc String - | AttrArgFieldRefList [String] - | AttrArgNumber String - | AttrArgUnknown String - deriving (Show, Eq) + = AttrArgString String + | AttrArgIdentifier String + | AttrArgFunc String + | AttrArgFieldRefList [String] + | AttrArgNumber String + | AttrArgUnknown String + deriving (Show, Eq) diff --git a/waspc/src/Psl/Generator/Model.hs b/waspc/src/Psl/Generator/Model.hs index 3542836a1..1cd3eb6e1 100644 --- a/waspc/src/Psl/Generator/Model.hs +++ b/waspc/src/Psl/Generator/Model.hs @@ -1,12 +1,11 @@ module Psl.Generator.Model - ( generateModel - ) where - -import Data.List (intercalate) + ( generateModel, + ) +where +import Data.List (intercalate) import qualified Psl.Ast.Model as Ast - generateModel :: Ast.Model -> String generateModel (Ast.Model name body) = "model " ++ name ++ " {\n" ++ generateBody body ++ "\n}" @@ -15,37 +14,38 @@ generateBody (Ast.Body elements) = unlines $ map ((" " ++) . generateElement) e generateElement :: Ast.Element -> String generateElement (Ast.ElementField field) = - Ast._name field ++ " " - ++ generateFieldType (Ast._type field) ++ concatMap generateFieldTypeModifier (Ast._typeModifiers field) + Ast._name field ++ " " + ++ generateFieldType (Ast._type field) + ++ concatMap generateFieldTypeModifier (Ast._typeModifiers field) ++ concatMap ((" " ++) . generateAttribute) (Ast._attrs field) generateElement (Ast.ElementBlockAttribute attribute) = - "@" ++ generateAttribute attribute + "@" ++ generateAttribute attribute generateFieldType :: Ast.FieldType -> String generateFieldType fieldType = case fieldType of - Ast.String -> "String" - Ast.Boolean -> "Boolean" - Ast.Int -> "Int" - Ast.BigInt -> "BigInt" - Ast.Float -> "Float" - Ast.Decimal -> "Decimal" - Ast.DateTime -> "DateTime" - Ast.Json -> "Json" - Ast.Bytes -> "Bytes" - Ast.UserType label -> label - Ast.Unsupported typeName -> "Unsupported(" ++ show typeName ++ ")" + Ast.String -> "String" + Ast.Boolean -> "Boolean" + Ast.Int -> "Int" + Ast.BigInt -> "BigInt" + Ast.Float -> "Float" + Ast.Decimal -> "Decimal" + Ast.DateTime -> "DateTime" + Ast.Json -> "Json" + Ast.Bytes -> "Bytes" + Ast.UserType label -> label + Ast.Unsupported typeName -> "Unsupported(" ++ show typeName ++ ")" generateFieldTypeModifier :: Ast.FieldTypeModifier -> String generateFieldTypeModifier typeModifier = case typeModifier of - Ast.List -> "[]" - Ast.Optional -> "?" + Ast.List -> "[]" + Ast.Optional -> "?" generateAttribute :: Ast.Attribute -> String generateAttribute attribute = - "@" ++ Ast._attrName attribute + "@" ++ Ast._attrName attribute ++ if null (Ast._attrArgs attribute) - then "" - else "(" ++ intercalate ", " (map generateAttributeArg (Ast._attrArgs attribute)) ++ ")" + then "" + else "(" ++ intercalate ", " (map generateAttributeArg (Ast._attrArgs attribute)) ++ ")" generateAttributeArg :: Ast.AttributeArg -> String generateAttributeArg (Ast.AttrArgNamed name value) = name ++ ": " ++ generateAttrArgValue value @@ -53,12 +53,12 @@ generateAttributeArg (Ast.AttrArgUnnamed value) = generateAttrArgValue value generateAttrArgValue :: Ast.AttrArgValue -> String generateAttrArgValue value = case value of - Ast.AttrArgString strValue -> show strValue - Ast.AttrArgIdentifier identifier -> identifier - Ast.AttrArgFunc funcName -> funcName ++ "()" - Ast.AttrArgFieldRefList refs -> "[" ++ intercalate ", " refs ++ "]" - Ast.AttrArgNumber numberStr -> numberStr - Ast.AttrArgUnknown unknownStr -> unknownStr + Ast.AttrArgString strValue -> show strValue + Ast.AttrArgIdentifier identifier -> identifier + Ast.AttrArgFunc funcName -> funcName ++ "()" + Ast.AttrArgFieldRefList refs -> "[" ++ intercalate ", " refs ++ "]" + Ast.AttrArgNumber numberStr -> numberStr + Ast.AttrArgUnknown unknownStr -> unknownStr -- TODO: I should make sure to skip attributes that are not known in prisma. -- Or maybe it would be better if that was done in previous step, where diff --git a/waspc/src/Psl/Parser/Model.hs b/waspc/src/Psl/Parser/Model.hs index c6d5d1d17..a49034fef 100644 --- a/waspc/src/Psl/Parser/Model.hs +++ b/waspc/src/Psl/Parser/Model.hs @@ -1,19 +1,30 @@ module Psl.Parser.Model - ( model - , body + ( model, + body, -- NOTE: Only for testing: - , attrArgument - ) where + attrArgument, + ) +where -import Data.Maybe (fromMaybe, maybeToList) -import Text.Parsec (alphaNum, char, choice, letter, - lookAhead, many, many1, noneOf, oneOf, - optionMaybe, try, (<|>)) -import Text.Parsec.Language (emptyDef) -import Text.Parsec.String (Parser) -import qualified Text.Parsec.Token as T - -import qualified Psl.Ast.Model as Model +import Data.Maybe (fromMaybe, maybeToList) +import qualified Psl.Ast.Model as Model +import Text.Parsec + ( alphaNum, + char, + choice, + letter, + lookAhead, + many, + many1, + noneOf, + oneOf, + optionMaybe, + try, + (<|>), + ) +import Text.Parsec.Language (emptyDef) +import Text.Parsec.String (Parser) +import qualified Text.Parsec.Token as T -- | Parses PSL (Prisma Schema Language model). -- Example of PSL model: @@ -24,123 +35,133 @@ import qualified Psl.Ast.Model as Model -- } model :: Parser Model.Model model = do - T.whiteSpace lexer - _ <- T.symbol lexer "model" - modelName <- T.identifier lexer - Model.Model modelName <$> T.braces lexer body + T.whiteSpace lexer + _ <- T.symbol lexer "model" + modelName <- T.identifier lexer + Model.Model modelName <$> T.braces lexer body -- | Parses body of the PSL (Prisma Schema Language) model, -- which is everything besides model keyword, name and braces: -- `model User { }`. body :: Parser Model.Body body = do - T.whiteSpace lexer - Model.Body <$> many1 element + T.whiteSpace lexer + Model.Body <$> many1 element element :: Parser Model.Element -element = try (Model.ElementField <$> field) <|> - try (Model.ElementBlockAttribute <$> blockAttribute) +element = + try (Model.ElementField <$> field) + <|> try (Model.ElementBlockAttribute <$> blockAttribute) field :: Parser Model.Field field = do - name <- T.identifier lexer - type' <- fieldType - maybeTypeModifier <- fieldTypeModifier - attrs <- many (try attribute) - return $ Model.Field - { Model._name = name - , Model._type = type' - , Model._typeModifiers = maybeToList maybeTypeModifier - , Model._attrs = attrs - } + name <- T.identifier lexer + type' <- fieldType + maybeTypeModifier <- fieldTypeModifier + attrs <- many (try attribute) + return $ + Model.Field + { Model._name = name, + Model._type = type', + Model._typeModifiers = maybeToList maybeTypeModifier, + Model._attrs = attrs + } where fieldType :: Parser Model.FieldType fieldType = - (foldl1 (<|>) $ - map (\(s, t) -> try (T.symbol lexer s) >> return t) - [ ("String", Model.String) - , ("Boolean", Model.Boolean) - , ("Int", Model.Int) - , ("BigInt", Model.BigInt) - , ("Float", Model.Float) - , ("Decimal", Model.Decimal) - , ("DateTime", Model.DateTime) - , ("Json", Model.Json) - , ("Bytes", Model.Bytes) - ] - ) + ( foldl1 (<|>) $ + map + (\(s, t) -> try (T.symbol lexer s) >> return t) + [ ("String", Model.String), + ("Boolean", Model.Boolean), + ("Int", Model.Int), + ("BigInt", Model.BigInt), + ("Float", Model.Float), + ("Decimal", Model.Decimal), + ("DateTime", Model.DateTime), + ("Json", Model.Json), + ("Bytes", Model.Bytes) + ] + ) <|> (try $ Model.Unsupported <$> (T.symbol lexer "Unsupported" >> T.parens lexer (T.stringLiteral lexer))) <|> Model.UserType <$> T.identifier lexer -- NOTE: As is Prisma currently implemented, there can be only one type modifier at one time: [] or ?. fieldTypeModifier :: Parser (Maybe Model.FieldTypeModifier) - fieldTypeModifier = optionMaybe - ( (try (T.brackets lexer (T.whiteSpace lexer)) >> return Model.List) <|> - (try (T.symbol lexer "?") >> return Model.Optional) + fieldTypeModifier = + optionMaybe + ( (try (T.brackets lexer (T.whiteSpace lexer)) >> return Model.List) + <|> (try (T.symbol lexer "?") >> return Model.Optional) ) attribute :: Parser Model.Attribute attribute = do - _ <- char '@' - name <- T.identifier lexer - -- NOTE: we support potential "selector" in order to support native database type attributes. - -- These have names with single . in them, like this: @db.VarChar(200), @db.TinyInt(1), ... . - -- We are not trying to be very smart here though: we don't check that "db" part matches - -- the name of the datasource block name (as it should), and we don't check that "VarChar" part is PascalCase - -- (as it should be) or that it is one of the valid values. - -- We just treat it as any other attribute, where "db.VarChar" becomes an attribute name. - -- In case that we wanted to be smarter, we could expand the AST to have special representation for it. - -- Also, we could do some additional checks here in parser (PascalCase), and some additional checks - -- in th generator ("db" matching the datasource block name). - maybeSelector <- optionMaybe $ try $ char '.' >> T.identifier lexer + _ <- char '@' + name <- T.identifier lexer + -- NOTE: we support potential "selector" in order to support native database type attributes. + -- These have names with single . in them, like this: @db.VarChar(200), @db.TinyInt(1), ... . + -- We are not trying to be very smart here though: we don't check that "db" part matches + -- the name of the datasource block name (as it should), and we don't check that "VarChar" part is PascalCase + -- (as it should be) or that it is one of the valid values. + -- We just treat it as any other attribute, where "db.VarChar" becomes an attribute name. + -- In case that we wanted to be smarter, we could expand the AST to have special representation for it. + -- Also, we could do some additional checks here in parser (PascalCase), and some additional checks + -- in th generator ("db" matching the datasource block name). + maybeSelector <- optionMaybe $ try $ char '.' >> T.identifier lexer - maybeArgs <- optionMaybe (T.parens lexer (T.commaSep1 lexer (try attrArgument))) - return $ Model.Attribute - { Model._attrName = case maybeSelector of - Just selector -> name ++ "." ++ selector - Nothing -> name - , Model._attrArgs = fromMaybe [] maybeArgs - } + maybeArgs <- optionMaybe (T.parens lexer (T.commaSep1 lexer (try attrArgument))) + return $ + Model.Attribute + { Model._attrName = case maybeSelector of + Just selector -> name ++ "." ++ selector + Nothing -> name, + Model._attrArgs = fromMaybe [] maybeArgs + } -- Parses attribute argument that ends with delimiter: , or ). -- Doesn't parse the delimiter. attrArgument :: Parser Model.AttributeArg attrArgument = do - arg <- try namedArg <|> try unnamedArg - return arg + arg <- try namedArg <|> try unnamedArg + return arg where namedArg :: Parser Model.AttributeArg namedArg = do - name <- T.identifier lexer - _ <- T.colon lexer - Model.AttrArgNamed name <$> argValue + name <- T.identifier lexer + _ <- T.colon lexer + Model.AttrArgNamed name <$> argValue unnamedArg :: Parser Model.AttributeArg unnamedArg = Model.AttrArgUnnamed <$> argValue argValue :: Parser Model.AttrArgValue - argValue = choice $ map (try . delimitedArgValue) - [ argValueString - , argValueFunc - , argValueFieldReferenceList - , argValueNumberFloat - , argValueNumberInt - , argValueIdentifier - , argValueUnknown - ] + argValue = + choice $ + map + (try . delimitedArgValue) + [ argValueString, + argValueFunc, + argValueFieldReferenceList, + argValueNumberFloat, + argValueNumberInt, + argValueIdentifier, + argValueUnknown + ] argValueString :: Parser Model.AttrArgValue argValueString = Model.AttrArgString <$> T.stringLiteral lexer argValueFunc :: Parser Model.AttrArgValue - argValueFunc = do -- TODO: Could I implement this with applicative? - name <- T.identifier lexer - T.parens lexer $ T.whiteSpace lexer - return $ Model.AttrArgFunc name + argValueFunc = do + -- TODO: Could I implement this with applicative? + name <- T.identifier lexer + T.parens lexer $ T.whiteSpace lexer + return $ Model.AttrArgFunc name argValueFieldReferenceList :: Parser Model.AttrArgValue - argValueFieldReferenceList = Model.AttrArgFieldRefList <$> - (T.brackets lexer $ T.commaSep1 lexer $ T.identifier lexer) + argValueFieldReferenceList = + Model.AttrArgFieldRefList + <$> (T.brackets lexer $ T.commaSep1 lexer $ T.identifier lexer) -- NOTE: For now we are not supporting negative numbers. -- I couldn't figure out from Prisma docs if there could be the case @@ -157,16 +178,16 @@ attrArgument = do argValueIdentifier :: Parser Model.AttrArgValue argValueIdentifier = Model.AttrArgIdentifier <$> T.identifier lexer - -- | Our "wildcard" -> tries to capture anything. argValueUnknown :: Parser Model.AttrArgValue - argValueUnknown = Model.AttrArgUnknown <$> - (many1 $ try $ noneOf argDelimiters) + argValueUnknown = + Model.AttrArgUnknown + <$> (many1 $ try $ noneOf argDelimiters) delimitedArgValue :: Parser Model.AttrArgValue -> Parser Model.AttrArgValue delimitedArgValue argValueP = do - value <- argValueP - _ <- lookAhead $ oneOf argDelimiters - return value + value <- argValueP + _ <- lookAhead $ oneOf argDelimiters + return value argDelimiters = [',', ')'] @@ -174,9 +195,11 @@ blockAttribute :: Parser Model.Attribute blockAttribute = char '@' >> attribute lexer :: T.TokenParser () -lexer = T.makeTokenParser emptyDef - { T.commentLine = "//" - , T.caseSensitive = True - , T.identStart = letter - , T.identLetter = alphaNum <|> char '_' - } +lexer = + T.makeTokenParser + emptyDef + { T.commentLine = "//", + T.caseSensitive = True, + T.identStart = letter, + T.identLetter = alphaNum <|> char '_' + } diff --git a/waspc/src/StrongPath.hs b/waspc/src/StrongPath.hs index d2340f527..c8f06b5ca 100644 --- a/waspc/src/StrongPath.hs +++ b/waspc/src/StrongPath.hs @@ -1,49 +1,87 @@ {-# LANGUAGE PartialTypeSignatures #-} + module StrongPath - ( Path, Path' - , Abs, Rel, Dir, File, File' - , System, Windows, Posix + ( Path, + Path', + Abs, + Rel, + Dir, + File, + File', + System, + Windows, + Posix, + parseRelDir, + parseRelFile, + parseAbsDir, + parseAbsFile, + parseRelDirW, + parseRelFileW, + parseAbsDirW, + parseAbsFileW, + parseRelDirP, + parseRelFileP, + parseAbsDirP, + parseAbsFileP, + fromPathRelDir, + fromPathRelFile, + fromPathAbsDir, + fromPathAbsFile, + fromPathRelDirW, + fromPathRelFileW, + fromPathAbsDirW, + fromPathAbsFileW, + fromPathRelDirP, + fromPathRelFileP, + fromPathAbsDirP, + fromPathAbsFileP, + toPathRelDir, + toPathRelFile, + toPathAbsDir, + toPathAbsFile, + toPathRelDirW, + toPathRelFileW, + toPathAbsDirW, + toPathAbsFileW, + toPathRelDirP, + toPathRelFileP, + toPathAbsDirP, + toPathAbsFileP, + fromRelDir, + fromRelFile, + fromAbsDir, + fromAbsFile, + fromRelDirP, + fromRelFileP, + fromAbsDirP, + fromAbsFileP, + fromRelDirW, + fromRelFileW, + fromAbsDirW, + fromAbsFileW, + toFilePath, + (), + castRel, + castDir, + parent, + relDirToPosix, + relFileToPosix, + relDirToPosix', + relFileToPosix', + ) +where - , parseRelDir, parseRelFile, parseAbsDir, parseAbsFile - , parseRelDirW, parseRelFileW, parseAbsDirW, parseAbsFileW - , parseRelDirP, parseRelFileP, parseAbsDirP, parseAbsFileP - - , fromPathRelDir, fromPathRelFile, fromPathAbsDir, fromPathAbsFile - , fromPathRelDirW, fromPathRelFileW, fromPathAbsDirW, fromPathAbsFileW - , fromPathRelDirP, fromPathRelFileP, fromPathAbsDirP, fromPathAbsFileP - - , toPathRelDir, toPathRelFile, toPathAbsDir, toPathAbsFile - , toPathRelDirW, toPathRelFileW, toPathAbsDirW, toPathAbsFileW - , toPathRelDirP, toPathRelFileP, toPathAbsDirP, toPathAbsFileP - - , fromRelDir, fromRelFile, fromAbsDir, fromAbsFile - , fromRelDirP, fromRelFileP, fromAbsDirP, fromAbsFileP - , fromRelDirW, fromRelFileW, fromAbsDirW, fromAbsFileW - - , toFilePath - - , () - - , castRel, castDir - - , parent - - , relDirToPosix, relFileToPosix, relDirToPosix', relFileToPosix' - ) where - -import Control.Monad.Catch (MonadThrow) -import Data.List (intercalate) -import Data.Maybe (fromJust) -import qualified Path as P -import qualified Path.Posix as PP -import qualified Path.Windows as PW -import qualified System.FilePath as FP -import qualified System.FilePath.Posix as FPP +import Control.Monad.Catch (MonadThrow) +import Data.List (intercalate) +import Data.Maybe (fromJust) +import qualified Path as P +import qualified Path.Posix as PP +import qualified Path.Windows as PW +import StrongPath.Internal +import qualified System.FilePath as FP +import qualified System.FilePath.Posix as FPP import qualified System.FilePath.Windows as FPW -import StrongPath.Internal - - -- TODO: We still depend on Path for creating hardcoded paths via generics. Any way to go around that? -- Maybe implement our own mechanism for that, so that people don't have to know about / use Path? -- This means we would implement our own [reldir|foobar|] stuff. @@ -78,87 +116,109 @@ import StrongPath.Internal -- so compiler does not differentiate them (because they are all exporting the same module containing Path), -- but Path.Windows.Rel and Path.Posix.Rel (and same for Abs/Dir/File) are not the same, -- because they are done via Include mechanism. -fromPathRelDir :: P.Path P.Rel P.Dir -> Path' System (Rel a) (Dir b) -fromPathRelFile :: P.Path P.Rel P.File -> Path' System (Rel a) (File' f) -fromPathAbsDir :: P.Path P.Abs P.Dir -> Path' System Abs (Dir a) -fromPathAbsFile :: P.Path P.Abs P.File -> Path' System Abs (File' f) -fromPathRelDirW :: PW.Path PW.Rel PW.Dir -> Path' Windows (Rel a) (Dir b) +fromPathRelDir :: P.Path P.Rel P.Dir -> Path' System (Rel a) (Dir b) +fromPathRelFile :: P.Path P.Rel P.File -> Path' System (Rel a) (File' f) +fromPathAbsDir :: P.Path P.Abs P.Dir -> Path' System Abs (Dir a) +fromPathAbsFile :: P.Path P.Abs P.File -> Path' System Abs (File' f) +fromPathRelDirW :: PW.Path PW.Rel PW.Dir -> Path' Windows (Rel a) (Dir b) fromPathRelFileW :: PW.Path PW.Rel PW.File -> Path' Windows (Rel a) (File' f) -fromPathAbsDirW :: PW.Path PW.Abs PW.Dir -> Path' Windows Abs (Dir a) -fromPathAbsFileW :: PW.Path PW.Abs PW.File -> Path' Windows Abs (File' f) -fromPathRelDirP :: PP.Path PP.Rel PP.Dir -> Path' Posix (Rel a) (Dir b) -fromPathRelFileP :: PP.Path PP.Rel PP.File -> Path' Posix (Rel a) (File' f) -fromPathAbsDirP :: PP.Path PP.Abs PP.Dir -> Path' Posix Abs (Dir a) -fromPathAbsFileP :: PP.Path PP.Abs PP.File -> Path' Posix Abs (File' f) +fromPathAbsDirW :: PW.Path PW.Abs PW.Dir -> Path' Windows Abs (Dir a) +fromPathAbsFileW :: PW.Path PW.Abs PW.File -> Path' Windows Abs (File' f) +fromPathRelDirP :: PP.Path PP.Rel PP.Dir -> Path' Posix (Rel a) (Dir b) +fromPathRelFileP :: PP.Path PP.Rel PP.File -> Path' Posix (Rel a) (File' f) +fromPathAbsDirP :: PP.Path PP.Abs PP.Dir -> Path' Posix Abs (Dir a) +fromPathAbsFileP :: PP.Path PP.Abs PP.File -> Path' Posix Abs (File' f) ---- System -fromPathRelDir p = RelDir p NoPrefix -fromPathRelFile p = RelFile p NoPrefix -fromPathAbsDir = AbsDir -fromPathAbsFile = AbsFile +fromPathRelDir p = RelDir p NoPrefix + +fromPathRelFile p = RelFile p NoPrefix + +fromPathAbsDir = AbsDir + +fromPathAbsFile = AbsFile + ---- Windows fromPathRelDirW p = RelDirW p NoPrefix + fromPathRelFileW p = RelFileW p NoPrefix -fromPathAbsDirW = AbsDirW + +fromPathAbsDirW = AbsDirW + fromPathAbsFileW = AbsFileW + ---- Posix fromPathRelDirP p = RelDirP p NoPrefix + fromPathRelFileP p = RelFileP p NoPrefix -fromPathAbsDirP = AbsDirP + +fromPathAbsDirP = AbsDirP + fromPathAbsFileP = AbsFileP -- TODO: Should I go with MonadThrow here instead of just throwing error? Probably! -- I could, as error, return actual Path + info on how many ../ were there in StrongPath, -- so user can recover from error and continue, if they wish. -- Deconstructors -toPathRelDir :: Path' System (Rel a) (Dir b) -> P.Path P.Rel P.Dir -toPathRelFile :: Path' System (Rel a) (File' f) -> P.Path P.Rel P.File -toPathAbsDir :: Path' System Abs (Dir a) -> P.Path P.Abs P.Dir -toPathAbsFile :: Path' System Abs (File' f) -> P.Path P.Abs P.File -toPathRelDirW :: Path' Windows (Rel a) (Dir b) -> PW.Path PW.Rel PW.Dir +toPathRelDir :: Path' System (Rel a) (Dir b) -> P.Path P.Rel P.Dir +toPathRelFile :: Path' System (Rel a) (File' f) -> P.Path P.Rel P.File +toPathAbsDir :: Path' System Abs (Dir a) -> P.Path P.Abs P.Dir +toPathAbsFile :: Path' System Abs (File' f) -> P.Path P.Abs P.File +toPathRelDirW :: Path' Windows (Rel a) (Dir b) -> PW.Path PW.Rel PW.Dir toPathRelFileW :: Path' Windows (Rel a) (File' f) -> PW.Path PW.Rel PW.File -toPathAbsDirW :: Path' Windows Abs (Dir a) -> PW.Path PW.Abs PW.Dir -toPathAbsFileW :: Path' Windows Abs (File' f) -> PW.Path PW.Abs PW.File -toPathRelDirP :: Path' Posix (Rel a) (Dir b) -> PP.Path PP.Rel PP.Dir -toPathRelFileP :: Path' Posix (Rel a) (File' f) -> PP.Path PP.Rel PP.File -toPathAbsDirP :: Path' Posix Abs (Dir a) -> PP.Path PP.Abs PP.Dir -toPathAbsFileP :: Path' Posix Abs (File' f) -> PP.Path PP.Abs PP.File +toPathAbsDirW :: Path' Windows Abs (Dir a) -> PW.Path PW.Abs PW.Dir +toPathAbsFileW :: Path' Windows Abs (File' f) -> PW.Path PW.Abs PW.File +toPathRelDirP :: Path' Posix (Rel a) (Dir b) -> PP.Path PP.Rel PP.Dir +toPathRelFileP :: Path' Posix (Rel a) (File' f) -> PP.Path PP.Rel PP.File +toPathAbsDirP :: Path' Posix Abs (Dir a) -> PP.Path PP.Abs PP.Dir +toPathAbsFileP :: Path' Posix Abs (File' f) -> PP.Path PP.Abs PP.File ---- System toPathRelDir (RelDir p NoPrefix) = p -toPathRelDir (RelDir _ _) = relativeStrongPathWithPrefixToPathError -toPathRelDir _ = impossible +toPathRelDir (RelDir _ _) = relativeStrongPathWithPrefixToPathError +toPathRelDir _ = impossible + toPathRelFile (RelFile p NoPrefix) = p -toPathRelFile (RelFile _ _) = relativeStrongPathWithPrefixToPathError -toPathRelFile _ = impossible +toPathRelFile (RelFile _ _) = relativeStrongPathWithPrefixToPathError +toPathRelFile _ = impossible + toPathAbsDir (AbsDir p) = p -toPathAbsDir _ = impossible +toPathAbsDir _ = impossible + toPathAbsFile (AbsFile p) = p -toPathAbsFile _ = impossible +toPathAbsFile _ = impossible + ---- Windows toPathRelDirW (RelDirW p NoPrefix) = p -toPathRelDirW (RelDirW _ _) = relativeStrongPathWithPrefixToPathError -toPathRelDirW _ = impossible +toPathRelDirW (RelDirW _ _) = relativeStrongPathWithPrefixToPathError +toPathRelDirW _ = impossible + toPathRelFileW (RelFileW p NoPrefix) = p -toPathRelFileW (RelFileW _ _) = relativeStrongPathWithPrefixToPathError -toPathRelFileW _ = impossible +toPathRelFileW (RelFileW _ _) = relativeStrongPathWithPrefixToPathError +toPathRelFileW _ = impossible + toPathAbsDirW (AbsDirW p) = p -toPathAbsDirW _ = impossible +toPathAbsDirW _ = impossible + toPathAbsFileW (AbsFileW p) = p -toPathAbsFileW _ = impossible +toPathAbsFileW _ = impossible + ---- Posix toPathRelDirP (RelDirP p NoPrefix) = p -toPathRelDirP (RelDirP _ _) = relativeStrongPathWithPrefixToPathError -toPathRelDirP _ = impossible +toPathRelDirP (RelDirP _ _) = relativeStrongPathWithPrefixToPathError +toPathRelDirP _ = impossible + toPathRelFileP (RelFileP p NoPrefix) = p -toPathRelFileP (RelFileP _ _) = relativeStrongPathWithPrefixToPathError -toPathRelFileP _ = impossible +toPathRelFileP (RelFileP _ _) = relativeStrongPathWithPrefixToPathError +toPathRelFileP _ = impossible + toPathAbsDirP (AbsDirP p) = p -toPathAbsDirP _ = impossible +toPathAbsDirP _ = impossible + toPathAbsFileP (AbsFileP p) = p -toPathAbsFileP _ = impossible +toPathAbsFileP _ = impossible relativeStrongPathWithPrefixToPathError :: a relativeStrongPathWithPrefixToPathError = - error "Relative StrongPath.Path with prefix can't be converted into Path.Path." + error "Relative StrongPath.Path with prefix can't be converted into Path.Path." -- | Parsers. -- How parsers work: @@ -173,60 +233,70 @@ relativeStrongPathWithPrefixToPathError = -- NOTE: System/Posix* means that path has to be System with exception of separators -- that can be Posix besides being System (but e.g. root can't be Posix). -- Win/Posix* is analogous to System/Posix*. -parseRelDir :: MonadThrow m => FilePath -> m (Path' System (Rel d1) (Dir d2)) -parseRelFile :: MonadThrow m => FilePath -> m (Path' System (Rel d) (File' f)) -parseAbsDir :: MonadThrow m => FilePath -> m (Path' System Abs (Dir d)) -parseAbsFile :: MonadThrow m => FilePath -> m (Path' System Abs (File' f)) -parseRelDirW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d1) (Dir d2)) -parseRelFileW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d) (File' f)) -parseAbsDirW :: MonadThrow m => FilePath -> m (Path' Windows Abs (Dir d)) -parseAbsFileW :: MonadThrow m => FilePath -> m (Path' Windows Abs (File' f)) -parseRelDirP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d1) (Dir d2)) -parseRelFileP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d) (File' f)) -parseAbsDirP :: MonadThrow m => FilePath -> m (Path' Posix Abs (Dir d)) -parseAbsFileP :: MonadThrow m => FilePath -> m (Path' Posix Abs (File' f)) +parseRelDir :: MonadThrow m => FilePath -> m (Path' System (Rel d1) (Dir d2)) +parseRelFile :: MonadThrow m => FilePath -> m (Path' System (Rel d) (File' f)) +parseAbsDir :: MonadThrow m => FilePath -> m (Path' System Abs (Dir d)) +parseAbsFile :: MonadThrow m => FilePath -> m (Path' System Abs (File' f)) +parseRelDirW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d1) (Dir d2)) +parseRelFileW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d) (File' f)) +parseAbsDirW :: MonadThrow m => FilePath -> m (Path' Windows Abs (Dir d)) +parseAbsFileW :: MonadThrow m => FilePath -> m (Path' Windows Abs (File' f)) +parseRelDirP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d1) (Dir d2)) +parseRelFileP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d) (File' f)) +parseAbsDirP :: MonadThrow m => FilePath -> m (Path' Posix Abs (Dir d)) +parseAbsFileP :: MonadThrow m => FilePath -> m (Path' Posix Abs (File' f)) ---- System -parseRelDir = parseRelFP RelDir [FP.pathSeparator, FPP.pathSeparator] P.parseRelDir +parseRelDir = parseRelFP RelDir [FP.pathSeparator, FPP.pathSeparator] P.parseRelDir + parseRelFile = parseRelFP RelFile [FP.pathSeparator, FPP.pathSeparator] P.parseRelFile + parseAbsDir fp = fromPathAbsDir <$> P.parseAbsDir fp + parseAbsFile fp = fromPathAbsFile <$> P.parseAbsFile fp + ---- Windows parseRelDirW = parseRelFP RelDirW [FPW.pathSeparator, FPP.pathSeparator] PW.parseRelDir + parseRelFileW = parseRelFP RelFileW [FPW.pathSeparator, FPP.pathSeparator] PW.parseRelFile + parseAbsDirW fp = fromPathAbsDirW <$> PW.parseAbsDir fp + parseAbsFileW fp = fromPathAbsFileW <$> PW.parseAbsFile fp + ---- Posix parseRelDirP = parseRelFP RelDirP [FPP.pathSeparator] PP.parseRelDir -parseRelFileP = parseRelFP RelFileP [FPP.pathSeparator] PP.parseRelFile -parseAbsDirP fp = fromPathAbsDirP <$> PP.parseAbsDir fp -parseAbsFileP fp = fromPathAbsFileP <$> PP.parseAbsFile fp +parseRelFileP = parseRelFP RelFileP [FPP.pathSeparator] PP.parseRelFile + +parseAbsDirP fp = fromPathAbsDirP <$> PP.parseAbsDir fp + +parseAbsFileP fp = fromPathAbsFileP <$> PP.parseAbsFile fp toFilePath :: Path' s b t -> FilePath toFilePath sp = case sp of - ---- System - RelDir p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p - RelFile p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p - AbsDir p -> P.toFilePath p - AbsFile p -> P.toFilePath p - ---- Windows - RelDirW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p - RelFileW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p - AbsDirW p -> PW.toFilePath p - AbsFileW p -> PW.toFilePath p - ---- Posix - RelDirP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p - RelFileP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p - AbsDirP p -> PP.toFilePath p - AbsFileP p -> PP.toFilePath p + ---- System + RelDir p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p + RelFile p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p + AbsDir p -> P.toFilePath p + AbsFile p -> P.toFilePath p + ---- Windows + RelDirW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p + RelFileW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p + AbsDirW p -> PW.toFilePath p + AbsFileW p -> PW.toFilePath p + ---- Posix + RelDirP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p + RelFileP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p + AbsDirP p -> PP.toFilePath p + AbsFileP p -> PP.toFilePath p where relPathToFilePath pathToFilePath sep prefix path = - combinePrefixWithPath sep (relPathPrefixToFilePath sep prefix) (pathToFilePath path) + combinePrefixWithPath sep (relPathPrefixToFilePath sep prefix) (pathToFilePath path) relPathPrefixToFilePath :: Char -> RelPathPrefix -> FilePath relPathPrefixToFilePath _ NoPrefix = "" relPathPrefixToFilePath sep (ParentDir n) = - intercalate [sep] (replicate n "..") ++ [sep] + intercalate [sep] (replicate n "..") ++ [sep] -- TODO: This function and helper functions above are somewhat too loose and hard to -- follow, implement them in better way. @@ -234,56 +304,67 @@ toFilePath sp = case sp of -- and it could also be empty. combinePrefixWithPath :: Char -> String -> FilePath -> FilePath combinePrefixWithPath sep prefix path - | path `elem` [".", ['.', sep], "./"] && not (null prefix) = prefix + | path `elem` [".", ['.', sep], "./"] && not (null prefix) = prefix combinePrefixWithPath _ prefix path = prefix ++ path -- These functions just call toFilePath, but their value is in -- their type: they allow you to capture expected type of the strong path -- that you want to convert into FilePath. -fromRelDir :: Path' System (Rel r) (Dir d) -> FilePath -fromRelDir = toFilePath -fromRelFile :: Path' System (Rel r) (File' f) -> FilePath -fromRelFile = toFilePath -fromAbsDir :: Path' System Abs (Dir d) -> FilePath -fromAbsDir = toFilePath -fromAbsFile :: Path' System Abs (File' f) -> FilePath -fromAbsFile = toFilePath -fromRelDirP :: Path' Posix (Rel r) (Dir d) -> FilePath -fromRelDirP = toFilePath -fromRelFileP :: Path' Posix (Rel r) (File' f) -> FilePath +fromRelDir :: Path' System (Rel r) (Dir d) -> FilePath +fromRelDir = toFilePath + +fromRelFile :: Path' System (Rel r) (File' f) -> FilePath +fromRelFile = toFilePath + +fromAbsDir :: Path' System Abs (Dir d) -> FilePath +fromAbsDir = toFilePath + +fromAbsFile :: Path' System Abs (File' f) -> FilePath +fromAbsFile = toFilePath + +fromRelDirP :: Path' Posix (Rel r) (Dir d) -> FilePath +fromRelDirP = toFilePath + +fromRelFileP :: Path' Posix (Rel r) (File' f) -> FilePath fromRelFileP = toFilePath -fromAbsDirP :: Path' Posix Abs (Dir d) -> FilePath -fromAbsDirP = toFilePath -fromAbsFileP :: Path' Posix Abs (File' f) -> FilePath + +fromAbsDirP :: Path' Posix Abs (Dir d) -> FilePath +fromAbsDirP = toFilePath + +fromAbsFileP :: Path' Posix Abs (File' f) -> FilePath fromAbsFileP = toFilePath -fromRelDirW :: Path' Windows (Rel r) (Dir d) -> FilePath -fromRelDirW = toFilePath + +fromRelDirW :: Path' Windows (Rel r) (Dir d) -> FilePath +fromRelDirW = toFilePath + fromRelFileW :: Path' Windows (Rel r) (File' f) -> FilePath fromRelFileW = toFilePath -fromAbsDirW :: Path' Windows Abs (Dir d) -> FilePath -fromAbsDirW = toFilePath -fromAbsFileW :: Path' Windows Abs (File' f) -> FilePath + +fromAbsDirW :: Path' Windows Abs (Dir d) -> FilePath +fromAbsDirW = toFilePath + +fromAbsFileW :: Path' Windows Abs (File' f) -> FilePath fromAbsFileW = toFilePath -- | Either removes last entry or if there are no entries and just "../"s, adds one more "../". -- If path is absolute root and it has no parent, it will return unchanged path, same like Path. parent :: Path' s b t -> Path' s b (Dir d) parent path = case path of - ---- System - RelDir p prefix -> relDirPathParent RelDir P.parent p prefix - RelFile p prefix -> RelDir (P.parent p) prefix - AbsDir p -> AbsDir $ P.parent p - AbsFile p -> AbsDir $ P.parent p - ---- Windows - RelDirW p prefix -> relDirPathParent RelDirW PW.parent p prefix - RelFileW p prefix -> RelDirW (PW.parent p) prefix - AbsDirW p -> AbsDirW $ PW.parent p - AbsFileW p -> AbsDirW $ PW.parent p - ---- Posix - RelDirP p prefix -> relDirPathParent RelDirP PP.parent p prefix - RelFileP p prefix -> RelDirP (PP.parent p) prefix - AbsDirP p -> AbsDirP $ PP.parent p - AbsFileP p -> AbsDirP $ PP.parent p + ---- System + RelDir p prefix -> relDirPathParent RelDir P.parent p prefix + RelFile p prefix -> RelDir (P.parent p) prefix + AbsDir p -> AbsDir $ P.parent p + AbsFile p -> AbsDir $ P.parent p + ---- Windows + RelDirW p prefix -> relDirPathParent RelDirW PW.parent p prefix + RelFileW p prefix -> RelDirW (PW.parent p) prefix + AbsDirW p -> AbsDirW $ PW.parent p + AbsFileW p -> AbsDirW $ PW.parent p + ---- Posix + RelDirP p prefix -> relDirPathParent RelDirP PP.parent p prefix + RelFileP p prefix -> RelDirP (PP.parent p) prefix + AbsDirP p -> AbsDirP $ PP.parent p + AbsFileP p -> AbsDirP $ PP.parent p where -- NOTE: We need this special logic for RelDir, because if we have RelDir Path, -- it is possible that it is "." or smth like that and no parent can be obtained, @@ -291,14 +372,15 @@ parent path = case path of -- For file though, we don't have that concern, because it will always be possible to -- get a parent, as per current Path implementation. relDirPathParent constructor pathParent p prefix = - if pathParent p == p - then let prefix' = case prefix of - ParentDir n -> ParentDir (n + 1) - NoPrefix -> ParentDir 1 - in constructor p prefix' - else let p' = pathParent p - in constructor p' prefix - + if pathParent p == p + then + let prefix' = case prefix of + ParentDir n -> ParentDir (n + 1) + NoPrefix -> ParentDir 1 + in constructor p prefix' + else + let p' = pathParent p + in constructor p' prefix -- | How "../"s are resolved: -- For each "../" at the start of the right hand path, one most right entry is removed @@ -313,92 +395,95 @@ parent path = case path of () :: Path' s a (Dir d) -> Path' s (Rel d) c -> Path' s a c ---- System lsp@(RelDir _ _) (RelFile rp rprefix) = - let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix - in RelFile (lp' P. rp) lprefix' + let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix + in RelFile (lp' P. rp) lprefix' lsp@(RelDir _ _) (RelDir rp rprefix) = - let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix - in RelDir (lp' P. rp) lprefix' + let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix + in RelDir (lp' P. rp) lprefix' lsp@(AbsDir _) (RelFile rp rprefix) = - let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix - in AbsFile (lp' P. rp) + let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix + in AbsFile (lp' P. rp) lsp@(AbsDir _) (RelDir rp rprefix) = - let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix - in AbsDir (lp' P. rp) + let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix + in AbsDir (lp' P. rp) ---- Windows lsp@(RelDirW _ _) (RelFileW rp rprefix) = - let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix - in RelFileW (lp' `pathWinCombineRelDirAndRelFile` rp) lprefix' + let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix + in RelFileW (lp' `pathWinCombineRelDirAndRelFile` rp) lprefix' lsp@(RelDirW _ _) (RelDirW rp rprefix) = - let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix - in RelDirW (lp' `pathWinCombineRelDirAndRelDir` rp) lprefix' + let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix + in RelDirW (lp' `pathWinCombineRelDirAndRelDir` rp) lprefix' lsp@(AbsDirW _) (RelFileW rp rprefix) = - let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix - in AbsFileW (lp' PW. rp) + let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix + in AbsFileW (lp' PW. rp) lsp@(AbsDirW _) (RelDirW rp rprefix) = - let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix - in AbsDirW (lp' `pathWinCombineAbsDirAndRelDir` rp) + let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix + in AbsDirW (lp' `pathWinCombineAbsDirAndRelDir` rp) ---- Posix lsp@(RelDirP _ _) (RelFileP rp rprefix) = - let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix - in RelFileP (lp' `pathPosixCombineRelDirAndRelFile` rp) lprefix' + let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix + in RelFileP (lp' `pathPosixCombineRelDirAndRelFile` rp) lprefix' lsp@(RelDirP _ _) (RelDirP rp rprefix) = - let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix - in RelDirP (lp' `pathPosixCombineRelDirAndRelDir` rp) lprefix' + let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix + in RelDirP (lp' `pathPosixCombineRelDirAndRelDir` rp) lprefix' lsp@(AbsDirP _) (RelFileP rp rprefix) = - let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix - in AbsFileP (lp' PP. rp) + let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix + in AbsFileP (lp' PP. rp) lsp@(AbsDirP _) (RelDirP rp rprefix) = - let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix - in AbsDirP (lp' `pathPosixCombineAbsDirAndRelDir` rp) + let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix + in AbsDirP (lp' `pathPosixCombineAbsDirAndRelDir` rp) _ _ = impossible - castRel :: Path' s (Rel d1) a -> Path' s (Rel d2) a ---- System -castRel (RelDir p pr) = RelDir p pr -castRel (RelFile p pr) = RelFile p pr +castRel (RelDir p pr) = RelDir p pr +castRel (RelFile p pr) = RelFile p pr ---- Windows -castRel (RelDirW p pr) = RelDirW p pr +castRel (RelDirW p pr) = RelDirW p pr castRel (RelFileW p pr) = RelFileW p pr ---- Posix -castRel (RelDirP p pr) = RelDirP p pr +castRel (RelDirP p pr) = RelDirP p pr castRel (RelFileP p pr) = RelFileP p pr -castRel _ = impossible +castRel _ = impossible castDir :: Path' s a (Dir d1) -> Path' s a (Dir d2) ---- System -castDir (AbsDir p) = AbsDir p -castDir (RelDir p pr) = RelDir p pr +castDir (AbsDir p) = AbsDir p +castDir (RelDir p pr) = RelDir p pr ---- Windows -castDir (AbsDirW p) = AbsDirW p +castDir (AbsDirW p) = AbsDirW p castDir (RelDirW p pr) = RelDirW p pr ---- Posix -castDir (AbsDirP p) = AbsDirP p +castDir (AbsDirP p) = AbsDirP p castDir (RelDirP p pr) = RelDirP p pr -castDir _ = impossible +castDir _ = impossible -- TODO: I was not able to unite these two functions (`relDirToPosix` and `relFileToPosix`) into just `toPosix`` -- because Haskell did not believe me that I would be returning same "t" (Dir/File) in Path -- as was in first argument. I wonder if there is easy way to go around that or if -- we have to redo significant part of the StrongPath to be able to do smth like this. + -- | Converts relative path to posix by replacing current path separators with posix path separators. -- Works well for "normal" relative paths like "a\b\c" (Win) or "a/b/c" (Posix). -- If path is weird but still considered relative, like just "C:" on Win, -- results can be unxpected, most likely resulting with error thrown. -- If path is already Posix, it will not change. relDirToPosix :: MonadThrow m => Path' s (Rel d1) (Dir d2) -> m (Path' Posix (Rel d1) (Dir d2)) -relDirToPosix sp@(RelDir _ _) = parseRelDirP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp +relDirToPosix sp@(RelDir _ _) = parseRelDirP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp relDirToPosix sp@(RelDirW _ _) = parseRelDirP $ FPP.joinPath $ FPW.splitDirectories $ toFilePath sp -relDirToPosix (RelDirP p pr) = return $ RelDirP p pr -relDirToPosix _ = impossible +relDirToPosix (RelDirP p pr) = return $ RelDirP p pr +relDirToPosix _ = impossible + relFileToPosix :: MonadThrow m => Path' s (Rel d1) (File' f) -> m (Path' Posix (Rel d1) (File' f)) -relFileToPosix sp@(RelFile _ _) = parseRelFileP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp +relFileToPosix sp@(RelFile _ _) = parseRelFileP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp relFileToPosix sp@(RelFileW _ _) = parseRelFileP $ FPP.joinPath $ FPW.splitDirectories $ toFilePath sp -relFileToPosix (RelFileP p pr) = return $ RelFileP p pr -relFileToPosix _ = impossible +relFileToPosix (RelFileP p pr) = return $ RelFileP p pr +relFileToPosix _ = impossible + -- TODO: Should I name these unsafe versions differently? Maybe relDirToPosixU? -- Unsafe versions: relDirToPosix' :: Path' s (Rel d1) (Dir d2) -> Path' Posix (Rel d1) (Dir d2) relDirToPosix' = fromJust . relDirToPosix + relFileToPosix' :: Path' s (Rel d1) (File' f) -> Path' Posix (Rel d1) (File' f) relFileToPosix' = fromJust . relFileToPosix diff --git a/waspc/src/StrongPath/Internal.hs b/waspc/src/StrongPath/Internal.hs index 53942bea1..b3b0d7aaf 100644 --- a/waspc/src/StrongPath/Internal.hs +++ b/waspc/src/StrongPath/Internal.hs @@ -1,85 +1,91 @@ module StrongPath.Internal where -import Control.Monad.Catch (MonadThrow) -import qualified Path as P -import qualified Path.Posix as PP -import qualified Path.Windows as PW -import qualified System.FilePath.Posix as FPP +import Control.Monad.Catch (MonadThrow) +import qualified Path as P +import qualified Path.Posix as PP +import qualified Path.Windows as PW +import qualified System.FilePath.Posix as FPP import qualified System.FilePath.Windows as FPW - -- | s -> standard, b -> base, t -> type data Path' s b t - -- System - = RelDir (P.Path P.Rel P.Dir) RelPathPrefix - | RelFile (P.Path P.Rel P.File) RelPathPrefix - | AbsDir (P.Path P.Abs P.Dir) - | AbsFile (P.Path P.Abs P.File) - -- Windows - | RelDirW (PW.Path PW.Rel PW.Dir) RelPathPrefix - | RelFileW (PW.Path PW.Rel PW.File) RelPathPrefix - | AbsDirW (PW.Path PW.Abs PW.Dir) - | AbsFileW (PW.Path PW.Abs PW.File) - -- Posix - | RelDirP (PP.Path PP.Rel PP.Dir) RelPathPrefix - | RelFileP (PP.Path PP.Rel PP.File) RelPathPrefix - | AbsDirP (PP.Path PP.Abs PP.Dir) - | AbsFileP (PP.Path PP.Abs PP.File) - deriving (Show, Eq) + = -- System + RelDir (P.Path P.Rel P.Dir) RelPathPrefix + | RelFile (P.Path P.Rel P.File) RelPathPrefix + | AbsDir (P.Path P.Abs P.Dir) + | AbsFile (P.Path P.Abs P.File) + | -- Windows + RelDirW (PW.Path PW.Rel PW.Dir) RelPathPrefix + | RelFileW (PW.Path PW.Rel PW.File) RelPathPrefix + | AbsDirW (PW.Path PW.Abs PW.Dir) + | AbsFileW (PW.Path PW.Abs PW.File) + | -- Posix + RelDirP (PP.Path PP.Rel PP.Dir) RelPathPrefix + | RelFileP (PP.Path PP.Rel PP.File) RelPathPrefix + | AbsDirP (PP.Path PP.Abs PP.Dir) + | AbsFileP (PP.Path PP.Abs PP.File) + deriving (Show, Eq) -data RelPathPrefix = ParentDir Int -- ^ ../, Int saying how many times it repeats. - | NoPrefix - deriving (Show, Eq) +data RelPathPrefix + = -- | ../, Int saying how many times it repeats. + ParentDir Int + | NoPrefix + deriving (Show, Eq) type Path = Path' System -- | base data Abs + data Rel dir -- | type data Dir dir + data File' file type File = File' () -- | standard data System -- Depends on the platform, it is either Posix or Windows. + data Windows + data Posix - -parseRelFP :: MonadThrow m - => (P.Path pb pt -> RelPathPrefix -> Path' s (Rel d) t) - -> [Char] - -> (FilePath -> m (P.Path pb pt)) - -> FilePath - -> m (Path' s (Rel d) t) +parseRelFP :: + MonadThrow m => + (P.Path pb pt -> RelPathPrefix -> Path' s (Rel d) t) -> + [Char] -> + (FilePath -> m (P.Path pb pt)) -> + FilePath -> + m (Path' s (Rel d) t) parseRelFP constructor validSeparators pathParser fp = - let (prefix, fp') = extractRelPathPrefix validSeparators fp - fp'' = if fp' == "" then "." else fp' -- Because Path Rel parsers can't handle just "". - in (\p -> constructor p prefix) <$> pathParser fp'' + let (prefix, fp') = extractRelPathPrefix validSeparators fp + fp'' = if fp' == "" then "." else fp' -- Because Path Rel parsers can't handle just "". + in (\p -> constructor p prefix) <$> pathParser fp'' -- | Extracts a multiple "../" from start of the file path. -- If path is completely ../../.., also handles the last one. -- NOTE: We don't normalize path in any way. extractRelPathPrefix :: [Char] -> FilePath -> (RelPathPrefix, FilePath) extractRelPathPrefix validSeparators path = - let (n, path') = dropParentDirs path - in (if n == 0 then NoPrefix else ParentDir n, path') + let (n, path') = dropParentDirs path + in (if n == 0 then NoPrefix else ParentDir n, path') where parentDirStrings :: [String] - parentDirStrings = [['.', '.', s] | s <- validSeparators] + parentDirStrings = [['.', '.', s] | s <- validSeparators] pathStartsWithParentDir :: FilePath -> Bool - pathStartsWithParentDir p = take 3 p `elem` parentDirStrings + pathStartsWithParentDir p = take 3 p `elem` parentDirStrings dropParentDirs :: FilePath -> (Int, FilePath) dropParentDirs p - | pathStartsWithParentDir p = let (n, p') = dropParentDirs (drop 3 p) - in (1 + n, p') - | p == ".." = (1, "") - | otherwise = (0, p) + | pathStartsWithParentDir p = + let (n, p') = dropParentDirs (drop 3 p) + in (1 + n, p') + | p == ".." = (1, "") + | otherwise = (0, p) -- NOTE: These three funtions, pathWinCombine... exist only to fix -- Path.Windows. behaviour regarding concatenating '.' rel dirs @@ -102,35 +108,39 @@ extractRelPathPrefix validSeparators path = -- do the rest of the work. pathWinCombineRelDirAndRelFile :: PW.Path PW.Rel PW.Dir -> PW.Path PW.Rel PW.File -> PW.Path PW.Rel PW.File pathWinCombineRelDirAndRelFile lp rp - | PW.toFilePath lp == ['.', FPW.pathSeparator] = rp - | otherwise = lp PW. rp + | PW.toFilePath lp == ['.', FPW.pathSeparator] = rp + | otherwise = lp PW. rp + pathWinCombineRelDirAndRelDir :: PW.Path PW.Rel PW.Dir -> PW.Path PW.Rel PW.Dir -> PW.Path PW.Rel PW.Dir pathWinCombineRelDirAndRelDir lp rp - | PW.toFilePath lp == ['.', FPW.pathSeparator] = rp - | PW.toFilePath rp == ['.', FPW.pathSeparator] = lp - | otherwise = lp PW. rp + | PW.toFilePath lp == ['.', FPW.pathSeparator] = rp + | PW.toFilePath rp == ['.', FPW.pathSeparator] = lp + | otherwise = lp PW. rp + pathWinCombineAbsDirAndRelDir :: PW.Path PW.Abs PW.Dir -> PW.Path PW.Rel PW.Dir -> PW.Path PW.Abs PW.Dir pathWinCombineAbsDirAndRelDir lp rp - | PW.toFilePath rp == ['.', FPW.pathSeparator] = lp - | otherwise = lp PW. rp + | PW.toFilePath rp == ['.', FPW.pathSeparator] = lp + | otherwise = lp PW. rp -- NOTE: Same as pathWinCombineRelDirAndRelFile but for Posix (Path has the same problem). pathPosixCombineRelDirAndRelFile :: PP.Path PP.Rel PP.Dir -> PP.Path PP.Rel PP.File -> PP.Path PP.Rel PP.File pathPosixCombineRelDirAndRelFile lp rp - | PP.toFilePath lp == ['.', FPP.pathSeparator] = rp - | otherwise = lp PP. rp + | PP.toFilePath lp == ['.', FPP.pathSeparator] = rp + | otherwise = lp PP. rp + pathPosixCombineRelDirAndRelDir :: PP.Path PP.Rel PP.Dir -> PP.Path PP.Rel PP.Dir -> PP.Path PP.Rel PP.Dir pathPosixCombineRelDirAndRelDir lp rp - | PP.toFilePath lp == ['.', FPP.pathSeparator] = rp - | PP.toFilePath rp == ['.', FPP.pathSeparator] = lp - | otherwise = lp PP. rp + | PP.toFilePath lp == ['.', FPP.pathSeparator] = rp + | PP.toFilePath rp == ['.', FPP.pathSeparator] = lp + | otherwise = lp PP. rp + pathPosixCombineAbsDirAndRelDir :: PP.Path PP.Abs PP.Dir -> PP.Path PP.Rel PP.Dir -> PP.Path PP.Abs PP.Dir pathPosixCombineAbsDirAndRelDir lp rp - | PP.toFilePath rp == ['.', FPP.pathSeparator] = lp - | otherwise = lp PP. rp + | PP.toFilePath rp == ['.', FPP.pathSeparator] = lp + | otherwise = lp PP. rp prefixNumParentDirs :: RelPathPrefix -> Int -prefixNumParentDirs NoPrefix = 0 +prefixNumParentDirs NoPrefix = 0 prefixNumParentDirs (ParentDir n) = n relPathNumParentDirs :: Path' s (Rel r) t -> Int @@ -138,13 +148,13 @@ relPathNumParentDirs = prefixNumParentDirs . relPathPrefix relPathPrefix :: Path' s (Rel r) t -> RelPathPrefix relPathPrefix sp = case sp of - RelDir _ pr -> pr - RelFile _ pr -> pr - RelDirW _ pr -> pr - RelFileW _ pr -> pr - RelDirP _ pr -> pr - RelFileP _ pr -> pr - _ -> impossible + RelDir _ pr -> pr + RelFile _ pr -> pr + RelDirW _ pr -> pr + RelFileW _ pr -> pr + RelDirP _ pr -> pr + RelFileP _ pr -> pr + _ -> impossible impossible :: a impossible = error "This should be impossible." diff --git a/waspc/src/Util.hs b/waspc/src/Util.hs index a67e92eed..62e58d794 100644 --- a/waspc/src/Util.hs +++ b/waspc/src/Util.hs @@ -1,33 +1,35 @@ module Util - ( camelToKebabCase - , onFirst - , toLowerFirst - , toUpperFirst - , headSafe - , jsonSet - ) where + ( camelToKebabCase, + onFirst, + toLowerFirst, + toUpperFirst, + headSafe, + jsonSet, + ) +where -import Data.Char (isUpper, toLower, toUpper) import qualified Data.Aeson as Aeson -import qualified Data.Text as Text +import Data.Char (isUpper, toLower, toUpper) import qualified Data.HashMap.Strict as M - +import qualified Data.Text as Text camelToKebabCase :: String -> String camelToKebabCase "" = "" -camelToKebabCase camel@(camelHead:camelTail) = kebabHead:kebabTail +camelToKebabCase camel@(camelHead : camelTail) = kebabHead : kebabTail where kebabHead = toLower camelHead - kebabTail = concat $ map - (\(a, b) -> (if (isCamelHump (a, b)) then ['-'] else []) ++ [toLower b]) - (zip camel camelTail) + kebabTail = + concat $ + map + (\(a, b) -> (if (isCamelHump (a, b)) then ['-'] else []) ++ [toLower b]) + (zip camel camelTail) isCamelHump (a, b) = (not . isUpper) a && isUpper b -- | Applies given function to the first element of the list. -- If list is empty, returns empty list. onFirst :: (a -> a) -> [a] -> [a] onFirst _ [] = [] -onFirst f (x:xs) = (f x):xs +onFirst f (x : xs) = (f x) : xs toLowerFirst :: String -> String toLowerFirst = onFirst toLower diff --git a/waspc/src/Util/Fib.hs b/waspc/src/Util/Fib.hs index e1dec6fa7..3e7a83b30 100644 --- a/waspc/src/Util/Fib.hs +++ b/waspc/src/Util/Fib.hs @@ -1,6 +1,7 @@ -module Util.Fib ( - fibonacci -) where +module Util.Fib + ( fibonacci, + ) +where fibonacci :: Int -> Int fibonacci 0 = 0 diff --git a/waspc/src/Util/IO.hs b/waspc/src/Util/IO.hs index a3bad27e5..4c277b918 100644 --- a/waspc/src/Util/IO.hs +++ b/waspc/src/Util/IO.hs @@ -1,17 +1,18 @@ module Util.IO - ( listDirectoryDeep - , listDirectory - ) where + ( listDirectoryDeep, + listDirectory, + ) +where +import Control.Monad (filterM) +import qualified Path as P import qualified System.Directory as Dir import qualified System.FilePath as FilePath import System.IO.Error (isDoesNotExistError) import UnliftIO.Exception (catch, throwIO) -import Control.Monad (filterM) -import qualified Path as P - -- TODO: write tests. + -- | Lists all files in the directory recursively. -- All paths are relative to the directory we are listing. -- If directory does not exist, returns empty list. @@ -23,34 +24,36 @@ import qualified Path as P -- >>> ["test.txt", "bar/text2.txt"] listDirectoryDeep :: P.Path P.Abs P.Dir -> IO [P.Path P.Rel P.File] listDirectoryDeep absDirPath = do - (relFilePaths, relSubDirPaths) <- listDirectory absDirPath - `catch` \e -> if isDoesNotExistError e then return ([], []) else throwIO e - relSubDirFilesPaths <- mapM (listSubDirDeep . (absDirPath P.)) relSubDirPaths - return $ relFilePaths ++ concat relSubDirFilesPaths + (relFilePaths, relSubDirPaths) <- + listDirectory absDirPath + `catch` \e -> if isDoesNotExistError e then return ([], []) else throwIO e + relSubDirFilesPaths <- mapM (listSubDirDeep . (absDirPath P.)) relSubDirPaths + return $ relFilePaths ++ concat relSubDirFilesPaths where - -- | NOTE: Here, returned paths are relative to the main dir whose sub dir we are listing, - -- which is one level above what you might intuitively expect. - listSubDirDeep :: P.Path P.Abs P.Dir -> IO [P.Path P.Rel P.File] - listSubDirDeep subDirPath = do - files <- listDirectoryDeep subDirPath - return $ map (P.dirname subDirPath P.) files + listSubDirDeep :: P.Path P.Abs P.Dir -> IO [P.Path P.Rel P.File] + listSubDirDeep subDirPath = do + files <- listDirectoryDeep subDirPath + return $ map (P.dirname subDirPath P.) files -- TODO: write tests. + -- | Lists files and directories at top lvl of the directory. listDirectory :: P.Path P.Abs P.Dir -> IO ([P.Path P.Rel P.File], [P.Path P.Rel P.Dir]) listDirectory absDirPath = do - fpRelItemPaths <- Dir.listDirectory fpAbsDirPath - relFilePaths <- filterFiles fpAbsDirPath fpRelItemPaths - relDirPaths <- filterDirs fpAbsDirPath fpRelItemPaths - return (relFilePaths, relDirPaths) + fpRelItemPaths <- Dir.listDirectory fpAbsDirPath + relFilePaths <- filterFiles fpAbsDirPath fpRelItemPaths + relDirPaths <- filterDirs fpAbsDirPath fpRelItemPaths + return (relFilePaths, relDirPaths) where - fpAbsDirPath :: FilePath - fpAbsDirPath = P.toFilePath absDirPath + fpAbsDirPath :: FilePath + fpAbsDirPath = P.toFilePath absDirPath - filterFiles :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.File] - filterFiles absDir relItems = filterM (Dir.doesFileExist . (absDir FilePath.)) relItems - >>= mapM P.parseRelFile + filterFiles :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.File] + filterFiles absDir relItems = + filterM (Dir.doesFileExist . (absDir FilePath.)) relItems + >>= mapM P.parseRelFile - filterDirs :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.Dir] - filterDirs absDir relItems = filterM (Dir.doesDirectoryExist . (absDir FilePath.)) relItems - >>= mapM P.parseRelDir + filterDirs :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.Dir] + filterDirs absDir relItems = + filterM (Dir.doesDirectoryExist . (absDir FilePath.)) relItems + >>= mapM P.parseRelDir diff --git a/waspc/src/Util/Terminal.hs b/waspc/src/Util/Terminal.hs index 21c5127e9..9dbcdf89a 100644 --- a/waspc/src/Util/Terminal.hs +++ b/waspc/src/Util/Terminal.hs @@ -1,18 +1,20 @@ module Util.Terminal - ( Style(..) - , applyStyles - ) where + ( Style (..), + applyStyles, + ) +where -data Style = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - | Bold - | Underline +data Style + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | Bold + | Underline -- | Given a string, returns decorated string that when printed in terminal -- will have same content as original string but will also exibit specified styles. @@ -20,18 +22,19 @@ applyStyles :: [Style] -> String -> String applyStyles [] str = str applyStyles _ "" = "" applyStyles styles str = foldl applyStyle str styles ++ escapeCode ++ resetCode - where applyStyle s style = escapeCode ++ styleCode style ++ s + where + applyStyle s style = escapeCode ++ styleCode style ++ s styleCode :: Style -> String -styleCode Black = "[30m" -styleCode Red = "[31m" -styleCode Green = "[32m" -styleCode Yellow = "[33m" -styleCode Blue = "[34m" -styleCode Magenta = "[35m" -styleCode Cyan = "[36m" -styleCode White = "[37m" -styleCode Bold = "[1m" +styleCode Black = "[30m" +styleCode Red = "[31m" +styleCode Green = "[32m" +styleCode Yellow = "[33m" +styleCode Blue = "[34m" +styleCode Magenta = "[35m" +styleCode Cyan = "[36m" +styleCode White = "[37m" +styleCode Bold = "[1m" styleCode Underline = "[4m" escapeCode :: String diff --git a/waspc/src/Wasp.hs b/waspc/src/Wasp.hs index 8ec539114..fcc9e79ae 100644 --- a/waspc/src/Wasp.hs +++ b/waspc/src/Wasp.hs @@ -1,95 +1,85 @@ module Wasp - ( Wasp - , WaspElement (..) - , fromWaspElems - - , module Wasp.JsImport - , getJsImports - , setJsImports - - , module Wasp.App - , fromApp - , getApp - , setApp - - , getAuth - , getPSLEntities - - , getDb - - , module Wasp.Page - , getPages - , addPage - , getRoutes - - , getQueries - , addQuery - , getQueryByName - - , getActions - , addAction - , getActionByName - - , setExternalCodeFiles - , getExternalCodeFiles - - , setDotEnvFile - , getDotEnvFile - - , setIsBuild - , getIsBuild - - , setNpmDependencies - , getNpmDependencies - ) where - -import Data.Aeson (ToJSON (..), object, (.=)) -import StrongPath (Path, Abs, File) + ( Wasp, + WaspElement (..), + fromWaspElems, + module Wasp.JsImport, + getJsImports, + setJsImports, + module Wasp.App, + fromApp, + getApp, + setApp, + getAuth, + getPSLEntities, + getDb, + module Wasp.Page, + getPages, + addPage, + getRoutes, + getQueries, + addQuery, + getQueryByName, + getActions, + addAction, + getActionByName, + setExternalCodeFiles, + getExternalCodeFiles, + setDotEnvFile, + getDotEnvFile, + setIsBuild, + getIsBuild, + setNpmDependencies, + getNpmDependencies, + ) +where +import Data.Aeson (ToJSON (..), object, (.=)) import qualified ExternalCode -import qualified Util as U +import StrongPath (Abs, File, Path) +import qualified Util as U import qualified Wasp.Action -import Wasp.App +import Wasp.App import qualified Wasp.Auth import qualified Wasp.Db -import Wasp.Entity -import Wasp.JsImport -import Wasp.NpmDependencies (NpmDependencies) +import Wasp.Entity +import Wasp.JsImport +import Wasp.NpmDependencies (NpmDependencies) import qualified Wasp.NpmDependencies -import Wasp.Page +import Wasp.Page import qualified Wasp.Query -import Wasp.Route - +import Wasp.Route -- * Wasp data Wasp = Wasp - { waspElements :: [WaspElement] - , waspJsImports :: [JsImport] - , externalCodeFiles :: [ExternalCode.File] - , dotEnvFile :: Maybe (Path Abs File) - , isBuild :: Bool - } deriving (Show, Eq) + { waspElements :: [WaspElement], + waspJsImports :: [JsImport], + externalCodeFiles :: [ExternalCode.File], + dotEnvFile :: Maybe (Path Abs File), + isBuild :: Bool + } + deriving (Show, Eq) data WaspElement - = WaspElementApp !App - | WaspElementAuth !Wasp.Auth.Auth - | WaspElementDb !Wasp.Db.Db - | WaspElementPage !Page - | WaspElementNpmDependencies !NpmDependencies - | WaspElementRoute !Route - | WaspElementEntity !Wasp.Entity.Entity - | WaspElementQuery !Wasp.Query.Query - | WaspElementAction !Wasp.Action.Action - deriving (Show, Eq) + = WaspElementApp !App + | WaspElementAuth !Wasp.Auth.Auth + | WaspElementDb !Wasp.Db.Db + | WaspElementPage !Page + | WaspElementNpmDependencies !NpmDependencies + | WaspElementRoute !Route + | WaspElementEntity !Wasp.Entity.Entity + | WaspElementQuery !Wasp.Query.Query + | WaspElementAction !Wasp.Action.Action + deriving (Show, Eq) fromWaspElems :: [WaspElement] -> Wasp -fromWaspElems elems = Wasp - { waspElements = elems - , waspJsImports = [] - , externalCodeFiles = [] - , dotEnvFile = Nothing - , isBuild = False +fromWaspElems elems = + Wasp + { waspElements = elems, + waspJsImports = [], + externalCodeFiles = [], + dotEnvFile = Nothing, + isBuild = False } -- * Build @@ -98,7 +88,7 @@ getIsBuild :: Wasp -> Bool getIsBuild = isBuild setIsBuild :: Wasp -> Bool -> Wasp -setIsBuild wasp isBuildNew = wasp { isBuild = isBuildNew } +setIsBuild wasp isBuildNew = wasp {isBuild = isBuildNew} -- * External code files @@ -106,7 +96,7 @@ getExternalCodeFiles :: Wasp -> [ExternalCode.File] getExternalCodeFiles = externalCodeFiles setExternalCodeFiles :: Wasp -> [ExternalCode.File] -> Wasp -setExternalCodeFiles wasp files = wasp { externalCodeFiles = files } +setExternalCodeFiles wasp files = wasp {externalCodeFiles = files} -- * Dot env files @@ -114,7 +104,7 @@ getDotEnvFile :: Wasp -> Maybe (Path Abs File) getDotEnvFile = dotEnvFile setDotEnvFile :: Wasp -> Maybe (Path Abs File) -> Wasp -setDotEnvFile wasp file = wasp { dotEnvFile = file } +setDotEnvFile wasp file = wasp {dotEnvFile = file} -- * Js imports @@ -122,25 +112,26 @@ getJsImports :: Wasp -> [JsImport] getJsImports = waspJsImports setJsImports :: Wasp -> [JsImport] -> Wasp -setJsImports wasp jsImports = wasp { waspJsImports = jsImports } +setJsImports wasp jsImports = wasp {waspJsImports = jsImports} -- * App getApp :: Wasp -> App -getApp wasp = let apps = getApps wasp in - if (length apps /= 1) - then error "Wasp has to contain exactly one WaspElementApp element!" - else head apps +getApp wasp = + let apps = getApps wasp + in if (length apps /= 1) + then error "Wasp has to contain exactly one WaspElementApp element!" + else head apps isAppElem :: WaspElement -> Bool -isAppElem WaspElementApp{} = True -isAppElem _ = False +isAppElem WaspElementApp {} = True +isAppElem _ = False getApps :: Wasp -> [App] getApps wasp = [app | (WaspElementApp app) <- waspElements wasp] setApp :: Wasp -> App -> Wasp -setApp wasp app = wasp { waspElements = (WaspElementApp app) : (filter (not . isAppElem) (waspElements wasp)) } +setApp wasp app = wasp {waspElements = (WaspElementApp app) : (filter (not . isAppElem) (waspElements wasp))} fromApp :: App -> Wasp fromApp app = fromWaspElems [WaspElementApp app] @@ -148,37 +139,40 @@ fromApp app = fromWaspElems [WaspElementApp app] -- * Auth getAuth :: Wasp -> Maybe Wasp.Auth.Auth -getAuth wasp = let auths = [a | WaspElementAuth a <- waspElements wasp] in - case auths of - [] -> Nothing +getAuth wasp = + let auths = [a | WaspElementAuth a <- waspElements wasp] + in case auths of + [] -> Nothing [a] -> Just a - _ -> error "Wasp can't contain more than one WaspElementAuth element!" + _ -> error "Wasp can't contain more than one WaspElementAuth element!" -- * Db getDb :: Wasp -> Maybe Wasp.Db.Db -getDb wasp = let dbs = [db | WaspElementDb db <- waspElements wasp] in - case dbs of - [] -> Nothing +getDb wasp = + let dbs = [db | WaspElementDb db <- waspElements wasp] + in case dbs of + [] -> Nothing [db] -> Just db - _ -> error "Wasp can't contain more than one Db element!" + _ -> error "Wasp can't contain more than one Db element!" -- * NpmDependencies getNpmDependencies :: Wasp -> NpmDependencies -getNpmDependencies wasp - = let depses = [d | (WaspElementNpmDependencies d) <- waspElements wasp] - in case depses of - [] -> Wasp.NpmDependencies.empty - [deps] -> deps - _ -> error "Wasp can't contain more than one NpmDependencies element!" +getNpmDependencies wasp = + let depses = [d | (WaspElementNpmDependencies d) <- waspElements wasp] + in case depses of + [] -> Wasp.NpmDependencies.empty + [deps] -> deps + _ -> error "Wasp can't contain more than one NpmDependencies element!" isNpmDependenciesElem :: WaspElement -> Bool -isNpmDependenciesElem WaspElementNpmDependencies{} = True -isNpmDependenciesElem _ = False +isNpmDependenciesElem WaspElementNpmDependencies {} = True +isNpmDependenciesElem _ = False setNpmDependencies :: Wasp -> NpmDependencies -> Wasp -setNpmDependencies wasp deps = wasp +setNpmDependencies wasp deps = + wasp { waspElements = WaspElementNpmDependencies deps : filter (not . isNpmDependenciesElem) (waspElements wasp) } @@ -193,7 +187,7 @@ getPages :: Wasp -> [Page] getPages wasp = [page | (WaspElementPage page) <- waspElements wasp] addPage :: Wasp -> Page -> Wasp -addPage wasp page = wasp { waspElements = (WaspElementPage page):(waspElements wasp) } +addPage wasp page = wasp {waspElements = (WaspElementPage page) : (waspElements wasp)} -- * Query @@ -201,7 +195,7 @@ getQueries :: Wasp -> [Wasp.Query.Query] getQueries wasp = [query | (WaspElementQuery query) <- waspElements wasp] addQuery :: Wasp -> Wasp.Query.Query -> Wasp -addQuery wasp query = wasp { waspElements = WaspElementQuery query : waspElements wasp } +addQuery wasp query = wasp {waspElements = WaspElementQuery query : waspElements wasp} -- | Gets query with a specified name from wasp, if such an action exists. -- We assume here that there are no two queries with same name. @@ -214,7 +208,7 @@ getActions :: Wasp -> [Wasp.Action.Action] getActions wasp = [action | (WaspElementAction action) <- waspElements wasp] addAction :: Wasp -> Wasp.Action.Action -> Wasp -addAction wasp action = wasp { waspElements = WaspElementAction action : waspElements wasp } +addAction wasp action = wasp {waspElements = WaspElementAction action : waspElements wasp} -- | Gets action with a specified name from wasp, if such an action exists. -- We assume here that there are no two actions with same name. @@ -226,13 +220,13 @@ getActionByName wasp name = U.headSafe $ filter (\a -> Wasp.Action._name a == na getPSLEntities :: Wasp -> [Wasp.Entity.Entity] getPSLEntities wasp = [entity | (WaspElementEntity entity) <- (waspElements wasp)] - -- * ToJSON instances. instance ToJSON Wasp where - toJSON wasp = object - [ "app" .= getApp wasp - , "pages" .= getPages wasp - , "routes" .= getRoutes wasp - , "jsImports" .= getJsImports wasp - ] + toJSON wasp = + object + [ "app" .= getApp wasp, + "pages" .= getPages wasp, + "routes" .= getRoutes wasp, + "jsImports" .= getJsImports wasp + ] diff --git a/waspc/src/Wasp/Action.hs b/waspc/src/Wasp/Action.hs index 7c7af2d7e..facf462cd 100644 --- a/waspc/src/Wasp/Action.hs +++ b/waspc/src/Wasp/Action.hs @@ -1,21 +1,24 @@ module Wasp.Action - ( Action(..) - ) where + ( Action (..), + ) +where -import Data.Aeson (ToJSON (..), object, (.=)) -import Wasp.JsImport (JsImport) +import Data.Aeson (ToJSON (..), object, (.=)) +import Wasp.JsImport (JsImport) -- TODO: Very similar to Wasp.Query, consider extracting duplication. data Action = Action - { _name :: !String - , _jsFunction :: !JsImport - , _entities :: !(Maybe [String]) - } deriving (Show, Eq) + { _name :: !String, + _jsFunction :: !JsImport, + _entities :: !(Maybe [String]) + } + deriving (Show, Eq) instance ToJSON Action where - toJSON action = object - [ "name" .= _name action - , "jsFunction" .= _jsFunction action - , "entities" .= _entities action - ] + toJSON action = + object + [ "name" .= _name action, + "jsFunction" .= _jsFunction action, + "entities" .= _entities action + ] diff --git a/waspc/src/Wasp/App.hs b/waspc/src/Wasp/App.hs index a32015d44..00eaadcc3 100644 --- a/waspc/src/Wasp/App.hs +++ b/waspc/src/Wasp/App.hs @@ -1,18 +1,20 @@ module Wasp.App - ( App(..) - ) where - -import Data.Aeson ((.=), object, ToJSON(..)) + ( App (..), + ) +where +import Data.Aeson (ToJSON (..), object, (.=)) data App = App - { appName :: !String -- Identifier - , appTitle :: !String - , appHead :: !(Maybe [String]) - } deriving (Show, Eq) + { appName :: !String, -- Identifier + appTitle :: !String, + appHead :: !(Maybe [String]) + } + deriving (Show, Eq) instance ToJSON App where - toJSON app = object - [ "name" .= appName app - , "title" .= appTitle app - ] + toJSON app = + object + [ "name" .= appName app, + "title" .= appTitle app + ] diff --git a/waspc/src/Wasp/Auth.hs b/waspc/src/Wasp/Auth.hs index 4d6cdddfb..654125a39 100644 --- a/waspc/src/Wasp/Auth.hs +++ b/waspc/src/Wasp/Auth.hs @@ -1,14 +1,16 @@ module Wasp.Auth - ( Auth (..) - , AuthMethod (..) - ) where + ( Auth (..), + AuthMethod (..), + ) +where data Auth = Auth - { _userEntity :: !String - , _methods :: [AuthMethod] - , _onAuthFailedRedirectTo :: !String - } deriving (Show, Eq) + { _userEntity :: !String, + _methods :: [AuthMethod], + _onAuthFailedRedirectTo :: !String + } + deriving (Show, Eq) data AuthMethod - = EmailAndPassword - deriving (Show, Eq) + = EmailAndPassword + deriving (Show, Eq) diff --git a/waspc/src/Wasp/Db.hs b/waspc/src/Wasp/Db.hs index 28a19ab0d..3f9b03a25 100644 --- a/waspc/src/Wasp/Db.hs +++ b/waspc/src/Wasp/Db.hs @@ -1,13 +1,15 @@ module Wasp.Db - ( Db (..) - , DbSystem (..) - ) where + ( Db (..), + DbSystem (..), + ) +where data Db = Db - { _system :: !DbSystem - } deriving (Show, Eq) + { _system :: !DbSystem + } + deriving (Show, Eq) data DbSystem - = PostgreSQL - | SQLite - deriving (Show, Eq) + = PostgreSQL + | SQLite + deriving (Show, Eq) diff --git a/waspc/src/Wasp/Entity.hs b/waspc/src/Wasp/Entity.hs index 826fd3a18..3de93bda0 100644 --- a/waspc/src/Wasp/Entity.hs +++ b/waspc/src/Wasp/Entity.hs @@ -1,55 +1,55 @@ module Wasp.Entity - ( Entity (..) - , Field (..) - , FieldType (..) - , Scalar (..) - , Composite (..) - ) where - -import Data.Aeson (ToJSON(..), (.=), object) + ( Entity (..), + Field (..), + FieldType (..), + Scalar (..), + Composite (..), + ) +where +import Data.Aeson (ToJSON (..), object, (.=)) import qualified Psl.Ast.Model - data Entity = Entity - { _name :: !String - , _fields :: ![Field] - , _pslModelBody :: !Psl.Ast.Model.Body - } - deriving (Show, Eq) + { _name :: !String, + _fields :: ![Field], + _pslModelBody :: !Psl.Ast.Model.Body + } + deriving (Show, Eq) data Field = Field - { _fieldName :: !String - , _fieldType :: !FieldType - } - deriving (Show, Eq) + { _fieldName :: !String, + _fieldType :: !FieldType + } + deriving (Show, Eq) data FieldType = FieldTypeScalar Scalar | FieldTypeComposite Composite - deriving (Show, Eq) + deriving (Show, Eq) data Composite = Optional Scalar | List Scalar - deriving (Show, Eq) + deriving (Show, Eq) data Scalar - = String - | Boolean - | Int - | BigInt - | Float - | Decimal - | DateTime - | Json - | Bytes - -- | Name of the user-defined type. + = String + | Boolean + | Int + | BigInt + | Float + | Decimal + | DateTime + | Json + | Bytes + | -- | Name of the user-defined type. -- This could be another entity, or maybe an enum, -- we don't know here yet. - | UserType String - | Unsupported String - deriving (Show, Eq) + UserType String + | Unsupported String + deriving (Show, Eq) instance ToJSON Entity where - toJSON entity = object - [ "name" .= _name entity - , "fields" .= show (_fields entity) - , "pslModelBody" .= show (_pslModelBody entity) - ] + toJSON entity = + object + [ "name" .= _name entity, + "fields" .= show (_fields entity), + "pslModelBody" .= show (_pslModelBody entity) + ] diff --git a/waspc/src/Wasp/JsCode.hs b/waspc/src/Wasp/JsCode.hs index f9a811327..63cefb3f8 100644 --- a/waspc/src/Wasp/JsCode.hs +++ b/waspc/src/Wasp/JsCode.hs @@ -1,8 +1,9 @@ module Wasp.JsCode - ( JsCode(..) - ) where + ( JsCode (..), + ) +where -import Data.Aeson (ToJSON(..)) +import Data.Aeson (ToJSON (..)) import Data.Text (Text) data JsCode = JsCode !Text deriving (Show, Eq) @@ -11,4 +12,4 @@ data JsCode = JsCode !Text deriving (Show, Eq) -- ideal. Ideally all the generation logic would be in the generator. But for now this was -- the simplest way to implement it. instance ToJSON JsCode where - toJSON (JsCode code) = toJSON code + toJSON (JsCode code) = toJSON code diff --git a/waspc/src/Wasp/JsImport.hs b/waspc/src/Wasp/JsImport.hs index 90b600a99..f694b6217 100644 --- a/waspc/src/Wasp/JsImport.hs +++ b/waspc/src/Wasp/JsImport.hs @@ -1,24 +1,25 @@ module Wasp.JsImport - ( JsImport(..) - ) where - -import Data.Aeson (ToJSON (..), object, (.=)) - -import ExternalCode (SourceExternalCodeDir) -import StrongPath (File, Path', Posix, Rel) -import qualified StrongPath as SP + ( JsImport (..), + ) +where +import Data.Aeson (ToJSON (..), object, (.=)) +import ExternalCode (SourceExternalCodeDir) +import StrongPath (File, Path', Posix, Rel) +import qualified StrongPath as SP -- | Represents javascript import -> "import from ". data JsImport = JsImport - { _defaultImport :: !(Maybe String) - , _namedImports :: ![String] - , _from :: Path' Posix (Rel SourceExternalCodeDir) File - } deriving (Show, Eq) + { _defaultImport :: !(Maybe String), + _namedImports :: ![String], + _from :: Path' Posix (Rel SourceExternalCodeDir) File + } + deriving (Show, Eq) instance ToJSON JsImport where - toJSON jsImport = object - [ "defaultImport" .= _defaultImport jsImport - , "namedImports" .= _namedImports jsImport - , "from" .= SP.toFilePath (_from jsImport) - ] + toJSON jsImport = + object + [ "defaultImport" .= _defaultImport jsImport, + "namedImports" .= _namedImports jsImport, + "from" .= SP.toFilePath (_from jsImport) + ] diff --git a/waspc/src/Wasp/NpmDependencies.hs b/waspc/src/Wasp/NpmDependencies.hs index 575faed51..4ffff6676 100644 --- a/waspc/src/Wasp/NpmDependencies.hs +++ b/waspc/src/Wasp/NpmDependencies.hs @@ -1,20 +1,22 @@ module Wasp.NpmDependencies - ( NpmDependencies(..) - , empty - ) where - -import Data.Aeson (ToJSON (..), object, (.=)) -import NpmDependency + ( NpmDependencies (..), + empty, + ) +where +import Data.Aeson (ToJSON (..), object, (.=)) +import NpmDependency data NpmDependencies = NpmDependencies - { _dependencies :: ![NpmDependency] - } deriving (Show, Eq) + { _dependencies :: ![NpmDependency] + } + deriving (Show, Eq) empty :: NpmDependencies -empty = NpmDependencies { _dependencies = [] } +empty = NpmDependencies {_dependencies = []} instance ToJSON NpmDependencies where - toJSON deps = object - [ "dependencies" .= _dependencies deps - ] + toJSON deps = + object + [ "dependencies" .= _dependencies deps + ] diff --git a/waspc/src/Wasp/Operation.hs b/waspc/src/Wasp/Operation.hs index 641860159..d1765b21c 100644 --- a/waspc/src/Wasp/Operation.hs +++ b/waspc/src/Wasp/Operation.hs @@ -1,21 +1,23 @@ module Wasp.Operation - ( Operation(..) - , getName - , getJsFn - , getEntities - ) where + ( Operation (..), + getName, + getJsFn, + getEntities, + ) +where -- TODO: Is this ok approach, should I instead use typeclass? -- So far, all usages in the codebase could be easily replaced with the Typeclass. +import Wasp.Action (Action) +import qualified Wasp.Action as Action import Wasp.JsImport (JsImport) import Wasp.Query (Query) import qualified Wasp.Query as Query -import Wasp.Action (Action) -import qualified Wasp.Action as Action -data Operation = QueryOp Query - | ActionOp Action +data Operation + = QueryOp Query + | ActionOp Action getName :: Operation -> String getName (QueryOp query) = Query._name query diff --git a/waspc/src/Wasp/Page.hs b/waspc/src/Wasp/Page.hs index a6b4a0023..063c8e147 100644 --- a/waspc/src/Wasp/Page.hs +++ b/waspc/src/Wasp/Page.hs @@ -1,19 +1,21 @@ module Wasp.Page - ( Page(..) - ) where + ( Page (..), + ) +where -import Data.Aeson ((.=), object, ToJSON(..)) +import Data.Aeson (ToJSON (..), object, (.=)) import Wasp.JsImport (JsImport) - data Page = Page - { _name :: !String - , _component :: !JsImport - , _authRequired :: Maybe Bool - } deriving (Show, Eq) + { _name :: !String, + _component :: !JsImport, + _authRequired :: Maybe Bool + } + deriving (Show, Eq) instance ToJSON Page where - toJSON page = object - [ "name" .= _name page - , "component" .= _component page - ] + toJSON page = + object + [ "name" .= _name page, + "component" .= _component page + ] diff --git a/waspc/src/Wasp/Query.hs b/waspc/src/Wasp/Query.hs index 822bfd982..f298429d1 100644 --- a/waspc/src/Wasp/Query.hs +++ b/waspc/src/Wasp/Query.hs @@ -1,21 +1,24 @@ module Wasp.Query - ( Query(..) - ) where + ( Query (..), + ) +where -import Data.Aeson (ToJSON (..), object, (.=)) -import Wasp.JsImport (JsImport) +import Data.Aeson (ToJSON (..), object, (.=)) +import Wasp.JsImport (JsImport) -- TODO: Very similar to Wasp.Action, consider extracting duplication. data Query = Query - { _name :: !String - , _jsFunction :: !JsImport - , _entities :: !(Maybe [String]) - } deriving (Show, Eq) + { _name :: !String, + _jsFunction :: !JsImport, + _entities :: !(Maybe [String]) + } + deriving (Show, Eq) instance ToJSON Query where - toJSON query = object - [ "name" .= _name query - , "jsFunction" .= _jsFunction query - , "entities" .= _entities query - ] + toJSON query = + object + [ "name" .= _name query, + "jsFunction" .= _jsFunction query, + "entities" .= _entities query + ] diff --git a/waspc/src/Wasp/Route.hs b/waspc/src/Wasp/Route.hs index fc83df2ad..7805aaaa4 100644 --- a/waspc/src/Wasp/Route.hs +++ b/waspc/src/Wasp/Route.hs @@ -1,18 +1,21 @@ module Wasp.Route - ( Route(..) - ) where + ( Route (..), + ) +where -import Data.Aeson ((.=), object, ToJSON(..)) +import Data.Aeson (ToJSON (..), object, (.=)) data Route = Route - { _urlPath :: !String + { _urlPath :: !String, -- NOTE(matija): for now page is the only possible target, but in -- the future there might be different types of targets (e.g. another route). - , _targetPage :: !String - } deriving (Show, Eq) + _targetPage :: !String + } + deriving (Show, Eq) instance ToJSON Route where - toJSON route = object - [ "urlPath" .= _urlPath route - , "targetPage" .= _targetPage route - ] + toJSON route = + object + [ "urlPath" .= _urlPath route, + "targetPage" .= _targetPage route + ] diff --git a/waspc/src/Wasp/Style.hs b/waspc/src/Wasp/Style.hs index 89ac5211f..cffd310d7 100644 --- a/waspc/src/Wasp/Style.hs +++ b/waspc/src/Wasp/Style.hs @@ -1,18 +1,18 @@ module Wasp.Style - ( Style(..) - ) where + ( Style (..), + ) +where -import Data.Aeson (ToJSON (..)) -import Data.Text (Text) +import Data.Aeson (ToJSON (..)) +import Data.Text (Text) +import ExternalCode (SourceExternalCodeDir) +import StrongPath (File, Path', Posix, Rel, toFilePath) -import ExternalCode (SourceExternalCodeDir) -import StrongPath (File, Path', Posix, Rel, toFilePath) - - -data Style = ExtCodeCssFile !(Path' Posix (Rel SourceExternalCodeDir) File) - | CssCode !Text - deriving (Show, Eq) +data Style + = ExtCodeCssFile !(Path' Posix (Rel SourceExternalCodeDir) File) + | CssCode !Text + deriving (Show, Eq) instance ToJSON Style where - toJSON (ExtCodeCssFile path) = toJSON $ toFilePath path - toJSON (CssCode code) = toJSON code + toJSON (ExtCodeCssFile path) = toJSON $ toFilePath path + toJSON (CssCode code) = toJSON code diff --git a/waspc/src/WaspignoreFile.hs b/waspc/src/WaspignoreFile.hs index 374ac9676..8b009796f 100644 --- a/waspc/src/WaspignoreFile.hs +++ b/waspc/src/WaspignoreFile.hs @@ -1,14 +1,15 @@ module WaspignoreFile - ( WaspignoreFile - , parseWaspignoreFile - , readWaspignoreFile - , ignores - ) where + ( WaspignoreFile, + parseWaspignoreFile, + readWaspignoreFile, + ignores, + ) +where -import UnliftIO.Exception (catch, throwIO) -import System.IO.Error (isDoesNotExistError) -import StrongPath (Path, Abs, File, toFilePath) +import StrongPath (Abs, File, Path, toFilePath) import System.FilePath.Glob (Pattern, compile, match) +import System.IO.Error (isDoesNotExistError) +import UnliftIO.Exception (catch, throwIO) newtype WaspignoreFile = WaspignoreFile [Pattern] @@ -34,16 +35,17 @@ defaultIgnorePatterns = map compile [".waspignore"] -- [@[^xyz\]@] Matches a single character not in the set `xyz`. -- [@**/@] Matches a string of at least 1 character, including slashes. parseWaspignoreFile :: String -> WaspignoreFile -parseWaspignoreFile = WaspignoreFile . - (defaultIgnorePatterns++) . - map compile . - filter isPatternLine . - lines - where - isPatternLine :: String -> Bool - isPatternLine [] = False - isPatternLine ('#':_) = False - isPatternLine _ = True +parseWaspignoreFile = + WaspignoreFile + . (defaultIgnorePatterns ++) + . map compile + . filter isPatternLine + . lines + where + isPatternLine :: String -> Bool + isPatternLine [] = False + isPatternLine ('#' : _) = False + isPatternLine _ = True -- | Reads and parses the wasp ignore file. See 'parseWaspignoreFile' for details of -- the file format, but it is very similar to `.gitignore`'s format. @@ -51,10 +53,14 @@ parseWaspignoreFile = WaspignoreFile . -- If the ignore file does not exist, it is interpreted as a blank file. readWaspignoreFile :: Path Abs File -> IO WaspignoreFile readWaspignoreFile fp = do - text <- readFile (toFilePath fp) - `catch` (\e -> if isDoesNotExistError e then return "" - else throwIO e) - return $ parseWaspignoreFile text + text <- + readFile (toFilePath fp) + `catch` ( \e -> + if isDoesNotExistError e + then return "" + else throwIO e + ) + return $ parseWaspignoreFile text -- | Tests whether a file should be ignored according to a 'WaspignoreFile'. -- diff --git a/waspc/test/Fixtures.hs b/waspc/test/Fixtures.hs index 4c7f2c402..df99e2741 100644 --- a/waspc/test/Fixtures.hs +++ b/waspc/test/Fixtures.hs @@ -1,27 +1,29 @@ module Fixtures where -import qualified Path as P import Data.Maybe (fromJust) +import qualified Path as P import qualified System.FilePath as FP - import Wasp import qualified Wasp.Route as RouteAST app :: App -app = App - { appName = "test_app" - , appTitle = "Hello World!" - , appHead = Nothing +app = + App + { appName = "test_app", + appTitle = "Hello World!", + appHead = Nothing } routeHome :: RouteAST.Route -routeHome = RouteAST.Route - { RouteAST._urlPath = "/home" - , RouteAST._targetPage = "Home" +routeHome = + RouteAST.Route + { RouteAST._urlPath = "/home", + RouteAST._targetPage = "Home" } wasp :: Wasp -wasp = fromWaspElems +wasp = + fromWaspElems [ WaspElementApp app ] diff --git a/waspc/test/Generator/ExternalCodeGenerator/JsTest.hs b/waspc/test/Generator/ExternalCodeGenerator/JsTest.hs index bab8e91a3..cb97b12bd 100644 --- a/waspc/test/Generator/ExternalCodeGenerator/JsTest.hs +++ b/waspc/test/Generator/ExternalCodeGenerator/JsTest.hs @@ -1,20 +1,18 @@ module Generator.ExternalCodeGenerator.JsTest where -import Test.Tasty.Hspec -import qualified Path as P - -import qualified StrongPath as SP -import Generator.ExternalCodeGenerator.Js as Js import Generator.ExternalCodeGenerator.Common (asGenExtFile) +import Generator.ExternalCodeGenerator.Js as Js +import qualified Path as P +import qualified StrongPath as SP +import Test.Tasty.Hspec spec_resolveJsFileWaspImportsForExtCodeDir :: Spec spec_resolveJsFileWaspImportsForExtCodeDir = do - (asGenExtFile [P.relfile|extFile.js|], "import foo from 'bar'") ~> "import foo from 'bar'" - (asGenExtFile [P.relfile|extFile.js|], "import foo from '@wasp/bar'") ~> "import foo from '../bar'" - (asGenExtFile [P.relfile|a/extFile.js|], "import foo from \"@wasp/bar/foo\"") ~> - "import foo from \"../../bar/foo\"" + (asGenExtFile [P.relfile|extFile.js|], "import foo from 'bar'") ~> "import foo from 'bar'" + (asGenExtFile [P.relfile|extFile.js|], "import foo from '@wasp/bar'") ~> "import foo from '../bar'" + (asGenExtFile [P.relfile|a/extFile.js|], "import foo from \"@wasp/bar/foo\"") + ~> "import foo from \"../../bar/foo\"" where (path, text) ~> expectedText = - it (SP.toFilePath path ++ " " ++ show text ++ " -> " ++ show expectedText) $ do - Js.resolveJsFileWaspImportsForExtCodeDir (SP.fromPathRelDir [P.reldir|src|]) path text `shouldBe` expectedText - + it (SP.toFilePath path ++ " " ++ show text ++ " -> " ++ show expectedText) $ do + Js.resolveJsFileWaspImportsForExtCodeDir (SP.fromPathRelDir [P.reldir|src|]) path text `shouldBe` expectedText diff --git a/waspc/test/Generator/FileDraft/CopyFileDraftTest.hs b/waspc/test/Generator/FileDraft/CopyFileDraftTest.hs index ff0136443..c219acf09 100644 --- a/waspc/test/Generator/FileDraft/CopyFileDraftTest.hs +++ b/waspc/test/Generator/FileDraft/CopyFileDraftTest.hs @@ -1,32 +1,28 @@ module Generator.FileDraft.CopyFileDraftTest where -import Test.Tasty.Hspec - -import qualified Path as P - -import Generator.FileDraft -import qualified StrongPath as SP - -import Fixtures (systemPathRoot) +import Fixtures (systemPathRoot) +import Generator.FileDraft import qualified Generator.MockWriteableMonad as Mock - +import qualified Path as P +import qualified StrongPath as SP +import Test.Tasty.Hspec spec_CopyFileDraft :: Spec spec_CopyFileDraft = do - describe "write" $ do - it "Creates new file by copying existing file" $ do - let mock = write dstDir fileDraft - let mockLogs = Mock.getMockLogs mock Mock.defaultMockConfig - Mock.createDirectoryIfMissing_calls mockLogs - `shouldBe` [(True, SP.toFilePath $ SP.parent expectedDstPath)] - Mock.copyFile_calls mockLogs - `shouldBe` [(SP.toFilePath expectedSrcPath, SP.toFilePath expectedDstPath)] + describe "write" $ do + it "Creates new file by copying existing file" $ do + let mock = write dstDir fileDraft + let mockLogs = Mock.getMockLogs mock Mock.defaultMockConfig + Mock.createDirectoryIfMissing_calls mockLogs + `shouldBe` [(True, SP.toFilePath $ SP.parent expectedDstPath)] + Mock.copyFile_calls mockLogs + `shouldBe` [(SP.toFilePath expectedSrcPath, SP.toFilePath expectedDstPath)] where - (dstDir, dstPath, srcPath) = - ( SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|a/b|] - , SP.fromPathRelFile [P.relfile|c/d/dst.txt|] - , SP.fromPathAbsFile $ systemPathRoot P. [P.relfile|e/src.txt|] - ) - fileDraft = createCopyFileDraft dstPath srcPath - expectedSrcPath = srcPath - expectedDstPath = dstDir SP. dstPath + (dstDir, dstPath, srcPath) = + ( SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|a/b|], + SP.fromPathRelFile [P.relfile|c/d/dst.txt|], + SP.fromPathAbsFile $ systemPathRoot P. [P.relfile|e/src.txt|] + ) + fileDraft = createCopyFileDraft dstPath srcPath + expectedSrcPath = srcPath + expectedDstPath = dstDir SP. dstPath diff --git a/waspc/test/Generator/FileDraft/TemplateFileDraftTest.hs b/waspc/test/Generator/FileDraft/TemplateFileDraftTest.hs index 4a854c1b5..67b155c91 100644 --- a/waspc/test/Generator/FileDraft/TemplateFileDraftTest.hs +++ b/waspc/test/Generator/FileDraft/TemplateFileDraftTest.hs @@ -1,42 +1,39 @@ module Generator.FileDraft.TemplateFileDraftTest where -import Test.Tasty.Hspec - import Data.Aeson (object, (.=)) import Data.Text (Text) -import qualified Path as P - -import qualified StrongPath as SP -import Generator.FileDraft - -import qualified Generator.MockWriteableMonad as Mock import Fixtures (systemPathRoot) - +import Generator.FileDraft +import qualified Generator.MockWriteableMonad as Mock +import qualified Path as P +import qualified StrongPath as SP +import Test.Tasty.Hspec spec_TemplateFileDraft :: Spec spec_TemplateFileDraft = do - describe "write" $ do - it "Creates new file from existing template file" $ do - let mock = write dstDir fileDraft - let mockLogs = Mock.getMockLogs mock mockConfig - Mock.compileAndRenderTemplate_calls mockLogs - `shouldBe` [(templatePath, templateData)] - Mock.createDirectoryIfMissing_calls mockLogs - `shouldBe` [(True, SP.toFilePath $ SP.parent expectedDstPath)] - Mock.writeFileFromText_calls mockLogs - `shouldBe` [(SP.toFilePath expectedDstPath, mockTemplateContent)] - where - (dstDir, dstPath, templatePath) = - ( SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|a/b|] - , SP.fromPathRelFile [P.relfile|c/d/dst.txt|] - , SP.fromPathRelFile [P.relfile|e/tmpl.txt|] - ) - templateData = object [ "foo" .= ("bar" :: String) ] - fileDraft = createTemplateFileDraft dstPath templatePath (Just templateData) - expectedDstPath = dstDir SP. dstPath - mockTemplatesDirAbsPath = SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|mock/templates/dir|] - mockTemplateContent = "Mock template content" :: Text - mockConfig = Mock.defaultMockConfig - { Mock.getTemplatesDirAbsPath_impl = mockTemplatesDirAbsPath - , Mock.compileAndRenderTemplate_impl = \_ _ -> mockTemplateContent - } + describe "write" $ do + it "Creates new file from existing template file" $ do + let mock = write dstDir fileDraft + let mockLogs = Mock.getMockLogs mock mockConfig + Mock.compileAndRenderTemplate_calls mockLogs + `shouldBe` [(templatePath, templateData)] + Mock.createDirectoryIfMissing_calls mockLogs + `shouldBe` [(True, SP.toFilePath $ SP.parent expectedDstPath)] + Mock.writeFileFromText_calls mockLogs + `shouldBe` [(SP.toFilePath expectedDstPath, mockTemplateContent)] + where + (dstDir, dstPath, templatePath) = + ( SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|a/b|], + SP.fromPathRelFile [P.relfile|c/d/dst.txt|], + SP.fromPathRelFile [P.relfile|e/tmpl.txt|] + ) + templateData = object ["foo" .= ("bar" :: String)] + fileDraft = createTemplateFileDraft dstPath templatePath (Just templateData) + expectedDstPath = dstDir SP. dstPath + mockTemplatesDirAbsPath = SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|mock/templates/dir|] + mockTemplateContent = "Mock template content" :: Text + mockConfig = + Mock.defaultMockConfig + { Mock.getTemplatesDirAbsPath_impl = mockTemplatesDirAbsPath, + Mock.compileAndRenderTemplate_impl = \_ _ -> mockTemplateContent + } diff --git a/waspc/test/Generator/MockWriteableMonad.hs b/waspc/test/Generator/MockWriteableMonad.hs index 74967d19d..ea9de770c 100644 --- a/waspc/test/Generator/MockWriteableMonad.hs +++ b/waspc/test/Generator/MockWriteableMonad.hs @@ -1,35 +1,36 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Generator.MockWriteableMonad - ( MockWriteableMonad - , MockWriteableMonadLogs(..) - , MockWriteableMonadConfig(..) - , getMockLogs - , defaultMockConfig - ) where -import Data.Text (Text, pack) +module Generator.MockWriteableMonad + ( MockWriteableMonad, + MockWriteableMonadLogs (..), + MockWriteableMonadConfig (..), + getMockLogs, + defaultMockConfig, + ) +where + import Control.Monad.State import qualified Data.Aeson as Aeson -import qualified Path as P - -import StrongPath (Path, Rel, Abs, Dir, File) -import qualified StrongPath as SP -import Generator.Templates (TemplatesDir) -import Generator.FileDraft.WriteableMonad +import Data.Text (Text, pack) import Fixtures (systemPathRoot) - +import Generator.FileDraft.WriteableMonad +import Generator.Templates (TemplatesDir) +import qualified Path as P +import StrongPath (Abs, Dir, File, Path, Rel) +import qualified StrongPath as SP -- TODO: Instead of manually defining mock like this, consider using monad-mock package, -- it should do most of this automatically, now there is a lot of boilerplate. -- Or we ourselves can maybe use template haskell to reduce duplication. defaultMockConfig :: MockWriteableMonadConfig -defaultMockConfig = MockWriteableMonadConfig - { getTemplatesDirAbsPath_impl = SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|mock/templates/dir|] - , getTemplateFileAbsPath_impl = \path -> SP.fromPathAbsDir (systemPathRoot P. [P.reldir|mock/templates/dir|]) SP. path - , compileAndRenderTemplate_impl = \_ _ -> pack "Mock template content" - , doesFileExist_impl = const True +defaultMockConfig = + MockWriteableMonadConfig + { getTemplatesDirAbsPath_impl = SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|mock/templates/dir|], + getTemplateFileAbsPath_impl = \path -> SP.fromPathAbsDir (systemPathRoot P. [P.reldir|mock/templates/dir|]) SP. path, + compileAndRenderTemplate_impl = \_ _ -> pack "Mock template content", + doesFileExist_impl = const True } getMockLogs :: MockWriteableMonad a -> MockWriteableMonadConfig -> MockWriteableMonadLogs @@ -38,88 +39,93 @@ getMockLogs mock config = fst $ execState (unMockWriteableMonad mock) (emptyLogs emptyLogs = MockWriteableMonadLogs [] [] [] [] [] [] instance WriteableMonad MockWriteableMonad where - writeFileFromText dstPath text = MockWriteableMonad $ do - modifyLogs (writeFileFromText_addCall dstPath text) + writeFileFromText dstPath text = MockWriteableMonad $ do + modifyLogs (writeFileFromText_addCall dstPath text) - getTemplatesDirAbsPath = MockWriteableMonad $ do - modifyLogs getTemplatesDirAbsPath_addCall - (_, config) <- get - return $ getTemplatesDirAbsPath_impl config + getTemplatesDirAbsPath = MockWriteableMonad $ do + modifyLogs getTemplatesDirAbsPath_addCall + (_, config) <- get + return $ getTemplatesDirAbsPath_impl config - createDirectoryIfMissing createParents path = MockWriteableMonad $ do - modifyLogs (createDirectoryIfMissing_addCall createParents path) + createDirectoryIfMissing createParents path = MockWriteableMonad $ do + modifyLogs (createDirectoryIfMissing_addCall createParents path) - copyFile srcPath dstPath = MockWriteableMonad $ do - modifyLogs (copyFile_addCall srcPath dstPath) + copyFile srcPath dstPath = MockWriteableMonad $ do + modifyLogs (copyFile_addCall srcPath dstPath) - getTemplateFileAbsPath path = MockWriteableMonad $ do - modifyLogs (getTemplateFileAbsPath_addCall path) - (_, config) <- get - return $ getTemplateFileAbsPath_impl config path + getTemplateFileAbsPath path = MockWriteableMonad $ do + modifyLogs (getTemplateFileAbsPath_addCall path) + (_, config) <- get + return $ getTemplateFileAbsPath_impl config path - compileAndRenderTemplate path json = MockWriteableMonad $ do - modifyLogs (compileAndRenderTemplate_addCall path json) - (_, config) <- get - return $ compileAndRenderTemplate_impl config path json + compileAndRenderTemplate path json = MockWriteableMonad $ do + modifyLogs (compileAndRenderTemplate_addCall path json) + (_, config) <- get + return $ compileAndRenderTemplate_impl config path json - doesFileExist path = MockWriteableMonad $ do - (_, config) <- get - return $ doesFileExist_impl config path + doesFileExist path = MockWriteableMonad $ do + (_, config) <- get + return $ doesFileExist_impl config path - throwIO = throwIO + throwIO = throwIO instance MonadIO MockWriteableMonad where - liftIO = undefined + liftIO = undefined modifyLogs :: MonadState (a, b) m => (a -> a) -> m () modifyLogs f = modify (\(logs, config) -> (f logs, config)) newtype MockWriteableMonad a = MockWriteableMonad - { unMockWriteableMonad :: State (MockWriteableMonadLogs, MockWriteableMonadConfig) a - } - deriving (Monad, Applicative, Functor) + { unMockWriteableMonad :: State (MockWriteableMonadLogs, MockWriteableMonadConfig) a + } + deriving (Monad, Applicative, Functor) data MockWriteableMonadLogs = MockWriteableMonadLogs - { writeFileFromText_calls :: [(FilePath, Text)] - , getTemplatesDirAbsPath_calls :: [()] - , createDirectoryIfMissing_calls :: [(Bool, FilePath)] - , copyFile_calls :: [(FilePath, FilePath)] - , getTemplateFileAbsPath_calls :: [(Path (Rel TemplatesDir) File)] - , compileAndRenderTemplate_calls :: [(Path (Rel TemplatesDir) File, Aeson.Value)] - } + { writeFileFromText_calls :: [(FilePath, Text)], + getTemplatesDirAbsPath_calls :: [()], + createDirectoryIfMissing_calls :: [(Bool, FilePath)], + copyFile_calls :: [(FilePath, FilePath)], + getTemplateFileAbsPath_calls :: [(Path (Rel TemplatesDir) File)], + compileAndRenderTemplate_calls :: [(Path (Rel TemplatesDir) File, Aeson.Value)] + } data MockWriteableMonadConfig = MockWriteableMonadConfig - { getTemplatesDirAbsPath_impl :: Path Abs (Dir TemplatesDir) - , getTemplateFileAbsPath_impl :: Path (Rel TemplatesDir) File -> Path Abs File - , compileAndRenderTemplate_impl :: Path (Rel TemplatesDir) File -> Aeson.Value -> Text - , doesFileExist_impl :: FilePath -> Bool - } + { getTemplatesDirAbsPath_impl :: Path Abs (Dir TemplatesDir), + getTemplateFileAbsPath_impl :: Path (Rel TemplatesDir) File -> Path Abs File, + compileAndRenderTemplate_impl :: Path (Rel TemplatesDir) File -> Aeson.Value -> Text, + doesFileExist_impl :: FilePath -> Bool + } writeFileFromText_addCall :: FilePath -> Text -> MockWriteableMonadLogs -> MockWriteableMonadLogs writeFileFromText_addCall path text logs = - logs { writeFileFromText_calls = (path, text):(writeFileFromText_calls logs) } + logs {writeFileFromText_calls = (path, text) : (writeFileFromText_calls logs)} getTemplatesDirAbsPath_addCall :: MockWriteableMonadLogs -> MockWriteableMonadLogs getTemplatesDirAbsPath_addCall logs = - logs { getTemplatesDirAbsPath_calls = ():(getTemplatesDirAbsPath_calls logs) } + logs {getTemplatesDirAbsPath_calls = () : (getTemplatesDirAbsPath_calls logs)} getTemplateFileAbsPath_addCall :: Path (Rel TemplatesDir) File -> MockWriteableMonadLogs -> MockWriteableMonadLogs getTemplateFileAbsPath_addCall path logs = - logs { getTemplateFileAbsPath_calls = (path):(getTemplateFileAbsPath_calls logs) } + logs {getTemplateFileAbsPath_calls = (path) : (getTemplateFileAbsPath_calls logs)} copyFile_addCall :: FilePath -> FilePath -> MockWriteableMonadLogs -> MockWriteableMonadLogs copyFile_addCall srcPath dstPath logs = - logs { copyFile_calls = (srcPath, dstPath):(copyFile_calls logs) } + logs {copyFile_calls = (srcPath, dstPath) : (copyFile_calls logs)} createDirectoryIfMissing_addCall :: Bool -> FilePath -> MockWriteableMonadLogs -> MockWriteableMonadLogs createDirectoryIfMissing_addCall createParents path logs = - logs { createDirectoryIfMissing_calls = - (createParents, path):(createDirectoryIfMissing_calls logs) } + logs + { createDirectoryIfMissing_calls = + (createParents, path) : (createDirectoryIfMissing_calls logs) + } -compileAndRenderTemplate_addCall :: Path (Rel TemplatesDir) File - -> Aeson.Value - -> MockWriteableMonadLogs - -> MockWriteableMonadLogs +compileAndRenderTemplate_addCall :: + Path (Rel TemplatesDir) File -> + Aeson.Value -> + MockWriteableMonadLogs -> + MockWriteableMonadLogs compileAndRenderTemplate_addCall path json logs = - logs { compileAndRenderTemplate_calls = - (path, json):(compileAndRenderTemplate_calls logs) } + logs + { compileAndRenderTemplate_calls = + (path, json) : (compileAndRenderTemplate_calls logs) + } diff --git a/waspc/test/Generator/PackageJsonGeneratorTest.hs b/waspc/test/Generator/PackageJsonGeneratorTest.hs index 5a2e0769e..c869dc355 100644 --- a/waspc/test/Generator/PackageJsonGeneratorTest.hs +++ b/waspc/test/Generator/PackageJsonGeneratorTest.hs @@ -1,34 +1,36 @@ module Generator.PackageJsonGeneratorTest where -import Test.Tasty.Hspec - -import Generator.PackageJsonGenerator (resolveNpmDeps) -import qualified NpmDependency as ND - +import Generator.PackageJsonGenerator (resolveNpmDeps) +import qualified NpmDependency as ND +import Test.Tasty.Hspec spec_resolveNpmDeps :: Spec spec_resolveNpmDeps = do - let waspDeps = [ ("axios", "^0.20.0") - , ("lodash", "^4.17.15") - ] + let waspDeps = + [ ("axios", "^0.20.0"), + ("lodash", "^4.17.15") + ] - it "Concatenates two distincts lists of deps." $ do - let userDeps = [ ("foo", "bar") - , ("foo2", "bar2") - ] - resolveNpmDeps (ND.fromList waspDeps) (ND.fromList userDeps) - `shouldBe` Right (ND.fromList waspDeps, ND.fromList userDeps) + it "Concatenates two distincts lists of deps." $ do + let userDeps = + [ ("foo", "bar"), + ("foo2", "bar2") + ] + resolveNpmDeps (ND.fromList waspDeps) (ND.fromList userDeps) + `shouldBe` Right (ND.fromList waspDeps, ND.fromList userDeps) - it "Does not repeat dep if it is both user and wasp dep." $ do - let userDeps = [ ("axios", "^0.20.0") - , ("foo", "bar") - ] - resolveNpmDeps (ND.fromList waspDeps) (ND.fromList userDeps) - `shouldBe` Right (ND.fromList waspDeps, ND.fromList [("foo", "bar")]) + it "Does not repeat dep if it is both user and wasp dep." $ do + let userDeps = + [ ("axios", "^0.20.0"), + ("foo", "bar") + ] + resolveNpmDeps (ND.fromList waspDeps) (ND.fromList userDeps) + `shouldBe` Right (ND.fromList waspDeps, ND.fromList [("foo", "bar")]) - it "Reports error if user dep version does not match wasp dep version." $ do - let userDeps = [ ("axios", "^1.20.0") - , ("foo", "bar") - ] - let Left conflicts = resolveNpmDeps (ND.fromList waspDeps) (ND.fromList userDeps) - (map fst conflicts) `shouldBe` ND.fromList [("axios", "^1.20.0")] + it "Reports error if user dep version does not match wasp dep version." $ do + let userDeps = + [ ("axios", "^1.20.0"), + ("foo", "bar") + ] + let Left conflicts = resolveNpmDeps (ND.fromList waspDeps) (ND.fromList userDeps) + (map fst conflicts) `shouldBe` ND.fromList [("axios", "^1.20.0")] diff --git a/waspc/test/Generator/WebAppGeneratorTest.hs b/waspc/test/Generator/WebAppGeneratorTest.hs index 52ff3bf48..9262d7fea 100644 --- a/waspc/test/Generator/WebAppGeneratorTest.hs +++ b/waspc/test/Generator/WebAppGeneratorTest.hs @@ -1,66 +1,70 @@ module Generator.WebAppGeneratorTest where -import Test.Tasty.Hspec - -import System.FilePath (()) -import qualified Path as P - -import qualified StrongPath as SP import qualified CompileOptions -import Generator.WebAppGenerator -import Generator.FileDraft -import qualified Generator.FileDraft.TemplateFileDraft as TmplFD -import qualified Generator.FileDraft.CopyFileDraft as CopyFD -import qualified Generator.FileDraft.TextFileDraft as TextFD -import qualified Generator.WebAppGenerator.Common as Common -import Wasp import Fixtures (systemPathRoot) +import Generator.FileDraft +import qualified Generator.FileDraft.CopyFileDraft as CopyFD +import qualified Generator.FileDraft.TemplateFileDraft as TmplFD +import qualified Generator.FileDraft.TextFileDraft as TextFD +import Generator.WebAppGenerator +import qualified Generator.WebAppGenerator.Common as Common +import qualified Path as P +import qualified StrongPath as SP +import System.FilePath (()) +import Test.Tasty.Hspec +import Wasp -- TODO(martin): We could define Arbitrary instance for Wasp, define properties over -- generator functions and then do property testing on them, that would be cool. spec_WebAppGenerator :: Spec spec_WebAppGenerator = do - let testApp = (App "TestApp" "Test App" Nothing) - let testWasp = (fromApp testApp) - let testCompileOptions = CompileOptions.CompileOptions - { CompileOptions.externalCodeDirPath = SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|test/src|] - , CompileOptions.isBuild = False - } + let testApp = (App "TestApp" "Test App" Nothing) + let testWasp = (fromApp testApp) + let testCompileOptions = + CompileOptions.CompileOptions + { CompileOptions.externalCodeDirPath = SP.fromPathAbsDir $ systemPathRoot P. [P.reldir|test/src|], + CompileOptions.isBuild = False + } - describe "generateWebApp" $ do - -- NOTE: This test does not (for now) check that content of files is correct or - -- that they will successfully be written, it checks only that their - -- destinations are correct. - it "Given a simple Wasp, creates file drafts at expected destinations" $ do - let fileDrafts = generateWebApp testWasp testCompileOptions - let expectedFileDraftDstPaths = map ((SP.toFilePath Common.webAppRootDirInProjectRootDir) ) $ concat $ - [ [ "README.md" - , "package.json" - , ".gitignore" - ] - , map ("public" ) - [ "favicon.ico" - , "index.html" - , "manifest.json" - ] - , map ((SP.toFilePath Common.webAppSrcDirInWebAppRootDir) ) - [ "logo.png" - , "index.css" - , "index.js" - , "router.js" - , "serviceWorker.js" - ] + describe "generateWebApp" $ do + -- NOTE: This test does not (for now) check that content of files is correct or + -- that they will successfully be written, it checks only that their + -- destinations are correct. + it "Given a simple Wasp, creates file drafts at expected destinations" $ do + let fileDrafts = generateWebApp testWasp testCompileOptions + let expectedFileDraftDstPaths = + map ((SP.toFilePath Common.webAppRootDirInProjectRootDir) ) $ + concat $ + [ [ "README.md", + "package.json", + ".gitignore" + ], + map + ("public" ) + [ "favicon.ico", + "index.html", + "manifest.json" + ], + map + ((SP.toFilePath Common.webAppSrcDirInWebAppRootDir) ) + [ "logo.png", + "index.css", + "index.js", + "router.js", + "serviceWorker.js" ] + ] - mapM_ - -- NOTE(martin): I added fd to the pair here in order to have it - -- printed when shouldBe fails, otherwise I could not know which - -- file draft failed. - (\dstPath -> (dstPath, existsFdWithDst fileDrafts dstPath) - `shouldBe` (dstPath, True)) - expectedFileDraftDstPaths - + mapM_ + -- NOTE(martin): I added fd to the pair here in order to have it + -- printed when shouldBe fails, otherwise I could not know which + -- file draft failed. + ( \dstPath -> + (dstPath, existsFdWithDst fileDrafts dstPath) + `shouldBe` (dstPath, True) + ) + expectedFileDraftDstPaths existsFdWithDst :: [FileDraft] -> FilePath -> Bool existsFdWithDst fds dstPath = any ((== dstPath) . getFileDraftDstPath) fds diff --git a/waspc/test/Parser/ActionTest.hs b/waspc/test/Parser/ActionTest.hs index d2012ab15..4fb39a442 100644 --- a/waspc/test/Parser/ActionTest.hs +++ b/waspc/test/Parser/ActionTest.hs @@ -1,13 +1,11 @@ module Parser.ActionTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) -import qualified Path.Posix as PPosix - -import Parser.Action (action) -import Parser.Common (runWaspParser) -import qualified StrongPath as SP +import Data.Either (isLeft) +import Parser.Action (action) +import Parser.Common (runWaspParser) +import qualified Path.Posix as PPosix +import qualified StrongPath as SP +import Test.Tasty.Hspec import qualified Wasp.Action import qualified Wasp.JsImport @@ -18,25 +16,31 @@ import qualified Wasp.JsImport spec_parseAction :: Spec spec_parseAction = - describe "Parsing action declaration" $ do - let parseAction = runWaspParser action + describe "Parsing action declaration" $ do + let parseAction = runWaspParser action - it "When given a valid action declaration, returns correct AST" $ do - let testActionName = "myAction" - testActionJsFunctionName = "myJsAction" - testActionJsFunctionFrom = SP.fromPathRelFileP [PPosix.relfile|some/path|] - let testAction = Wasp.Action.Action - { Wasp.Action._name = testActionName - , Wasp.Action._jsFunction = Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = Nothing - , Wasp.JsImport._namedImports = [ testActionJsFunctionName ] - , Wasp.JsImport._from = testActionJsFunctionFrom - } - , Wasp.Action._entities = Nothing - } - parseAction ( "action " ++ testActionName ++ " {\n" ++ - " fn: import { " ++ testActionJsFunctionName ++ " } from \"@ext/some/path\"\n" ++ - "}" - ) `shouldBe` Right testAction - it "When given action wasp declaration without 'fn' property, should return Left" $ do - isLeft (parseAction "action myAction { }") `shouldBe` True + it "When given a valid action declaration, returns correct AST" $ do + let testActionName = "myAction" + testActionJsFunctionName = "myJsAction" + testActionJsFunctionFrom = SP.fromPathRelFileP [PPosix.relfile|some/path|] + let testAction = + Wasp.Action.Action + { Wasp.Action._name = testActionName, + Wasp.Action._jsFunction = + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = Nothing, + Wasp.JsImport._namedImports = [testActionJsFunctionName], + Wasp.JsImport._from = testActionJsFunctionFrom + }, + Wasp.Action._entities = Nothing + } + parseAction + ( "action " ++ testActionName ++ " {\n" + ++ " fn: import { " + ++ testActionJsFunctionName + ++ " } from \"@ext/some/path\"\n" + ++ "}" + ) + `shouldBe` Right testAction + it "When given action wasp declaration without 'fn' property, should return Left" $ do + isLeft (parseAction "action myAction { }") `shouldBe` True diff --git a/waspc/test/Parser/CommonTest.hs b/waspc/test/Parser/CommonTest.hs index ae53ad000..ef773ee45 100644 --- a/waspc/test/Parser/CommonTest.hs +++ b/waspc/test/Parser/CommonTest.hs @@ -1,110 +1,112 @@ module Parser.CommonTest where -import Test.Tasty.Hspec - -import Data.Either -import Path (relfile) -import Text.Parsec - -import Lexer -import qualified Lexer as L -import Parser.Common - +import Data.Either +import Lexer +import qualified Lexer as L +import Parser.Common +import Path (relfile) +import Test.Tasty.Hspec +import Text.Parsec spec_parseWaspCommon :: Spec spec_parseWaspCommon = do - describe "Parsing wasp element linked to an entity" $ do - it "When given a valid declaration, parses it correctly." $ do - runWaspParser (waspElementLinkedToEntity "entity-form" (waspClosure whiteSpace)) - "entity-form TaskForm { }" - `shouldBe` Right ("Task", "TaskForm", ()) + describe "Parsing wasp element linked to an entity" $ do + it "When given a valid declaration, parses it correctly." $ do + runWaspParser + (waspElementLinkedToEntity "entity-form" (waspClosure whiteSpace)) + "entity-form TaskForm { }" + `shouldBe` Right ("Task", "TaskForm", ()) - describe "Parsing wasp element name and properties" $ do - let parseWaspElementNameAndClosureContent elemKeyword p input = - runWaspParser (waspElementNameAndClosureContent elemKeyword p) input + describe "Parsing wasp element name and properties" $ do + let parseWaspElementNameAndClosureContent elemKeyword p input = + runWaspParser (waspElementNameAndClosureContent elemKeyword p) input - it "When given valid wasp element declaration along with whitespace parser,\ - \ returns an expected result" $ do - parseWaspElementNameAndClosureContent "app" whiteSpace "app someApp { }" - `shouldBe` Right ("someApp", ()) + it + "When given valid wasp element declaration along with whitespace parser,\ + \ returns an expected result" + $ do + parseWaspElementNameAndClosureContent "app" whiteSpace "app someApp { }" + `shouldBe` Right ("someApp", ()) - it "When given valid wasp element declaration along with char parser, returns\ - \ an expected result" $ do - parseWaspElementNameAndClosureContent "app" (char 'a') "app someApp {a}" - `shouldBe` Right ("someApp", 'a') + it + "When given valid wasp element declaration along with char parser, returns\ + \ an expected result" + $ do + parseWaspElementNameAndClosureContent "app" (char 'a') "app someApp {a}" + `shouldBe` Right ("someApp", 'a') - it "When given wasp element declaration with invalid name, returns Left" $ do - (isLeft $ parseWaspElementNameAndClosureContent "app" whiteSpace "app 1someApp { }") - `shouldBe` True + it "When given wasp element declaration with invalid name, returns Left" $ do + (isLeft $ parseWaspElementNameAndClosureContent "app" whiteSpace "app 1someApp { }") + `shouldBe` True - describe "Parsing wasp closure" $ do - it "Parses a closure with braces {}" $ do - runWaspParser (waspClosure (symbol "content")) "{ content }" - `shouldBe` Right "content" + describe "Parsing wasp closure" $ do + it "Parses a closure with braces {}" $ do + runWaspParser (waspClosure (symbol "content")) "{ content }" + `shouldBe` Right "content" - it "Does not parse a closure with brackets []" $ do - (isLeft $ runWaspParser (waspClosure (symbol "content")) "[ content ]") - `shouldBe` True + it "Does not parse a closure with brackets []" $ do + (isLeft $ runWaspParser (waspClosure (symbol "content")) "[ content ]") + `shouldBe` True - describe "Parsing wasp property with a closure as a value" $ do - it "When given a string as a key and closure as a value, returns closure content." $ do - runWaspParser (waspPropertyClosure "someKey" (symbol "content")) "someKey: { content }" - `shouldBe` Right "content" + describe "Parsing wasp property with a closure as a value" $ do + it "When given a string as a key and closure as a value, returns closure content." $ do + runWaspParser (waspPropertyClosure "someKey" (symbol "content")) "someKey: { content }" + `shouldBe` Right "content" - describe "Parsing wasp property - string literal" $ do - let parseWaspPropertyStringLiteral key input = - runWaspParser (waspPropertyStringLiteral key) input + describe "Parsing wasp property - string literal" $ do + let parseWaspPropertyStringLiteral key input = + runWaspParser (waspPropertyStringLiteral key) input - it "When given key/value with int value, returns Left." $ do - isLeft (parseWaspPropertyStringLiteral "title" "title: 23") - `shouldBe` True + it "When given key/value with int value, returns Left." $ do + isLeft (parseWaspPropertyStringLiteral "title" "title: 23") + `shouldBe` True - it "When given key/value with string value, returns a parsed value." $ do - let appTitle = "my first app" - parseWaspPropertyStringLiteral "title" ("title: \"" ++ appTitle ++ "\"") - `shouldBe` Right appTitle + it "When given key/value with string value, returns a parsed value." $ do + let appTitle = "my first app" + parseWaspPropertyStringLiteral "title" ("title: \"" ++ appTitle ++ "\"") + `shouldBe` Right appTitle - describe "Parsing wasp property - jsx closure {=jsx...jsx=}" $ do - let parseWaspPropertyJsxClosure key input = - runWaspParser (waspPropertyJsxClosure key) input + describe "Parsing wasp property - jsx closure {=jsx...jsx=}" $ do + let parseWaspPropertyJsxClosure key input = + runWaspParser (waspPropertyJsxClosure key) input - it "When given unexpected property key, returns Left." $ do - isLeft (parseWaspPropertyJsxClosure "content" "title: 23") - `shouldBe` True + it "When given unexpected property key, returns Left." $ do + isLeft (parseWaspPropertyJsxClosure "content" "title: 23") + `shouldBe` True - it "When given content within jsx closure, returns that content." $ do - parseWaspPropertyJsxClosure "content" "content: {=jsx some content jsx=}" - `shouldBe` Right "some content" + it "When given content within jsx closure, returns that content." $ do + parseWaspPropertyJsxClosure "content" "content: {=jsx some content jsx=}" + `shouldBe` Right "some content" - describe "Parsing wasp jsx closure" $ do - let parseWaspJsxClosure input = runWaspParser waspJsxClosure input - let closureContent = "
hello world
" + describe "Parsing wasp jsx closure" $ do + let parseWaspJsxClosure input = runWaspParser waspJsxClosure input + let closureContent = "
hello world
" - it "Returns the content of closure" $ do - parseWaspJsxClosure ("{=jsx " ++ closureContent ++ " jsx=}") - `shouldBe` Right closureContent + it "Returns the content of closure" $ do + parseWaspJsxClosure ("{=jsx " ++ closureContent ++ " jsx=}") + `shouldBe` Right closureContent - it "Can parse braces {} within the closure" $ do - let closureContentWithBraces = "
hello world {task.length}
" + it "Can parse braces {} within the closure" $ do + let closureContentWithBraces = "
hello world {task.length}
" - parseWaspJsxClosure ("{=jsx " ++ closureContentWithBraces ++ " jsx=}") - `shouldBe` Right closureContentWithBraces + parseWaspJsxClosure ("{=jsx " ++ closureContentWithBraces ++ " jsx=}") + `shouldBe` Right closureContentWithBraces - it "Removes leading and trailing spaces" $ do - parseWaspJsxClosure ("{=jsx " ++ closureContent ++ " jsx=}") - `shouldBe` Right closureContent + it "Removes leading and trailing spaces" $ do + parseWaspJsxClosure ("{=jsx " ++ closureContent ++ " jsx=}") + `shouldBe` Right closureContent - describe "Parsing relative file path string" $ do - it "Correctly parses relative path in double quotes" $ do - runWaspParser relFilePathString "\"foo/bar.txt\"" - `shouldBe` Right [relfile|foo/bar.txt|] + describe "Parsing relative file path string" $ do + it "Correctly parses relative path in double quotes" $ do + runWaspParser relFilePathString "\"foo/bar.txt\"" + `shouldBe` Right [relfile|foo/bar.txt|] - -- TODO: It is not passing on Windows, due to Path differently parsing paths on Windows. - -- Check out Path.Posix vs Path.Windows. - -- it "When path is not relative, returns Left" $ do - -- isLeft (runWaspParser relFilePathString "\"/foo/bar.txt\"") `shouldBe` True + -- TODO: It is not passing on Windows, due to Path differently parsing paths on Windows. + -- Check out Path.Posix vs Path.Windows. + -- it "When path is not relative, returns Left" $ do + -- isLeft (runWaspParser relFilePathString "\"/foo/bar.txt\"") `shouldBe` True - describe "Parsing wasp array" $ do - it "Correctly parses array of identifiers" $ do - runWaspParser (waspList L.identifier) "[ Task, Project ,User]" - `shouldBe` Right ["Task", "Project", "User"] + describe "Parsing wasp array" $ do + it "Correctly parses array of identifiers" $ do + runWaspParser (waspList L.identifier) "[ Task, Project ,User]" + `shouldBe` Right ["Task", "Project", "User"] diff --git a/waspc/test/Parser/DbTest.hs b/waspc/test/Parser/DbTest.hs index 9bf32b85c..52391ba9d 100644 --- a/waspc/test/Parser/DbTest.hs +++ b/waspc/test/Parser/DbTest.hs @@ -1,24 +1,21 @@ module Parser.DbTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) - -import Parser.Common (runWaspParser) -import Parser.Db (db) +import Data.Either (isLeft) +import Parser.Common (runWaspParser) +import Parser.Db (db) +import Test.Tasty.Hspec import qualified Wasp.Db - spec_parseDb :: Spec spec_parseDb = - describe "Parsing db declaration" $ do - let parseDb input = runWaspParser db input + describe "Parsing db declaration" $ do + let parseDb input = runWaspParser db input - it "When given a valid db declaration, returns correct AST" $ do - parseDb "db { system: PostgreSQL }" - `shouldBe` Right (Wasp.Db.Db { Wasp.Db._system = Wasp.Db.PostgreSQL }) - parseDb "db { system: SQLite }" - `shouldBe` Right (Wasp.Db.Db { Wasp.Db._system = Wasp.Db.SQLite }) + it "When given a valid db declaration, returns correct AST" $ do + parseDb "db { system: PostgreSQL }" + `shouldBe` Right (Wasp.Db.Db {Wasp.Db._system = Wasp.Db.PostgreSQL}) + parseDb "db { system: SQLite }" + `shouldBe` Right (Wasp.Db.Db {Wasp.Db._system = Wasp.Db.SQLite}) - it "When given db wasp declaration without 'db', should return Left" $ do - isLeft (parseDb "db { }") `shouldBe` True + it "When given db wasp declaration without 'db', should return Left" $ do + isLeft (parseDb "db { }") `shouldBe` True diff --git a/waspc/test/Parser/ExternalCodeTest.hs b/waspc/test/Parser/ExternalCodeTest.hs index 22baad0d4..b358f234a 100644 --- a/waspc/test/Parser/ExternalCodeTest.hs +++ b/waspc/test/Parser/ExternalCodeTest.hs @@ -1,21 +1,18 @@ module Parser.ExternalCodeTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) -import qualified Path.Posix as PPosix - -import Parser.Common (runWaspParser) -import Parser.ExternalCode (extCodeFilePathString) -import qualified StrongPath as SP - +import Data.Either (isLeft) +import Parser.Common (runWaspParser) +import Parser.ExternalCode (extCodeFilePathString) +import qualified Path.Posix as PPosix +import qualified StrongPath as SP +import Test.Tasty.Hspec spec_ParserExternalCode :: Spec spec_ParserExternalCode = do - describe "Parsing external code file path string" $ do - it "Correctly parses external code path in double quotes" $ do - runWaspParser extCodeFilePathString "\"@ext/foo/bar.txt\"" - `shouldBe` Right (SP.fromPathRelFileP [PPosix.relfile|foo/bar.txt|]) + describe "Parsing external code file path string" $ do + it "Correctly parses external code path in double quotes" $ do + runWaspParser extCodeFilePathString "\"@ext/foo/bar.txt\"" + `shouldBe` Right (SP.fromPathRelFileP [PPosix.relfile|foo/bar.txt|]) - it "When path does not start with @ext/, returns Left" $ do - isLeft (runWaspParser extCodeFilePathString "\"@ext2/foo/bar.txt\"") `shouldBe` True + it "When path does not start with @ext/, returns Left" $ do + isLeft (runWaspParser extCodeFilePathString "\"@ext2/foo/bar.txt\"") `shouldBe` True diff --git a/waspc/test/Parser/JsImportTest.hs b/waspc/test/Parser/JsImportTest.hs index 4ce0d23c4..f4a71a7a5 100644 --- a/waspc/test/Parser/JsImportTest.hs +++ b/waspc/test/Parser/JsImportTest.hs @@ -1,48 +1,45 @@ module Parser.JsImportTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) -import Path.Posix (relfile) - -import Parser.Common (runWaspParser) -import Parser.JsImport (jsImport) -import qualified StrongPath as SP +import Data.Either (isLeft) +import Parser.Common (runWaspParser) +import Parser.JsImport (jsImport) +import Path.Posix (relfile) +import qualified StrongPath as SP +import Test.Tasty.Hspec import qualified Wasp - spec_parseJsImport :: Spec spec_parseJsImport = do - let someFilePath = SP.fromPathRelFileP [relfile|some/file.js|] + let someFilePath = SP.fromPathRelFileP [relfile|some/file.js|] - it "Parses external code js import with default import correctly" $ do - runWaspParser jsImport "import something from \"@ext/some/file.js\"" - `shouldBe` Right (Wasp.JsImport (Just "something") [] someFilePath) + it "Parses external code js import with default import correctly" $ do + runWaspParser jsImport "import something from \"@ext/some/file.js\"" + `shouldBe` Right (Wasp.JsImport (Just "something") [] someFilePath) - it "Parses correctly when there is whitespace up front" $ do - runWaspParser jsImport " import something from \"@ext/some/file.js\"" - `shouldBe` Right (Wasp.JsImport (Just "something") [] someFilePath) + it "Parses correctly when there is whitespace up front" $ do + runWaspParser jsImport " import something from \"@ext/some/file.js\"" + `shouldBe` Right (Wasp.JsImport (Just "something") [] someFilePath) - it "Parses correctly when 'from' is part of WHAT part" $ do - runWaspParser jsImport "import somethingfrom from \"@ext/some/file.js\"" - `shouldBe` Right (Wasp.JsImport (Just "somethingfrom") [] someFilePath) + it "Parses correctly when 'from' is part of WHAT part" $ do + runWaspParser jsImport "import somethingfrom from \"@ext/some/file.js\"" + `shouldBe` Right (Wasp.JsImport (Just "somethingfrom") [] someFilePath) - it "Parses correctly when 'what' is a single named export" $ do - runWaspParser jsImport "import { something } from \"@ext/some/file.js\"" - `shouldBe` Right (Wasp.JsImport Nothing ["something"] someFilePath) + it "Parses correctly when 'what' is a single named export" $ do + runWaspParser jsImport "import { something } from \"@ext/some/file.js\"" + `shouldBe` Right (Wasp.JsImport Nothing ["something"] someFilePath) - it "For now we don't support multiple named exports in WHAT part" $ do - isLeft (runWaspParser jsImport "import { foo, bar } from \"@ext/some/file.js\"") - `shouldBe` True + it "For now we don't support multiple named exports in WHAT part" $ do + isLeft (runWaspParser jsImport "import { foo, bar } from \"@ext/some/file.js\"") + `shouldBe` True - it "Throws error if there is no whitespace after import" $ do - isLeft (runWaspParser jsImport "importsomething from \"@ext/some/file.js\"") - `shouldBe` True + it "Throws error if there is no whitespace after import" $ do + isLeft (runWaspParser jsImport "importsomething from \"@ext/some/file.js\"") + `shouldBe` True - it "Throws error if 'from' part is not referring to the external code" $ do - isLeft (runWaspParser jsImport "import something from \"some/file.js\"") - `shouldBe` True + it "Throws error if 'from' part is not referring to the external code" $ do + isLeft (runWaspParser jsImport "import something from \"some/file.js\"") + `shouldBe` True - it "For now we don't support single quotes in FROM part (TODO: support them in the future!)" $ do - isLeft (runWaspParser jsImport "import something from '@ext/some/file.js'") - `shouldBe` True + it "For now we don't support single quotes in FROM part (TODO: support them in the future!)" $ do + isLeft (runWaspParser jsImport "import something from '@ext/some/file.js'") + `shouldBe` True diff --git a/waspc/test/Parser/NpmDependenciesTest.hs b/waspc/test/Parser/NpmDependenciesTest.hs index ee1abd110..cfdb0eebd 100644 --- a/waspc/test/Parser/NpmDependenciesTest.hs +++ b/waspc/test/Parser/NpmDependenciesTest.hs @@ -1,26 +1,24 @@ module Parser.NpmDependenciesTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) - -import qualified NpmDependency as ND -import Parser.Common (runWaspParser) -import Parser.NpmDependencies (npmDependencies) -import Wasp.NpmDependencies - +import Data.Either (isLeft) +import qualified NpmDependency as ND +import Parser.Common (runWaspParser) +import Parser.NpmDependencies (npmDependencies) +import Test.Tasty.Hspec +import Wasp.NpmDependencies spec_parseNpmDependencies :: Spec spec_parseNpmDependencies = do - describe "Parsing npm dependencies" $ do - it "When given a valid declaration with valid json, parses it correctly" $ do - runWaspParser npmDependencies "dependencies {=json \"foo\": \"test1\", \"bar\": \"test2\" json=}" - `shouldBe` Right NpmDependencies - { _dependencies = - [ ND.NpmDependency { ND._name = "foo", ND._version = "test1" } - , ND.NpmDependency { ND._name = "bar", ND._version = "test2" } - ] - } - it "When given invalid json, reports error" $ do - isLeft (runWaspParser npmDependencies "dependencies {=json foo: 42 json=}") - `shouldBe` True + describe "Parsing npm dependencies" $ do + it "When given a valid declaration with valid json, parses it correctly" $ do + runWaspParser npmDependencies "dependencies {=json \"foo\": \"test1\", \"bar\": \"test2\" json=}" + `shouldBe` Right + NpmDependencies + { _dependencies = + [ ND.NpmDependency {ND._name = "foo", ND._version = "test1"}, + ND.NpmDependency {ND._name = "bar", ND._version = "test2"} + ] + } + it "When given invalid json, reports error" $ do + isLeft (runWaspParser npmDependencies "dependencies {=json foo: 42 json=}") + `shouldBe` True diff --git a/waspc/test/Parser/OperationTest.hs b/waspc/test/Parser/OperationTest.hs index 6f1ff9a3d..5c577adc2 100644 --- a/waspc/test/Parser/OperationTest.hs +++ b/waspc/test/Parser/OperationTest.hs @@ -1,35 +1,35 @@ module Parser.OperationTest where -import Test.Tasty.Hspec - -import Data.List (intercalate) -import qualified Path.Posix as PPosix - -import Parser.Common (runWaspParser) -import Parser.Operation -import qualified StrongPath as SP +import Data.List (intercalate) +import Parser.Common (runWaspParser) +import Parser.Operation +import qualified Path.Posix as PPosix +import qualified StrongPath as SP +import Test.Tasty.Hspec import qualified Wasp.JsImport - spec_parseOperation :: Spec spec_parseOperation = - describe "Parsing operation properties" $ do - let parseOperationProperties = runWaspParser properties + describe "Parsing operation properties" $ do + let parseOperationProperties = runWaspParser properties - it "When given a valid list of properties, correctly parses them" $ do - let testJsFnName = "myJsFn" - testJsFnFrom = SP.fromPathRelFileP [PPosix.relfile|some/path|] - let testProps = - [ JsFunction $ Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = Nothing - , Wasp.JsImport._namedImports = [ testJsFnName ] - , Wasp.JsImport._from = testJsFnFrom - } - , Entities ["Task", "Project"] ] - parseOperationProperties ( - intercalate ",\n" - [ "fn: import { " ++ testJsFnName ++ " } from \"@ext/some/path\"" - , "entities: [Task, Project]" - ] - ) - `shouldBe` Right testProps + it "When given a valid list of properties, correctly parses them" $ do + let testJsFnName = "myJsFn" + testJsFnFrom = SP.fromPathRelFileP [PPosix.relfile|some/path|] + let testProps = + [ JsFunction $ + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = Nothing, + Wasp.JsImport._namedImports = [testJsFnName], + Wasp.JsImport._from = testJsFnFrom + }, + Entities ["Task", "Project"] + ] + parseOperationProperties + ( intercalate + ",\n" + [ "fn: import { " ++ testJsFnName ++ " } from \"@ext/some/path\"", + "entities: [Task, Project]" + ] + ) + `shouldBe` Right testProps diff --git a/waspc/test/Parser/PageTest.hs b/waspc/test/Parser/PageTest.hs index 32a05e4a6..8578df615 100644 --- a/waspc/test/Parser/PageTest.hs +++ b/waspc/test/Parser/PageTest.hs @@ -1,54 +1,58 @@ module Parser.PageTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) -import qualified Path.Posix as PPosix - -import Parser.Common (runWaspParser) -import Parser.Page (page) -import qualified StrongPath as SP +import Data.Either (isLeft) +import Parser.Common (runWaspParser) +import Parser.Page (page) +import qualified Path.Posix as PPosix +import qualified StrongPath as SP +import Test.Tasty.Hspec import qualified Wasp.JsImport import qualified Wasp.Page - spec_parsePage :: Spec spec_parsePage = - describe "Parsing page declaration" $ do - let parsePage input = runWaspParser page input + describe "Parsing page declaration" $ do + let parsePage input = runWaspParser page input - let expectedPageComponentImport = Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = Just "Main" - , Wasp.JsImport._namedImports = [] - , Wasp.JsImport._from = (SP.fromPathRelFileP [PPosix.relfile|pages/Main|]) - } + let expectedPageComponentImport = + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = Just "Main", + Wasp.JsImport._namedImports = [], + Wasp.JsImport._from = (SP.fromPathRelFileP [PPosix.relfile|pages/Main|]) + } - it "When given a valid page declaration, returns correct AST" $ do - let testPageName = "Landing" + it "When given a valid page declaration, returns correct AST" $ do + let testPageName = "Landing" - parsePage ( - "page " ++ testPageName ++ " { " ++ - "component: import Main from \"@ext/pages/Main\"" ++ - "}") - `shouldBe` Right (Wasp.Page.Page - { Wasp.Page._name = testPageName - , Wasp.Page._component = expectedPageComponentImport - , Wasp.Page._authRequired = Nothing - }) + parsePage + ( "page " ++ testPageName ++ " { " + ++ "component: import Main from \"@ext/pages/Main\"" + ++ "}" + ) + `shouldBe` Right + ( Wasp.Page.Page + { Wasp.Page._name = testPageName, + Wasp.Page._component = expectedPageComponentImport, + Wasp.Page._authRequired = Nothing + } + ) - it "When given a valid page with authRequired property, returns correct AST" $ do - let testPageName = "Landing" + it "When given a valid page with authRequired property, returns correct AST" $ do + let testPageName = "Landing" - parsePage ( - "page " ++ testPageName ++ " { " ++ - "component: import Main from \"@ext/pages/Main\"," ++ - "authRequired: true" ++ - "}") - `shouldBe` Right (Wasp.Page.Page - { Wasp.Page._name = testPageName - , Wasp.Page._component = expectedPageComponentImport - , Wasp.Page._authRequired = Just True - }) + parsePage + ( "page " ++ testPageName ++ " { " + ++ "component: import Main from \"@ext/pages/Main\"," + ++ "authRequired: true" + ++ "}" + ) + `shouldBe` Right + ( Wasp.Page.Page + { Wasp.Page._name = testPageName, + Wasp.Page._component = expectedPageComponentImport, + Wasp.Page._authRequired = Just True + } + ) - it "When given page wasp declaration without 'page', should return Left" $ do - isLeft (parsePage "Landing { component: import Main from \"@ext/pages/Main\" }") `shouldBe` True + it "When given page wasp declaration without 'page', should return Left" $ do + isLeft (parsePage "Landing { component: import Main from \"@ext/pages/Main\" }") `shouldBe` True diff --git a/waspc/test/Parser/ParserTest.hs b/waspc/test/Parser/ParserTest.hs index 654b5e3f8..9dadc1863 100644 --- a/waspc/test/Parser/ParserTest.hs +++ b/waspc/test/Parser/ParserTest.hs @@ -1,109 +1,124 @@ module Parser.ParserTest where -import Data.Either -import qualified Path.Posix as PPosix -import Test.Tasty.Hspec - -import NpmDependency as ND -import Parser -import Parser.Common (runWaspParser) +import Data.Either +import NpmDependency as ND +import Parser +import Parser.Common (runWaspParser) +import qualified Path.Posix as PPosix import qualified Psl.Parser.Model -import qualified StrongPath as SP -import Wasp +import qualified StrongPath as SP +import Test.Tasty.Hspec +import Wasp import qualified Wasp.Auth import qualified Wasp.Entity import qualified Wasp.JsImport import qualified Wasp.NpmDependencies import qualified Wasp.Page import qualified Wasp.Query -import qualified Wasp.Route as R +import qualified Wasp.Route as R spec_parseWasp :: Spec spec_parseWasp = - describe "Parsing wasp" $ do - it "When given wasp without app, should return Left" $ do - isLeft (parseWasp "hoho") `shouldBe` True + describe "Parsing wasp" $ do + it "When given wasp without app, should return Left" $ do + isLeft (parseWasp "hoho") `shouldBe` True - before (readFile "test/Parser/valid.wasp") $ do - it "When given a valid wasp source, should return correct Wasp" $ \wasp -> do - parseWasp wasp - `shouldBe` - Right (fromWaspElems - [ WaspElementApp $ App - { appName = "test_app" - , appTitle = "Hello World!" - , appHead = Nothing - } - , WaspElementAuth $ Wasp.Auth.Auth - { Wasp.Auth._userEntity = "User" - , Wasp.Auth._methods = [Wasp.Auth.EmailAndPassword] - , Wasp.Auth._onAuthFailedRedirectTo = "/test" - } - , WaspElementRoute $ R.Route - { R._urlPath = "/" - , R._targetPage = "Landing" - } - , WaspElementPage $ Wasp.Page.Page - { Wasp.Page._name = "Landing" - , Wasp.Page._component = Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = Just "Landing" - , Wasp.JsImport._namedImports = [] - , Wasp.JsImport._from = SP.fromPathRelFileP [PPosix.relfile|pages/Landing|] - } - , Wasp.Page._authRequired = Just False - } - , WaspElementRoute $ R.Route - { R._urlPath = "/test" - , R._targetPage = "TestPage" - } - , WaspElementPage $ Wasp.Page.Page - { Wasp.Page._name = "TestPage" - , Wasp.Page._component = Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = Just "Test" - , Wasp.JsImport._namedImports = [] - , Wasp.JsImport._from = SP.fromPathRelFileP [PPosix.relfile|pages/Test|] - } - , Wasp.Page._authRequired = Nothing - } - , WaspElementEntity $ Wasp.Entity.Entity - { Wasp.Entity._name = "Task" - , Wasp.Entity._fields = + before (readFile "test/Parser/valid.wasp") $ do + it "When given a valid wasp source, should return correct Wasp" $ \wasp -> + do + parseWasp wasp + `shouldBe` Right + ( fromWaspElems + [ WaspElementApp $ + App + { appName = "test_app", + appTitle = "Hello World!", + appHead = Nothing + }, + WaspElementAuth $ + Wasp.Auth.Auth + { Wasp.Auth._userEntity = "User", + Wasp.Auth._methods = [Wasp.Auth.EmailAndPassword], + Wasp.Auth._onAuthFailedRedirectTo = "/test" + }, + WaspElementRoute $ + R.Route + { R._urlPath = "/", + R._targetPage = "Landing" + }, + WaspElementPage $ + Wasp.Page.Page + { Wasp.Page._name = "Landing", + Wasp.Page._component = + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = Just "Landing", + Wasp.JsImport._namedImports = [], + Wasp.JsImport._from = SP.fromPathRelFileP [PPosix.relfile|pages/Landing|] + }, + Wasp.Page._authRequired = Just False + }, + WaspElementRoute $ + R.Route + { R._urlPath = "/test", + R._targetPage = "TestPage" + }, + WaspElementPage $ + Wasp.Page.Page + { Wasp.Page._name = "TestPage", + Wasp.Page._component = + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = Just "Test", + Wasp.JsImport._namedImports = [], + Wasp.JsImport._from = SP.fromPathRelFileP [PPosix.relfile|pages/Test|] + }, + Wasp.Page._authRequired = Nothing + }, + WaspElementEntity $ + Wasp.Entity.Entity + { Wasp.Entity._name = "Task", + Wasp.Entity._fields = [ Wasp.Entity.Field - { Wasp.Entity._fieldName = "id" - , Wasp.Entity._fieldType = Wasp.Entity.FieldTypeScalar Wasp.Entity.Int - } - , Wasp.Entity.Field - { Wasp.Entity._fieldName = "description" - , Wasp.Entity._fieldType = Wasp.Entity.FieldTypeScalar Wasp.Entity.String - } - , Wasp.Entity.Field - { Wasp.Entity._fieldName = "isDone" - , Wasp.Entity._fieldType = Wasp.Entity.FieldTypeScalar Wasp.Entity.Boolean - } - ] - , Wasp.Entity._pslModelBody = fromRight (error "failed to parse") $ - runWaspParser Psl.Parser.Model.body "\ + { Wasp.Entity._fieldName = "id", + Wasp.Entity._fieldType = Wasp.Entity.FieldTypeScalar Wasp.Entity.Int + }, + Wasp.Entity.Field + { Wasp.Entity._fieldName = "description", + Wasp.Entity._fieldType = Wasp.Entity.FieldTypeScalar Wasp.Entity.String + }, + Wasp.Entity.Field + { Wasp.Entity._fieldName = "isDone", + Wasp.Entity._fieldType = Wasp.Entity.FieldTypeScalar Wasp.Entity.Boolean + } + ], + Wasp.Entity._pslModelBody = + fromRight (error "failed to parse") $ + runWaspParser + Psl.Parser.Model.body + "\ \ id Int @id @default(autoincrement())\n\ \ description String\n\ \ isDone Boolean @default(false)" - } - , WaspElementQuery $ Wasp.Query.Query - { Wasp.Query._name = "myQuery" - , Wasp.Query._jsFunction = Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = Nothing - , Wasp.JsImport._namedImports = [ "myJsQuery" ] - , Wasp.JsImport._from = SP.fromPathRelFileP [PPosix.relfile|some/path|] - } - , Wasp.Query._entities = Nothing - } - , WaspElementNpmDependencies $ Wasp.NpmDependencies.NpmDependencies - { Wasp.NpmDependencies._dependencies = + }, + WaspElementQuery $ + Wasp.Query.Query + { Wasp.Query._name = "myQuery", + Wasp.Query._jsFunction = + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = Nothing, + Wasp.JsImport._namedImports = ["myJsQuery"], + Wasp.JsImport._from = SP.fromPathRelFileP [PPosix.relfile|some/path|] + }, + Wasp.Query._entities = Nothing + }, + WaspElementNpmDependencies $ + Wasp.NpmDependencies.NpmDependencies + { Wasp.NpmDependencies._dependencies = [ ND.NpmDependency - { ND._name = "lodash" - , ND._version = "^4.17.15" - } + { ND._name = "lodash", + ND._version = "^4.17.15" + } ] - } - ] - `setJsImports` [ JsImport (Just "something") [] (SP.fromPathRelFileP [PPosix.relfile|some/file|]) ] - ) + } + ] + `setJsImports` [JsImport (Just "something") [] (SP.fromPathRelFileP [PPosix.relfile|some/file|])] + ) diff --git a/waspc/test/Parser/QueryTest.hs b/waspc/test/Parser/QueryTest.hs index 07b89b235..f1e0d3e2f 100644 --- a/waspc/test/Parser/QueryTest.hs +++ b/waspc/test/Parser/QueryTest.hs @@ -1,39 +1,42 @@ module Parser.QueryTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) -import qualified Path.Posix as PPosix - -import Parser.Common (runWaspParser) -import Parser.Query (query) -import qualified StrongPath as SP +import Data.Either (isLeft) +import Parser.Common (runWaspParser) +import Parser.Query (query) +import qualified Path.Posix as PPosix +import qualified StrongPath as SP +import Test.Tasty.Hspec import qualified Wasp.JsImport import qualified Wasp.Query - spec_parseQuery :: Spec spec_parseQuery = - describe "Parsing query declaration" $ do - let parseQuery = runWaspParser query + describe "Parsing query declaration" $ do + let parseQuery = runWaspParser query - it "When given a valid query declaration, returns correct AST" $ do - let testQueryName = "myQuery" - testQueryJsFunctionName = "myJsQuery" - testQueryJsFunctionFrom = SP.fromPathRelFileP [PPosix.relfile|some/path|] - let testQuery = Wasp.Query.Query - { Wasp.Query._name = testQueryName - , Wasp.Query._jsFunction = Wasp.JsImport.JsImport - { Wasp.JsImport._defaultImport = Nothing - , Wasp.JsImport._namedImports = [ testQueryJsFunctionName ] - , Wasp.JsImport._from = testQueryJsFunctionFrom - } - , Wasp.Query._entities = Just ["Task", "Project"] - } - parseQuery ( "query " ++ testQueryName ++ " {\n" ++ - " fn: import { " ++ testQueryJsFunctionName ++ " } from \"@ext/some/path\",\n" ++ - " entities: [Task, Project]\n" ++ - "}" - ) `shouldBe` Right testQuery - it "When given query wasp declaration without 'fn' property, should return Left" $ do - isLeft (parseQuery "query myQuery { }") `shouldBe` True + it "When given a valid query declaration, returns correct AST" $ do + let testQueryName = "myQuery" + testQueryJsFunctionName = "myJsQuery" + testQueryJsFunctionFrom = SP.fromPathRelFileP [PPosix.relfile|some/path|] + let testQuery = + Wasp.Query.Query + { Wasp.Query._name = testQueryName, + Wasp.Query._jsFunction = + Wasp.JsImport.JsImport + { Wasp.JsImport._defaultImport = Nothing, + Wasp.JsImport._namedImports = [testQueryJsFunctionName], + Wasp.JsImport._from = testQueryJsFunctionFrom + }, + Wasp.Query._entities = Just ["Task", "Project"] + } + parseQuery + ( "query " ++ testQueryName ++ " {\n" + ++ " fn: import { " + ++ testQueryJsFunctionName + ++ " } from \"@ext/some/path\",\n" + ++ " entities: [Task, Project]\n" + ++ "}" + ) + `shouldBe` Right testQuery + it "When given query wasp declaration without 'fn' property, should return Left" $ do + isLeft (parseQuery "query myQuery { }") `shouldBe` True diff --git a/waspc/test/Parser/RouteTest.hs b/waspc/test/Parser/RouteTest.hs index bab5223f4..2245d4ec1 100644 --- a/waspc/test/Parser/RouteTest.hs +++ b/waspc/test/Parser/RouteTest.hs @@ -1,29 +1,29 @@ module Parser.RouteTest where -import Test.Tasty.Hspec - import Data.Either (isLeft) - import Parser.Common (runWaspParser) import Parser.Route (route) +import Test.Tasty.Hspec import qualified Wasp.Route as RouteAST spec_parseRoute :: Spec spec_parseRoute = - describe "Parsing route declaration" $ do - let parseRoute = runWaspParser route + describe "Parsing route declaration" $ do + let parseRoute = runWaspParser route - it "When given a valid route declaration, returns correct AST." $ do - let inputUrlPath = "/some/url/path" - let inputTargetPage = "somePage" + it "When given a valid route declaration, returns correct AST." $ do + let inputUrlPath = "/some/url/path" + let inputTargetPage = "somePage" - parseRoute ( - "route " ++ "\"" ++ inputUrlPath ++ "\"" ++ " -> page " ++ inputTargetPage - ) - `shouldBe` Right (RouteAST.Route - { RouteAST._urlPath = inputUrlPath - , RouteAST._targetPage = inputTargetPage - }) + parseRoute + ( "route " ++ "\"" ++ inputUrlPath ++ "\"" ++ " -> page " ++ inputTargetPage + ) + `shouldBe` Right + ( RouteAST.Route + { RouteAST._urlPath = inputUrlPath, + RouteAST._targetPage = inputTargetPage + } + ) - it "When given a route declaration without 'page', should return Left" $ do - isLeft (parseRoute "route \"/url\" -> Home") `shouldBe` True + it "When given a route declaration without 'page', should return Left" $ do + isLeft (parseRoute "route \"/url\" -> Home") `shouldBe` True diff --git a/waspc/test/Parser/StyleTest.hs b/waspc/test/Parser/StyleTest.hs index d74c8de29..a830aca39 100644 --- a/waspc/test/Parser/StyleTest.hs +++ b/waspc/test/Parser/StyleTest.hs @@ -1,26 +1,23 @@ module Parser.StyleTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) -import qualified Path.Posix as PPosix - -import Parser.Common (runWaspParser) -import Parser.Style (style) -import qualified StrongPath as SP +import Data.Either (isLeft) +import Parser.Common (runWaspParser) +import Parser.Style (style) +import qualified Path.Posix as PPosix +import qualified StrongPath as SP +import Test.Tasty.Hspec import qualified Wasp.Style - spec_parseStyle :: Spec spec_parseStyle = do - it "Parses external code file path correctly" $ do - runWaspParser style "\"@ext/some/file.css\"" - `shouldBe` Right (Wasp.Style.ExtCodeCssFile (SP.fromPathRelFileP [PPosix.relfile|some/file.css|])) + it "Parses external code file path correctly" $ do + runWaspParser style "\"@ext/some/file.css\"" + `shouldBe` Right (Wasp.Style.ExtCodeCssFile (SP.fromPathRelFileP [PPosix.relfile|some/file.css|])) - it "Parses css closure correctly" $ do - runWaspParser style "{=css Some css code css=}" - `shouldBe` Right (Wasp.Style.CssCode "Some css code") + it "Parses css closure correctly" $ do + runWaspParser style "{=css Some css code css=}" + `shouldBe` Right (Wasp.Style.CssCode "Some css code") - it "Throws error if path is not external code path." $ do - isLeft (runWaspParser style "\"some/file.css\"") - `shouldBe` True + it "Throws error if path is not external code path." $ do + isLeft (runWaspParser style "\"some/file.css\"") + `shouldBe` True diff --git a/waspc/test/Path/ExtraTest.hs b/waspc/test/Path/ExtraTest.hs index f7f2ea334..062471cf5 100644 --- a/waspc/test/Path/ExtraTest.hs +++ b/waspc/test/Path/ExtraTest.hs @@ -1,17 +1,15 @@ module Path.ExtraTest where -import Test.Tasty.Hspec - import Path (reldir) import qualified Path.Extra as PE - +import Test.Tasty.Hspec spec_reversePosixPath :: Spec spec_reversePosixPath = do - [reldir|.|] ~> "." - [reldir|foo|] ~> ".." - [reldir|foo/bar|] ~> "../.." - [reldir|./foo/bar/./test|] ~> "../../.." + [reldir|.|] ~> "." + [reldir|foo|] ~> ".." + [reldir|foo/bar|] ~> "../.." + [reldir|./foo/bar/./test|] ~> "../../.." where path ~> expectedReversedPath = it ((show path) ++ " -> " ++ expectedReversedPath) $ do - PE.reversePosixPath (PE.toPosixFilePath path) `shouldBe` expectedReversedPath + PE.reversePosixPath (PE.toPosixFilePath path) `shouldBe` expectedReversedPath diff --git a/waspc/test/Psl/Common/ModelTest.hs b/waspc/test/Psl/Common/ModelTest.hs index e6cec9aef..1b7cec049 100644 --- a/waspc/test/Psl/Common/ModelTest.hs +++ b/waspc/test/Psl/Common/ModelTest.hs @@ -1,94 +1,93 @@ module Psl.Common.ModelTest where -import qualified Psl.Ast.Model as AST - +import qualified Psl.Ast.Model as AST -- | Corresponds to sampleBodyAst below. sampleBodySchema :: String sampleBodySchema = unlines - [ " id Int @id @default(value: autoincrement())" - , " email String? @db.VarChar(200)" - , " posts Post[] @relation(\"UserPosts\", references: [id]) @customattr" - , " weirdType Unsupported(\"weird\")" - , "" - , " @@someattr([id, email], 2 + 4, [posts])" - ] + [ " id Int @id @default(value: autoincrement())", + " email String? @db.VarChar(200)", + " posts Post[] @relation(\"UserPosts\", references: [id]) @customattr", + " weirdType Unsupported(\"weird\")", + "", + " @@someattr([id, email], 2 + 4, [posts])" + ] -- | Corresponds to sampleBodySchema above. sampleBodyAst :: AST.Body sampleBodyAst = AST.Body - [ AST.ElementField - ( AST.Field - { AST._name = "id" - , AST._type = AST.Int - , AST._typeModifiers = [] - , AST._attrs = - [ AST.Attribute - { AST._attrName = "id" - , AST._attrArgs = [] - } - , AST.Attribute - { AST._attrName = "default" - , AST._attrArgs = - [ AST.AttrArgNamed "value" (AST.AttrArgFunc "autoincrement") - ] - } - ] - } - ) - , AST.ElementField - ( AST.Field - { AST._name = "email" - , AST._type = AST.String - , AST._typeModifiers = [AST.Optional] - , AST._attrs = - [ AST.Attribute - { AST._attrName = "db.VarChar" - , AST._attrArgs = - [ AST.AttrArgUnnamed (AST.AttrArgNumber "200") - ] - } - ] - } - ) - , AST.ElementField - ( AST.Field - { AST._name = "posts" - , AST._type = AST.UserType "Post" - , AST._typeModifiers = [AST.List] - , AST._attrs = - [ AST.Attribute - { AST._attrName = "relation" - , AST._attrArgs = - [ AST.AttrArgUnnamed (AST.AttrArgString "UserPosts") - , AST.AttrArgNamed "references" (AST.AttrArgFieldRefList ["id"]) - ] - } - , AST.Attribute - { AST._attrName = "customattr" - , AST._attrArgs = [] - } - ] - } - ) - , AST.ElementField - ( AST.Field - { AST._name = "weirdType" - , AST._type = AST.Unsupported "weird" - , AST._typeModifiers = [] - , AST._attrs = [] - } - ) - , AST.ElementBlockAttribute - ( AST.Attribute - { AST._attrName = "someattr" - , AST._attrArgs = - [ AST.AttrArgUnnamed (AST.AttrArgFieldRefList ["id", "email"]) - , AST.AttrArgUnnamed (AST.AttrArgUnknown "2 + 4") - , AST.AttrArgUnnamed (AST.AttrArgFieldRefList ["posts"]) - ] - } - ) - ] + [ AST.ElementField + ( AST.Field + { AST._name = "id", + AST._type = AST.Int, + AST._typeModifiers = [], + AST._attrs = + [ AST.Attribute + { AST._attrName = "id", + AST._attrArgs = [] + }, + AST.Attribute + { AST._attrName = "default", + AST._attrArgs = + [ AST.AttrArgNamed "value" (AST.AttrArgFunc "autoincrement") + ] + } + ] + } + ), + AST.ElementField + ( AST.Field + { AST._name = "email", + AST._type = AST.String, + AST._typeModifiers = [AST.Optional], + AST._attrs = + [ AST.Attribute + { AST._attrName = "db.VarChar", + AST._attrArgs = + [ AST.AttrArgUnnamed (AST.AttrArgNumber "200") + ] + } + ] + } + ), + AST.ElementField + ( AST.Field + { AST._name = "posts", + AST._type = AST.UserType "Post", + AST._typeModifiers = [AST.List], + AST._attrs = + [ AST.Attribute + { AST._attrName = "relation", + AST._attrArgs = + [ AST.AttrArgUnnamed (AST.AttrArgString "UserPosts"), + AST.AttrArgNamed "references" (AST.AttrArgFieldRefList ["id"]) + ] + }, + AST.Attribute + { AST._attrName = "customattr", + AST._attrArgs = [] + } + ] + } + ), + AST.ElementField + ( AST.Field + { AST._name = "weirdType", + AST._type = AST.Unsupported "weird", + AST._typeModifiers = [], + AST._attrs = [] + } + ), + AST.ElementBlockAttribute + ( AST.Attribute + { AST._attrName = "someattr", + AST._attrArgs = + [ AST.AttrArgUnnamed (AST.AttrArgFieldRefList ["id", "email"]), + AST.AttrArgUnnamed (AST.AttrArgUnknown "2 + 4"), + AST.AttrArgUnnamed (AST.AttrArgFieldRefList ["posts"]) + ] + } + ) + ] diff --git a/waspc/test/Psl/Generator/ModelTest.hs b/waspc/test/Psl/Generator/ModelTest.hs index 7fa7921f8..43f44e616 100644 --- a/waspc/test/Psl/Generator/ModelTest.hs +++ b/waspc/test/Psl/Generator/ModelTest.hs @@ -3,111 +3,123 @@ module Psl.Generator.ModelTest where -import Test.Tasty.Hspec -import Test.Tasty.QuickCheck - -import Parser.Common (runWaspParser) -import qualified Psl.Ast.Model as AST -import Psl.Common.ModelTest (sampleBodyAst) -import Psl.Generator.Model (generateModel) +import Parser.Common (runWaspParser) +import qualified Psl.Ast.Model as AST +import Psl.Common.ModelTest (sampleBodyAst) +import Psl.Generator.Model (generateModel) import qualified Psl.Parser.Model - +import Test.Tasty.Hspec +import Test.Tasty.QuickCheck spec_generatePslModel :: Spec spec_generatePslModel = do - describe "Complex example" $ do - let pslModelAst = AST.Model "User" sampleBodyAst + describe "Complex example" $ do + let pslModelAst = AST.Model "User" sampleBodyAst - it "parse(generate(sampleBodyAst)) == sampleBodyAst" $ do - runWaspParser Psl.Parser.Model.model (generateModel pslModelAst) `shouldBe` Right pslModelAst + it "parse(generate(sampleBodyAst)) == sampleBodyAst" $ do + runWaspParser Psl.Parser.Model.model (generateModel pslModelAst) `shouldBe` Right pslModelAst prop_generatePslModel :: Property -prop_generatePslModel = mapSize (const 100) $ \modelAst -> within 1000000 $ +prop_generatePslModel = mapSize (const 100) $ \modelAst -> + within 1000000 $ runWaspParser Psl.Parser.Model.model (generateModel modelAst) `shouldBe` Right modelAst instance Arbitrary AST.Model where - arbitrary = AST.Model <$> arbitraryIdentifier <*> arbitrary + arbitrary = AST.Model <$> arbitraryIdentifier <*> arbitrary instance Arbitrary AST.Body where - arbitrary = do - fieldElement <- AST.ElementField <$> arbitrary - elementsBefore <- scale (const 5) arbitrary - elementsAfter <- scale (const 5) arbitrary - return $ AST.Body $ elementsBefore ++ [fieldElement] ++ elementsAfter + arbitrary = do + fieldElement <- AST.ElementField <$> arbitrary + elementsBefore <- scale (const 5) arbitrary + elementsAfter <- scale (const 5) arbitrary + return $ AST.Body $ elementsBefore ++ [fieldElement] ++ elementsAfter instance Arbitrary AST.Element where - arbitrary = oneof [ AST.ElementField <$> arbitrary - , AST.ElementBlockAttribute <$> arbitrary - ] + arbitrary = + oneof + [ AST.ElementField <$> arbitrary, + AST.ElementBlockAttribute <$> arbitrary + ] instance Arbitrary AST.Field where - arbitrary = do - name <- arbitraryIdentifier - fieldType <- arbitrary - modifiers <- oneof [ (:[]) <$> arbitrary, return [] ] - attrs <- scale (const 5) arbitrary - return $ AST.Field { AST._name = name - , AST._type = fieldType - , AST._typeModifiers = modifiers - , AST._attrs = attrs - } + arbitrary = do + name <- arbitraryIdentifier + fieldType <- arbitrary + modifiers <- oneof [(: []) <$> arbitrary, return []] + attrs <- scale (const 5) arbitrary + return $ + AST.Field + { AST._name = name, + AST._type = fieldType, + AST._typeModifiers = modifiers, + AST._attrs = attrs + } instance Arbitrary AST.FieldType where - arbitrary = oneof - [ return AST.String - , return AST.Boolean - , return AST.Int - , return AST.BigInt - , return AST.Float - , return AST.Decimal - , return AST.DateTime - , return AST.Json - , return AST.Bytes - , AST.Unsupported . show <$> arbitraryIdentifier - , AST.UserType <$> arbitraryIdentifier ] + arbitrary = + oneof + [ return AST.String, + return AST.Boolean, + return AST.Int, + return AST.BigInt, + return AST.Float, + return AST.Decimal, + return AST.DateTime, + return AST.Json, + return AST.Bytes, + AST.Unsupported . show <$> arbitraryIdentifier, + AST.UserType <$> arbitraryIdentifier + ] instance Arbitrary AST.FieldTypeModifier where - arbitrary = oneof [ return AST.List, return AST.Optional ] + arbitrary = oneof [return AST.List, return AST.Optional] instance Arbitrary AST.Attribute where - arbitrary = do - name <- frequency - [ (2, arbitraryIdentifier) - , (1, ("db." ++) <$> arbitraryIdentifier) - ] - args <- scale (const 5) arbitrary - return $ AST.Attribute { AST._attrName = name, AST._attrArgs = args } + arbitrary = do + name <- + frequency + [ (2, arbitraryIdentifier), + (1, ("db." ++) <$> arbitraryIdentifier) + ] + args <- scale (const 5) arbitrary + return $ AST.Attribute {AST._attrName = name, AST._attrArgs = args} instance Arbitrary AST.AttributeArg where - arbitrary = oneof [ AST.AttrArgNamed <$> arbitraryIdentifier <*> arbitrary - , AST.AttrArgUnnamed <$> arbitrary ] + arbitrary = + oneof + [ AST.AttrArgNamed <$> arbitraryIdentifier <*> arbitrary, + AST.AttrArgUnnamed <$> arbitrary + ] instance Arbitrary AST.AttrArgValue where - arbitrary = oneof - [ AST.AttrArgString <$> arbitraryNonEmptyPrintableString - , AST.AttrArgIdentifier <$> arbitraryIdentifier - , AST.AttrArgFunc <$> arbitraryIdentifier - , AST.AttrArgFieldRefList <$> scale (const 5) (listOf1 arbitraryIdentifier) + arbitrary = + oneof + [ AST.AttrArgString <$> arbitraryNonEmptyPrintableString, + AST.AttrArgIdentifier <$> arbitraryIdentifier, + AST.AttrArgFunc <$> arbitraryIdentifier, + AST.AttrArgFieldRefList <$> scale (const 5) (listOf1 arbitraryIdentifier), -- NOTE: For now we are not supporting negative numbers. -- I couldn't figure out from Prisma docs if there could be the case -- where these numbers could be negative. Probably we should take care of that case. - , AST.AttrArgNumber <$> oneof - [ show <$> (arbitrary :: Gen Int) `suchThat` (>= 0) - , show <$> (arbitrary :: Gen Float) `suchThat` (>= 0) ] - -- NOTE: Unknown is commented out because unknown should contain only values - -- that are not recognized as any other type of attribute argument, - -- and defining how those are generated is not so simple, so I skipped it for now. - -- , AST.AttrArgUnknown <$> arbitraryNonEmptyPrintableString - ] + AST.AttrArgNumber + <$> oneof + [ show <$> (arbitrary :: Gen Int) `suchThat` (>= 0), + show <$> (arbitrary :: Gen Float) `suchThat` (>= 0) + ] + -- NOTE: Unknown is commented out because unknown should contain only values + -- that are not recognized as any other type of attribute argument, + -- and defining how those are generated is not so simple, so I skipped it for now. + -- , AST.AttrArgUnknown <$> arbitraryNonEmptyPrintableString + ] arbitraryNonEmptyPrintableString :: Gen String arbitraryNonEmptyPrintableString = listOf1 arbitraryPrintableChar arbitraryAlpha :: Gen Char -arbitraryAlpha = elements $ ['a'..'z'] ++ ['A'..'Z'] +arbitraryAlpha = elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] arbitraryAlphaNum :: Gen Char -arbitraryAlphaNum = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] +arbitraryAlphaNum = elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] arbitraryIdentifier :: Gen String arbitraryIdentifier = (:) <$> arbitraryAlpha <*> listOf arbitraryAlphaNum diff --git a/waspc/test/Psl/Parser/ModelTest.hs b/waspc/test/Psl/Parser/ModelTest.hs index b958877bc..aab7eb8ee 100644 --- a/waspc/test/Psl/Parser/ModelTest.hs +++ b/waspc/test/Psl/Parser/ModelTest.hs @@ -1,57 +1,55 @@ module Psl.Parser.ModelTest where -import Test.Tasty.Hspec - -import Data.Either (isLeft) -import Parser.Common (runWaspParser) -import qualified Psl.Ast.Model as AST -import Psl.Common.ModelTest (sampleBodyAst, sampleBodySchema) -import Psl.Parser.Model (attrArgument, body, model) - +import Data.Either (isLeft) +import Parser.Common (runWaspParser) +import qualified Psl.Ast.Model as AST +import Psl.Common.ModelTest (sampleBodyAst, sampleBodySchema) +import Psl.Parser.Model (attrArgument, body, model) +import Test.Tasty.Hspec spec_parsePslModel :: Spec spec_parsePslModel = do - describe "Complex example" $ do - let pslModel = "model User {\n" ++ sampleBodySchema ++ "\n}" - expectedModelAst = AST.Model "User" sampleBodyAst + describe "Complex example" $ do + let pslModel = "model User {\n" ++ sampleBodySchema ++ "\n}" + expectedModelAst = AST.Model "User" sampleBodyAst - it "Body parser correctly parses" $ do - runWaspParser body sampleBodySchema `shouldBe` Right sampleBodyAst + it "Body parser correctly parses" $ do + runWaspParser body sampleBodySchema `shouldBe` Right sampleBodyAst - it "Model parser correctly parses" $ do - runWaspParser model pslModel `shouldBe` Right expectedModelAst + it "Model parser correctly parses" $ do + runWaspParser model pslModel `shouldBe` Right expectedModelAst - describe "Body parser" $ do - describe "Fails if input is not valid PSL" $ do - let runTest psl = it psl $ isLeft (runWaspParser body psl) `shouldBe` True - mapM_ runTest - [ " noType" - , " @startsWithAttribute" - , " @@@tooManyMonkeys" - ] + describe "Body parser" $ do + describe "Fails if input is not valid PSL" $ do + let runTest psl = it psl $ isLeft (runWaspParser body psl) `shouldBe` True + mapM_ + runTest + [ " noType", + " @startsWithAttribute", + " @@@tooManyMonkeys" + ] - describe "Attribute argument parser" $ do - let tests = - [ ( "[foo, bar]," - , AST.AttrArgUnnamed (AST.AttrArgFieldRefList ["foo", "bar"]) - ) - , ( "\"test\")" - , AST.AttrArgUnnamed (AST.AttrArgString "test") - ) - , ( "foo: bar()," - , AST.AttrArgNamed "foo" (AST.AttrArgFunc "bar") - ) - , ( "Bob," - , AST.AttrArgUnnamed (AST.AttrArgIdentifier "Bob") - ) - , ( "42.3)" - , AST.AttrArgUnnamed (AST.AttrArgNumber "42.3") - ) - , ( "2 + 3," - , AST.AttrArgUnnamed (AST.AttrArgUnknown "2 + 3") - ) - - ] - let runTest (psl, expected) = - it ("correctly parses " ++ psl) $ runWaspParser attrArgument psl `shouldBe` Right expected - mapM_ runTest tests + describe "Attribute argument parser" $ do + let tests = + [ ( "[foo, bar],", + AST.AttrArgUnnamed (AST.AttrArgFieldRefList ["foo", "bar"]) + ), + ( "\"test\")", + AST.AttrArgUnnamed (AST.AttrArgString "test") + ), + ( "foo: bar(),", + AST.AttrArgNamed "foo" (AST.AttrArgFunc "bar") + ), + ( "Bob,", + AST.AttrArgUnnamed (AST.AttrArgIdentifier "Bob") + ), + ( "42.3)", + AST.AttrArgUnnamed (AST.AttrArgNumber "42.3") + ), + ( "2 + 3,", + AST.AttrArgUnnamed (AST.AttrArgUnknown "2 + 3") + ) + ] + let runTest (psl, expected) = + it ("correctly parses " ++ psl) $ runWaspParser attrArgument psl `shouldBe` Right expected + mapM_ runTest tests diff --git a/waspc/test/StrongPathTest.hs b/waspc/test/StrongPathTest.hs index 73cf27c5d..97e2c1e49 100644 --- a/waspc/test/StrongPathTest.hs +++ b/waspc/test/StrongPathTest.hs @@ -1,23 +1,24 @@ module StrongPathTest where -import Test.Tasty.Hspec - -import Data.Maybe (fromJust) -import qualified Path as P -import qualified Path.Posix as PP -import qualified Path.Windows as PW -import qualified System.FilePath as FP -import qualified System.FilePath.Posix as FPP +import Data.Maybe (fromJust) +import Fixtures (systemFpRoot, systemPathRoot) +import qualified Path as P +import qualified Path.Posix as PP +import qualified Path.Windows as PW +import StrongPath +import StrongPath.Internal + ( RelPathPrefix (..), + extractRelPathPrefix, + relPathNumParentDirs, + ) +import qualified System.FilePath as FP +import qualified System.FilePath.Posix as FPP import qualified System.FilePath.Windows as FPW - -import Fixtures (systemFpRoot, systemPathRoot) -import StrongPath -import StrongPath.Internal (RelPathPrefix (..), - extractRelPathPrefix, - relPathNumParentDirs) -import Test.Util (posixToSystemFp, posixToWindowsFp) +import Test.Tasty.Hspec +import Test.Util (posixToSystemFp, posixToWindowsFp) data Bar + data Fizz -- TODO: I should look into using QuickCheck to simplify / enhcance StrongPath tests, @@ -25,267 +26,267 @@ data Fizz spec_StrongPath :: Spec spec_StrongPath = do - describe "Example with Foo file and Bar, Fizz and Kokolo dirs" $ do - let fooFileInBarDir = fromPathRelFile [P.relfile|foo.txt|] :: Path (Rel Bar) File - let barDirInFizzDir = fromPathRelDir [P.reldir|kokolo/bar|] :: Path (Rel Fizz) (Dir Bar) - let fizzDir = (fromPathAbsDir $ systemPathRoot P. [P.reldir|fizz|]) :: Path Abs (Dir Fizz) - let fooFile = (fizzDir barDirInFizzDir fooFileInBarDir) :: Path Abs File - let fooFileInFizzDir = (barDirInFizzDir fooFileInBarDir) :: Path (Rel Fizz) File + describe "Example with Foo file and Bar, Fizz and Kokolo dirs" $ do + let fooFileInBarDir = fromPathRelFile [P.relfile|foo.txt|] :: Path (Rel Bar) File + let barDirInFizzDir = fromPathRelDir [P.reldir|kokolo/bar|] :: Path (Rel Fizz) (Dir Bar) + let fizzDir = (fromPathAbsDir $ systemPathRoot P. [P.reldir|fizz|]) :: Path Abs (Dir Fizz) + let fooFile = (fizzDir barDirInFizzDir fooFileInBarDir) :: Path Abs File + let fooFileInFizzDir = (barDirInFizzDir fooFileInBarDir) :: Path (Rel Fizz) File - it "Paths are correctly concatenated" $ do - P.toFilePath (toPathAbsFile fooFile) `shouldBe` posixToSystemFp "/fizz/kokolo/bar/foo.txt" - P.toFilePath (toPathRelFile fooFileInFizzDir) `shouldBe` posixToSystemFp "kokolo/bar/foo.txt" + it "Paths are correctly concatenated" $ do + P.toFilePath (toPathAbsFile fooFile) `shouldBe` posixToSystemFp "/fizz/kokolo/bar/foo.txt" + P.toFilePath (toPathRelFile fooFileInFizzDir) `shouldBe` posixToSystemFp "kokolo/bar/foo.txt" - it "Paths are unchanged when packed from Path.Path and unpacked to Path.Path" $ do - let test pack unpack path = unpack (pack path) == path `shouldBe` True - test fromPathRelFile toPathRelFile [P.relfile|some/file.txt|] - test fromPathRelDir toPathRelDir [P.reldir|some/dir/|] - test fromPathAbsFile toPathAbsFile $ systemPathRoot P. [P.relfile|some/file.txt|] - test fromPathAbsDir toPathAbsDir $ systemPathRoot P. [P.reldir|some/file.txt|] + it "Paths are unchanged when packed from Path.Path and unpacked to Path.Path" $ do + let test pack unpack path = unpack (pack path) == path `shouldBe` True + test fromPathRelFile toPathRelFile [P.relfile|some/file.txt|] + test fromPathRelDir toPathRelDir [P.reldir|some/dir/|] + test fromPathAbsFile toPathAbsFile $ systemPathRoot P. [P.relfile|some/file.txt|] + test fromPathAbsDir toPathAbsDir $ systemPathRoot P. [P.reldir|some/file.txt|] - describe "relDirToPosix/relFileToPosix correctly converts relative strong path to Posix" $ do - describe "when strong path is relative dir" $ do - let expectedPosixPath = fromPathRelDirP [PP.reldir|test/dir/|] - it "from standard Win" $ - fromJust (relDirToPosix $ fromPathRelDirW [PW.reldir|test\dir\|]) - `shouldBe` expectedPosixPath - it "from standard Posix" $ - fromJust (relDirToPosix $ fromPathRelDirP [PP.reldir|test/dir/|]) - `shouldBe` expectedPosixPath - it "from standard System" $ - fromJust (relDirToPosix $ fromPathRelDir [P.reldir|test/dir/|]) - `shouldBe` expectedPosixPath - describe "correctly when strong path is relative file" $ do - let expectedPosixPath = fromPathRelFileP [PP.relfile|test/file|] - it "from standard Win" $ - fromJust (relFileToPosix $ fromPathRelFileW [PW.relfile|test\file|]) - `shouldBe` expectedPosixPath - it "from standard Posix" $ - fromJust (relFileToPosix $ fromPathRelFileP [PP.relfile|test/file|]) - `shouldBe` expectedPosixPath - it "from standard System" $ - fromJust (relFileToPosix $ fromPathRelFile [P.relfile|test/file|]) - `shouldBe` expectedPosixPath + describe "relDirToPosix/relFileToPosix correctly converts relative strong path to Posix" $ do + describe "when strong path is relative dir" $ do + let expectedPosixPath = fromPathRelDirP [PP.reldir|test/dir/|] + it "from standard Win" $ + fromJust (relDirToPosix $ fromPathRelDirW [PW.reldir|test\dir\|]) + `shouldBe` expectedPosixPath + it "from standard Posix" $ + fromJust (relDirToPosix $ fromPathRelDirP [PP.reldir|test/dir/|]) + `shouldBe` expectedPosixPath + it "from standard System" $ + fromJust (relDirToPosix $ fromPathRelDir [P.reldir|test/dir/|]) + `shouldBe` expectedPosixPath + describe "correctly when strong path is relative file" $ do + let expectedPosixPath = fromPathRelFileP [PP.relfile|test/file|] + it "from standard Win" $ + fromJust (relFileToPosix $ fromPathRelFileW [PW.relfile|test\file|]) + `shouldBe` expectedPosixPath + it "from standard Posix" $ + fromJust (relFileToPosix $ fromPathRelFileP [PP.relfile|test/file|]) + `shouldBe` expectedPosixPath + it "from standard System" $ + fromJust (relFileToPosix $ fromPathRelFile [P.relfile|test/file|]) + `shouldBe` expectedPosixPath - describe "extractRelPathPrefix correctly extracts prefix from rel FilePath." $ do - it "when path starts with multiple ../" $ do - extractRelPathPrefix [FPP.pathSeparator] "../../" `shouldBe` (ParentDir 2, "") - extractRelPathPrefix [FPP.pathSeparator] "../.." `shouldBe` (ParentDir 2, "") - extractRelPathPrefix [FP.pathSeparator] ".." `shouldBe` (ParentDir 1, "") - extractRelPathPrefix [FP.pathSeparator, FPP.pathSeparator]"../../../a/b" `shouldBe` (ParentDir 3, "a/b") - extractRelPathPrefix [FPW.pathSeparator]"..\\a\\b" `shouldBe` (ParentDir 1, "a\\b") - it "when path does not start with ../" $ do - extractRelPathPrefix [FPP.pathSeparator] "a/b" `shouldBe` (NoPrefix, "a/b") - extractRelPathPrefix [FP.pathSeparator] "b" `shouldBe` (NoPrefix, "b") - extractRelPathPrefix [FP.pathSeparator] "." `shouldBe` (NoPrefix, ".") + describe "extractRelPathPrefix correctly extracts prefix from rel FilePath." $ do + it "when path starts with multiple ../" $ do + extractRelPathPrefix [FPP.pathSeparator] "../../" `shouldBe` (ParentDir 2, "") + extractRelPathPrefix [FPP.pathSeparator] "../.." `shouldBe` (ParentDir 2, "") + extractRelPathPrefix [FP.pathSeparator] ".." `shouldBe` (ParentDir 1, "") + extractRelPathPrefix [FP.pathSeparator, FPP.pathSeparator] "../../../a/b" `shouldBe` (ParentDir 3, "a/b") + extractRelPathPrefix [FPW.pathSeparator] "..\\a\\b" `shouldBe` (ParentDir 1, "a\\b") + it "when path does not start with ../" $ do + extractRelPathPrefix [FPP.pathSeparator] "a/b" `shouldBe` (NoPrefix, "a/b") + extractRelPathPrefix [FP.pathSeparator] "b" `shouldBe` (NoPrefix, "b") + extractRelPathPrefix [FP.pathSeparator] "." `shouldBe` (NoPrefix, ".") - describe "Parsing from FilePath" $ do - let runTest fpToParseIntoExpectedFp parser fpToParse = - let expectedFp = fpToParseIntoExpectedFp fpToParse - in it (fpToParse ++ " should parse into " ++ expectedFp) $ do - let sp = fromJust $ parser fpToParse - toFilePath sp `shouldBe` expectedFp - let runTestRel fpToParseIntoExpectedFp parser fpToParse expectedNumParentDirs = - let expectedFp = fpToParseIntoExpectedFp fpToParse - in it (fpToParse ++ " should parse into " ++ expectedFp) $ do - let sp = fromJust $ parser fpToParse - toFilePath sp `shouldBe` expectedFp - relPathNumParentDirs sp `shouldBe` expectedNumParentDirs + describe "Parsing from FilePath" $ do + let runTest fpToParseIntoExpectedFp parser fpToParse = + let expectedFp = fpToParseIntoExpectedFp fpToParse + in it (fpToParse ++ " should parse into " ++ expectedFp) $ do + let sp = fromJust $ parser fpToParse + toFilePath sp `shouldBe` expectedFp + let runTestRel fpToParseIntoExpectedFp parser fpToParse expectedNumParentDirs = + let expectedFp = fpToParseIntoExpectedFp fpToParse + in it (fpToParse ++ " should parse into " ++ expectedFp) $ do + let sp = fromJust $ parser fpToParse + toFilePath sp `shouldBe` expectedFp + relPathNumParentDirs sp `shouldBe` expectedNumParentDirs - describe "into standard System" $ do - describe "into base Rel" $ do - describe "captures one or multiple ../ at start of relative path" $ do - let test = runTestRel id - test parseRelDir (posixToSystemFp "../../a/b/") 2 - test parseRelDir (posixToSystemFp "../") 1 - test parseRelDir (posixToSystemFp "../../") 2 - test parseRelDir (posixToSystemFp "./") 0 - test parseRelFile (posixToSystemFp "../a/b.txt") 1 - describe "can parse from system FilePath" $ do - let test = runTestRel id - test parseRelDir (posixToSystemFp "../a/b/") 1 - test parseRelDir (posixToSystemFp "a/b/") 0 - test parseRelFile (posixToSystemFp "../a/b.txt") 1 - test parseRelFile (posixToSystemFp "a/b.txt") 0 - describe "can parse from posix FilePath" $ do - let test = runTestRel posixToSystemFp - test parseRelDir "../a/b/" 1 - test parseRelDir "a/b/" 0 - test parseRelFile "../a/b.txt" 1 - test parseRelFile "a/b.txt" 0 - describe "into base Abs" $ do - describe "can parse from system FilePath" $ do - let test = runTest id - test parseAbsDir (systemFpRoot FP. posixToSystemFp "a/b/") - test parseAbsFile (systemFpRoot FP. posixToSystemFp "a/b.txt") - describe "can parse from FilePath with system root and posix separators" $ do - let test = runTest posixToSystemFp - test parseAbsDir (systemFpRoot FP. "a/b/") - test parseAbsFile (systemFpRoot FP. "a/b.txt") + describe "into standard System" $ do + describe "into base Rel" $ do + describe "captures one or multiple ../ at start of relative path" $ do + let test = runTestRel id + test parseRelDir (posixToSystemFp "../../a/b/") 2 + test parseRelDir (posixToSystemFp "../") 1 + test parseRelDir (posixToSystemFp "../../") 2 + test parseRelDir (posixToSystemFp "./") 0 + test parseRelFile (posixToSystemFp "../a/b.txt") 1 + describe "can parse from system FilePath" $ do + let test = runTestRel id + test parseRelDir (posixToSystemFp "../a/b/") 1 + test parseRelDir (posixToSystemFp "a/b/") 0 + test parseRelFile (posixToSystemFp "../a/b.txt") 1 + test parseRelFile (posixToSystemFp "a/b.txt") 0 + describe "can parse from posix FilePath" $ do + let test = runTestRel posixToSystemFp + test parseRelDir "../a/b/" 1 + test parseRelDir "a/b/" 0 + test parseRelFile "../a/b.txt" 1 + test parseRelFile "a/b.txt" 0 + describe "into base Abs" $ do + describe "can parse from system FilePath" $ do + let test = runTest id + test parseAbsDir (systemFpRoot FP. posixToSystemFp "a/b/") + test parseAbsFile (systemFpRoot FP. posixToSystemFp "a/b.txt") + describe "can parse from FilePath with system root and posix separators" $ do + let test = runTest posixToSystemFp + test parseAbsDir (systemFpRoot FP. "a/b/") + test parseAbsFile (systemFpRoot FP. "a/b.txt") - describe "into standard Windows" $ do - describe "into base Rel" $ do - describe "captures one or multiple ../ at start of relative path" $ do - let test = runTestRel posixToWindowsFp - test parseRelDirW (posixToSystemFp "../../a/b/") 2 - test parseRelFileW (posixToSystemFp "../a/b.txt") 1 - describe "can parse from windows FilePath" $ do - let test = runTestRel id - test parseRelDirW "..\\a\\b\\" 1 - test parseRelDirW "a\\b\\" 0 - test parseRelFileW "..\\a\\b.txt" 1 - test parseRelFileW "..\\..\\a\\b.txt" 2 - test parseRelFileW "a\\b.txt" 0 - describe "can parse from posix FilePath" $ do - let test = runTestRel posixToWindowsFp - test parseRelDirW "../a/b/" 1 - test parseRelDirW "a/b/" 0 - test parseRelFileW "../a/b.txt" 1 - test parseRelFileW "a/b.txt" 0 - describe "into base Abs" $ do - describe "can parse from windows FilePath" $ do - let test = runTest id - test parseAbsDirW "C:\\a\\b\\" - test parseAbsFileW "C:\\a\\b.txt" - describe "can parse from FilePath with windows root and Posix separators" $ do - let test = runTest posixToWindowsFp - test parseAbsDirW "C:\\a/b/" - test parseAbsFileW "C:\\a/b.txt" + describe "into standard Windows" $ do + describe "into base Rel" $ do + describe "captures one or multiple ../ at start of relative path" $ do + let test = runTestRel posixToWindowsFp + test parseRelDirW (posixToSystemFp "../../a/b/") 2 + test parseRelFileW (posixToSystemFp "../a/b.txt") 1 + describe "can parse from windows FilePath" $ do + let test = runTestRel id + test parseRelDirW "..\\a\\b\\" 1 + test parseRelDirW "a\\b\\" 0 + test parseRelFileW "..\\a\\b.txt" 1 + test parseRelFileW "..\\..\\a\\b.txt" 2 + test parseRelFileW "a\\b.txt" 0 + describe "can parse from posix FilePath" $ do + let test = runTestRel posixToWindowsFp + test parseRelDirW "../a/b/" 1 + test parseRelDirW "a/b/" 0 + test parseRelFileW "../a/b.txt" 1 + test parseRelFileW "a/b.txt" 0 + describe "into base Abs" $ do + describe "can parse from windows FilePath" $ do + let test = runTest id + test parseAbsDirW "C:\\a\\b\\" + test parseAbsFileW "C:\\a\\b.txt" + describe "can parse from FilePath with windows root and Posix separators" $ do + let test = runTest posixToWindowsFp + test parseAbsDirW "C:\\a/b/" + test parseAbsFileW "C:\\a/b.txt" - describe "into standard Posix" $ do - describe "into base Rel" $ do - describe "captures one or multiple ../ at start of relative path" $ do - let test = runTestRel id - test parseRelDirP "../../a/b/" 2 - test parseRelFileP "../a/b.txt" 1 - describe "can parse from posix FilePath" $ do - let test = runTestRel id - test parseRelDirP "../a/b/" 1 - test parseRelDirP "a/b/" 0 - test parseRelFileP "a/b.txt" 0 - describe "into base Abs" $ do - describe "can parse from posix FilePath" $ do - let test = runTest id - test parseAbsDirP "/a/b/" - test parseAbsFileP "/a/b.txt" + describe "into standard Posix" $ do + describe "into base Rel" $ do + describe "captures one or multiple ../ at start of relative path" $ do + let test = runTestRel id + test parseRelDirP "../../a/b/" 2 + test parseRelFileP "../a/b.txt" 1 + describe "can parse from posix FilePath" $ do + let test = runTestRel id + test parseRelDirP "../a/b/" 1 + test parseRelDirP "a/b/" 0 + test parseRelFileP "a/b.txt" 0 + describe "into base Abs" $ do + describe "can parse from posix FilePath" $ do + let test = runTest id + test parseAbsDirP "/a/b/" + test parseAbsFileP "/a/b.txt" - describe "toFilePath correctly transforms strong path into FilePath" $ do - let test msp efp = it ("toFilePath (" ++ show msp ++ ") = " ++ efp) $ - toFilePath (fromJust msp) `shouldBe` efp - test (parseRelDir $ posixToSystemFp "../") (posixToSystemFp "../") - test (parseRelDir $ posixToSystemFp "a/b") (posixToSystemFp "a/b/") - test (parseRelFile $ posixToSystemFp "../../foo.txt") (posixToSystemFp "../../foo.txt") - test (parseRelDirW "../") "..\\" - test (parseRelDirP "../") "../" - -- TODO: Add more tests. + describe "toFilePath correctly transforms strong path into FilePath" $ do + let test msp efp = + it ("toFilePath (" ++ show msp ++ ") = " ++ efp) $ + toFilePath (fromJust msp) `shouldBe` efp + test (parseRelDir $ posixToSystemFp "../") (posixToSystemFp "../") + test (parseRelDir $ posixToSystemFp "a/b") (posixToSystemFp "a/b/") + test (parseRelFile $ posixToSystemFp "../../foo.txt") (posixToSystemFp "../../foo.txt") + test (parseRelDirW "../") "..\\" + test (parseRelDirP "../") "../" + -- TODO: Add more tests. - describe "`parent` correctly returns parent dir" $ do - let test msp mexpectedSp = - it ("parent (" ++ show msp ++ ") == " ++ show mexpectedSp) $ do - let sp = fromJust msp - let expectedSp = fromJust mexpectedSp - parent sp `shouldBe` expectedSp - let tests relDirParser relFileParser absDirParser absFileParser root = do - test (relDirParser "a/b") (relDirParser "a") - test (relDirParser "../a") (relDirParser "..") - test (relDirParser "..") (relDirParser "../..") - test (relDirParser ".") (relDirParser "..") - test (relFileParser "a.txt") (relDirParser ".") - test (relFileParser "../a.txt") (relDirParser "..") - test (relFileParser "a/b.txt") (relDirParser "a") - test (absDirParser $ root ++ "a/b") (absDirParser $ root ++ "a") - test (absDirParser root) (absDirParser root) - test (absFileParser $ root ++ "a/b.txt") (absDirParser $ root ++ "a") - describe "when standard is System" $ - tests parseRelDir parseRelFile parseAbsDir parseAbsFile systemFpRoot - describe "when standard is Windows" $ - tests parseRelDirW parseRelFileW parseAbsDirW parseAbsFileW "C:\\" - describe "when standard is Posix" $ - tests parseRelDirP parseRelFileP parseAbsDirP parseAbsFileP "/" - - describe " correctly concatenates two corresponding paths" $ do - let test mlsp mrsp mexpectedSp = - it (show mlsp ++ " " ++ show mrsp ++ " == " ++ show mexpectedSp) $ do - let lsp = fromJust mlsp - let rsp = fromJust mrsp - let expectedSp = fromJust mexpectedSp - (lsp rsp) `shouldBe` expectedSp - let tests relDirParser relFileParser absDirParser absFileParser root = do - test (relDirParser "a/b") (relFileParser "c.txt") (relFileParser "a/b/c.txt") - test (relDirParser "a/b") (relFileParser "../c.txt") (relFileParser "a/c.txt") - test (relDirParser "..") (relFileParser "../c.txt") (relFileParser "../../c.txt") - test (relDirParser "..") (relDirParser "..") (relDirParser "../..") - test (relDirParser ".") (relDirParser "../a") (relDirParser "../a") - test (relDirParser ".") (relDirParser ".") (relDirParser ".") - test (relDirParser "a/b") (relDirParser "c/d") (relDirParser "a/b/c/d") - test (relDirParser "../a/b") (relDirParser "c/d") (relDirParser "../a/b/c/d") - test (absDirParser $ root ++ "a/b") (relFileParser "c.txt") (absFileParser $ root ++ "a/b/c.txt") - test (absDirParser $ root ++ "a/b") (relFileParser "../c.txt") (absFileParser $ root ++ "a/c.txt") - test (absDirParser $ root ++ "a") (relDirParser "../b") (absDirParser $ root ++ "b") - test (absDirParser $ root ++ "a/b") (relDirParser "../../../") (absDirParser root) - describe "when standard is System" $ - tests parseRelDir parseRelFile parseAbsDir parseAbsFile systemFpRoot - describe "when standard is Windows" $ - tests parseRelDirW parseRelFileW parseAbsDirW parseAbsFileW "C:\\" - describe "when standard is Posix" $ - tests parseRelDirP parseRelFileP parseAbsDirP parseAbsFileP "/" + describe "`parent` correctly returns parent dir" $ do + let test msp mexpectedSp = + it ("parent (" ++ show msp ++ ") == " ++ show mexpectedSp) $ do + let sp = fromJust msp + let expectedSp = fromJust mexpectedSp + parent sp `shouldBe` expectedSp + let tests relDirParser relFileParser absDirParser absFileParser root = do + test (relDirParser "a/b") (relDirParser "a") + test (relDirParser "../a") (relDirParser "..") + test (relDirParser "..") (relDirParser "../..") + test (relDirParser ".") (relDirParser "..") + test (relFileParser "a.txt") (relDirParser ".") + test (relFileParser "../a.txt") (relDirParser "..") + test (relFileParser "a/b.txt") (relDirParser "a") + test (absDirParser $ root ++ "a/b") (absDirParser $ root ++ "a") + test (absDirParser root) (absDirParser root) + test (absFileParser $ root ++ "a/b.txt") (absDirParser $ root ++ "a") + describe "when standard is System" $ + tests parseRelDir parseRelFile parseAbsDir parseAbsFile systemFpRoot + describe "when standard is Windows" $ + tests parseRelDirW parseRelFileW parseAbsDirW parseAbsFileW "C:\\" + describe "when standard is Posix" $ + tests parseRelDirP parseRelFileP parseAbsDirP parseAbsFileP "/" + describe " correctly concatenates two corresponding paths" $ do + let test mlsp mrsp mexpectedSp = + it (show mlsp ++ " " ++ show mrsp ++ " == " ++ show mexpectedSp) $ do + let lsp = fromJust mlsp + let rsp = fromJust mrsp + let expectedSp = fromJust mexpectedSp + (lsp rsp) `shouldBe` expectedSp + let tests relDirParser relFileParser absDirParser absFileParser root = do + test (relDirParser "a/b") (relFileParser "c.txt") (relFileParser "a/b/c.txt") + test (relDirParser "a/b") (relFileParser "../c.txt") (relFileParser "a/c.txt") + test (relDirParser "..") (relFileParser "../c.txt") (relFileParser "../../c.txt") + test (relDirParser "..") (relDirParser "..") (relDirParser "../..") + test (relDirParser ".") (relDirParser "../a") (relDirParser "../a") + test (relDirParser ".") (relDirParser ".") (relDirParser ".") + test (relDirParser "a/b") (relDirParser "c/d") (relDirParser "a/b/c/d") + test (relDirParser "../a/b") (relDirParser "c/d") (relDirParser "../a/b/c/d") + test (absDirParser $ root ++ "a/b") (relFileParser "c.txt") (absFileParser $ root ++ "a/b/c.txt") + test (absDirParser $ root ++ "a/b") (relFileParser "../c.txt") (absFileParser $ root ++ "a/c.txt") + test (absDirParser $ root ++ "a") (relDirParser "../b") (absDirParser $ root ++ "b") + test (absDirParser $ root ++ "a/b") (relDirParser "../../../") (absDirParser root) + describe "when standard is System" $ + tests parseRelDir parseRelFile parseAbsDir parseAbsFile systemFpRoot + describe "when standard is Windows" $ + tests parseRelDirW parseRelFileW parseAbsDirW parseAbsFileW "C:\\" + describe "when standard is Posix" $ + tests parseRelDirP parseRelFileP parseAbsDirP parseAbsFileP "/" spec_Path :: Spec spec_Path = do - -- Just checking that Path behaves in a way that we expect it to behave. - it "Path.Windows.parseRelDir correctly parses Windows path" $ do - fromJust (PW.parseRelDir ".\\") `shouldBe` fromJust (PW.parseRelDir "./") - fromJust (PW.parseRelDir "a\\\\b\\") `shouldBe` fromJust (PW.parseRelDir "a/b/") - fromJust (PW.parseRelDir "a\\b") `shouldBe` fromJust (PW.parseRelDir "a/b") - PW.toFilePath (fromJust $ PW.parseRelDir "a\\b\\") `shouldBe` "a\\b\\" + -- Just checking that Path behaves in a way that we expect it to behave. + it "Path.Windows.parseRelDir correctly parses Windows path" $ do + fromJust (PW.parseRelDir ".\\") `shouldBe` fromJust (PW.parseRelDir "./") + fromJust (PW.parseRelDir "a\\\\b\\") `shouldBe` fromJust (PW.parseRelDir "a/b/") + fromJust (PW.parseRelDir "a\\b") `shouldBe` fromJust (PW.parseRelDir "a/b") + PW.toFilePath (fromJust $ PW.parseRelDir "a\\b\\") `shouldBe` "a\\b\\" - describe "Concatenation of System . paths works as expected" $ do - let test lp rp ep = - it (show lp ++ " " ++ show rp ++ " == " ++ show ep) $ - (lp P. rp) `shouldBe` ep - test [P.reldir|.|] [P.reldir|.|] [P.reldir|.|] - test [P.reldir|a|] [P.reldir|.|] [P.reldir|a|] - test [P.reldir|.|] [P.reldir|a|] [P.reldir|a|] - test [P.reldir|.|] [P.relfile|c.txt|] [P.relfile|c.txt|] + describe "Concatenation of System . paths works as expected" $ do + let test lp rp ep = + it (show lp ++ " " ++ show rp ++ " == " ++ show ep) $ + (lp P. rp) `shouldBe` ep + test [P.reldir|.|] [P.reldir|.|] [P.reldir|.|] + test [P.reldir|a|] [P.reldir|.|] [P.reldir|a|] + test [P.reldir|.|] [P.reldir|a|] [P.reldir|a|] + test [P.reldir|.|] [P.relfile|c.txt|] [P.relfile|c.txt|] - -- NOTE: All of the failing Path tests are due to the badly implemented Include mechanism in Path. - -- I made a PR for fix on Path, so when that gets in we can uncomment these tests and also remove - -- workarounds in StrongPath / StrongPath.Internal. + -- NOTE: All of the failing Path tests are due to the badly implemented Include mechanism in Path. + -- I made a PR for fix on Path, so when that gets in we can uncomment these tests and also remove + -- workarounds in StrongPath / StrongPath.Internal. - -- describe "Concatenation of Win . paths works as expected" $ do - -- let test lp rp ep = - -- it (show lp ++ " " ++ show rp ++ " == " ++ show ep) $ - -- (lp PW. rp) `shouldBe` ep - -- -- TODO: Fails on Linux/Mac: expected: ".\\" but got: ".\\.\\" - -- test [PW.reldir|.|] [PW.reldir|.|] [PW.reldir|.|] - -- -- TODO: Fails on Linux/Mac: expected: "a\\" but got: ".\\a\\" - -- test [PW.reldir|.|] [PW.reldir|a|] [PW.reldir|a|] - -- -- TODO: Fails on Linux/Mac: expected: "a\\" but got: "a\\.\\" - -- test [PW.reldir|a|] [PW.reldir|.|] [PW.reldir|a|] + -- describe "Concatenation of Win . paths works as expected" $ do + -- let test lp rp ep = + -- it (show lp ++ " " ++ show rp ++ " == " ++ show ep) $ + -- (lp PW. rp) `shouldBe` ep + -- -- TODO: Fails on Linux/Mac: expected: ".\\" but got: ".\\.\\" + -- test [PW.reldir|.|] [PW.reldir|.|] [PW.reldir|.|] + -- -- TODO: Fails on Linux/Mac: expected: "a\\" but got: ".\\a\\" + -- test [PW.reldir|.|] [PW.reldir|a|] [PW.reldir|a|] + -- -- TODO: Fails on Linux/Mac: expected: "a\\" but got: "a\\.\\" + -- test [PW.reldir|a|] [PW.reldir|.|] [PW.reldir|a|] - -- describe "Concatenation of Posix . paths works as expected" $ do - -- let test lp rp ep = - -- it (show lp ++ " " ++ show rp ++ " == " ++ show ep) $ - -- (lp PP. rp) `shouldBe` ep - -- -- TODO: Fails on Win: expected: "./" but got: "././" - -- test [PP.reldir|.|] [PP.reldir|.|] [PP.reldir|.|] - -- -- TODO: Fails on Win: expected: "a/" but got: "./a/" - -- test [PP.reldir|.|] [PP.reldir|a|] [PP.reldir|a|] - -- -- TODO: Fails on Win: expected: "a/" but got: "a/./" - -- test [PP.reldir|a|] [PP.reldir|.|] [PP.reldir|a|] + -- describe "Concatenation of Posix . paths works as expected" $ do + -- let test lp rp ep = + -- it (show lp ++ " " ++ show rp ++ " == " ++ show ep) $ + -- (lp PP. rp) `shouldBe` ep + -- -- TODO: Fails on Win: expected: "./" but got: "././" + -- test [PP.reldir|.|] [PP.reldir|.|] [PP.reldir|.|] + -- -- TODO: Fails on Win: expected: "a/" but got: "./a/" + -- test [PP.reldir|.|] [PP.reldir|a|] [PP.reldir|a|] + -- -- TODO: Fails on Win: expected: "a/" but got: "a/./" + -- test [PP.reldir|a|] [PP.reldir|.|] [PP.reldir|a|] - describe "Parsing rel path with .. at start should fail" $ do - let test parser p = - it (show p ++ " should successfully parse") $ - parser p `shouldBe` Nothing - describe "for PW.parseRelDir" $ do - test PW.parseRelDir "../a" - -- -- TODO: This fails on Linux/Mac! Weird, I thought Path does not allow relative paths starting with ..? - -- -- expected: Nothing but got: Just "..\\a\\" - -- test PW.parseRelDir "..\\a" - describe "for P.parseRelDir" $ do - test P.parseRelDir "../a" - test P.parseRelDir $ ".." FP. "a" - describe "for PP.parseRelDir" $ do - test PP.parseRelDir "../a" + describe "Parsing rel path with .. at start should fail" $ do + let test parser p = + it (show p ++ " should successfully parse") $ + parser p `shouldBe` Nothing + describe "for PW.parseRelDir" $ do + test PW.parseRelDir "../a" + -- -- TODO: This fails on Linux/Mac! Weird, I thought Path does not allow relative paths starting with ..? + -- -- expected: Nothing but got: Just "..\\a\\" + -- test PW.parseRelDir "..\\a" + describe "for P.parseRelDir" $ do + test P.parseRelDir "../a" + test P.parseRelDir $ ".." FP. "a" + describe "for PP.parseRelDir" $ do + test PP.parseRelDir "../a" diff --git a/waspc/test/Test/Util.hs b/waspc/test/Test/Util.hs index 98622e7c7..2d9261b9a 100644 --- a/waspc/test/Test/Util.hs +++ b/waspc/test/Test/Util.hs @@ -1,26 +1,25 @@ module Test.Util - ( posixToSystemFp - , posixToWindowsFp - ) where + ( posixToSystemFp, + posixToWindowsFp, + ) +where -import qualified System.FilePath as FP +import Fixtures (systemFpRoot) +import qualified System.FilePath as FP import qualified System.FilePath.Windows as FPW -import Fixtures (systemFpRoot) - - -- | Takes posix path and converts it into windows path if running on Windows or leaves as it is if on Unix. posixToSystemFp :: FilePath -> FilePath posixToSystemFp posixFp = maybeSystemRoot ++ systemFpRootless - where - maybeSystemRoot = if head posixFp == '/' then systemFpRoot else "" - posixFpRootless = if head posixFp == '/' then tail posixFp else posixFp - systemFpRootless = map (\c -> if c == '/' then FP.pathSeparator else c) posixFpRootless + where + maybeSystemRoot = if head posixFp == '/' then systemFpRoot else "" + posixFpRootless = if head posixFp == '/' then tail posixFp else posixFp + systemFpRootless = map (\c -> if c == '/' then FP.pathSeparator else c) posixFpRootless -- | Takes posix path and converts it into windows path. posixToWindowsFp :: FilePath -> FilePath posixToWindowsFp posixFp = maybeWinRoot ++ winFpRootless - where - maybeWinRoot = if head posixFp == '/' then "C:\\" else "" - posixFpRootless = if head posixFp == '/' then tail posixFp else posixFp - winFpRootless = map (\c -> if c == '/' then FPW.pathSeparator else c) posixFpRootless + where + maybeWinRoot = if head posixFp == '/' then "C:\\" else "" + posixFpRootless = if head posixFp == '/' then tail posixFp else posixFp + winFpRootless = map (\c -> if c == '/' then FPW.pathSeparator else c) posixFpRootless diff --git a/waspc/test/Util/FibTest.hs b/waspc/test/Util/FibTest.hs index 70a04e254..24ae17a2d 100644 --- a/waspc/test/Util/FibTest.hs +++ b/waspc/test/Util/FibTest.hs @@ -2,7 +2,6 @@ module Util.FibTest where import Test.Tasty.Hspec import Test.Tasty.QuickCheck - import Util.Fib spec_fibonacci :: Spec diff --git a/waspc/test/UtilTest.hs b/waspc/test/UtilTest.hs index 35ee804b9..050f398fb 100644 --- a/waspc/test/UtilTest.hs +++ b/waspc/test/UtilTest.hs @@ -1,64 +1,63 @@ module UtilTest where -import Test.Tasty.Hspec -import Control.Exception (evaluate) import Control.DeepSeq - +import Control.Exception (evaluate) +import Data.Aeson (object, toJSON, (.=)) import qualified Data.Aeson as Aeson -import Data.Aeson ((.=), object, toJSON) - +import Test.Tasty.Hspec import Util - spec_camelToKebabCase :: Spec spec_camelToKebabCase = do - "foobar" ~> "foobar" - "s3" ~> "s3" - "fooBarBar" ~> "foo-bar-bar" - "s3Folder" ~> "s3-folder" - "S3Folder" ~> "s3-folder" + "foobar" ~> "foobar" + "s3" ~> "s3" + "fooBarBar" ~> "foo-bar-bar" + "s3Folder" ~> "s3-folder" + "S3Folder" ~> "s3-folder" where camel ~> kebab = it (camel ++ " -> " ++ kebab) $ do - camelToKebabCase camel `shouldBe` kebab + camelToKebabCase camel `shouldBe` kebab spec_onFirst :: Spec spec_onFirst = do - it "Returns empty list for empty list" $ do - (onFirst id ([] :: [Char])) `shouldBe` [] - it "Applies given method on first element of list" $ do - onFirst (+ 1) ([1, 2, 3] :: [Int]) `shouldBe` [2, 2, 3] + it "Returns empty list for empty list" $ do + (onFirst id ([] :: [Char])) `shouldBe` [] + it "Applies given method on first element of list" $ do + onFirst (+ 1) ([1, 2, 3] :: [Int]) `shouldBe` [2, 2, 3] spec_toLowerFirst :: Spec spec_toLowerFirst = do - it "Lowers first letter of string" $ do - toLowerFirst "FooBar" `shouldBe` "fooBar" + it "Lowers first letter of string" $ do + toLowerFirst "FooBar" `shouldBe` "fooBar" spec_toUpperFirst :: Spec spec_toUpperFirst = do - it "Capitalizes first letter of string" $ do - toUpperFirst "fooBar" `shouldBe` "FooBar" + it "Capitalizes first letter of string" $ do + toUpperFirst "fooBar" `shouldBe` "FooBar" spec_jsonSet :: Spec spec_jsonSet = do - let inputObj = object - [ "prop1" .= ("first" :: String) + let inputObj = + object + [ "prop1" .= ("first" :: String) + ] + + it "When input JSON is not an object, throws an error." $ do + (evaluate . force) (jsonSet "someProp" (Aeson.Number 23) (Aeson.Bool True)) + `shouldThrow` errorCall "Input JSON must be an object" + + it "When a new property is set, result object contains it along with the original ones." $ do + let expectedObj = + object + [ "prop1" .= ("first" :: String), + "newProp" .= (23 :: Int) ] + (jsonSet "newProp" (Aeson.Number 23) inputObj) `shouldBe` expectedObj - it "When input JSON is not an object, throws an error." $ do - (evaluate . force) (jsonSet "someProp" (Aeson.Number 23) (Aeson.Bool True)) - `shouldThrow` errorCall "Input JSON must be an object" - - it "When a new property is set, result object contains it along with the original ones." $ do - let expectedObj = object - [ "prop1" .= ("first" :: String) - , "newProp" .= (23 :: Int) - ] - (jsonSet "newProp" (Aeson.Number 23) inputObj) `shouldBe` expectedObj - - it "When an existing property is set, it is overwritten in the result object." $ do - let newStrValue = "newVal" :: String - let expectedObj = object - [ "prop1" .= newStrValue - ] - (jsonSet "prop1" (toJSON newStrValue) inputObj) `shouldBe` expectedObj - + it "When an existing property is set, it is overwritten in the result object." $ do + let newStrValue = "newVal" :: String + let expectedObj = + object + [ "prop1" .= newStrValue + ] + (jsonSet "prop1" (toJSON newStrValue) inputObj) `shouldBe` expectedObj diff --git a/waspc/test/WaspignoreFileTest.hs b/waspc/test/WaspignoreFileTest.hs index 915911a5f..617773b36 100644 --- a/waspc/test/WaspignoreFileTest.hs +++ b/waspc/test/WaspignoreFileTest.hs @@ -2,37 +2,39 @@ module WaspignoreFileTest where import Test.Tasty.Hspec import Test.Tasty.QuickCheck (property) - -import WaspignoreFile (parseWaspignoreFile, ignores) +import WaspignoreFile (ignores, parseWaspignoreFile) spec_IgnoreFile :: Spec spec_IgnoreFile = do - describe "IgnoreFile" $ do - it "When given a single pattern, should match it and '.waspignore'" $ do - let ignoreFile = parseWaspignoreFile "*.tmp" - (ignoreFile `ignores` "a.tmp") `shouldBe` True - (ignoreFile `ignores` "a.src") `shouldBe` False - (ignoreFile `ignores` ".waspignore") `shouldBe` True - - it "When given a blank input, should match only '.waspignore'" $ do - let ignoreFile = parseWaspignoreFile "" - property $ \fp -> if fp == ".waspignore" - then ignoreFile `ignores` fp - else not $ ignoreFile `ignores` fp - - it "When given a comment as the only line, should match only '.waspignore'" $ do - let ignoreFile = parseWaspignoreFile "# test comment" - property $ \fp -> if fp == ".waspignore" - then ignoreFile `ignores` fp - else not $ ignoreFile `ignores` fp - - it "When the only difference between two files is a comment, the files should match the same strings" $ do - let comment = "\n# test comment" - property $ \pat fp -> (parseWaspignoreFile pat `ignores` fp) == - (parseWaspignoreFile (pat ++ comment) `ignores` fp) + describe "IgnoreFile" $ do + it "When given a single pattern, should match it and '.waspignore'" $ do + let ignoreFile = parseWaspignoreFile "*.tmp" + (ignoreFile `ignores` "a.tmp") `shouldBe` True + (ignoreFile `ignores` "a.src") `shouldBe` False + (ignoreFile `ignores` ".waspignore") `shouldBe` True - it "When given 2 patterns, should match the path if either of the patterns match" $ do - let pat1 = parseWaspignoreFile "a" - let pat2 = parseWaspignoreFile "b" - let patBoth = parseWaspignoreFile "a\nb" - property $ \fp -> patBoth `ignores` fp == (pat1 `ignores` fp || pat2 `ignores` fp) + it "When given a blank input, should match only '.waspignore'" $ do + let ignoreFile = parseWaspignoreFile "" + property $ \fp -> + if fp == ".waspignore" + then ignoreFile `ignores` fp + else not $ ignoreFile `ignores` fp + + it "When given a comment as the only line, should match only '.waspignore'" $ do + let ignoreFile = parseWaspignoreFile "# test comment" + property $ \fp -> + if fp == ".waspignore" + then ignoreFile `ignores` fp + else not $ ignoreFile `ignores` fp + + it "When the only difference between two files is a comment, the files should match the same strings" $ do + let comment = "\n# test comment" + property $ \pat fp -> + (parseWaspignoreFile pat `ignores` fp) + == (parseWaspignoreFile (pat ++ comment) `ignores` fp) + + it "When given 2 patterns, should match the path if either of the patterns match" $ do + let pat1 = parseWaspignoreFile "a" + let pat2 = parseWaspignoreFile "b" + let patBoth = parseWaspignoreFile "a\nb" + property $ \fp -> patBoth `ignores` fp == (pat1 `ignores` fp || pat2 `ignores` fp) diff --git a/waspc/testEnv.hs b/waspc/testEnv.hs index e7478d08b..8539b5d7e 100755 --- a/waspc/testEnv.hs +++ b/waspc/testEnv.hs @@ -14,13 +14,12 @@ Run it either as an executable or with `stack SCRIPT_NAME`. -} -import Text.Pretty.Simple (pPrint) import Data.Aeson import Data.Aeson.Encode.Pretty import Data.ByteString.Lazy.Char8 as L - -import Parser.Common (runWaspParser) import Fixtures +import Parser.Common (runWaspParser) +import Text.Pretty.Simple (pPrint) -- | Prints any ToJSON instance, useful when testing parser. printJSON :: ToJSON a => a -> IO ()