diff --git a/app/Spago.hs b/app/Spago.hs index eeeaec33d..2b542d211 100644 --- a/app/Spago.hs +++ b/app/Spago.hs @@ -10,7 +10,6 @@ import Spago.CLI (Command(..)) import qualified System.Environment as Env import qualified Spago.Build -import qualified Spago.GitHub import qualified Spago.Messages as Messages import qualified Spago.Packages import qualified Spago.PackageSet @@ -51,14 +50,16 @@ main = withUtf8 $ do -> Spago.PackageSet.updatePackageSetVersion tag Freeze -> Spago.PackageSet.freeze Spago.PackageSet.packagesPath - Login - -> Spago.GitHub.login Version -> CLI.echo spagoVersion - Path whichPath buildOptions + Path whichPath buildOptions -> Path.showPaths buildOptions whichPath Repl replPackageNames paths pursArgs depsOnly -> Spago.Build.repl replPackageNames paths pursArgs depsOnly + BundleApp modName tPath shouldBuild buildOptions + -> Spago.Build.bundleApp WithMain modName tPath shouldBuild buildOptions globalUsePsa + BundleModule modName tPath shouldBuild buildOptions + -> Spago.Build.bundleModule modName tPath shouldBuild buildOptions globalUsePsa -- ### Commmands that need only a Package Set ListPackages jsonFlag -> Run.withPackageSetEnv @@ -67,38 +68,32 @@ main = withUtf8 $ do -- ### Commands that need an "install environment": global options and a Config Install packageNames -> Run.withInstallEnv $ Spago.Packages.install packageNames - ListDeps jsonFlag transitiveFlag -> Run.withInstallEnv + ListDeps jsonFlag transitiveFlag -> Run.withInstallEnv $ Ls.listPackages transitiveFlag jsonFlag - Sources -> Run.withInstallEnv + Sources -> Run.withInstallEnv $ Spago.Packages.sources - + -- ### Commands that need a "publish env": install env + git and bower - BumpVersion dryRun spec -> Run.withPublishEnv + BumpVersion dryRun spec -> Run.withPublishEnv $ Spago.Version.bumpVersion dryRun spec - - -- ### Commands that need a "verification env": a Package Set + purs + + -- ### Commands that need a "verification env": a Package Set + purs Verify package -> Run.withVerifyEnv globalUsePsa $ Verify.verify NoCheckModulesUnique (Just package) VerifySet checkUniqueModules -> Run.withVerifyEnv globalUsePsa $ Verify.verify checkUniqueModules Nothing - + -- ### Commands that need a build environment: a config, build options and access to purs Build buildOptions -> Run.withBuildEnv globalUsePsa $ Spago.Build.build buildOptions Nothing - Search -> Run.withBuildEnv globalUsePsa + Search -> Run.withBuildEnv globalUsePsa $ Spago.Build.search - Docs format sourcePaths depsOnly noSearch openDocs -> Run.withBuildEnv globalUsePsa + Docs format sourcePaths depsOnly noSearch openDocs -> Run.withBuildEnv globalUsePsa $ Spago.Build.docs format sourcePaths depsOnly noSearch openDocs - - -- TODO: Bundle env: build env + bundle options Test modName buildOptions nodeArgs -> Run.withBuildEnv globalUsePsa $ Spago.Build.test modName buildOptions nodeArgs Run modName buildOptions nodeArgs -> Run.withBuildEnv globalUsePsa $ Spago.Build.run modName buildOptions nodeArgs - BundleApp modName tPath shouldBuild buildOptions -> Run.withBuildEnv globalUsePsa - $ Spago.Build.bundleApp WithMain modName tPath shouldBuild buildOptions - BundleModule modName tPath shouldBuild buildOptions -> Run.withBuildEnv globalUsePsa - $ Spago.Build.bundleModule modName tPath shouldBuild buildOptions -- ### Legacy commands, here for smoother migration path to new ones Bundle -> die [ display Messages.bundleCommandRenamed ] diff --git a/package.yaml b/package.yaml index 258cb309b..9f571e5b6 100644 --- a/package.yaml +++ b/package.yaml @@ -12,6 +12,10 @@ extra-source-files: ghc-options: - -Wall + - -Wcompat + - -Wincomplete-record-updates + - -Wredundant-constraints + - -fprint-potential-instances flags: static: @@ -41,6 +45,7 @@ default-extensions: - DeriveTraversable - DerivingStrategies - DoAndIfThenElse +- DuplicateRecordFields - EmptyDataDecls - ExistentialQuantification - FlexibleContexts @@ -51,21 +56,27 @@ default-extensions: - InstanceSigs - KindSignatures - LambdaCase +- LiberalTypeSynonyms +- MonadFailDesugaring - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude +- NoMonomorphismRestriction - OverloadedStrings - PartialTypeSignatures - PatternGuards - PolyKinds +- QuantifiedConstraints - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections +- TypeApplications - TypeFamilies - TypeSynonymInstances +- UndecidableInstances - ViewPatterns @@ -89,6 +100,7 @@ library: - filepath - foldl - fsnotify + - generic-lens - github - Glob - http-types diff --git a/spago.cabal b/spago.cabal index 432478e45..104dbfd82 100644 --- a/spago.cabal +++ b/spago.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b88f8100a3b763c486e0f8eef011ce424bcca172077abeb8b10114b874428683 +-- hash: 9de92542b083d8ac067f48da2712a1fb309797a50aa0494d1590a304f069b13e name: spago version: 0.17.0 @@ -63,8 +63,8 @@ library Paths_spago hs-source-dirs: src - default-extensions: ApplicativeDo BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns - ghc-options: -Wall + default-extensions: ApplicativeDo BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeSynonymInstances UndecidableInstances ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -fprint-potential-instances build-depends: Cabal , Glob @@ -84,6 +84,7 @@ library , filepath , foldl , fsnotify + , generic-lens , github , http-client , http-conduit @@ -125,8 +126,8 @@ executable spago Paths_spago hs-source-dirs: app - default-extensions: ApplicativeDo BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns - ghc-options: -Wall + default-extensions: ApplicativeDo BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeSynonymInstances UndecidableInstances ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -fprint-potential-instances build-depends: base >=4.7 && <5 , spago @@ -147,7 +148,7 @@ test-suite spec other-modules: BumpVersionSpec Spago.Build.ParserSpec - Spago.Command.PathSpec + Spago.PursSpec SpagoSpec Spec UnitSpec @@ -155,8 +156,8 @@ test-suite spec Paths_spago hs-source-dirs: test - default-extensions: ApplicativeDo BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -main-is Main + default-extensions: ApplicativeDo BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds QuantifiedConstraints RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeSynonymInstances UndecidableInstances ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -fprint-potential-instances -threaded -rtsopts -with-rtsopts=-N -main-is Main build-depends: QuickCheck , base >=4.7 && <5 diff --git a/src/Spago/Async.hs b/src/Spago/Async.hs index f4411fdc7..3676d43e0 100644 --- a/src/Spago/Async.hs +++ b/src/Spago/Async.hs @@ -8,10 +8,10 @@ import Spago.Prelude import qualified Control.Concurrent.Async.Pool as Async -withTaskGroup :: (MonadIO m, MonadReader env m, HasLogFunc env, MonadUnliftIO m) => Int -> (Async.TaskGroup -> m b) -> m b +withTaskGroup :: MonadUnliftIO m => Int -> (Async.TaskGroup -> m b) -> m b withTaskGroup n action = withRunInIO $ \run -> Async.withTaskGroup n (\taskGroup -> run $ action taskGroup) -async :: (MonadIO m, MonadReader env m, HasLogFunc env, MonadUnliftIO m) => Async.TaskGroup -> m a -> m (Async.Async a) +async :: MonadUnliftIO m => Async.TaskGroup -> m a -> m (Async.Async a) async taskGroup action = withRunInIO $ \run -> Async.async taskGroup (run action) wait :: MonadIO m => Async.Async a -> m a diff --git a/src/Spago/Bower.hs b/src/Spago/Bower.hs index f431c23cd..9713a142a 100644 --- a/src/Spago/Bower.hs +++ b/src/Spago/Bower.hs @@ -32,14 +32,14 @@ path = "bower.json" runBower :: HasBower env => [Text] -> RIO env (ExitCode, Text, Text) runBower args = do - bower <- view bowerL + BowerCmd bower <- view (the @BowerCmd) Turtle.procStrictWithErr bower args empty generateBowerJson :: HasPublishEnv env => RIO env Text generateBowerJson = do logInfo "Generating a new Bower config using the package set versions.." - Config{..} <- view configL + Config{..} <- view (the @Config) PublishConfig{..} <- throws publishConfig bowerName <- mkPackageName name @@ -66,7 +66,7 @@ generateBowerJson = do runBowerInstall :: (HasLogFunc env, HasBower env) => RIO env () runBowerInstall = do logInfo "Running `bower install` so `pulp publish` can read resolved versions from it" - bower <- view bowerL + BowerCmd bower <- view (the @BowerCmd) shell (bower <> " install --silent") empty >>= \case ExitSuccess -> pure () ExitFailure _ -> die [ "Failed to run `bower install` on your package" ] @@ -118,7 +118,7 @@ mkDependencies mkDependencies = do deps <- Packages.getDirectDeps - jobs <- getJobs + Jobs jobs <- getJobs Async.withTaskGroup jobs $ \taskGroup -> Async.mapTasks taskGroup $ mkDependency <$> deps @@ -137,5 +137,5 @@ mkDependencies = do getJobs = case OS.buildOS of -- Windows sucks so lets make it slow for them! -- (just kidding, its a bug: https://github.com/bower/spec/issues/79) - OS.Windows -> pure 1 - _ -> view jobsL + OS.Windows -> pure $ Jobs 1 + _ -> view (the @Jobs) diff --git a/src/Spago/Build.hs b/src/Spago/Build.hs index c8d852f92..bdd07c565 100644 --- a/src/Spago/Build.hs +++ b/src/Spago/Build.hs @@ -12,7 +12,6 @@ module Spago.Build import Spago.Prelude hiding (link) import Spago.Env -import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import qualified Data.Text as Text @@ -28,7 +27,7 @@ import qualified Web.Browser as Browser import qualified Spago.Build.Parser as Parse import qualified Spago.Command.Path as Path -import qualified Spago.RunEnv as Run +import qualified Spago.RunEnv as Run import qualified Spago.Config as Config import qualified Spago.Dhall as Dhall import qualified Spago.FetchPackage as Fetch @@ -49,14 +48,13 @@ prepareBundleDefaults maybeModuleName maybeTargetPath = (moduleName, targetPath) targetPath = fromMaybe (TargetPath "index.js") maybeTargetPath -- eventually running some other action after the build -build - :: forall env - . (HasEnv env, HasPurs env, HasCacheConfig env, HasConfig env) - => BuildOptions -> Maybe (RIO env ()) +build + :: HasBuildEnv env + => BuildOptions -> Maybe (RIO Env ()) -> RIO env () build BuildOptions{..} maybePostBuild = do logDebug "Running `spago build`" - Config{..} <- view configL + Config{..} <- view (the @Config) deps <- Packages.getProjectDeps case noInstall of DoInstall -> Fetch.fetchPackages deps @@ -69,7 +67,7 @@ build BuildOptions{..} maybePostBuild = do Nothing -> Purs.compile globs pursArgs Just backend -> do - when (PursArg "--codegen" `List.elem` pursArgs) $ + when (isJust $ Purs.findFlag 'g' "codegen" pursArgs) $ die [ "Can't pass `--codegen` option to build when using a backend" , "Hint: No need to pass `--codegen corefn` explicitly when using the `backend` option." @@ -85,7 +83,8 @@ build BuildOptions{..} maybePostBuild = do ExitFailure n -> die [ "Backend " <> displayShow backend <> " exited with error:" <> repr n ] buildAction globs = do - let action = buildBackend globs >> fromMaybe (pure ()) maybePostBuild + env <- Run.getEnv + let action = buildBackend globs >> (runRIO env $ fromMaybe (pure ()) maybePostBuild) runCommands "Before" beforeCommands action `onException` (runCommands "Else" elseCommands) runCommands "Then" thenCommands @@ -110,7 +109,7 @@ build BuildOptions{..} maybePostBuild = do (buildAction (wrap <$> psMatches)) where - runCommands :: Text -> [Text] -> RIO env () + runCommands :: HasLogFunc env => Text -> [Text] -> RIO env () runCommands label = traverse_ runCommand where runCommand command = shell command empty >>= \case @@ -142,13 +141,12 @@ repl -> RIO env () repl newPackages sourcePaths pursArgs depsOnly = do logDebug "Running `spago repl`" - -- TODO: instead of using HasPurs here we just call this for now purs <- Run.getPurs NoPsa Config.ensureConfig >>= \case Right config -> Run.withInstallEnv' (Just config) (replAction purs) Left err -> do logDebug err - cacheDir <- view globalCacheL + GlobalCache cacheDir _ <- view (the @GlobalCache) Temp.withTempDirectory cacheDir "spago-repl-tmp" $ \dir -> do Turtle.cd (Turtle.decodeString dir) @@ -160,7 +158,7 @@ repl newPackages sourcePaths pursArgs depsOnly = do Run.withInstallEnv' (Just newConfig) (replAction purs) where replAction purs = do - Config{..} <- view configL + Config{..} <- view (the @Config) deps <- Packages.getProjectDeps -- we check that psci-support is in the deps, see #550 unless (Set.member (PackageName "psci-support") (Set.fromList (map fst deps))) $ do @@ -170,18 +168,18 @@ repl newPackages sourcePaths pursArgs depsOnly = do ] let globs = Packages.getGlobs deps depsOnly (configSourcePaths <> sourcePaths) Fetch.fetchPackages deps - liftIO $ Purs.repl purs globs pursArgs + runRIO purs $ Purs.repl globs pursArgs -- | Test the project: compile and run "Test.Main" -- (or the provided module name) with node -test - :: (HasEnv env, HasConfig env, HasPurs env, HasCacheConfig env) - => Maybe ModuleName -> BuildOptions -> [PursArg] +test + :: HasBuildEnv env + => Maybe ModuleName -> BuildOptions -> [BackendArg] -> RIO env () test maybeModuleName buildOpts extraArgs = do let moduleName = fromMaybe (ModuleName "Test.Main") maybeModuleName - Config.Config { alternateBackend, configSourcePaths } <- view configL + Config.Config { alternateBackend, configSourcePaths } <- view (the @Config) liftIO (foldMapM (Glob.glob . Text.unpack . unSourcePath) configSourcePaths) >>= \paths -> do results <- forM paths $ \path -> do content <- readFileBinary path @@ -195,12 +193,12 @@ test maybeModuleName buildOpts extraArgs = do -- | Run the project: compile and run "Main" -- (or the provided module name) with node -run - :: (HasEnv env, HasConfig env, HasPurs env, HasCacheConfig env) - => Maybe ModuleName -> BuildOptions -> [PursArg] +run + :: HasBuildEnv env + => Maybe ModuleName -> BuildOptions -> [BackendArg] -> RIO env () run maybeModuleName buildOpts extraArgs = do - Config.Config { alternateBackend } <- view configL + Config.Config { alternateBackend } <- view (the @Config) let moduleName = fromMaybe (ModuleName "Main") maybeModuleName runBackend alternateBackend moduleName Nothing "Running failed; " buildOpts extraArgs @@ -208,20 +206,20 @@ run maybeModuleName buildOpts extraArgs = do -- | Run the project with node (or the chosen alternate backend): -- compile and run the provided ModuleName runBackend - :: (HasEnv env, HasPurs env, HasCacheConfig env, HasConfig env) + :: HasBuildEnv env => Maybe Text -> ModuleName -> Maybe Text -> Text -> BuildOptions - -> [PursArg] + -> [BackendArg] -> RIO env () -runBackend maybeBackend moduleName maybeSuccessMessage failureMessage buildOpts extraArgs = do +runBackend maybeBackend moduleName maybeSuccessMessage failureMessage buildOpts@BuildOptions{pursArgs} extraArgs = do logDebug $ display $ "Running with backend: " <> fromMaybe "nodejs" maybeBackend - let postBuild = maybe (nodeAction $ Path.getOutputPath buildOpts) backendAction maybeBackend + let postBuild = maybe (nodeAction $ Path.getOutputPath pursArgs) backendAction maybeBackend build buildOpts (Just postBuild) where - nodeArgs = Text.intercalate " " $ map unPursArg extraArgs + nodeArgs = Text.intercalate " " $ map unBackendArg extraArgs nodeContents outputPath' = "#!/usr/bin/env node\n\n" <> "require('../" <> Text.pack outputPath' <> "/" <> unModuleName moduleName <> "').main()" nodeCmd = "node .spago/run.js " <> nodeArgs @@ -235,7 +233,7 @@ runBackend maybeBackend moduleName maybeSuccessMessage failureMessage buildOpts ExitSuccess -> maybe (pure ()) (logInfo . display) maybeSuccessMessage ExitFailure n -> die [ display failureMessage <> "exit code: " <> repr n ] backendAction backend = do - let args :: [Text] = ["--run", unModuleName moduleName <> ".main"] <> fmap unPursArg extraArgs + let args :: [Text] = ["--run", unModuleName moduleName <> ".main"] <> fmap unBackendArg extraArgs logDebug $ display $ "Running command `" <> backend <> " " <> Text.unwords args <> "`" Turtle.proc backend args empty >>= \case ExitSuccess -> maybe (pure ()) (logInfo . display) maybeSuccessMessage @@ -243,29 +241,31 @@ runBackend maybeBackend moduleName maybeSuccessMessage failureMessage buildOpts -- | Bundle the project to a js file bundleApp - :: (HasEnv env, HasPurs env, HasCacheConfig env, HasConfig env) + :: HasEnv env => WithMain -> Maybe ModuleName -> Maybe TargetPath -> NoBuild -> BuildOptions + -> UsePsa -> RIO env () -bundleApp withMain maybeModuleName maybeTargetPath noBuild buildOpts = +bundleApp withMain maybeModuleName maybeTargetPath noBuild buildOpts usePsa = let (moduleName, targetPath) = prepareBundleDefaults maybeModuleName maybeTargetPath bundleAction = Purs.bundle withMain (withSourceMap buildOpts) moduleName targetPath in case noBuild of - DoBuild -> build buildOpts (Just bundleAction) - NoBuild -> bundleAction + DoBuild -> Run.withBuildEnv usePsa $ build buildOpts (Just bundleAction) + NoBuild -> Run.getEnv >>= (flip runRIO) bundleAction -- | Bundle into a CommonJS module bundleModule - :: (HasEnv env, HasPurs env, HasCacheConfig env, HasConfig env) + :: HasEnv env => Maybe ModuleName -> Maybe TargetPath -> NoBuild -> BuildOptions + -> UsePsa -> RIO env () -bundleModule maybeModuleName maybeTargetPath noBuild buildOpts = do +bundleModule maybeModuleName maybeTargetPath noBuild buildOpts usePsa = do logDebug "Running `bundleModule`" let (moduleName, targetPath) = prepareBundleDefaults maybeModuleName maybeTargetPath jsExport = Text.unpack $ "\nmodule.exports = PS[\""<> unModuleName moduleName <> "\"];" @@ -280,8 +280,8 @@ bundleModule maybeModuleName maybeTargetPath noBuild buildOpts = do Right _ -> logInfo $ display $ "Make module succeeded and output file to " <> unTargetPath targetPath Left (n :: SomeException) -> die [ "Make module failed: " <> repr n ] case noBuild of - DoBuild -> build buildOpts (Just bundleAction) - NoBuild -> bundleAction + DoBuild -> Run.withBuildEnv usePsa $ build buildOpts (Just bundleAction) + NoBuild -> Run.getEnv >>= (flip runRIO) bundleAction -- | Generate docs for the `sourcePaths` and run `purescript-docs-search build-index` to patch them. @@ -295,7 +295,7 @@ docs -> RIO env () docs format sourcePaths depsOnly noSearch open = do logDebug "Running `spago docs`" - Config{..} <- view configL + Config{..} <- view (the @Config) deps <- Packages.getProjectDeps logInfo "Generating documentation for the project. This might take a while..." Purs.docs docsFormat $ Packages.getGlobs deps depsOnly configSourcePaths <> sourcePaths @@ -334,7 +334,7 @@ search :: (HasPurs env, HasLogFunc env, HasConfig env) => RIO env () search = do - Config{..} <- view configL + Config{..} <- view (the @Config) deps <- Packages.getProjectDeps logInfo "Building module metadata..." diff --git a/src/Spago/CLI.hs b/src/Spago/CLI.hs index 98933db77..7de663aeb 100644 --- a/src/Spago/CLI.hs +++ b/src/Spago/CLI.hs @@ -24,7 +24,7 @@ data Command -- | Default catch-all command = Default ShowVersion - + -- | Initialize a new project | Init Force TemplateComments (Maybe Text) @@ -43,9 +43,6 @@ data Command -- | Bump and tag a new version in preparation for release. | BumpVersion DryRun VersionBump - -- | Save a GitHub token to cache, to authenticate to various GitHub things - | Login - -- | Upgrade the package-set to the latest release | PackageSetUpgrade (Maybe Text) @@ -73,17 +70,17 @@ data Command | Docs (Maybe DocsFormat) [SourcePath] DepsOnly NoSearch OpenDocs -- | Run the project with some module, default Main - | Run (Maybe ModuleName) BuildOptions [PursArg] - + | Run (Maybe ModuleName) BuildOptions [BackendArg] + -- | Test the project with some module, default Test.Main - | Test (Maybe ModuleName) BuildOptions [PursArg] + | Test (Maybe ModuleName) BuildOptions [BackendArg] -- | Bundle the project into an executable | BundleApp (Maybe ModuleName) (Maybe TargetPath) NoBuild BuildOptions -- | Bundle a module into a CommonJS module | BundleModule (Maybe ModuleName) (Maybe TargetPath) NoBuild BuildOptions - + -- | Verify that a single package is consistent with the Package Set | Verify PackageName @@ -157,7 +154,7 @@ parser = do toTarget = CLI.optional $ CLI.opt (Just . TargetPath) "to" 't' "The target file path" docsFormat = CLI.optional $ CLI.opt Purs.parseDocsFormat "format" 'f' "Docs output format (markdown | html | etags | ctags)" jobsLimit = CLI.optional (CLI.optInt "jobs" 'j' "Limit the amount of jobs that can run concurrently") - nodeArgs = many $ CLI.opt (Just . PursArg) "node-args" 'a' "Argument to pass to node (run/test only)" + nodeArgs = many $ CLI.opt (Just . BackendArg) "node-args" 'a' "Argument to pass to node (run/test only)" replPackageNames = many $ CLI.opt (Just . PackageName) "dependency" 'D' "Package name to add to the REPL as dependency" sourcePaths = many $ CLI.opt (Just . SourcePath) "path" 'p' "Source path to include" @@ -293,12 +290,6 @@ parser = do , pure Freeze ) - login = - ( "login" - , "Save the GitHub token to the global cache - set it with the SPAGO_GITHUB_TOKEN env variable" - , pure Login - ) - bumpVersion = ( "bump-version" , "Bump and tag a new version, and generate bower.json, in preparation for release." @@ -350,8 +341,7 @@ parser = do , freeze ] publishCommands = CLI.subcommandGroup "Publish commands:" - [ login - , bumpVersion + [ bumpVersion ] oldCommands = Opts.subparser $ Opts.internal <> bundle <> makeModule <> listPackagesOld diff --git a/src/Spago/Command/Ls.hs b/src/Spago/Command/Ls.hs index b5612be0a..d9bf0f1c8 100644 --- a/src/Spago/Command/Ls.hs +++ b/src/Spago/Command/Ls.hs @@ -32,24 +32,24 @@ encodeJsonPackageOutput :: JsonPackageOutput -> Text encodeJsonPackageOutput = LT.toStrict . LT.decodeUtf8 . Json.encode -listPackageSet +listPackageSet :: (HasLogFunc env, HasPackageSet env) => JsonFlag -> RIO env () listPackageSet jsonFlag = do logDebug "Running `listPackageSet`" - PackageSet{..} <- view packageSetL + PackageSet{..} <- view (the @PackageSet) traverse_ output $ formatPackageNames jsonFlag (Map.toList packagesDB) -listPackages - :: (HasLogFunc env, HasConfig env) - => IncludeTransitive -> JsonFlag +listPackages + :: (HasLogFunc env, HasConfig env) + => IncludeTransitive -> JsonFlag -> RIO env () listPackages packagesFilter jsonFlag = do logDebug "Running `listPackages`" packagesToList :: [(PackageName, Package)] <- case packagesFilter of - IncludeTransitive -> Packages.getProjectDeps + IncludeTransitive -> Packages.getProjectDeps _ -> do - Config { packageSet = PackageSet{ packagesDB }, dependencies } <- view configL + Config { packageSet = PackageSet{ packagesDB }, dependencies } <- view (the @Config) pure $ Map.toList $ Map.restrictKeys packagesDB (Set.fromList dependencies) case packagesToList of diff --git a/src/Spago/Command/Path.hs b/src/Spago/Command/Path.hs index 68dd8df33..8b83d4999 100644 --- a/src/Spago/Command/Path.hs +++ b/src/Spago/Command/Path.hs @@ -1,4 +1,4 @@ -module Spago.Command.Path (showPaths, getOutputPath, findFlag) where +module Spago.Command.Path (showPaths, getOutputPath) where import Spago.Prelude import Spago.Env @@ -6,81 +6,42 @@ import Spago.Env import qualified Data.Text as Text import qualified System.IO as Sys +import qualified Spago.Purs as Purs + showPaths - :: (HasLogFunc env, HasGlobalCache env) + :: (HasGlobalCache env) => BuildOptions -> Maybe PathType -> RIO env () -showPaths buildOptions whichPaths = +showPaths BuildOptions{ pursArgs } whichPaths = case whichPaths of - (Just PathOutput) -> outputStr (getOutputPath buildOptions) - (Just PathGlobalCache) -> view globalCacheL >>= outputStr + (Just PathOutput) -> outputStr (getOutputPath pursArgs) + (Just PathGlobalCache) -> do + GlobalCache path _ <- view (the @GlobalCache) + outputStr path Nothing -> do let showPath (a,b) = output (a <> ": " <> b) - getAllPaths buildOptions >>= traverse_ showPath + getAllPaths pursArgs >>= traverse_ showPath getAllPaths - :: (HasLogFunc env, HasGlobalCache env) - => BuildOptions + :: (HasGlobalCache env) + => [PursArg] -> RIO env [(Text, Text)] -getAllPaths buildOptions = do - globalCache <- view globalCacheL +getAllPaths pursArgs = do + GlobalCache path _ <- view (the @GlobalCache) pure - [ ("output", Text.pack (getOutputPath buildOptions)) - , ("global-cache", Text.pack globalCache) + [ ("output", Text.pack (getOutputPath pursArgs)) + , ("global-cache", Text.pack path) ] -- | Find the output path for purs compiler getOutputPath - :: BuildOptions + :: [PursArg] -> Sys.FilePath -getOutputPath buildOpts = do - case findFlag 'o' "output" (pursArgs buildOpts) of +getOutputPath pursArgs = do + case Purs.findFlag 'o' "output" pursArgs of Nothing -> "output" - Just path -> Text.unpack path - - --- See tests in: test/Spago/Command/PathSpec.hs --- ["-o", "something"] --- ["--output", "something"] --- ["--output something"] --- [" -o something"] --- ["--output=something"] - --- | Try to find the content of a certain flag in a list of PursArgs -findFlag :: Char -> Text -> [PursArg] -> Maybe Text -findFlag char string = \case - (x:xs) -> if isFlag x - then case xs of - (y:_) -> Just (unPursArg y) - _ -> Nothing - else if hasFlag x - then case Text.words (unPursArg x) of - [word] -> case Text.split (=='=') word of - [_,value] -> Just value - _ -> Nothing - (_:value:_) -> Just value - _ -> Nothing - else findFlag char string xs - _ -> Nothing - where - isFlag :: PursArg -> Bool - isFlag (PursArg word) - = word == (Text.pack ['-', char]) - || word == ("--" <> string) - hasFlag :: PursArg -> Bool - hasFlag (PursArg a) - = firstWord == (Text.pack ['-', char]) - || firstWord == ("--" <> string) - where - firstWord - = fromMaybe "" $ case Text.words a of - [] -> Nothing - [word] -> case Text.split (=='=') word of - [one] -> Just one - [key,_] -> Just key - _ -> Nothing - (word:_) -> Just word + Just path -> Text.unpack path \ No newline at end of file diff --git a/src/Spago/Command/Verify.hs b/src/Spago/Command/Verify.hs index 91ac6bd35..11855c033 100644 --- a/src/Spago/Command/Verify.hs +++ b/src/Spago/Command/Verify.hs @@ -13,13 +13,13 @@ import qualified Spago.Packages as Packages verify :: forall env - . HasVerifyEnv env - => CheckModulesUnique -> Maybe PackageName + . HasVerifyEnv env + => CheckModulesUnique -> Maybe PackageName -> RIO env () verify chkModsUniq maybePackage = do logDebug "Running `spago verify`" - PackageSet{..} <- view packageSetL + PackageSet{..} <- view (the @PackageSet) case maybePackage of -- If no package is specified, verify all of them @@ -58,7 +58,7 @@ verify chkModsUniq maybePackage = do compileEverything :: RIO env () compileEverything = do - PackageSet{ packagesDB } <- view packageSetL + PackageSet{ packagesDB } <- view (the @PackageSet) let deps = Map.toList packagesDB globs = Packages.getGlobs deps Packages.DepsOnly [] Fetch.fetchPackages deps diff --git a/src/Spago/Config.hs b/src/Spago/Config.hs index 40ba4b381..4303328b9 100644 --- a/src/Spago/Config.hs +++ b/src/Spago/Config.hs @@ -110,14 +110,14 @@ parsePackageSet pkgs = do -- | Tries to read in a Spago Config -parseConfig +parseConfig :: (HasLogFunc env, HasConfigPath env) => RIO env Config parseConfig = do -- Here we try to migrate any config that is not in the latest format void $ withConfigAST $ pure . addSourcePaths - path <- view configPathL + ConfigPath path <- view (the @ConfigPath) expr <- liftIO $ Dhall.inputExpr $ "./" <> path case expr of Dhall.RecordLit ks' -> do @@ -149,7 +149,7 @@ ensureConfig :: (HasLogFunc env, HasConfigPath env) => RIO env (Either Utf8Builder Config) ensureConfig = do - path <- view configPathL + ConfigPath path <- view (the @ConfigPath) exists <- testfile path if not exists then pure $ Left $ display Messages.cannotFindConfig @@ -164,10 +164,10 @@ ensureConfig = do -- Eventually ports an existing `psc-package.json` to the new config. makeConfig :: (HasConfigPath env, HasLogFunc env) - => Force -> Dhall.TemplateComments + => Force -> Dhall.TemplateComments -> RIO env Config makeConfig force comments = do - path <- view configPathL + ConfigPath path <- view (the @ConfigPath) when (force == NoForce) $ do hasSpagoDhall <- testfile path when hasSpagoDhall $ die [ display $ Messages.foundExistingProject path ] @@ -357,7 +357,7 @@ withConfigAST :: (HasLogFunc env, HasConfigPath env) => (Expr -> RIO env Expr) -> RIO env Bool withConfigAST transform = do - path <- view configPathL + ConfigPath path <- view (the @ConfigPath) rawConfig <- liftIO $ Dhall.readRawExpr path case rawConfig of Nothing -> die [ display $ Messages.cannotFindConfig ] diff --git a/src/Spago/Dhall.hs b/src/Spago/Dhall.hs index 1f6778558..6d2482aec 100644 --- a/src/Spago/Dhall.hs +++ b/src/Spago/Dhall.hs @@ -108,13 +108,13 @@ writeRawExpr pathText (header, expr) = do -- | Returns a Dhall Text literal from a lone string -toTextLit :: Pretty a => Text -> DhallExpr a +toTextLit :: Text -> DhallExpr a toTextLit str = Dhall.TextLit (Dhall.Chunks [] str) -- | Casts a Dhall Text literal to a string, or fails fromTextLit - :: (Pretty a, Typeable a) + :: (Typeable a) => DhallExpr a -> Either (ReadError a) Text fromTextLit(Dhall.TextLit (Dhall.Chunks [] str)) = Right str @@ -124,7 +124,7 @@ fromTextLit expr = Left $ ExprIsNotTextLit expr -- | Require a key from a Dhall.Map, and run an action on it if found. -- If not found, return the name of the key. requireKey - :: (Typeable b, Pretty b, MonadIO m, MonadThrow m) + :: (Typeable b, Pretty b, MonadThrow m) => Dhall.Map.Map Text (DhallExpr b) -> Text -> (DhallExpr b -> m a) diff --git a/src/Spago/Env.hs b/src/Spago/Env.hs index 2feb249f1..e57fe7945 100644 --- a/src/Spago/Env.hs +++ b/src/Spago/Env.hs @@ -1,52 +1,41 @@ module Spago.Env - ( - -- | Global environment - Env(..) - , HasEnv(..) - , HasGlobalCache(..) - , HasConfigPath(..) - , HasJobs(..) - - , GlobalOptions(..) - - -- | Package set environment + ( + -- | Environments + GlobalOptions(..) + , Env(..) , PackageSetEnv(..) - , HasPackageSetEnv - , HasPackageSet(..) - - -- | Install environment , InstallEnv(..) - , HasInstallEnv(..) - , HasConfig(..) - , HasCacheConfig(..) - - -- | Publish environment , PublishEnv(..) - , HasPublishEnv - , HasGit(..) - , HasBower(..) - - -- | Verification environment , VerifyEnv(..) - , HasVerifyEnv - - -- | Build environment , BuildEnv(..) + + -- | Environment constraints + , HasEnv + , HasVerifyEnv + , HasPublishEnv , HasBuildEnv - , HasPurs(..) + + -- | Simple capabilities + , HasGlobalCache + , HasConfigPath + , HasJobs + , HasPackageSet + , HasConfig + , HasGit + , HasBower + , HasPurs -- | Other types , module Spago.Types ) where -import RIO +import RIO (LogFunc, Generic, Maybe, Text, Bool, Int) -import qualified GHC.IO +import Data.Generics.Product (HasType) import Spago.Types - data GlobalOptions = GlobalOptions { globalQuiet :: Bool , globalVerbose :: Bool @@ -58,251 +47,94 @@ data GlobalOptions = GlobalOptions , globalCacheConfig :: Maybe CacheFlag } +type HasLogFunc env = HasType LogFunc env +type HasJobs env = HasType Jobs env +type HasGlobalCache env = HasType GlobalCache env +type HasConfigPath env = HasType ConfigPath env +type HasPackageSet env = HasType PackageSet env +type HasPurs env = HasType PursCmd env +type HasGit env = HasType GitCmd env +type HasBower env = HasType BowerCmd env + +type HasEnv env = + ( HasLogFunc env + , HasJobs env + , HasConfigPath env + , HasGlobalCache env + ) --- | App configuration containing parameters and other common --- things it's useful to compute only once at startup. -data Env = Env - { envJobs :: !Int - , envConfigPath :: !Text - , envLogFunc :: !LogFunc - , envGlobalCache :: !GHC.IO.FilePath - , envCacheConfig :: !(Maybe CacheFlag) - } - -data PackageSetEnv = PackageSetEnv - { packageSetEnvGlobal :: !Env - -- ^ the global options - , packageSetSet :: !PackageSet - -- ^ the package set - } - -data VerifyEnv = VerifyEnv - { verifyEnvGlobal :: !Env - -- ^ the global options - , verifyEnvPurs :: !Text - -- ^ the purs command to use - , verifyPackageSet :: PackageSet - -- ^ the package set - } - -data InstallEnv = InstallEnv - { installEnvGlobal :: !Env - -- ^ the global options - , installSpagoConfig :: !Config - -- ^ the project config - } - -data PublishEnv = PublishEnv - { publishEnvInstall :: !InstallEnv - -- ^ the install config - , publishEnvGit :: !Text - -- ^ git command to use - , publishEnvBower :: !Text - -- ^ bower command to use - } - -data BuildEnv = BuildEnv - { buildInstallEnv :: !InstallEnv - -- ^ the install config - , buildEnvPurs :: !Text - -- ^ the purs command to use - } - --- ### Classes - -class HasGlobalCache env where - globalCacheL :: Lens' env GHC.IO.FilePath - -class HasConfigPath env where - configPathL :: Lens' env Text - -class HasJobs env where - jobsL :: Lens' env Int - -class HasGlobalCache env => HasCacheConfig env where - cacheConfigL :: Lens' env (Maybe CacheFlag) - -class HasPackageSet env where - packageSetL :: Lens' env PackageSet - -class - ( HasPackageSet env - ) => HasConfig env where - configL :: Lens' env Config - -class HasPurs env where - pursL :: Lens' env Text - -class HasGit env where - gitL :: Lens' env Text - -class HasBower env where - bowerL :: Lens' env Text - +type HasConfig env = ( HasType Config env, HasPackageSet env ) -class - ( HasGlobalCache env - , HasLogFunc env - , HasConfigPath env +type HasVerifyEnv env = + ( HasLogFunc env , HasJobs env - ) => HasEnv env where - envL :: Lens' env Env - -class - ( HasEnv env + , HasGlobalCache env + , HasPurs env , HasPackageSet env - ) => HasPackageSetEnv env + ) -class - ( HasEnv env - , HasCacheConfig env +type HasPublishEnv env = + ( HasLogFunc env + , HasJobs env , HasConfig env - ) => HasInstallEnv env where - installEnvL :: Lens' env InstallEnv - -class - ( HasInstallEnv env - , HasGit env , HasBower env - ) => HasPublishEnv env - -class - ( HasPurs env - , HasInstallEnv env - ) => HasBuildEnv env + , HasGit env + ) -class +type HasBuildEnv env = ( HasEnv env , HasPurs env - , HasCacheConfig env - , HasPackageSet env - ) => HasVerifyEnv env - - --- ### Instances - --- Config -instance HasPackageSet Config where - packageSetL = lens packageSet (\x y -> x { packageSet = y }) - - --- Env -instance HasLogFunc Env where - logFuncL = lens envLogFunc (\x y -> x { envLogFunc = y }) -instance HasConfigPath Env where - configPathL = lens envConfigPath (\x y -> x { envConfigPath = y }) -instance HasJobs Env where - jobsL = lens envJobs (\x y -> x { envJobs = y }) -instance HasGlobalCache Env where - globalCacheL = lens envGlobalCache (\x y -> x { envGlobalCache = y }) -instance HasCacheConfig Env where - cacheConfigL = lens envCacheConfig (\x y -> x { envCacheConfig = y }) -instance HasEnv Env where - envL = id - - --- PackageSetEnv -instance HasLogFunc PackageSetEnv where - logFuncL = envL . logFuncL -instance HasGlobalCache PackageSetEnv where - globalCacheL = envL . globalCacheL -instance HasConfigPath PackageSetEnv where - configPathL = envL . configPathL -instance HasJobs PackageSetEnv where - jobsL = envL . jobsL -instance HasPackageSet PackageSetEnv where - packageSetL = lens packageSetSet (\x y -> x { packageSetSet = y }) -instance HasEnv PackageSetEnv where - envL = lens packageSetEnvGlobal (\x y -> x { packageSetEnvGlobal = y }) -instance HasPackageSetEnv PackageSetEnv - - --- VerifyEnv -instance HasLogFunc VerifyEnv where - logFuncL = envL . logFuncL -instance HasGlobalCache VerifyEnv where - globalCacheL = envL . globalCacheL -instance HasConfigPath VerifyEnv where - configPathL = envL . configPathL -instance HasJobs VerifyEnv where - jobsL = envL . jobsL -instance HasCacheConfig VerifyEnv where - cacheConfigL = envL . cacheConfigL -instance HasPurs VerifyEnv where - pursL = lens verifyEnvPurs (\x y -> x { verifyEnvPurs = y }) -instance HasPackageSet VerifyEnv where - packageSetL = lens verifyPackageSet (\x y -> x { verifyPackageSet = y }) -instance HasEnv VerifyEnv where - envL = lens verifyEnvGlobal (\x y -> x { verifyEnvGlobal = y }) -instance HasVerifyEnv VerifyEnv - + , HasGit env + , HasConfig env + ) --- Install env -instance HasLogFunc InstallEnv where - logFuncL = envL . logFuncL -instance HasGlobalCache InstallEnv where - globalCacheL = envL . globalCacheL -instance HasConfigPath InstallEnv where - configPathL = envL . configPathL -instance HasJobs InstallEnv where - jobsL = envL . jobsL -instance HasCacheConfig InstallEnv where - cacheConfigL = envL . cacheConfigL -instance HasPackageSet InstallEnv where - packageSetL = configL . packageSetL -instance HasConfig InstallEnv where - configL = lens installSpagoConfig (\x y -> x { installSpagoConfig = y }) -instance HasEnv InstallEnv where - envL = lens installEnvGlobal (\x y -> x { installEnvGlobal = y }) -instance HasInstallEnv InstallEnv where - installEnvL = id +-- | App configuration containing parameters and other common +-- things it's useful to compute only once at startup. +data Env = Env + { envLogFunc :: !LogFunc + , envJobs :: !Jobs + , envConfigPath :: !ConfigPath + , envGlobalCache :: !GlobalCache + } deriving (Generic) +data PackageSetEnv = PackageSetEnv + { envLogFunc :: !LogFunc + , envPackageSet :: !PackageSet + } deriving (Generic) --- PublishEnv -instance HasLogFunc PublishEnv where - logFuncL = envL . logFuncL -instance HasGlobalCache PublishEnv where - globalCacheL = envL . globalCacheL -instance HasConfigPath PublishEnv where - configPathL = envL . configPathL -instance HasJobs PublishEnv where - jobsL = envL . jobsL -instance HasBower PublishEnv where - bowerL = lens publishEnvBower (\x y -> x { publishEnvBower = y }) -instance HasGit PublishEnv where - gitL = lens publishEnvGit (\x y -> x { publishEnvGit = y }) -instance HasCacheConfig PublishEnv where - cacheConfigL = installEnvL . cacheConfigL -instance HasPackageSet PublishEnv where - packageSetL = installEnvL . packageSetL -instance HasConfig PublishEnv where - configL = installEnvL . configL -instance HasEnv PublishEnv where - envL = installEnvL . envL -instance HasInstallEnv PublishEnv where - installEnvL = lens publishEnvInstall (\x y -> x { publishEnvInstall = y }) -instance HasPublishEnv PublishEnv +data VerifyEnv = VerifyEnv + { envLogFunc :: !LogFunc + , envJobs :: !Jobs + , envGlobalCache :: !GlobalCache + , envPursCmd :: !PursCmd + , envPackageSet :: !PackageSet + } deriving (Generic) +data InstallEnv = InstallEnv + { envLogFunc :: !LogFunc + , envJobs :: !Jobs + , envConfigPath :: !ConfigPath + , envGlobalCache :: !GlobalCache + , envPackageSet :: !PackageSet + , envConfig :: !Config + } deriving (Generic) --- BuildEnv -instance HasLogFunc BuildEnv where - logFuncL = envL . logFuncL -instance HasGlobalCache BuildEnv where - globalCacheL = envL . globalCacheL -instance HasConfigPath BuildEnv where - configPathL = envL . configPathL -instance HasJobs BuildEnv where - jobsL = envL . jobsL -instance HasPurs BuildEnv where - pursL = lens buildEnvPurs (\x y -> x { buildEnvPurs = y }) -instance HasCacheConfig BuildEnv where - cacheConfigL = installEnvL . cacheConfigL -instance HasPackageSet BuildEnv where - packageSetL = installEnvL . packageSetL -instance HasConfig BuildEnv where - configL = installEnvL . configL -instance HasEnv BuildEnv where - envL = installEnvL . envL -instance HasInstallEnv BuildEnv where - installEnvL = lens buildInstallEnv (\x y -> x { buildInstallEnv = y }) -instance HasBuildEnv BuildEnv \ No newline at end of file +data PublishEnv = PublishEnv + { envLogFunc :: !LogFunc + , envJobs :: !Jobs + , envConfig :: !Config + , envPackageSet :: !PackageSet + , envGitCmd :: !GitCmd + , envBowerCmd :: !BowerCmd + } deriving (Generic) + +data BuildEnv = BuildEnv + { envLogFunc :: !LogFunc + , envJobs :: !Jobs + , envConfigPath :: !ConfigPath + , envGlobalCache :: !GlobalCache + , envPursCmd :: !PursCmd + , envGitCmd :: !GitCmd + , envPackageSet :: !PackageSet + , envConfig :: !Config + } deriving (Generic) \ No newline at end of file diff --git a/src/Spago/FetchPackage.hs b/src/Spago/FetchPackage.hs index 8ba98e9fb..8ecef33c0 100644 --- a/src/Spago/FetchPackage.hs +++ b/src/Spago/FetchPackage.hs @@ -2,6 +2,7 @@ module Spago.FetchPackage ( fetchPackages , getLocalCacheDir , getCacheVersionDir + , localCacheDir ) where import Spago.Prelude @@ -34,7 +35,7 @@ import qualified Spago.PackageSet as PackageSet -- * if yes, download the tar archive and copy it to global and then local cache -- * if not, run a series of git commands to get the code, and copy to local cache fetchPackages - :: (HasEnv env, HasCacheConfig env, HasPackageSet env) + :: (HasLogFunc env, HasJobs env, HasGlobalCache env, HasPackageSet env) => [(PackageName, Package)] -> RIO env () fetchPackages allDeps = do @@ -43,8 +44,8 @@ fetchPackages allDeps = do PackageSet.checkPursIsUpToDate -- Ensure both local and global cache dirs are there - globalCache <- view globalCacheL - assertDirectory globalCache + GlobalCache globalCacheDir _ <- view (the @GlobalCache) + assertDirectory globalCacheDir assertDirectory localCacheDir -- We try to fetch a dep only if their local cache directory doesn't exist @@ -58,10 +59,9 @@ fetchPackages allDeps = do let nOfDeps = List.length depsToFetch when (nOfDeps > 0) $ do logInfo $ "Installing " <> display nOfDeps <> " dependencies." - globalCacheFlag <- view cacheConfigL - metadata <- GlobalCache.getMetadata globalCacheFlag + metadata <- GlobalCache.getMetadata - limit <- view jobsL + Jobs limit <- view (the @Jobs) Async.withTaskGroup limit $ \taskGroup -> do asyncs <- for depsToFetch (Async.async taskGroup . fetchPackage metadata) handle (handler asyncs) (for_ asyncs Async.wait) @@ -91,18 +91,19 @@ fetchPackages allDeps = do -- eventually caching it to the global cache, or copying it from there if it's -- sensible to do so. -- If it's a local directory do nothing -fetchPackage +fetchPackage :: forall env . (HasLogFunc env, HasGlobalCache env) - => GlobalCache.ReposMetadataV1 -> (PackageName, Package) + => GlobalCache.ReposMetadataV1 -> (PackageName, Package) -> RIO env () fetchPackage _ (PackageName package, Package { location = Local{..}, .. }) = logInfo $ display $ Messages.foundLocalPackage package localPath fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Remote{..}, .. } ) = do logDebug $ "Fetching package " <> display packageName - globalCache <- view globalCacheL + GlobalCache globalCacheDir cacheFlag <- view (the @GlobalCache) + let useGlobalCache = cacheFlag /= Just SkipCache let packageDir = getPackageDir packageName' version - packageGlobalCacheDir = globalCache packageDir + let packageGlobalCacheDir = globalCacheDir packageDir packageLocalCacheDir <- makeAbsolute $ getLocalCacheDir pair @@ -111,13 +112,13 @@ fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Re let downloadDir = path "download" -- If a Package is in the global cache, copy it to the local cache. - if inGlobalCache + if (inGlobalCache && useGlobalCache) then do logInfo $ "Copying from global cache: " <> display quotedName cptree packageGlobalCacheDir downloadDir assertDirectory (localCacheDir Text.unpack packageName) mv downloadDir packageLocalCacheDir - else Temp.withTempDirectory globalCache (Text.unpack ("__temp-" <> "-" <> packageName <> getCacheVersionDir version)) $ \globalTemp -> do + else Temp.withTempDirectory globalCacheDir (Text.unpack ("__temp-" <> "-" <> packageName <> getCacheVersionDir version)) $ \globalTemp -> do -- Otherwise, check if the Package is on GitHub and an "immutable" ref. -- If yes, download the tar archive and copy it to global and then local cache. let cacheableCallback :: FilePath.FilePath -> RIO env () @@ -126,12 +127,15 @@ fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Re -- then atomically move it to the correct cache location. Since -- `mv` will not move folders across filesystems, this temp -- is created inside globalDir, guaranteeing the same filesystem. - logInfo $ "Installing and globally caching " <> display quotedName let resultDir2 = globalTemp "download2" assertDirectory resultDir2 cptree resultDir resultDir2 - catch (mv resultDir2 packageGlobalCacheDir) $ \(err :: SomeException) -> - logWarn $ display $ Messages.failedToCopyToGlobalCache err + if useGlobalCache + then do + logInfo $ "Installing and globally caching " <> display quotedName + catch (mv resultDir2 packageGlobalCacheDir) $ \(err :: SomeException) -> + logWarn $ display $ Messages.failedToCopyToGlobalCache err + else logInfo $ "Installing " <> display quotedName mv resultDir packageLocalCacheDir -- If not, run a series of git commands to get the code, and move it to local cache. @@ -155,7 +159,7 @@ fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Re -- The folder to store the download: assertDirectory downloadDir -- The parent package folder in the global cache (that stores all the versions): - assertDirectory (globalCache Text.unpack packageName) + assertDirectory (globalCacheDir Text.unpack packageName) -- The parent package folder in the local cache (that stores all the versions): assertDirectory (localCacheDir Text.unpack packageName) diff --git a/src/Spago/Git.hs b/src/Spago/Git.hs index 6bf61ec69..65970def4 100644 --- a/src/Spago/Git.hs +++ b/src/Spago/Git.hs @@ -4,7 +4,6 @@ module Spago.Git , getAllTags , commitAndTag , isIgnored - , unsafeIsIgnored ) where import Spago.Prelude @@ -34,13 +33,13 @@ hasCleanWorkingTree = do getAllTags :: HasGit env => RIO env [Text] getAllTags = do - git <- view gitL + GitCmd git <- view (the @GitCmd) fmap Text.lines $ Turtle.strict $ Turtle.inproc git ["tag", "--list"] empty commitAndTag :: HasGit env => Text -> Text -> RIO env () commitAndTag tag message = do - git <- view gitL + GitCmd git <- view (the @GitCmd) Turtle.procs git ["commit", "--quiet", "--allow-empty", "--message=" <> message] empty Turtle.procs git ["tag", "--annotate", "--message=" <> message, tag] empty @@ -50,14 +49,7 @@ commitAndTag tag message = do -- `git check-ignore` exits with 1 when path is not ignored, and 128 when -- a fatal error occurs (i.e. when not in a git repository). isIgnored :: HasGit env => Text -> RIO env Bool -isIgnored = unsafeIsIgnored - - --- FIXME: Remove the unsafe variant --- --- With the current constraint system, this was the easiest method --- to make .gitignore checking configurable via a CLI flag. -unsafeIsIgnored :: MonadIO m => Text -> m Bool -unsafeIsIgnored path = do - (exitCode, _, _) <- Turtle.procStrictWithErr "git" ["check-ignore", "--quiet", path] empty +isIgnored path = do + GitCmd git <- view (the @GitCmd) + (exitCode, _, _) <- Turtle.procStrictWithErr git ["check-ignore", "--quiet", path] empty pure $ exitCode == ExitSuccess diff --git a/src/Spago/GitHub.hs b/src/Spago/GitHub.hs index 04d12215a..42a0595e1 100644 --- a/src/Spago/GitHub.hs +++ b/src/Spago/GitHub.hs @@ -8,12 +8,9 @@ import qualified Control.Retry as Retry import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Encoding -import qualified GitHub import qualified Network.HTTP.Client as Http import qualified Network.HTTP.Simple as Http -import qualified System.Environment -import qualified Spago.GlobalCache as GlobalCache import qualified Spago.Messages as Messages @@ -23,58 +20,25 @@ tokenCacheFile = "github-token.txt" tagCacheFile :: Text -> Text -> Text tagCacheFile org repo = org <> "-" <> repo <> "-tag.txt" - -login :: (HasGlobalCache env, HasLogFunc env) => RIO env () -login = do - maybeToken <- liftIO (System.Environment.lookupEnv githubTokenEnvVar) - globalCacheDir <- view globalCacheL - - case maybeToken of - Nothing -> die [ display Messages.getNewGitHubToken ] - Just (Text.pack -> token) -> do - logInfo "Token read, authenticating with GitHub.." - username <- getUsername token - logInfo $ "Successfully authenticated as " <> displayShow username - writeTextFile (Text.pack $ globalCacheDir tokenCacheFile) token - where - getUsername token = do - result <- liftIO $ GitHub.executeRequest - (GitHub.OAuth $ Data.Text.Encoding.encodeUtf8 token) - GitHub.userInfoCurrentR - case result of - Left err -> die [ display $ Messages.failedToReachGitHub err ] - Right GitHub.User{..} -> pure $ GitHub.untagName userLogin - - -readToken :: (MonadReader env m, MonadIO m, Alternative m, HasLogFunc env, MonadThrow m) => m Text -readToken = readFromEnv <|> readFromFile - where - readFromEnv = liftIO (System.Environment.lookupEnv githubTokenEnvVar) >>= \case - Nothing -> empty - Just (Text.pack -> token) -> return token - - readFromFile = do - globalCache <- GlobalCache.getGlobalCacheDir - assertDirectory globalCache - readTextFile $ pathFromText $ Text.pack $ globalCache tokenCacheFile - - -getLatestPackageSetsTag +getLatestPackageSetsTag :: (HasLogFunc env, HasGlobalCache env) => Text -> Text -> RIO env (Either SomeException Text) getLatestPackageSetsTag org repo = do - globalCacheDir <- view globalCacheL + GlobalCache globalCacheDir cacheFlag <- view (the @GlobalCache) assertDirectory globalCacheDir let globalPathToCachedTag = globalCacheDir (Text.unpack $ tagCacheFile org repo) let writeTagCache = writeTextFile (Text.pack globalPathToCachedTag) let readTagCache = try $ readTextFile $ pathFromText $ Text.pack globalPathToCachedTag let downloadTagToCache env = try $ Retry.recoverAll (Retry.fullJitterBackoff 50000 <> Retry.limitRetries 5) - $ \_ -> runReaderT (getLatestRelease1 <|> getLatestRelease2) env + $ \_ -> runReaderT getLatestRelease env logDebug $ "Getting latest release for " <> display org <> "/" <> display repo - whenM (shouldRefreshFile globalPathToCachedTag) $ do + shouldRefresh <- if isNothing cacheFlag + then shouldRefreshFile globalPathToCachedTag + else pure True + when shouldRefresh $ do env <- ask liftIO (downloadTagToCache env) >>= \case Left (err :: SomeException) -> logDebug $ display $ Messages.failedToReachGitHub err @@ -83,29 +47,12 @@ getLatestPackageSetsTag org repo = do readTagCache where - getLatestRelease1 :: (HasLogFunc env, MonadReader env m, MonadIO m, Alternative m, MonadUnliftIO m, MonadThrow m) => m Text - getLatestRelease1 = do - maybeToken :: Either SomeException Text <- try readToken - f <- case hush maybeToken of - Nothing -> pure GitHub.executeRequest' - Just token -> do - logDebug "Using cached GitHub token for getting the latest release.." - pure $ GitHub.executeRequest (GitHub.OAuth $ Data.Text.Encoding.encodeUtf8 token) - result <- liftIO $ f $ GitHub.latestReleaseR (GitHub.mkName (Proxy :: Proxy GitHub.Owner) org) (GitHub.mkName (Proxy :: Proxy GitHub.Repo) repo) - - case result of - Right GitHub.Release{..} -> return releaseTagName - Left err -> do - logWarn $ display $ "rel1" <> Messages.failedToReachGitHub err - empty - -- | The idea here is that we go to the `latest` endpoint, and then get redirected -- to the latest release. So we search for the `Location` header which should contain -- the URL we get redirected to, and strip the release name from there (it's the -- last segment of the URL) - getLatestRelease2 :: (HasLogFunc env, MonadReader env m, MonadIO m, MonadThrow m, Alternative m) => m Text - getLatestRelease2 = do - logDebug "rel2" + getLatestRelease :: (HasLogFunc env, MonadReader env m, MonadIO m, MonadThrow m, Alternative m) => m Text + getLatestRelease = do request <- Http.parseRequest $ "https://github.com/" <> (Text.unpack org) <> "/" <> (Text.unpack repo) <> "/releases/latest" response <- Http.httpBS $ Http.addRequestHeader "User-Agent" "Mozilla/5.0" diff --git a/src/Spago/GlobalCache.hs b/src/Spago/GlobalCache.hs index 2fdf46f95..da3596db7 100644 --- a/src/Spago/GlobalCache.hs +++ b/src/Spago/GlobalCache.hs @@ -86,11 +86,11 @@ globallyCache (packageName, Repo url, ref) downloadDir metadata cacheableCallbac -- | Download the GitHub Index cache from the `package-sets-metadata` repo -getMetadata :: HasLogFunc env => Maybe CacheFlag -> RIO env ReposMetadataV1 -getMetadata cacheFlag = do +getMetadata :: (HasLogFunc env, HasGlobalCache env) => RIO env ReposMetadataV1 +getMetadata = do logDebug "Running `getMetadata`" - globalCacheDir <- getGlobalCacheDir + GlobalCache globalCacheDir cacheFlag <- view (the @GlobalCache) logDebug $ "Global cache directory: " <> displayShow globalCacheDir diff --git a/src/Spago/PackageSet.hs b/src/Spago/PackageSet.hs index eca10977b..9378c03b7 100644 --- a/src/Spago/PackageSet.hs +++ b/src/Spago/PackageSet.hs @@ -89,7 +89,7 @@ updatePackageSetVersion maybeTag = do useSpecificRelease org repo currentTag tag = updateTag org repo currentTag tag - updateTag :: HasLogFunc env => Text -> Text -> Text -> Text -> RIO env () + updateTag :: Text -> Text -> Text -> Text -> RIO env () updateTag org repo currentTag specificTag = do let quotedTag = surroundQuote specificTag orgRepo = org <> "/" <> repo @@ -169,7 +169,7 @@ updatePackageSetVersion maybeTag = do checkPursIsUpToDate :: forall env. (HasLogFunc env, HasPackageSet env) => RIO env () checkPursIsUpToDate = do logDebug "Checking if `purs` is up to date" - PackageSet{..} <- view packageSetL + PackageSet{..} <- view (the @PackageSet) eitherCompilerVersion <- Purs.pursVersion case (eitherCompilerVersion, packagesMinPursVersion) of (Right compilerVersion, Just pursVersionFromPackageSet) -> performCheck compilerVersion pursVersionFromPackageSet diff --git a/src/Spago/Packages.hs b/src/Spago/Packages.hs index 5bc9cd6d3..175255daf 100644 --- a/src/Spago/Packages.hs +++ b/src/Spago/Packages.hs @@ -103,11 +103,11 @@ getJsGlobs deps depsOnly configSourcePaths -- | Return the direct dependencies of the current project -getDirectDeps +getDirectDeps :: (HasLogFunc env, HasConfig env) => RIO env [(PackageName, Package)] getDirectDeps = do - Config { packageSet = PackageSet{..}, dependencies } <- view configL + Config { packageSet = PackageSet{..}, dependencies } <- view (the @Config) for dependencies $ \dep -> case Map.lookup dep packagesDB of Nothing -> @@ -115,11 +115,11 @@ getDirectDeps = do Just pkg -> pure (dep, pkg) -getProjectDeps +getProjectDeps :: (HasLogFunc env, HasConfig env) => RIO env [(PackageName, Package)] getProjectDeps = do - Config{ dependencies } <- view configL + Config{ dependencies } <- view (the @Config) getTransitiveDeps dependencies -- | Return the transitive dependencies of a list of packages @@ -128,7 +128,7 @@ getTransitiveDeps => [PackageName] -> RIO env [(PackageName, Package)] getTransitiveDeps deps = do logDebug "Getting transitive deps" - PackageSet{..} <- view packageSetL + PackageSet{..} <- view (the @PackageSet) let handleErrors packageMap notFoundErrors cycleErrors @@ -179,7 +179,7 @@ newtype FoundWithoutPrefix = FoundWithoutPrefix PackageName getReverseDeps :: HasPackageSet env => PackageName -> RIO env [(PackageName, Package)] getReverseDeps dep = do - PackageSet{ packagesDB } <- view packageSetL + PackageSet{ packagesDB } <- view (the @PackageSet) List.nub <$> foldMap go (Map.toList packagesDB) where go pair@(packageName, Package{..}) = do @@ -191,19 +191,17 @@ getReverseDeps dep = do -- | Fetch all dependencies into `.spago/` -install - :: HasInstallEnv env - => [PackageName] -> RIO env () +install :: (HasEnv env, HasConfig env) => [PackageName] -> RIO env () install newPackages = do logDebug "Running `spago install`" - config@Config{ packageSet = PackageSet{..}, ..} <- view configL + config@Config{ packageSet = PackageSet{..}, ..} <- view (the @Config) existingNewPackages <- reportMissingPackages $ classifyPackages packagesDB newPackages -- Try fetching the dependencies with the new names too let newConfig :: Config newConfig = config { Config.dependencies = dependencies <> existingNewPackages } - mapRIO (set configL newConfig) $ do + mapRIO (set (the @Config) newConfig) $ do deps <- getProjectDeps -- If the above doesn't fail, write the new packages to the config @@ -255,7 +253,7 @@ stripPurescriptPrefix (PackageName name) = sources :: (HasLogFunc env, HasConfig env) => RIO env () sources = do logDebug "Running `spago sources`" - config <- view configL + config <- view (the @Config) deps <- getProjectDeps traverse_ output $ fmap unSourcePath diff --git a/src/Spago/Prelude.hs b/src/Spago/Prelude.hs index d04cb22e7..59f0c54b2 100644 --- a/src/Spago/Prelude.hs +++ b/src/Spago/Prelude.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE IncoherentInstances #-} module Spago.Prelude ( -- * Basic exports @@ -20,11 +21,18 @@ module Spago.Prelude , die , hush , surroundQuote + , logInfo + , logWarn + , logDebug + , logError + , HasLogFunc -- * Lens , () , (^..) , transformMOf + , the + , HasType -- * Files and directories , FilePath @@ -73,6 +81,7 @@ import qualified Data.Text.Prettyprint.Doc.Render.Text as PrettyText import qualified Data.Time as Time import Dhall (Text) import qualified Dhall.Core +import qualified RIO import qualified System.FilePath as FilePath import qualified System.IO import qualified Turtle @@ -87,12 +96,14 @@ import Data.Bool as X import Data.Either as X import Data.Either.Validation (Validation (..)) import Data.Foldable as X +import Data.Generics.Product (the, HasType(..)) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe as X import Data.Sequence (Seq (..)) import Data.Text.Prettyprint.Doc (Pretty) import Dhall.Optics (transformMOf) import Lens.Family ((^..)) -import RIO as X hiding (FilePath, first, force, second, (^..)) +import RIO as X hiding (FilePath, first, force, second, HasLogFunc, logDebug, logError, logInfo, logWarn, (^..)) import RIO.Orphans as X import Safe (headMay, lastMay) import System.FilePath (isAbsolute, pathSeparator, ()) @@ -245,3 +256,24 @@ findExecutableOrDie cmd = do -- here is absolute, and Windows doesn't seem to be able to deal with that. -- See: https://github.com/purescript/spago/issues/635 Just _path -> pure $ Text.pack cmd + + +type HasLogFunc env = HasType LogFunc env + +liftLog + :: (HasLogFunc env, MonadIO m, MonadReader env m) + => (Utf8Builder -> RIO LogFunc ()) + -> Utf8Builder + -> m () +liftLog logImpl msg = do + logFunc <- view (the @LogFunc) + runRIO logFunc (logImpl msg) + +logDebug, logInfo, logWarn, logError + :: (HasLogFunc env, MonadIO m, MonadReader env m) + => Utf8Builder + -> m () +logDebug = liftLog RIO.logDebug +logInfo = liftLog RIO.logInfo +logWarn = liftLog RIO.logWarn +logError = liftLog RIO.logError \ No newline at end of file diff --git a/src/Spago/Purs.hs b/src/Spago/Purs.hs index 29a39322d..c2a9c8282 100644 --- a/src/Spago/Purs.hs +++ b/src/Spago/Purs.hs @@ -5,6 +5,7 @@ module Spago.Purs , docs , pursVersion , parseDocsFormat + , findFlag , DocsFormat(..) ) where @@ -20,12 +21,12 @@ import qualified Spago.Messages as Messages import qualified Turtle.Bytes -compile - :: (HasPurs env, HasLogFunc env) - => [SourcePath] -> [PursArg] +compile + :: (HasPurs env, HasLogFunc env) + => [SourcePath] -> [PursArg] -> RIO env () compile sourcePaths extraArgs = do - purs <- view pursL + PursCmd purs <- view (the @PursCmd) logDebug $ "Compiling with " <> displayShow purs let paths = Text.intercalate " " $ surroundQuote <$> map unSourcePath sourcePaths @@ -35,9 +36,9 @@ compile sourcePaths extraArgs = do "Build succeeded." "Failed to build." --- TODO: this should use HasPurs -repl :: Text -> [SourcePath] -> [PursArg] -> IO () -repl purs sourcePaths extraArgs = do +repl :: HasPurs env => [SourcePath] -> [PursArg] -> RIO env () +repl sourcePaths extraArgs = do + PursCmd purs <- view (the @PursCmd) let paths = Text.intercalate " " $ surroundQuote <$> map unSourcePath sourcePaths args = Text.intercalate " " $ map unPursArg extraArgs cmd = purs <> " repl " <> paths <> " " <> args @@ -122,3 +123,40 @@ runWithOutput command success failure = do shell command empty >>= \case ExitSuccess -> logInfo $ display success ExitFailure _ -> die [ display failure ] + + +-- | Try to find the content of a certain flag in a list of PursArgs +-- See tests in: test/Spago/Command/PathSpec.hs +findFlag :: Char -> Text -> [PursArg] -> Maybe Text +findFlag char string = \case + (x:xs) -> if isFlag x + then case xs of + (y:_) -> Just (unPursArg y) + _ -> Nothing + else if hasFlag x + then case Text.words (unPursArg x) of + [word] -> case Text.split (=='=') word of + [_,value] -> Just value + _ -> Nothing + (_:value:_) -> Just value + _ -> Nothing + else findFlag char string xs + _ -> Nothing + where + isFlag :: PursArg -> Bool + isFlag (PursArg word) + = word == (Text.pack ['-', char]) + || word == ("--" <> string) + hasFlag :: PursArg -> Bool + hasFlag (PursArg a) + = firstWord == (Text.pack ['-', char]) + || firstWord == ("--" <> string) + where + firstWord + = fromMaybe "" $ case Text.words a of + [] -> Nothing + [word] -> case Text.split (=='=') word of + [one] -> Just one + [key,_] -> Just key + _ -> Nothing + (word:_) -> Just word diff --git a/src/Spago/RunEnv.hs b/src/Spago/RunEnv.hs index 22a885819..6c20fec28 100644 --- a/src/Spago/RunEnv.hs +++ b/src/Spago/RunEnv.hs @@ -6,10 +6,12 @@ import Spago.Env import qualified Data.Text as Text import qualified System.Environment as Env import qualified Distribution.System as OS +import qualified RIO import qualified Turtle import qualified Spago.Config as Config import qualified Spago.GlobalCache as Cache +import qualified Spago.FetchPackage as FetchPackage import qualified Spago.Dhall as Dhall import qualified Spago.Messages as Messages import qualified Spago.PackageSet as PackageSet @@ -40,66 +42,79 @@ withEnv GlobalOptions{..} app = do let configPath = fromMaybe Config.defaultPath globalConfigPath - globalCache <- runRIO logFunc' $ do - logDebug "Running `getGlobalCacheDir`" - Cache.getGlobalCacheDir + globalCache <- do + path <- case globalCacheConfig of + Just SkipCache -> pure FetchPackage.localCacheDir + _ -> runRIO logFunc' $ do + RIO.logDebug "Running `getGlobalCacheDir`" + Cache.getGlobalCacheDir + pure $ GlobalCache path globalCacheConfig let env = Env { envLogFunc = logFunc' - , envJobs = fromMaybe 20 globalJobs - , envConfigPath = configPath + , envJobs = Jobs $ fromMaybe 20 globalJobs + , envConfigPath = ConfigPath configPath , envGlobalCache = globalCache - , envCacheConfig = globalCacheConfig } runRIO env app withPackageSetEnv - :: HasEnv env + :: (HasLogFunc env, HasConfigPath env) => RIO PackageSetEnv a -> RIO env a withPackageSetEnv app = do - packageSetSet <- getPackageSet - packageSetEnvGlobal <- view envL + envPackageSet <- getPackageSet + envLogFunc <- view (the @LogFunc) runRIO PackageSetEnv{..} app withInstallEnv' - :: HasEnv env - => Maybe Config + :: (HasEnv env) + => Maybe Config -> RIO InstallEnv a -> RIO env a withInstallEnv' maybeConfig app = do - installSpagoConfig <- case maybeConfig of + Env{..} <- getEnv + envConfig@Config{..} <- case maybeConfig of Just c -> pure c - Nothing -> Config.ensureConfig >>= \case - Right c -> pure c - Left err -> die [ "Failed to read the config. Error was:", err ] - installEnvGlobal <- view envL + Nothing -> getConfig + let envPackageSet = packageSet runRIO InstallEnv{..} app -withInstallEnv :: HasEnv env => RIO InstallEnv a -> RIO env a +withInstallEnv + :: (HasEnv env) + => RIO InstallEnv a + -> RIO env a withInstallEnv = withInstallEnv' Nothing -withVerifyEnv :: HasEnv env => UsePsa -> RIO VerifyEnv a -> RIO env a +withVerifyEnv + :: HasEnv env + => UsePsa + -> RIO VerifyEnv a + -> RIO env a withVerifyEnv usePsa app = do - verifyEnvPurs <- getPurs usePsa - verifyPackageSet <- getPackageSet - verifyEnvGlobal <- view envL + Env{..} <- getEnv + envPursCmd <- getPurs usePsa + envPackageSet <- getPackageSet runRIO VerifyEnv{..} app -withPublishEnv :: HasEnv env => RIO PublishEnv a -> RIO env a -withPublishEnv app = withInstallEnv $ do - publishEnvGit <- findExecutableOrDie "git" - publishEnvBower <- +withPublishEnv + :: HasEnv env + => RIO PublishEnv a + -> RIO env a +withPublishEnv app = do + Env{..} <- getEnv + envConfig@Config{..} <- getConfig + let envPackageSet = packageSet + envGitCmd <- getGit + envBowerCmd <- BowerCmd <$> -- workaround windows issue: https://github.com/haskell/process/issues/140 case OS.buildOS of OS.Windows -> do let bowers = Turtle.inproc "where" ["bower.cmd"] empty Turtle.lineToText <$> Turtle.single (Turtle.limit 1 bowers) - _ -> - findExecutableOrDie "bower" - publishEnvInstall <- view installEnvL + _ -> findExecutableOrDie "bower" runRIO PublishEnv{..} app withBuildEnv @@ -107,13 +122,28 @@ withBuildEnv => UsePsa -> RIO BuildEnv a -> RIO env a -withBuildEnv usePsa app = withInstallEnv $ do - buildEnvPurs <- getPurs usePsa - buildInstallEnv <- view installEnvL +withBuildEnv usePsa app = do + Env{..} <- getEnv + envPursCmd <- getPurs usePsa + envConfig@Config{..} <- getConfig + let envPackageSet = packageSet + envGitCmd <- getGit runRIO BuildEnv{..} app +getEnv :: HasEnv env => RIO env Env +getEnv = do + envLogFunc <- view (the @LogFunc) + envJobs <- view (the @Jobs) + envConfigPath <- view (the @ConfigPath) + envGlobalCache <- view (the @GlobalCache) + pure Env{..} -getPurs :: HasLogFunc env => UsePsa -> RIO env Text +getConfig :: (HasLogFunc env, HasConfigPath env) => RIO env Config +getConfig = Config.ensureConfig >>= \case + Right c -> pure c + Left err -> die [ "Failed to read the config. Error was:", err ] + +getPurs :: HasLogFunc env => UsePsa -> RIO env PursCmd getPurs usePsa = do -- first we decide if we _want_ to use psa, then if we _can_ pursCandidate <- case usePsa of @@ -122,13 +152,16 @@ getPurs usePsa = do Just _ -> pure "psa" Nothing -> pure "purs" -- We first try this for Windows - case OS.buildOS of + PursCmd <$> case OS.buildOS of OS.Windows -> do findExecutable (pursCandidate <> ".cmd") >>= \case Just _ -> pure (Text.pack pursCandidate <> ".cmd") Nothing -> findExecutableOrDie pursCandidate _ -> findExecutableOrDie pursCandidate +getGit :: HasLogFunc env => RIO env GitCmd +getGit = GitCmd <$> findExecutableOrDie "git" + getPackageSet :: (HasLogFunc env, HasConfigPath env) => RIO env PackageSet getPackageSet = do -- Try to read a "packages.dhall" directly diff --git a/src/Spago/Types.hs b/src/Spago/Types.hs index 6e90ee706..870c7ec05 100644 --- a/src/Spago/Types.hs +++ b/src/Spago/Types.hs @@ -6,6 +6,7 @@ import Spago.Prelude import qualified Data.Text as Text import qualified Data.Versions as Version import qualified Network.URI as URI +import qualified GHC.IO import qualified Spago.Dhall as Dhall import qualified Spago.Messages as Messages @@ -80,12 +81,15 @@ newtype SourcePath = SourcePath { unSourcePath :: Text } deriving newtype (Show, Dhall.FromDhall) newtype PursArg = PursArg { unPursArg :: Text } deriving newtype (Eq) +newtype BackendArg = BackendArg { unBackendArg :: Text } + deriving newtype (Eq) data WithMain = WithMain | WithoutMain data WithSrcMap = WithSrcMap | WithoutSrcMap data CacheFlag = SkipCache | NewCache + deriving (Eq) data CheckModulesUnique = DoCheckModulesUnique | NoCheckModulesUnique @@ -159,3 +163,11 @@ data PublishConfig = PublishConfig { publishLicense :: Text , publishRepository :: Text } deriving (Show, Generic) + +newtype Jobs = Jobs Int +newtype ConfigPath = ConfigPath Text +newtype PursCmd = PursCmd Text +newtype GitCmd = GitCmd Text +newtype BowerCmd = BowerCmd Text + +data GlobalCache = GlobalCache !GHC.IO.FilePath !(Maybe CacheFlag) \ No newline at end of file diff --git a/src/Spago/Watch.hs b/src/Spago/Watch.hs index a0ae25042..aba6fbd8d 100644 --- a/src/Spago/Watch.hs +++ b/src/Spago/Watch.hs @@ -26,7 +26,7 @@ import qualified UnliftIO.Async as Async import qualified Spago.Git as Git watch - :: HasLogFunc env + :: (HasLogFunc env, HasGit env) => Set.Set Glob.Pattern -> ClearScreen -> AllowIgnored -> RIO env () -> RIO env () watch globs shouldClear allowIgnored action = do @@ -52,7 +52,7 @@ debounceTime = 0.1 -- watched. When any of those files are changed, we rerun the action again. fileWatchConf :: forall env - . (HasLogFunc env) + . (HasLogFunc env, HasGit env) => Watch.WatchConfig -> ClearScreen -> AllowIgnored @@ -81,7 +81,7 @@ fileWatchConf watchConfig shouldClear allowIgnored inner = withManagerConf watch let eventPath = Watch.eventPath event isPathIgnored = case allowIgnored of - NoAllowIgnored -> Git.unsafeIsIgnored + NoAllowIgnored -> Git.isIgnored DoAllowIgnored -> const (pure False) pathIgnored <- isPathIgnored $ Text.pack eventPath diff --git a/stack.yaml b/stack.yaml index 20b0d1986..b1f4c1f3c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,10 +7,13 @@ extra-deps: - binary-instances-1.0.0.1@sha256:e234be994da675479a3661f050d4a1d53565c9ed7786d9a68b7a29ba8b54b5a7,2659 - dhall-1.36.0 - directory-1.3.6.1@sha256:3dc9c69c8e09ec95a7a45c6d06abe0f0d2f604439c37e5f88e5a6c335b088d71,2810 +- generic-lens-2.0.0.0@sha256:7409fa0ce540d0bd41acf596edd1c5d0c0ab1cd1294d514cf19c5c24e8ef2550,3866 +- generic-lens-core-2.0.0.0@sha256:40b063c4a1399b3cdb19f2df1fae5a1a82f3313015c7c3e47fc23b8ef1b3e443,2913 - github-0.26@sha256:a9d4046325c3eb28cdc7bef2c3f5bb213328caeae0b7dce6f51de655f0bffaa1,7162 - haskeline-0.8.1.0@sha256:6a6158c90b929ce7aa5331ff5e9819aa32c7df8f4a7ba324b3cc055ee96b48cb,5818 - hspec-megaparsec-2.0.1@sha256:7f26ab334eaa653054766110cf259c31314d1c2ec170270e56101e344ce65ef9,2163 - http-client-0.7.2.1 +- indexed-profunctors-0.1@sha256:ddf618d0d4c58319c1e735e746bc69a1021f13b6f475dc9614b80af03432e6d4,1016 - megaparsec-7.0.5@sha256:45e1f1348fab2783646fdb4d9e6097568981a740951c7356d36d794e2baba305,3902 - prettyprinter-1.7.0 - process-1.6.10.0@sha256:c0d2d8adaca7cea7ceaa60e67b61c775dc03727b83bdb1c97aa8cbeac9f5dd84,2469 diff --git a/test/Spago/Command/PathSpec.hs b/test/Spago/PursSpec.hs similarity index 61% rename from test/Spago/Command/PathSpec.hs rename to test/Spago/PursSpec.hs index fce120e52..851e2e9a8 100644 --- a/test/Spago/Command/PathSpec.hs +++ b/test/Spago/PursSpec.hs @@ -1,32 +1,32 @@ -module Spago.Command.PathSpec (spec) where +module Spago.PursSpec (spec) where import Prelude import Test.Hspec import Spago.Prelude hiding (link) import Spago.Env -import qualified Spago.Command.Path as Path +import qualified Spago.Purs as Purs spec :: Spec spec = do - describe "Path findFlag" $ do + describe "findFlag" $ do it "[\"-o\", \"something\"]" $ do - let a = fromMaybe "" $ Path.findFlag 'o' "output" [PursArg "-o" , PursArg "something"] + let a = fromMaybe "" $ Purs.findFlag 'o' "output" [PursArg "-o" , PursArg "something"] let b = "something" a `shouldBe` b it "[\"--output\", \"something\"]" $ do - let a = fromMaybe "" $ Path.findFlag 'o' "output" [PursArg "--output" , PursArg "something"] + let a = fromMaybe "" $ Purs.findFlag 'o' "output" [PursArg "--output" , PursArg "something"] let b = "something" a `shouldBe` b it "[\"-o something\"]" $ do - let a = fromMaybe "" $ Path.findFlag 'o' "output" [PursArg "-o something"] + let a = fromMaybe "" $ Purs.findFlag 'o' "output" [PursArg "-o something"] let b = "something" a `shouldBe` b it "[\"--output something\"]" $ do - let a = fromMaybe "" $ Path.findFlag 'o' "output" [PursArg "--output something"] + let a = fromMaybe "" $ Purs.findFlag 'o' "output" [PursArg "--output something"] let b = "something" a `shouldBe` b it "[\"--output=something\"]" $ do - let a = fromMaybe "" $ Path.findFlag 'o' "output" [PursArg "--output=something"] + let a = fromMaybe "" $ Purs.findFlag 'o' "output" [PursArg "--output=something"] let b = "something" a `shouldBe` b diff --git a/test/UnitSpec.hs b/test/UnitSpec.hs index 47d6d232b..2d3ea0397 100644 --- a/test/UnitSpec.hs +++ b/test/UnitSpec.hs @@ -52,7 +52,7 @@ checkInjective f gen = check inputs = let collisions = findCollisions inputs - maxCounterexamples = 10 + maxCounterexamples :: Int = 10 in if null collisions then