diff --git a/.github/workflows/releases.yml b/.github/workflows/releases.yml index d9de94c2..74355d81 100644 --- a/.github/workflows/releases.yml +++ b/.github/workflows/releases.yml @@ -31,7 +31,7 @@ jobs: - uses: haskell/actions/setup@v1 id: setup-haskell with: - ghc-version: '9.2.4' + ghc-version: '9.4.2' cabal-version: '3.8.1.0' - name: Cache diff --git a/.github/workflows/verify.yml b/.github/workflows/verify.yml index 0811df4f..d5c3e585 100644 --- a/.github/workflows/verify.yml +++ b/.github/workflows/verify.yml @@ -20,7 +20,7 @@ jobs: - uses: haskell/actions/setup@v1 id: setup-haskell with: - ghc-version: '9.2.4' + ghc-version: '9.4.2' cabal-version: '3.8.1.0' - name: Cache diff --git a/README.md b/README.md index 2a3c25a9..13b4fb93 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ There are easier ways to install the compiler than compiling the source, you mig ## Build from source -Then Gren compiler is written in Haskell, so to build from source you need to have GHC 9.2 (Haskell compiler) and Cabal 3.8 (haskell build tool) installed on your system. +Then Gren compiler is written in Haskell, so to build from source you need to have GHC 9.4 (Haskell compiler) and Cabal 3.8 (haskell build tool) installed on your system. You can install these using [ghcup](https://www.haskell.org/ghcup/). By default, ghcup will install an older version of Haskell and Cabal, so you can install and set the required versions using `ghcup tui`. diff --git a/builder/src/Gren/Outline.hs b/builder/src/Gren/Outline.hs index c68f1e8e..e759bc89 100644 --- a/builder/src/Gren/Outline.hs +++ b/builder/src/Gren/Outline.hs @@ -16,7 +16,6 @@ module Gren.Outline flattenExposed, toAbsoluteSrcDir, sourceDirs, - testDirs, platform, dependencyConstraints, ) @@ -257,10 +256,6 @@ sourceDirs outline = Pkg _ -> NE.singleton (RelativeSrcDir "src") -testDirs :: Outline -> NE.List SrcDir -testDirs _ = - NE.singleton (RelativeSrcDir "tests") - -- JSON DECODE type Decoder a = diff --git a/builder/src/Reporting/Exit.hs b/builder/src/Reporting/Exit.hs index 85dc3ca5..296e6fc4 100644 --- a/builder/src/Reporting/Exit.hs +++ b/builder/src/Reporting/Exit.hs @@ -15,6 +15,8 @@ module Reporting.Exit validateToReport, Install (..), installToReport, + Uninstall (..), + uninstallToReport, Format (..), formatToReport, newPackageOverview, @@ -918,6 +920,40 @@ installToReport exit = InstallBadDetails details -> toDetailsReport details +-- UNINSTALL + +data Uninstall + = UninstallNoOutline + | UninstallBadOutline Outline + | UninstallHadSolverTrouble Solver + | UninstallNoSolverSolution + | UninstallBadDetails Details + +uninstallToReport :: Uninstall -> Help.Report +uninstallToReport exit = + case exit of + UninstallNoOutline -> + Help.report + "COULD NOT FIND PROJECT" + Nothing + "I could not locate the gren.json file of your project." + [] + UninstallBadOutline outline -> + toOutlineReport outline + UninstallHadSolverTrouble solver -> + toSolverReport solver + UninstallNoSolverSolution -> + Help.report + "COULD NOT RESOLVE DEPENDENCIES" + (Just "gren.json") + ( "After removing the package I was unable to resolve your project's dependencies.\ + \ I'm not sure how this can happen. It might be a good idea to reach out to the Gren\ + \ core team." + ) + [] + UninstallBadDetails details -> + toDetailsReport details + -- SOLVER data Solver diff --git a/gren.cabal b/gren.cabal index 30555217..73fe7a03 100644 --- a/gren.cabal +++ b/gren.cabal @@ -51,16 +51,17 @@ Common gren-common terminal/src other-modules: - Bump - Diff Format Init - Install Make Docs - Validate Repl Package + Package.Install + Package.Uninstall + Package.Bump + Package.Diff + Package.Validate -- terminal args Terminal @@ -201,7 +202,7 @@ Common gren-common Build-depends: ansi-terminal >= 0.11 && < 0.12, ansi-wl-pprint >= 0.6.8 && < 0.7, - base >=4.16 && <5, + base >= 4.17 && <5, binary >= 0.8 && < 0.9, bytestring >= 0.11 && < 0.12, containers >= 0.6 && < 0.7, diff --git a/terminal/impl/Terminal/Error.hs b/terminal/impl/Terminal/Error.hs index c33981db..59a37465 100644 --- a/terminal/impl/Terminal/Error.hs +++ b/terminal/impl/Terminal/Error.hs @@ -278,16 +278,7 @@ argErrorToDocs argError = examples <- makeExamples return [ P.fillSep - [ "The", - "arguments", - "you", - "have", - "are", - "fine,", - "but", - "in", - "addition,", - "I", + [ "I", "was", "expecting", "a", diff --git a/terminal/impl/Terminal/Helpers.hs b/terminal/impl/Terminal/Helpers.hs index 61ea8bdb..e6ec6afe 100644 --- a/terminal/impl/Terminal/Helpers.hs +++ b/terminal/impl/Terminal/Helpers.hs @@ -93,8 +93,8 @@ package = { _singular = "package", _plural = "packages", _parser = parsePackage, - _suggest = (\_ -> return []), - _examples = \_ -> return [] + _suggest = (\_ -> return ["gren-lang/browser"]), + _examples = \_ -> return ["gren-lang/browser"] } parsePackage :: String -> Maybe Pkg.Name diff --git a/terminal/src/Format.hs b/terminal/src/Format.hs index 4cc0c9c9..af9d8ae1 100644 --- a/terminal/src/Format.hs +++ b/terminal/src/Format.hs @@ -86,7 +86,7 @@ sourceDirsFromGrenJson = Task.io $ filterM Dir.doesDirectoryExist =<< ( traverse (fmap AbsoluteSrcDir.toFilePath <$> Outline.toAbsoluteSrcDir root) $ - (NE.toList (Outline.sourceDirs outline) ++ NE.toList (Outline.testDirs outline)) + (NE.toList (Outline.sourceDirs outline)) ) resolveFiles :: [FilePath] -> Task.Task Exit.Format [FilePath] diff --git a/terminal/src/Package.hs b/terminal/src/Package.hs index 5262c85c..9494faf3 100644 --- a/terminal/src/Package.hs +++ b/terminal/src/Package.hs @@ -5,14 +5,15 @@ module Package ) where -import Bump qualified import Data.List qualified as List -import Diff qualified -import Install qualified +import Package.Bump qualified as Bump +import Package.Diff qualified as Diff +import Package.Install qualified as Install +import Package.Uninstall qualified as Uninstall +import Package.Validate qualified as Validate import Terminal import Terminal.Helpers import Text.PrettyPrint.ANSI.Leijen qualified as P -import Validate qualified -- RUN @@ -22,6 +23,7 @@ run = intro P.empty [ install, + uninstall, bump, diff, validate @@ -66,7 +68,43 @@ install = [ require0 Install.NoArgs, require1 Install.Install package ] - in Terminal.Command "install" (Common summary) details example installArgs noFlags Install.run + + installFlags = + flags Install.Flags + |-- onOff "yes" "Assume yes for all interactive prompts." + in Terminal.Command "install" (Common summary) details example installArgs installFlags Install.run + +-- UNINSTALL + +uninstall :: Terminal.Command +uninstall = + let details = + "The `uninstall` command removes packages from your project:" + + example = + stack + [ reflow + "For example, if you want to get rid of the browser package in your project,\ + \ you would say:", + P.indent 4 $ + P.green $ + P.vcat $ + [ "gren package uninstall gren-lang/browser" + ], + reflow + "Notice that you must say the AUTHOR name and PROJECT name!", + reflow + "What if another package depends on what you're trying to remove? No problem!\ + \ I'll let you know if that's the case, and help you resolve that situation." + ] + + uninstallArgs = + require1 Uninstall.Uninstall package + + uninstallFlags = + flags Uninstall.Flags + |-- onOff "yes" "Assume yes for all interactive prompts." + in Terminal.Command "uninstall" Uncommon details example uninstallArgs uninstallFlags Uninstall.run -- VALIDATE diff --git a/terminal/src/Bump.hs b/terminal/src/Package/Bump.hs similarity index 99% rename from terminal/src/Bump.hs rename to terminal/src/Package/Bump.hs index 6d9efacd..71b6a5fa 100644 --- a/terminal/src/Bump.hs +++ b/terminal/src/Package/Bump.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Bump +module Package.Bump ( run, ) where diff --git a/terminal/src/Diff.hs b/terminal/src/Package/Diff.hs similarity index 99% rename from terminal/src/Diff.hs rename to terminal/src/Package/Diff.hs index 96692061..6ef44ca6 100644 --- a/terminal/src/Diff.hs +++ b/terminal/src/Package/Diff.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} -module Diff +module Package.Diff ( Args (..), run, ) diff --git a/terminal/src/Install.hs b/terminal/src/Package/Install.hs similarity index 87% rename from terminal/src/Install.hs rename to terminal/src/Package/Install.hs index cb73fa9f..c81a6d2a 100644 --- a/terminal/src/Install.hs +++ b/terminal/src/Package/Install.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module Install +module Package.Install ( Args (..), + Flags (..), run, ) where @@ -30,8 +31,11 @@ data Args = NoArgs | Install Pkg.Name -run :: Args -> () -> IO () -run args () = +data Flags = Flags + {_skipPrompts :: Bool} + +run :: Args -> Flags -> IO () +run args (Flags _skipPrompts) = Reporting.attempt Exit.installToReport $ do maybeRoot <- Dirs.findRoot @@ -51,29 +55,28 @@ run args () = Outline.App outline -> do changes <- makeAppPlan env pkg outline - attemptChanges root env oldOutline V.toChars changes + attemptChanges root env _skipPrompts oldOutline V.toChars changes Outline.Pkg outline -> do changes <- makePkgPlan env pkg outline - attemptChanges root env oldOutline C.toChars changes + attemptChanges root env _skipPrompts oldOutline C.toChars changes -- ATTEMPT CHANGES data Changes vsn = AlreadyInstalled - | PromoteTest Outline.Outline | PromoteIndirect Outline.Outline | Changes (Map.Map Pkg.Name (Change vsn)) Outline.Outline type Task = Task.Task Exit.Install -attemptChanges :: FilePath -> Solver.Env -> Outline.Outline -> (a -> String) -> Changes a -> Task () -attemptChanges root env oldOutline toChars changes = +attemptChanges :: FilePath -> Solver.Env -> Bool -> Outline.Outline -> (a -> String) -> Changes a -> Task () +attemptChanges root env skipPrompt oldOutline toChars changes = case changes of AlreadyInstalled -> Task.io $ putStrLn "It is already installed!" PromoteIndirect newOutline -> - attemptChangesHelp root env oldOutline newOutline $ + attemptChangesHelp root env skipPrompt oldOutline newOutline $ D.vcat [ D.fillSep [ "I", @@ -104,41 +107,10 @@ attemptChanges root env oldOutline toChars changes = "[Y/n]: " ] ] - PromoteTest newOutline -> - attemptChangesHelp root env oldOutline newOutline $ - D.vcat - [ D.fillSep - [ "I", - "found", - "it", - "in", - "your", - "gren.json", - "file,", - "but", - "in", - "the", - D.dullyellow "\"test-dependencies\"", - "field." - ], - D.fillSep - [ "Should", - "I", - "move", - "it", - "into", - D.green "\"dependencies\"", - "for", - "more", - "general", - "use?", - "[Y/n]: " - ] - ] Changes changeDict newOutline -> let widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict - in attemptChangesHelp root env oldOutline newOutline $ + in attemptChangesHelp root env skipPrompt oldOutline newOutline $ D.vcat $ [ "Here is my plan:", viewChangeDocs changeDocs, @@ -146,12 +118,15 @@ attemptChanges root env oldOutline toChars changes = "Would you like me to update your gren.json accordingly? [Y/n]: " ] -attemptChangesHelp :: FilePath -> Solver.Env -> Outline.Outline -> Outline.Outline -> D.Doc -> Task () -attemptChangesHelp root env oldOutline newOutline question = +attemptChangesHelp :: FilePath -> Solver.Env -> Bool -> Outline.Outline -> Outline.Outline -> D.Doc -> Task () +attemptChangesHelp root env skipPrompt oldOutline newOutline question = Task.eio Exit.InstallBadDetails $ BW.withScope $ \scope -> do - approved <- Reporting.ask question + approved <- + if skipPrompt + then return True + else Reporting.ask question if approved then do Outline.write root newOutline diff --git a/terminal/src/Package/Uninstall.hs b/terminal/src/Package/Uninstall.hs new file mode 100644 index 00000000..e21c4a1c --- /dev/null +++ b/terminal/src/Package/Uninstall.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Package.Uninstall + ( Args (..), + Flags (..), + run, + ) +where + +import BackgroundWriter qualified as BW +import Data.Map qualified as Map +import Deps.Solver qualified as Solver +import Directories qualified as Dirs +import Gren.Constraint qualified as C +import Gren.Details qualified as Details +import Gren.Outline qualified as Outline +import Gren.Package qualified as Pkg +import Gren.Version qualified as V +import Reporting qualified +import Reporting.Doc ((<+>)) +import Reporting.Doc qualified as D +import Reporting.Exit qualified as Exit +import Reporting.Exit.Help qualified as Help +import Reporting.Task qualified as Task + +-- RUN + +data Args + = Uninstall Pkg.Name + +data Flags = Flags + {_skipPrompts :: Bool} + +run :: Args -> Flags -> IO () +run args (Flags _skipPrompts) = + Reporting.attempt Exit.uninstallToReport $ + do + maybeRoot <- Dirs.findRoot + case maybeRoot of + Nothing -> + return (Left Exit.UninstallNoOutline) + Just root -> + Task.run $ + do + env <- Task.io Solver.initEnv + oldOutline <- Task.eio Exit.UninstallBadOutline $ Outline.read root + case args of + Uninstall pkg -> + case oldOutline of + Outline.App outline -> + do + changes <- makeAppPlan env pkg outline + attemptChanges root env _skipPrompts oldOutline V.toChars changes + Outline.Pkg outline -> + do + changes <- makePkgPlan env pkg outline + attemptChanges root env _skipPrompts oldOutline C.toChars changes + +-- ATTEMPT CHANGES + +data Changes vsn + = NoSuchPackage + | MakeIndirect [Pkg.Name] Outline.Outline + | PackageIsRequired [Pkg.Name] + | Changes (Map.Map Pkg.Name vsn) Outline.Outline + +type Task = Task.Task Exit.Uninstall + +attemptChanges :: FilePath -> Solver.Env -> Bool -> Outline.Outline -> (a -> String) -> Changes a -> Task () +attemptChanges root env skipPrompt oldOutline toChars changes = + case changes of + NoSuchPackage -> + Task.io $ putStrLn "This package doesn't exist in your project." + MakeIndirect requiredBy newOutline -> + attemptChangesHelp root env skipPrompt oldOutline newOutline $ + D.vcat + [ D.reflow + "I cannot remove this package from your gren.json file because the following\ + \ packages depend on it:", + D.empty, + D.indent 4 $ + D.vcat $ + map (D.green . D.fromChars . Pkg.toChars) requiredBy, + D.empty, + D.fillSep + [ "Should", + "I", + "move", + "it", + "into", + D.green "\"indirect\"", + "dependencies", + "instead?", + "[Y/n]: " + ] + ] + PackageIsRequired requiredBy -> + Task.io $ + Help.toStdout $ + D.vcat + [ D.reflow + "I cannot remove this package from your gren.json file because the following\ + \ packages depend on it:", + D.empty, + D.indent 4 $ + D.vcat $ + map (D.green . D.fromChars . Pkg.toChars) requiredBy, + D.empty, + D.empty + ] + Changes changeDict newOutline -> + let widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict + changeDocs = Map.foldrWithKey (addChange toChars widths) ([]) changeDict + in attemptChangesHelp root env skipPrompt oldOutline newOutline $ + D.vcat $ + [ "Here is my plan:", + viewChangeDocs changeDocs, + "", + "Would you like me to update your gren.json accordingly? [Y/n]: " + ] + +attemptChangesHelp :: FilePath -> Solver.Env -> Bool -> Outline.Outline -> Outline.Outline -> D.Doc -> Task () +attemptChangesHelp root env skipPrompt oldOutline newOutline question = + Task.eio Exit.UninstallBadDetails $ + BW.withScope $ \scope -> + do + approved <- + if skipPrompt + then return True + else Reporting.ask question + if approved + then do + Outline.write root newOutline + result <- Details.verifyInstall scope root env newOutline + case result of + Left exit -> + do + Outline.write root oldOutline + return (Left exit) + Right () -> + do + putStrLn "Success!" + return (Right ()) + else do + putStrLn "Okay, I did not change anything!" + return (Right ()) + +-- MAKE APP PLAN + +makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version) +makeAppPlan (Solver.Env cache) pkg outline@(Outline.AppOutline _ rootPlatform _ direct indirect) = + case Map.lookup pkg direct of + Just vsn -> do + let constraints = toConstraints direct indirect + let withMissingPkg = Map.delete pkg constraints + result <- Task.io $ Solver.verify cache rootPlatform withMissingPkg + case result of + Solver.Ok solution -> + let old = Map.union direct indirect + new = Map.map (\(Solver.Details v _) -> v) solution + in if Map.member pkg new + then + return $ + MakeIndirect (packagesDependingOn pkg solution) $ + Outline.App $ + outline + { Outline._app_deps_direct = Map.delete pkg direct, + Outline._app_deps_indirect = Map.insert pkg vsn indirect + } + else + return $ + Changes (Map.difference old new) $ + Outline.App $ + outline + { Outline._app_deps_direct = Map.intersection direct new, + Outline._app_deps_indirect = Map.intersection indirect new + } + Solver.NoSolution -> + Task.throw $ Exit.UninstallNoSolverSolution + Solver.Err exit -> + Task.throw $ Exit.UninstallHadSolverTrouble exit + Nothing -> + case Map.lookup pkg indirect of + Just _ -> do + let constraints = toConstraints direct indirect + let withMissingPkg = Map.delete pkg constraints + result <- Task.io $ Solver.verify cache rootPlatform withMissingPkg + case result of + Solver.Ok solution -> + let old = Map.union direct indirect + new = Map.map (\(Solver.Details v _) -> v) solution + in if Map.member pkg new + then return $ PackageIsRequired (packagesDependingOn pkg solution) + else + return $ + Changes (Map.difference old new) $ + Outline.App $ + outline + { Outline._app_deps_direct = Map.intersection direct new, + Outline._app_deps_indirect = Map.intersection indirect new + } + Solver.NoSolution -> + Task.throw $ Exit.UninstallNoSolverSolution + Solver.Err exit -> + Task.throw $ Exit.UninstallHadSolverTrouble exit + Nothing -> + return NoSuchPackage + +toConstraints :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint +toConstraints direct indirect = + Map.map C.exactly $ Map.union direct indirect + +packagesDependingOn :: Pkg.Name -> Map.Map Pkg.Name Solver.Details -> [Pkg.Name] +packagesDependingOn targetPkg solution = + Map.foldrWithKey + ( \pkg (Solver.Details _ deps) acc -> + if Map.member targetPkg deps + then pkg : acc + else acc + ) + [] + solution + +-- MAKE PACKAGE PLAN + +makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint) +makePkgPlan (Solver.Env cache) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps _ rootPlatform) = + if not $ Map.member pkg deps + then return NoSuchPackage + else do + let withMissingPkg = Map.delete pkg deps + result <- Task.io $ Solver.verify cache rootPlatform withMissingPkg + case result of + Solver.Ok _ -> + let changes = Map.difference deps withMissingPkg + in return $ + Changes changes $ + Outline.Pkg $ + outline + { Outline._pkg_deps = withMissingPkg + } + Solver.NoSolution -> + Task.throw $ Exit.UninstallNoSolverSolution + Solver.Err exit -> + Task.throw $ Exit.UninstallHadSolverTrouble exit + +-- VIEW CHANGE DOCS + +type ChangeDocs = [D.Doc] + +viewChangeDocs :: ChangeDocs -> D.Doc +viewChangeDocs removes = + D.indent 2 $ + D.vcat $ + viewNonZero "Remove:" removes + +viewNonZero :: String -> [D.Doc] -> [D.Doc] +viewNonZero title entries = + if null entries + then [] + else + [ "", + D.fromChars title, + D.indent 2 (D.vcat entries) + ] + +-- VIEW CHANGE + +addChange :: (a -> String) -> Widths -> Pkg.Name -> a -> ChangeDocs -> ChangeDocs +addChange toChars widths name change removes = + viewRemove toChars widths name change : removes + +viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc +viewRemove toChars (Widths nameWidth leftWidth _) name old = + viewName nameWidth name <+> pad leftWidth (toChars old) + +viewName :: Int -> Pkg.Name -> D.Doc +viewName width name = + D.fill (width + 3) (D.fromPackage name) + +pad :: Int -> String -> D.Doc +pad width string = + D.fromChars (replicate (width - length string) ' ') <> D.fromChars string + +-- WIDTHS + +data Widths = Widths + { _name :: !Int, + _left :: !Int, + _right :: !Int + } + +widen :: (a -> String) -> Pkg.Name -> a -> Widths -> Widths +widen toChars pkg change (Widths name left right) = + let toLength a = + length (toChars a) + + newName = + max name (length (Pkg.toChars pkg)) + in Widths newName (max left (toLength change)) right diff --git a/terminal/src/Validate.hs b/terminal/src/Package/Validate.hs similarity index 99% rename from terminal/src/Validate.hs rename to terminal/src/Package/Validate.hs index d8eb0c5e..3280f7ef 100644 --- a/terminal/src/Validate.hs +++ b/terminal/src/Package/Validate.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Validate +module Package.Validate ( run, ) where