Merge remote-tracking branch 'origin/pr/115' into develop

haskell · Sep 4, 2023 · 392c387 · 392c387
2 parents b2d276c + 0702ea6
commit 392c387
Show file tree

Hide file tree

Showing 3 changed files with 59 additions and 2 deletions.
diff --git a/cabal.project b/cabal.project
@@ -7,7 +7,7 @@ package ghcup
 source-repository-package
   type: git
   location: https://github.com/haskell/ghcup-hs.git
-  tag: a2a605ad892675d317e8415522e2cf12d5e35571
+  tag: fd6ff9f8ece147bb4527843822462c72824e8ba7
 
 constraints: http-io-streams -brotli,
              any.aeson >= 2.0.1.0

diff --git a/ghcup-gen/Generate.hs b/ghcup-gen/Generate.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns     #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Generate where
 
@@ -48,6 +49,12 @@ import qualified Data.Text                     as T
 import qualified Data.Yaml.Pretty              as YAML
 import qualified Text.Megaparsec               as MP
 
+import           Data.Bifoldable                (bifoldMap)
+import           Data.Foldable                  (traverse_)
+import           Data.Text                      (Text)
+
+import           Text.PrettyPrint.HughesPJClass (pPrint)
+
 data Format = FormatJSON
             | FormatYAML
 
@@ -228,3 +235,53 @@ generateSystemInfo output = do
   prettyPlat (Linux UnknownLinux) = "Linux (generic)"
   prettyPlat p = show p
 
+
+generateSystemInfoWithDistroVersion :: ( MonadFail m
+                      , MonadMask m
+                      , Monad m
+                      , MonadReader env m
+                      , HasSettings env
+                      , HasDirs env
+                      , HasLog env
+                      , MonadThrow m
+                      , MonadIO m
+                      , HasPlatformReq env
+                      , HasGHCupInfo env
+                      , MonadUnliftIO m
+                      )
+                   => Output
+                   -> m ExitCode
+generateSystemInfoWithDistroVersion output = do
+  handle <- case output of
+              StdOut -> pure stdout
+              FileOutput fp -> liftIO $ openFile fp WriteMode
+
+  GHCupInfo { _toolRequirements = tr } <- getGHCupInfo
+  let ghcInfo = M.lookup Nothing <$> M.lookup GHC tr
+  liftIO $ traverse_ (\(key, value)  -> do
+                        liftIO $ hPutStrLn handle $ "### " <> prettyPlat key <> "\n"
+                        liftIO $ hPutStrLn handle $ T.unpack $ versionsAndRequirements value <> T.pack "\n")
+                      $ M.toList $ fromJust (fromJust ghcInfo)
+  pure ExitSuccess
+
+  where
+    pretty' Requirements {..} =
+      let d = if not . null $ _distroPKGs
+            then "The following distro packages are required: " <> "`" <> T.intercalate " " _distroPKGs <> "`" <> "\n"
+            else ""
+          n = if not . T.null $ _notes then _notes else ""
+      in  if | T.null d -> n
+             | T.null n -> d
+             | otherwise -> d <> "\n" <> n
+
+    versionsAndRequirements :: PlatformReqVersionSpec -> Text
+    versionsAndRequirements =
+      bifoldMap
+        ( \case
+            Nothing -> T.pack $ "#### Generic" <> "\n"
+            Just verz -> T.pack "#### Version " <> T.pack (show $ pPrint verz) <> "\n"
+        )
+        pretty'
+
+    prettyPlat (Linux UnknownLinux) = "Linux (generic)"
+    prettyPlat p = show p
diff --git a/ghcup-gen/Main.hs b/ghcup-gen/Main.hs
@@ -209,7 +209,7 @@ main = do
           ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
           GenerateHlsGhc vopts format output -> withValidateYamlOpts vopts (generateHLSGhc format output)
           GenerateToolTable vopts output -> withValidateYamlOpts vopts (generateTable output)
-          GenerateSystemDepsInfo vopts output -> withValidateYamlOpts vopts (generateSystemInfo output)
+          GenerateSystemDepsInfo vopts output -> withValidateYamlOpts vopts (generateSystemInfoWithDistroVersion output)
   pure ()
 
  where