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

64
app/ghcup/Main.hs
View File

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

49
lib/GHCup.hs
View File

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

42
lib/GHCup/Download.hs
View File

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

16
lib/GHCup/Platform.hs
View File

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

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

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

30
lib/GHCup/Utils.hs
View File

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