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

Use OverloadedStrings instead of TH

Browse Source
This commit is contained in:
Julian Ospald 2020-03-21 22:19:37 +01:00
parent af42598a27
commit 0963081fd8
8 changed files with 261 additions and 264 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

288
app/ghcup-gen/GHCupDownloads.hs
View File

File diff suppressed because it is too large Load Diff

66
app/ghcup/Main.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
@ -15,7 +16,6 @@ import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Version
import Control.Monad.Fail ( MonadFail )
@ -387,48 +387,46 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
Left e -> Left $ errorBundlePretty e
where
archP :: MP.Parsec Void Text Architecture
archP =
(MP.try (MP.chunk [s|x86_64|] $> A_64)) <|> (MP.chunk [s|i386|] $> A_32)
archP = (MP.try (MP.chunk "x86_64" $> A_64)) <|> (MP.chunk "i386" $> A_32)
platformP :: MP.Parsec Void Text PlatformRequest
platformP = choice'
[ (\a mv -> PlatformRequest a FreeBSD mv)
<$> (archP <* MP.chunk [s|-|])
<*> ( MP.chunk [s|portbld|]
*> ( MP.try (Just <$> verP (MP.chunk [s|-freebsd|] <* MP.eof))
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "portbld"
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
<|> pure Nothing
)
<* MP.chunk [s|-freebsd|]
<* MP.chunk "-freebsd"
)
, (\a mv -> PlatformRequest a Darwin mv)
<$> (archP <* MP.chunk [s|-|])
<*> ( MP.chunk [s|apple|]
*> ( MP.try (Just <$> verP (MP.chunk [s|-darwin|] <* MP.eof))
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "apple"
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
<|> pure Nothing
)
<* MP.chunk [s|-darwin|]
<* MP.chunk "-darwin"
)
, (\a d mv -> PlatformRequest a (Linux d) mv)
<$> (archP <* MP.chunk [s|-|])
<$> (archP <* MP.chunk "-")
<*> distroP
<*> ( ( MP.try (Just <$> verP (MP.chunk [s|-linux|] <* MP.eof))
<|> pure Nothing
)
<* MP.chunk [s|-linux|]
<*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing
)
<* MP.chunk "-linux"
)
]
distroP :: MP.Parsec Void Text LinuxDistro
distroP = choice'
[ MP.chunk [s|debian|] $> Debian
, MP.chunk [s|deb|] $> Debian
, MP.chunk [s|ubuntu|] $> Ubuntu
, MP.chunk [s|mint|] $> Mint
, MP.chunk [s|fedora|] $> Fedora
, MP.chunk [s|centos|] $> CentOS
, MP.chunk [s|redhat|] $> RedHat
, MP.chunk [s|alpine|] $> Alpine
, MP.chunk [s|gentoo|] $> Gentoo
, MP.chunk [s|exherbo|] $> Exherbo
, MP.chunk [s|unknown|] $> UnknownLinux
[ MP.chunk "debian" $> Debian
, MP.chunk "deb" $> Debian
, MP.chunk "ubuntu" $> Ubuntu
, MP.chunk "mint" $> Mint
, MP.chunk "fedora" $> Fedora
, MP.chunk "centos" $> CentOS
, MP.chunk "redhat" $> RedHat
, MP.chunk "alpine" $> Alpine
, MP.chunk "gentoo" $> Gentoo
, MP.chunk "exherbo" $> Exherbo
, MP.chunk "unknown" $> UnknownLinux
]
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
verP suffix = do
@ -618,8 +616,8 @@ main = do
liftE $ installGHCBin dls v instPlatform
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|GHC installation successful|])
VRight _ ->
runLogger $ $(logInfo) ("GHC installation successful")
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
@ -641,8 +639,8 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
liftE $ installCabalBin dls v instPlatform
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|Cabal installation successful|])
VRight _ ->
runLogger $ $(logInfo) ("Cabal installation successful")
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
@ -660,7 +658,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
)
>>= \case
VRight _ ->
runLogger $ $(logInfo) ([s|GHC successfully set|])
runLogger $ $(logInfo) ("GHC successfully set")
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
@ -703,7 +701,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|GHC successfully compiled and installed|])
("GHC successfully compiled and installed")
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
@ -724,7 +722,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|Cabal successfully compiled and installed|])
("Cabal successfully compiled and installed")
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}

49
lib/GHCup.hs
View File

@ -3,10 +3,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup where
@ -133,14 +134,14 @@ installGHCBin bDls ver mpfReq = do
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC' path inst = do
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
lEM $ liftIO $ execLogged [s|./configure|]
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ liftIO $ execLogged "./configure"
False
[[s|--prefix=|] <> toFilePath inst]
["--prefix=" <> toFilePath inst]
[rel|ghc-configure.log|]
(Just path)
Nothing
lEM $ liftIO $ make [[s|install|]] (Just path)
lEM $ liftIO $ make ["install"] (Just path)
pure ()
@ -194,7 +195,7 @@ installCabalBin bDls ver mpfReq = do
-> Path Abs -- ^ Path to install to
-> Excepts '[CopyError] m ()
installCabal' path inst = do
lift $ $(logInfo) [s|Installing cabal|]
lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|]
liftIO $ createDirIfMissing newDirPerms inst
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
@ -246,7 +247,7 @@ setGHC ver sghc = do
SetGHCOnly -> pure file
SetGHC_XY -> do
major' <-
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> "." <> intToText mi)
<$> getGHCMajor ver
parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
@ -276,7 +277,7 @@ setGHC ver sghc = do
let fullsharedir = ghcdir </> sharedir
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir
let targetF = [s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir
let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir
$(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
@ -462,7 +463,7 @@ compileGHC dls tver bver jobs mbuildConfig = do
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
bghc <- parseRel ("ghc-" <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver
@ -505,26 +506,24 @@ GhcWithLlvmCodeGen = YES|]
lift $ $(logInfo) [i|configuring build|]
-- force ld.bfd for build (others seem to misbehave, like lld from FreeBSD)
newEnv <- addToCurrentEnv [([s|LD|], [s|ld.bfd|])]
newEnv <- addToCurrentEnv [("LD", "ld.bfd")]
if
| tver >= [vver|8.8.0|] -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
lEM $ liftIO $ execLogged
[s|./configure|]
"./configure"
False
[[s|--prefix=|] <> toFilePath ghcdir]
["--prefix=" <> toFilePath ghcdir]
[rel|ghc-configure.log|]
(Just workdir)
(Just (([s|GHC|], toFilePath bghcPath) : newEnv))
(Just (("GHC", toFilePath bghcPath) : newEnv))
| otherwise -> do
lEM $ liftIO $ execLogged
[s|./configure|]
"./configure"
False
[ [s|--prefix=|] <> toFilePath ghcdir
, [s|--with-ghc=|] <> toFilePath bghc
]
["--prefix=" <> toFilePath ghcdir, "--with-ghc=" <> toFilePath bghc]
[rel|ghc-configure.log|]
(Just workdir)
(Just newEnv)
@ -540,11 +539,11 @@ GhcWithLlvmCodeGen = YES|]
lift
$ $(logInfo)
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/ghc-make.log' to see the progress.|]
lEM $ liftIO $ make (maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
lift $ $(logInfo) [i|Installing...|]
lEM $ liftIO $ make [[s|install|]] (Just workdir)
lEM $ liftIO $ make ["install"] (Just workdir)
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
@ -604,15 +603,15 @@ compileCabal dls tver bver jobs = do
let v' = verToBS bver
cabal_bin <- liftIO $ ghcupBinDir
newEnv <- lift $ addToCurrentEnv
[ ([s|GHC|] , [s|ghc-|] <> v')
, ([s|GHC_PKG|], [s|ghc-pkg-|] <> v')
, ([s|GHC_VER|], v')
, ([s|PREFIX|] , toFilePath cabal_bin)
[ ("GHC" , "ghc-" <> v')
, ("GHC_PKG", "ghc-pkg-" <> v')
, ("GHC_VER", v')
, ("PREFIX" , toFilePath cabal_bin)
]
lEM $ liftIO $ execLogged [s|./bootstrap.sh|]
lEM $ liftIO $ execLogged "./bootstrap.sh"
False
(maybe [] (\j -> [[s|-j|], fS (show j)]) jobs)
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
[rel|cabal-bootstrap.log|]
(Just workdir)
(Just newEnv)

52
lib/GHCup/Download.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Download where
@ -18,7 +19,6 @@ import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
@ -190,7 +190,7 @@ getDownloads urlSource = do
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
parseModifiedHeader headers =
(M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
(M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM
True
defaultTimeLocale
"%a, %d %b %Y %H:%M:%S %Z"
@ -271,9 +271,9 @@ download :: ( MonadMask m
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
download dli dest mfn
| scheme == [s|https|] = dl
| scheme == [s|http|] = dl
| scheme == [s|file|] = cp
| scheme == "https" = dl
| scheme == "http" = dl
| scheme == "file" = cp
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where
@ -370,11 +370,11 @@ downloadBS :: (MonadCatch m, MonadIO m)
m
L.ByteString
downloadBS uri'
| scheme == [s|https|]
| scheme == "https"
= dl True
| scheme == [s|http|]
| scheme == "http"
= dl False
| scheme == [s|file|]
| scheme == "file"
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path)
| otherwise
@ -447,7 +447,7 @@ downloadInternal = go (5 :: Int)
let scode = getStatusCode r
if
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Just $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
@ -460,7 +460,7 @@ downloadInternal = go (5 :: Int)
Left e -> throwE e
downloadStream r i' = do
let size = case getHeader r [s|Content-Length|] of
let size = case getHeader r "Content-Length" of
Just x' -> case decimal $ E.decodeUtf8 x' of
Left _ -> 0
Right (r', _) -> r'
@ -492,9 +492,9 @@ getHead :: (MonadCatch m, MonadIO m)
]
m
(M.Map (CI ByteString) ByteString)
getHead uri' | scheme == [s|https|] = head' True
| scheme == [s|http|] = head' False
| otherwise = throwE UnsupportedScheme
getHead uri' | scheme == "https" = head' True
| scheme == "http" = head' False
| otherwise = throwE UnsupportedScheme
where
scheme = view (uriSchemeL' % schemeBSL') uri'
@ -542,7 +542,7 @@ headInternal = go (5 :: Int)
| scode >= 200 && scode < 300 -> do
let headers = getHeaderMap r
pure $ Right $ headers
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Left $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
@ -585,19 +585,17 @@ uriToQuadruple URI {..} = do
?? UnsupportedScheme
https <- if
| scheme == [s|https|] -> pure True
| scheme == [s|http|] -> pure False
| otherwise -> throwE UnsupportedScheme
| scheme == "https" -> pure True
| scheme == "http" -> pure False
| otherwise -> throwE UnsupportedScheme
let
queryBS =
BS.intercalate [s|&|]
. fmap (\(x, y) -> encodeQuery x <> [s|=|] <> encodeQuery y)
$ (queryPairs uriQuery)
port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath =
if BS.null queryBS then uriPath else uriPath <> [s|?|] <> queryBS
let queryBS =
BS.intercalate "&"
. fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
$ (queryPairs uriQuery)
port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS
pure (https, host, fullpath, port)
where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery

26
lib/GHCup/Platform.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
@ -128,8 +129,8 @@ getLinuxDistro = do
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _) <- findExecutable lsb_release_cmd
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
name <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
try_lsb_release :: IO (Text, Maybe Text)
@ -142,23 +143,22 @@ getLinuxDistro = do
try_redhat_release = do
t <- fmap lBS2sT $ readFile redhat_release
let nameRegex n =
makeRegexOpts
compIgnoreCase
execBlank
(([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex
makeRegexOpts compIgnoreCase
execBlank
(([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex
let verRegex =
makeRegexOpts
compIgnoreCase
execBlank
([s|\<([0-9])+(.([0-9])+)*\>|] :: ByteString) :: Regex
let nameRe n = fromEmpty . match (nameRegex n) $ T.unpack t :: Maybe String
makeRegexOpts compIgnoreCase
execBlank
([s|\<([0-9])+(.([0-9])+)*\>|] :: ByteString) :: Regex
let nameRe n =
fromEmpty . match (nameRegex n) $ T.unpack t :: Maybe String
verRe = fromEmpty . match verRegex $ T.unpack t :: Maybe String
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
pure (T.pack name, fmap T.pack verRe)
where
fromEmpty :: String -> Maybe String
fromEmpty "" = Nothing
fromEmpty "" = Nothing
fromEmpty s' = Just s'
try_debian_version :: IO (Text, Maybe Text)

4
lib/GHCup/Types/JSON.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
@ -13,7 +14,6 @@ module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Data.Aeson
import Data.Aeson.TH
@ -138,7 +138,7 @@ instance FromJSONKey Tool where
instance ToJSON (Path Rel) where
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
True -> toJSON . E.decodeUtf8 $ fp
False -> String [s|/not/a/valid/path|]
False -> String "/not/a/valid/path"
where fp = toFilePath p
instance FromJSON (Path Rel) where

30
lib/GHCup/Utils.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
@ -17,7 +18,6 @@ import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
@ -44,7 +44,9 @@ import Prelude hiding ( abs
)
import Safe
import System.IO.Error
import System.Posix.FilePath ( getSearchPath, takeFileName )
import System.Posix.FilePath ( getSearchPath
, takeFileName
)
import System.Posix.Files.ByteString ( readSymbolicLink )
import URI.ByteString
@ -70,14 +72,14 @@ import qualified Data.Text.Encoding as E
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
-> Version
-> ByteString
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
ghcLinkDestination tool ver = "../ghc/" <> verToBS ver <> "/bin/" <> tool
-- | Extract the version part of the result of `ghcLinkDestination`.
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
where
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
parser = string "../ghc/" *> verParser <* string "/bin/ghc"
verParser = many1' (notWord8 _slash) >>= \t ->
case version $ E.decodeUtf8 $ B.pack t of
Left e -> fail $ show e
@ -90,7 +92,7 @@ rmMinorSymlinks ver = do
bindir <- liftIO $ ghcupBinDir
files <- liftIO $ getDirsFiles' bindir
let myfiles =
filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
filter (\x -> ("-" <> verToBS ver) `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> do
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
@ -117,12 +119,12 @@ rmPlain ver = do
rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
rmMajorSymlinks ver = do
(mj, mi) <- liftIO $ getGHCMajor ver
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
let v' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi
bindir <- liftIO ghcupBinDir
files <- liftIO $ getDirsFiles' bindir
let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
let myfiles = filter (\x -> ("-" <> v') `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> do
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
@ -173,7 +175,7 @@ cabalInstalled ver = do
cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet = do
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
mc <- liftIO $ executeOut cabalbin ["--numeric-version"] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
case version (E.decodeUtf8 reportedVer) of
Left e -> throwM e
@ -235,15 +237,15 @@ unpackToDir dest av = do
-- extract, depending on file extension
if
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
| ".tar.gz" `B.isSuffixOf` fn -> liftIO
(untar . GZip.decompress =<< readFile av)
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
| ".tar.xz" `B.isSuffixOf` fn -> do
filecontents <- liftIO $ readFile av
let decompressed = Lzma.decompress filecontents
liftIO $ untar decompressed
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
| ".tar.bz2" `B.isSuffixOf` fn -> liftIO
(untar . BZip.decompress =<< readFile av)
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| ".tar" `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive fn
@ -313,7 +315,7 @@ ghcToolFiles ver = do
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
(Just symver) <-
(B.stripPrefix [s|ghc-|] . takeFileName)
(B.stripPrefix "ghc-" . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
@ -332,5 +334,5 @@ make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
let mymake = if has_gmake then [s|gmake|] else [s|make|]
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make.log|] workdir Nothing

10
lib/GHCup/Utils/Dirs.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Utils.Dirs where
@ -5,7 +6,6 @@ module GHCup.Utils.Dirs where
import GHCup.Types.JSON ( )
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
@ -39,7 +39,7 @@ import qualified System.Posix.User as PU
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
@ -67,8 +67,8 @@ ghcupLogsDir = ghcupBaseDir <&> (</> [rel|logs|])
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
parseAbs tmp
@ -83,7 +83,7 @@ withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
e <- getEnv "HOME"
case e of
Just fp -> parseAbs fp
Nothing -> do