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
Download Patch File Download Diff File Expand all files Collapse all files

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