Clarify stack postinstall message wrt #153

Fixes #163

HACKING.md

@@ -69,3 +69,7 @@ yaml files: `ghcup-<yaml-ver>.yaml`.
    Most of the `Version` parameters to functions had to be replaced with
    that and ensured the logic is consistent for cross and non-cross
    installs.
+2. This refactor added windows support wrt [#130](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130).
+   The major changes here were switching `hpath` library out for `filepath`/`directory` (sadly) and
+   introducing a non-unix way of handling processes via the `process` library. It also introduced considerable
+   amounts of CPP wrt file handling, installation etc.

bootstrap-haskell

@@ -416,7 +416,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
 
 		case $hls_answer in
 			[Yy]*)
-				eghcup --cache install hls || warn "HLS installation failed, continuing anyway"
+				_eghcup --cache install hls || warn "HLS installation failed, continuing anyway"
 				break ;;
 			[Nn]* | "")
 				break ;;
@@ -443,7 +443,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
 
 		case $stack_answer in
 			[Yy]*)
-				eghcup --cache install stack || warn "Stack installation failed, continuing anyway"
+				_eghcup --cache install stack || warn "Stack installation failed, continuing anyway"
 				break ;;
 			[Nn]* | "")
 				break ;;

bootstrap-haskell.ps1

@@ -150,6 +150,15 @@ function Exec
 
 $ErrorActionPreference = 'Stop'
 
+$elevated = ([Security.Principal.WindowsPrincipal] `
+ [Security.Principal.WindowsIdentity]::GetCurrent()
+).IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)
+
+if ($elevated) {
+  Print-Msg -color Yellow -msg ('This script should not be run as administrator/elevated. Waiting 10s before continuing anyway...')
+  Start-Sleep -s 10
+}
+
 $GhcupBasePrefixEnv = [System.Environment]::GetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', 'user')
 
 if ($GhcupBasePrefixEnv) {

ghcup-0.0.5.yaml

@@ -2060,8 +2060,8 @@ ghcupDownloads:
         A_ARM64:
           Linux_UnknownLinux:
             unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-linux-ghcup-0.1.15.2
+              dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-linux-ghcup-0.1.15.2-r2
-              dlHash: d91b7a5416f292f2cf813824eb419f76ad9976d258cee3581123cb6eb01db9a7
+              dlHash: d67702f7c9e3586e85ed7c1bd09b7544da55bd1d3b4a961a07018348f78cf76b
           Darwin:
             unknown_versioning:
               dlUri: https://downloads.haskell.org/~ghcup/0.1.15.2/aarch64-apple-darwin-ghcup-0.1.15.2
@@ -2120,8 +2120,17 @@ ghcupDownloads:
         - old
       viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v251
       viPostInstall: &stack-post |
-        Stack manages GHC versions internally by default. In order to make it use ghcup installed GHC versions have a look at the options 'system-ghc', 'compiler-check' and 'compiler': https://docs.haskellstack.org/en/stable/yaml_configuration/#system-ghc
+        Stack manages GHC versions internally by default. In order to make it use ghcup installed
-        Additionally, you should upgrade stack only through ghcup.
+        GHC versions you can run the following commands:
+          stack config set install-ghc false --global
+          stack config set system-ghc  true  --global
+        
+        On windows, you may find the following config options useful too:
+          skip-msys, extra-path, extra-include-dirs, extra-lib-dirs
+
+        Also check out: https://docs.haskellstack.org/en/stable/yaml_configuration
+
+        !!! Additionally, you should upgrade stack only through ghcup and not use 'stack upgrade' !!!
       viArch:
         A_64:
           Linux_UnknownLinux:

lib/GHCup/Utils.hs

@@ -765,22 +765,49 @@ ghcToolFiles ver = do
   whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
         (throwE (NotInstalled GHC ver))
 
-  files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
+  files    <- liftIO $ listDirectory bindir
-  pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
+  -- figure out the <ver> suffix, because this might not be `Version` for
+  -- alpha/rc releases, but x.y.a.somedate.
 
+  ghcIsHadrian    <- liftIO $ isHadrian bindir
+  onlyUnversioned <- case ghcIsHadrian of
+    Right () -> pure id
+    Left (fmap (dropSuffix exeExt) -> [ghc, ghc_ver])
+      | (Just symver) <- stripPrefix (ghc <> "-") ghc_ver
+      , not (null symver) -> pure $ filter (\x -> not $ symver `isInfixOf` x)
+    _ -> fail "Fatal: Could not find internal GHC version"
+
+  pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
  where
-
-  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
-  groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
-
-  getUniqueTools :: [[(FilePath, String)]] -> [String]
-  getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
-
-  blackListedTools :: [String]
-  blackListedTools = ["haddock-ghc"]
-
-  isNotAnyInfix :: [String] -> String -> Bool
   isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
+    -- GHC is moving some builds to Hadrian for bindists,
+    -- which doesn't create versioned binaries.
+    -- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
+  isHadrian :: FilePath -- ^ ghcbin path
+            -> IO (Either [String] ()) -- ^ Right for Hadrian
+  isHadrian dir = do
+    -- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
+    -- which also requires us to discover the internal version
+    -- to filter the correct tool files.
+    -- We can't use the symlink on windows, so we fall back to some
+    -- more complicated logic.
+    fs <- fmap
+         -- regex over-matches
+         (filter (isNotAnyInfix ["haddock", "ghc-pkg", "ghci"]))
+       $ liftIO $ findFiles
+      dir
+      (makeRegexOpts compExtended
+                     execBlank
+                     -- for cross, this won't be "ghc", but e.g.
+                     -- "armv7-unknown-linux-gnueabihf-ghc"
+                     ([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$|] :: ByteString)
+      )
+    if | length fs == 1 -> pure $ Right ()        -- hadrian
+       | length fs == 2 -> pure $ Left
+                              (sortOn length fs)  -- legacy make, result should
+                                                  -- be ["ghc", "ghc-8.10.4"]
+       | otherwise      -> fail "isHadrian failed!"
+
 
 
 -- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that

lib/GHCup/Utils/Logger.hs

@@ -20,6 +20,7 @@ import           GHCup.Utils.String.QQ
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
+import           Data.Char               ( ord )
 import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
 import           System.FilePath
@@ -43,20 +44,33 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
   mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
   mylogger _ _ level str' = do
     -- color output
+    let style' = case level of
+          LevelDebug   -> style Bold . color Blue
+          LevelInfo    -> style Bold . color Green
+          LevelWarn    -> style Bold . color Yellow
+          LevelError   -> style Bold . color Red
+          LevelOther _ -> id
     let l = case level of
-          LevelDebug   -> toLogStr (style Bold $ color Blue "[ Debug ]")
+          LevelDebug   -> toLogStr (style' "[ Debug ]")
-          LevelInfo    -> toLogStr (style Bold $ color Green "[ Info  ]")
+          LevelInfo    -> toLogStr (style' "[ Info  ]")
-          LevelWarn    -> toLogStr (style Bold $ color Yellow "[ Warn  ]")
+          LevelWarn    -> toLogStr (style' "[ Warn  ]")
-          LevelError   -> toLogStr (style Bold $ color Red "[ Error ]")
+          LevelError   -> toLogStr (style' "[ Error ]")
           LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
-    let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
+    let strs = fmap toLogStr . B.split (fromIntegral $ ord '\n') . fromLogStr $ str'
+    let out = case strs of
+                [] -> B.empty
+                (x:xs) -> fromLogStr
+                  . foldr (\a b -> a <> toLogStr "\n" <> b) mempty
+                  . ((l <> toLogStr " " <> x) :)
+                  . fmap (\line' -> toLogStr (style' "[ ...   ] ") <> line' )
+                  $ xs
 
     when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
       $ colorOutter out
 
     -- raw output
     let lr = case level of
-          LevelDebug   -> toLogStr "Debug: "
+          LevelDebug   -> toLogStr "Debug:"
           LevelInfo    -> toLogStr "Info:"
           LevelWarn    -> toLogStr "Warn:"
           LevelError   -> toLogStr "Error:"

lib/GHCup/Utils/Prelude.hs

@@ -26,7 +26,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      ( lift )
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub, intercalate )
+import           Data.List                      ( nub )
 import           Data.Foldable
 import           Data.String
 import           Data.Text                      ( Text )
@@ -47,7 +47,6 @@ import           GHC.IO.Exception
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
-import qualified Data.List.Split               as Split
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Text.Encoding.Error      as E
@@ -426,19 +425,3 @@ isNewLine w
   | w == _lf = True
   | w == _cr = True
   | otherwise = False
-
-
--- | Split on a PVP suffix.
---
--- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706" == ("ghc-iserv-dyn", "9.3.20210706")
--- >>> splitOnPVP "-" "ghc-iserv-dyn"              == ("ghc-iserv-dyn", "")
-splitOnPVP :: String -> String -> (String, String)
-splitOnPVP c s = case Split.splitOn c s of
-  []  -> def
-  [_] -> def
-  xs
-    | let l = last xs
-    , (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)
-    | otherwise -> def
- where
-  def = (s, "")