hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Windows support

Browse Source
This commit is contained in:
Julian Ospald
2021-05-14 23:09:45 +02:00
parent b94a4123eb
commit 2c3ebe706d
36 changed files with 1615 additions and 1238 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
app/ghcup-gen/Validate.hs
View File

@@ -37,12 +37,11 @@ import Data.IORef
import Data.List
import Data.String.Interpolate
import Data.Versions
import HPath ( toFilePath, rel )
import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import System.IO
import System.Posix.FilePath
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
@@ -106,6 +105,10 @@ validate dls = do
addError
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
when (notElem Windows pspecs && arch == A_64) $ do
lift $ $(logError)
[i|Windows missing for for #{t} #{v'} #{arch'}|]
addError
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
@@ -238,7 +241,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
$ do
case tool of
Just GHCup -> do
let fn = [rel|ghcup|]
let fn = "ghcup"
dir <- liftIO ghcupCacheDir
p <- liftE $ download dli dir (Just fn)
liftE $ checkDigest dli p
@@ -252,7 +255,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
case r of
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir (toFilePath -> prel)) -> do
Just (RealDir prel) -> do
lift $ $(logInfo)
[i|verifying subdir: #{prel}|]
when (basePath /= prel) $ do

4
app/ghcup/BrickMain.hs
View File

@@ -14,6 +14,7 @@ import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File
import GHCup.Utils.Logger
@@ -518,7 +519,8 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Windows -> "start"
exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyShow e

63
app/ghcup/Main.hs
View File

@@ -53,8 +53,6 @@ import Data.Versions hiding ( str )
import Data.Void
import GHC.IO.Encoding
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Language.Haskell.TH
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
@@ -64,6 +62,7 @@ import System.Console.Pretty hiding ( color )
import qualified System.Console.Pretty as Pretty
import System.Environment
import System.Exit
import System.FilePath
import System.IO hiding ( appendFile )
import Text.Read hiding ( lift )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
@@ -170,17 +169,17 @@ data CompileCommand = CompileGHC GHCCompileOptions
data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: Either Version GitBranch
, bootstrapGhc :: Either Version (Path Abs)
, bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
, patchDir :: Maybe (Path Abs)
, buildConfig :: Maybe FilePath
, patchDir :: Maybe FilePath
, crossTarget :: Maybe Text
, addConfArgs :: [Text]
, setCompile :: Bool
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt (Path Abs)
| UpgradeAt FilePath
| UpgradeGHCupDir
deriving Show
@@ -721,8 +720,7 @@ ghcCompileOpts =
<*> option
(eitherReader
(\x ->
(bimap (const "Not a valid version") Left . version . T.pack $ x)
<|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ x)
(bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
)
)
( short 'b'
@@ -740,26 +738,14 @@ ghcCompileOpts =
)
<*> optional
(option
(eitherReader
(\x ->
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
str
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
)
)
<*> optional
(option
(eitherReader
(\x ->
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
str
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
"Absolute path to patch directory (applied in order, uses -p1)"
)
@@ -1040,13 +1026,7 @@ upgradeOptsP =
)
<|> ( UpgradeAt
<$> option
(eitherReader
(\x ->
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
str
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
@@ -1058,9 +1038,9 @@ upgradeOptsP =
describe_result :: String
describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
CapturedProcess{..} <- executeOut "git" ["describe"] Nothing
case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe $ _stdOut
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure _ -> pure numericVer
)
)
@@ -1114,7 +1094,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
, rawOutter = B.appendFile logfile
}
let runLogger = myLoggerT loggerConfig
@@ -1616,12 +1596,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
Upgrade uOpts force -> do
target <- case uOpts of
UpgradeInplace -> do
efp <- liftIO getExecutablePath
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
UpgradeInplace -> Just <$> liftIO getExecutablePath
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup"))
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
VRight v' -> do
@@ -1677,12 +1654,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Windows -> "start"
if clOpen
then
exec cmd
True
[serializeURIRef' uri]
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
Nothing
Nothing
>>= \case
@@ -1977,10 +1954,10 @@ checkForUpdates dls pfreq = do
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = [i|Debug Info
==========
GHCup base dir: #{toFilePath diBaseDir}
GHCup bin dir: #{toFilePath diBinDir}
GHCup GHC directory: #{toFilePath diGHCDir}
GHCup cache directory: #{toFilePath diCacheDir}
GHCup base dir: #{diBaseDir}
GHCup bin dir: #{diBinDir}
GHCup GHC directory: #{diGHCDir}
GHCup cache directory: #{diCacheDir}
Architecture: #{prettyShow diArch}
Platform: #{prettyShow diPlatform}
Version: #{describe_result}|]