Merge remote-tracking branch 'origin/main' into retain-comments

.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

.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

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`.
 

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 =

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

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,

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",

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

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]

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
 

terminal/src/Package/Bump.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Bump
+module Package.Bump
   ( run,
   )
 where

terminal/src/Package/Diff.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wall #-}
 
-module Diff
+module Package.Diff
   ( Args (..),
     run,
   )

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

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

terminal/src/Package/Validate.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Validate
+module Package.Validate
   ( run,
   )
 where