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

Lala

This commit is contained in:
Julian Ospald 2020-03-05 18:02:59 +01:00
parent 718442a1e7
commit 2d51ad8940
19 changed files with 635 additions and 307 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
TODO.md
View File

@ -2,20 +2,17 @@
## Now
* better logs
* better debug-output
* static builds
* static builds and host ghcup (and fix BinaryDownloads)
* interoperability with old ghcup
* OS faking
* sign the JSON? (Or check gpg keys?)
## Maybe
* maybe: download progress
* maybe: changelog Show the changelog of a GHC release (online)
* maybe: print-system-reqs Print an approximation of system requirements
* OS faking
* testing (especially distro detection -> unit tests)
@ -23,6 +20,7 @@
* add support for RC/alpha/HEAD versions
* check for updates on start
* use plucky or oops instead of Excepts
## Questions

85
app/ghcup-gen/BinaryDownloads.hs
View File

@ -4,9 +4,9 @@
module BinaryDownloads where
import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import Data.String.QQ
import HPath
import URI.ByteString.QQ
@ -95,7 +95,7 @@ ghc_802_32_deb8 :: DownloadInfo
ghc_802_32_deb8 = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-i386-deb8-linux.tar.xz|]
(Just ([rel|ghc-8.0.2|] :: Path Rel))
[s||818621342a2161b8afcc995a0765816bb40aefbfa1db2c8a7d59c04d8b18228a|]
[s|818621342a2161b8afcc995a0765816bb40aefbfa1db2c8a7d59c04d8b18228a|]
ghc_802_64_freebsd :: DownloadInfo
ghc_802_64_freebsd = DownloadInfo
@ -827,7 +827,8 @@ ghc_883_32_musl :: DownloadInfo
ghc_883_32_musl = DownloadInfo
[uri|https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.8.3-musl/ghc-8.8.3-i386-unknown-linux-musl.tar.xz|]
(Just ([rel|ghc-8.8.3|] :: Path Rel))
[s|7a5f41646d06777e75636291a1855d60a0984552bbdf33c3d107565d302f38a4|]
[s|23779adb4cf4b314d0f8c66ee215ba6e74154c0768a573780475943544020bec|]
@ -900,8 +901,10 @@ cabal_3000_64_darwin = DownloadInfo
ghcup_010_64_linux :: DownloadInfo
ghcup_010_64_linux =
DownloadInfo [uri|file:///home/ospa_ju/tmp/ghcup-exe|] Nothing [s||]
ghcup_010_64_linux = DownloadInfo
[uri|file:///home/ospa_ju/tmp/ghcup-exe|]
Nothing
[s|558126339252788a3d44a3f910417277c7ab656f0796b68bdc58afe73296b8cd|]
@ -1023,12 +1026,12 @@ binaryDownloads = M.fromList
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Ubuntu, M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Mint , M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Debian, M.fromList [(Nothing, ghc_841_64_deb8)])
, (Darwin , M.fromList [(Nothing, ghc_841_64_darwin)])
, (FreeBSD , M.fromList [(Nothing, ghc_841_64_freebsd)])
, (Linux Alpine, M.fromList [(Nothing, ghc_841_64_musl)])
, (Linux Ubuntu , M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Mint , M.fromList [(Nothing, ghc_841_64_fedora)])
, (Linux Debian , M.fromList [(Nothing, ghc_841_64_deb8)])
, (Darwin , M.fromList [(Nothing, ghc_841_64_darwin)])
, (FreeBSD , M.fromList [(Nothing, ghc_841_64_freebsd)])
, (Linux Alpine , M.fromList [(Nothing, ghc_841_64_musl)])
]
)
, ( A_32
@ -1118,9 +1121,9 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_844_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_844_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_844_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_844_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_844_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_844_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_844_64_fedora)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_844_64_fedora)
@ -1156,7 +1159,7 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_861_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_861_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_861_64_fedora)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_861_64_fedora)
@ -1192,7 +1195,7 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_862_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_862_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_862_64_fedora)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_862_64_fedora)
@ -1222,9 +1225,9 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_863_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_863_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_863_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_863_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_863_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_863_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_863_64_centos)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_863_64_fedora)
@ -1260,7 +1263,7 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_864_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_864_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_864_64_fedora)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_864_64_fedora)
@ -1291,13 +1294,13 @@ binaryDownloads = M.fromList
]
)
, ( [vver|8.6.5|]
, VersionInfo [] $ M.fromList
, VersionInfo [Recommended] $ M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_865_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_865_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_865_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_865_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_865_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_865_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_865_64_centos)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_865_64_fedora)
@ -1332,9 +1335,9 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_881_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_881_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_881_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_881_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_881_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_881_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_881_64_centos)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_881_64_fedora)
@ -1369,9 +1372,9 @@ binaryDownloads = M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_882_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_882_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_882_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_882_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_882_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_882_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_882_64_centos)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_882_64_fedora)
@ -1402,13 +1405,13 @@ binaryDownloads = M.fromList
]
)
, ( [vver|8.8.3|]
, VersionInfo [] $ M.fromList
, VersionInfo [Latest] $ M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghc_883_64_fedora)])
, (Linux Fedora , M.fromList [(Nothing, ghc_883_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_883_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_883_64_centos)])
, (Linux Fedora , M.fromList [(Nothing, ghc_883_64_fedora)])
, (Linux CentOS , M.fromList [(Nothing, ghc_883_64_centos)])
, (Linux AmazonLinux , M.fromList [(Nothing, ghc_883_64_centos)])
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_883_64_fedora)
@ -1443,17 +1446,15 @@ binaryDownloads = M.fromList
, ( Cabal
, M.fromList
[ ( [vver|2.4.1.0|]
, VersionInfo [Recommended, Latest] $ M.fromList
, VersionInfo [] $ M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, cabal_2410_64_linux)]
)
, ( Linux Alpine
, M.fromList [(Nothing, cabal_2410_64_alpine)]
)
, (Darwin , M.fromList [(Nothing, cabal_2410_64_darwin)])
, (FreeBSD, M.fromList [(Nothing, cabal_2410_64_freebsd)])
, (Linux Alpine, M.fromList [(Nothing, cabal_2410_64_alpine)])
, (Darwin , M.fromList [(Nothing, cabal_2410_64_darwin)])
, (FreeBSD , M.fromList [(Nothing, cabal_2410_64_freebsd)])
]
)
, ( A_32
@ -1489,7 +1490,7 @@ binaryDownloads = M.fromList
, ( GHCup
, M.fromList
[ ( [vver|0.1.0|]
, VersionInfo [Latest] $ M.fromList
, VersionInfo [Recommended, Latest] $ M.fromList
[ ( A_64
, M.fromList
[(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])]

33
app/ghcup-gen/Main.hs
View File

@ -21,7 +21,7 @@ import System.Exit
import System.IO ( stdout )
import Validate
import qualified Data.ByteString as B
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
@ -31,6 +31,7 @@ data Options = Options
data Command = GenJSON GenJSONOpts
| ValidateJSON ValidateJSONOpts
| ValidateTarballs ValidateJSONOpts
data Output
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
@ -107,7 +108,16 @@ com = subparser
"check"
( ValidateJSON
<$> (info (validateJSONOpts <**> helper)
(progDesc "Generate the json downloads file")
(progDesc "Validate the JSON")
)
)
)
<> (command
"check-tarballs"
( ValidateTarballs
<$> (info
(validateJSONOpts <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
)
)
@ -130,16 +140,25 @@ main = do
L.writeFile file bs
ValidateJSON vopts -> case vopts of
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit
L.getContents >>= valAndExit validate
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit
L.readFile file >>= valAndExit validate
ValidateTarballs vopts -> case vopts of
ValidateJSONOpts { input = Nothing } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just StdInput } ->
L.getContents >>= valAndExit validateTarballs
ValidateJSONOpts { input = Just (FileInput file) } ->
L.readFile file >>= valAndExit validateTarballs
pure ()
where
valAndExit contents = do
valAndExit f contents = do
av <- case eitherDecode contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout)) (validate av) >>= exitWith
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
>>= exitWith

4
app/ghcup-gen/SourceDownloads.hs
View File

@ -4,9 +4,9 @@ module SourceDownloads where
import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import Data.String.QQ
import HPath
import URI.ByteString.QQ

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

@ -5,42 +5,50 @@
module Validate where
import GHCup
import GHCup.Download
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Logger
import Control.Monad
import Control.Exception.Safe
import Control.Monad.Reader.Class
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
import Data.IORef
import Data.List
import Data.String.Interpolate
import Data.Versions
import Data.IORef
import Haskus.Utils.Variant.Excepts
import Optics
import System.Exit
import Control.Monad.Logger
import System.IO
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
-- TODO: improve logging
data ValidationError = InternalError String
deriving Show
instance Exception ValidationError
-- TODO: test that GHC is in semver
-- TODO: check there's LATEST tag for every tool
-- TODO: check all tarballs can be downloaded
-- AND their checksum
-- TODO: check gpg keys of tarballs?
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
addError = do
ref <- ask
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> m ExitCode
validate GHCupDownloads{..} = do
validate dls@GHCupDownloads {..} = do
ref <- liftIO $ newIORef 0
-- * verify binary downloads * --
@ -54,10 +62,16 @@ validate GHCupDownloads{..} = do
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v arch (M.keys pspecs)
checkGHCisSemver
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkMandatoryTags t
-- exit
e <- liftIO $ readIORef ref
if e > 0 then pure $ ExitFailure e else pure ExitSuccess
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
checkHasRequiredPlatforms t v arch pspecs = do
let v' = prettyVer v
@ -65,10 +79,10 @@ validate GHCupDownloads{..} = do
lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
addError
when (not $ any (== Darwin) pspecs) $ do
when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
addError
when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn)
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do
@ -89,14 +103,75 @@ validate GHCupDownloads{..} = do
case join nonUnique of
[] -> pure ()
xs -> do
lift $ $(logError) [i|Tags not unique: #{xs}|]
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
checkGHCisSemver = do
let ghcVers = toListOf (binaryDownloads % ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v -> case semver (prettyVer v) of
Left _ -> do
lift $ $(logError) [i|GHC version #{v} is not valid semver|]
addError
Right _ -> pure ()
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
addError = do
ref <- ask
liftIO $ modifyIORef ref (+ 1)
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
addError
True -> pure ()
validateTarballs :: ( Monad m
, MonadLogger m
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
)
=> GHCupDownloads
-> m ExitCode
validateTarballs GHCupDownloads {..} = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
let
dlis = nub $ join $ (M.elems _binaryDownloads) <&> \versions ->
join $ (M.elems versions) <&> \vi ->
join $ (M.elems $ _viArch vi) <&> \pspecs ->
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
forM_ dlis $ downloadAll
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
downloadAll dli = do
let settings = Settings True GHCupURL False
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())
}
r <-
runLogger
. flip runReaderT settings
. runResourceT
. runE
$ downloadCached dli Nothing
case r of
VRight _ -> pure ()
VLeft e -> do
lift $ $(logError)
[i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
addError

54
app/ghcup/Main.hs
View File

@ -16,6 +16,7 @@ import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Monad.Logger
import Control.Monad.Reader
@ -25,15 +26,16 @@ import Data.Char
import Data.List ( intercalate )
import Data.Semigroup ( (<>) )
import Data.String.Interpolate
import Data.String.QQ
import Data.Versions
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO
import System.IO hiding ( appendFile )
import Text.Read
import Text.Layout.Table
import URI.ByteString
@ -120,13 +122,15 @@ opts =
(option
(eitherReader parseUri)
(short 's' <> long "url-source" <> metavar "URL" <> help
"Alternative ghcup download info url (default: internal)"
"Alternative ghcup download info url"
)
)
)
<*> switch
(short 'n' <> long "no-verify" <> help
"Don't verify sha256 checksums of downloaded tarballs (default: False)"
( short 'n'
<> long "no-verify"
<> help
"Skip tarball checksum checks (default: False)"
)
<*> com
where
@ -153,7 +157,10 @@ com =
<> command
"upgrade"
( Upgrade
<$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)"))
<$> (info
(upgradeOptsP <**> helper)
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
)
)
<> commandGroup "Main commands:"
)
@ -362,10 +369,15 @@ main = do
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do
let settings = toSettings opt
let settings = toSettings opt
-- logger interpreter
let runLogger = myLoggerT (LoggerConfig optVerbose $ B.hPut stderr)
logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel)
let runLogger = myLoggerT LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
-- wrapper to run effects with settings
let runInstTool =
@ -463,8 +475,11 @@ main = do
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
Install (InstallCabal InstallOptions {..}) ->
void
$ (runInstTool $ do
@ -478,8 +493,11 @@ main = do
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
SetGHC (SetGHCOptions {..}) ->
void
@ -550,8 +568,8 @@ main = do
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do
liftIO $ putStrLn "blah"
pure Nothing
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
void
$ (runUpgrade $ do
@ -559,9 +577,11 @@ main = do
liftE $ upgradeGHCup dls target
)
>>= \case
VRight v' ->
runLogger $ $(logInfo)
[i|Successfully upgraded GHCup to version #{v'}|]
VRight v' -> do
let pretty_v = prettyVer v'
runLogger
$ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|]
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure

9
ghcup.cabal
View File

@ -58,7 +58,6 @@ common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 }
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
common string-qq { build-depends: string-qq >= 0.0.4 }
common table-layout { build-depends: table-layout >= 0.8 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
common template-haskell { build-depends: template-haskell >= 2.7 }
@ -127,7 +126,6 @@ library
, streamly-bytestring
, strict-base
, string-interpolate
, string-qq
, tar-bytestring
, template-haskell
, text
@ -150,9 +148,12 @@ library
GHCup.Types.Optics
GHCup.Utils
GHCup.Utils.Bash
GHCup.Utils.Dirs
GHCup.Utils.File
GHCup.Utils.Logger
GHCup.Utils.Prelude
GHCup.Utils.String.QQ
GHCup.Utils.Version.QQ
GHCup.Version
-- other-modules:
-- other-extensions:
@ -171,9 +172,9 @@ executable ghcup
, text
, versions
, hpath
, hpath-io
, pretty-terminal
, resourcet
, string-qq
, string-interpolate
, table-layout
, uri-bytestring
@ -203,7 +204,7 @@ executable ghcup-gen
, versions
, hpath
, pretty-terminal
, string-qq
, resourcet
, string-interpolate
, table-layout
, transformers

28
lib/GHCup.hs
View File

@ -21,7 +21,8 @@ import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Version
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import Control.Applicative
import Control.Exception.Safe
@ -37,7 +38,6 @@ import Data.Foldable
import Data.List
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Versions
import Data.Word8
import GHC.IO.Exception
@ -148,13 +148,19 @@ installGHC :: (MonadLogger m, MonadIO m)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC path inst = do
lift $ $(logInfo) [s|Installing GHC|]
lEM $ liftIO $ exec [s|./configure|]
False
[[s|--prefix=|] <> toFilePath inst]
(Just path)
Nothing
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
lEM $ liftIO $ execLogged [s|./configure|]
False
[[s|--prefix=|] <> toFilePath inst]
([rel|ghc-configure.log|] :: Path Rel)
(Just path)
Nothing
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just path)
Nothing
pure ()
@ -418,12 +424,12 @@ getDebugInfo = do
---------------
--[ Compile ]--
---------------
-- TODO: build config
compileGHC :: ( MonadReader Settings m
, MonadThrow m
, MonadResource m
@ -544,7 +550,7 @@ upgradeGHCup dls mtarget = do
dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|] :: Path Rel
p <- liftE $ download dli tmp (Just fn)
p <- liftE $ download dli tmp (Just fn)
case mtarget of
Nothing -> do
dest <- liftIO $ ghcupBinDir

2
lib/GHCup/Download.hs
View File

@ -17,6 +17,7 @@ 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
@ -32,7 +33,6 @@ import Data.ByteString.Builder
import Data.IORef
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Versions
import GHC.IO.Exception
import HPath

2
lib/GHCup/Platform.hs
View File

@ -13,6 +13,7 @@ import GHCup.Types.JSON ( )
import GHCup.Utils.Bash
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
@ -23,7 +24,6 @@ import Control.Monad.Trans.Class ( lift )
import Data.Foldable
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Text ( Text )
import Data.Versions
import HPath

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

@ -12,11 +12,12 @@
module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types
import Data.String.QQ
import Data.Text.Encoding ( decodeUtf8 )
import Data.Text.Encoding as E
import Data.Versions
@ -28,20 +29,18 @@ import qualified Data.ByteString as BS
import qualified Data.Text as T
deriveJSON defaultOptions ''Architecture
deriveJSON defaultOptions ''LinuxDistro
deriveJSON defaultOptions ''Mess
deriveJSON defaultOptions ''Platform
deriveJSON defaultOptions ''SemVer
deriveJSON defaultOptions ''Tool
deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit
deriveJSON defaultOptions ''VersionInfo
deriveJSON defaultOptions ''Tag
deriveJSON defaultOptions ''DownloadInfo
deriveJSON defaultOptions ''GHCupDownloads
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupDownloads
instance ToJSON URI where

134
lib/GHCup/Utils.hs
View File

@ -4,14 +4,20 @@
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils where
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
)
where
import GHCup.Errors
import GHCup.Types
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
@ -25,7 +31,6 @@ import Data.ByteString ( ByteString )
import Data.List
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Versions
import Data.Word8
import GHC.IO.Exception
@ -38,7 +43,6 @@ import Prelude hiding ( abs
, writeFile
)
import Safe
import System.Posix.Env.ByteString ( getEnv )
import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink )
import URI.ByteString
@ -54,27 +58,11 @@ import qualified Data.Text.Encoding as E
-----------------
--[ Utilities ]--
-----------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir)
------------------------
--[ Symlink handling ]--
------------------------
-- | The symlink destination of a ghc tool.
@ -95,6 +83,13 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
Right r -> pure r
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
@ -110,11 +105,6 @@ ghcSet = do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
@ -132,6 +122,13 @@ cabalSet = do
Left e -> throwM e
Right r -> pure r
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
getGHCMajor ver = do
@ -160,10 +157,12 @@ getGHCForMajor major' minor' = do
$ semvers
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-----------------
--[ Unpacking ]--
-----------------
-- | Unpack an archive to a temporary directory and return that path.
@ -191,6 +190,55 @@ unpackToDir dest av = do
| otherwise -> throwE $ UnknownArchive fn
------------
--[ Tags ]--
------------
-- | Get the tool versions that have this tag.
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: BinaryDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: BinaryDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
-----------------------
--[ Settings Getter ]--
-----------------------
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
-------------
--[ Other ]--
-------------
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks.
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
@ -214,27 +262,3 @@ ghcToolFiles ver = do
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
-- | Get the tool versions that have this tag.
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: BinaryDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: BinaryDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache

92
lib/GHCup/Utils/Dirs.hs Normal file
View File

@ -0,0 +1,92 @@
{-# LANGUAGE QuasiQuotes #-}
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
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Maybe
import Data.Versions
import HPath
import HPath.IO
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.UTF8 as UTF8
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
-------------------------
--[ GHCup directories ]--
-------------------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir)
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
--------------
--[ Others ]--
--------------
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess

60
lib/GHCup/Utils/File.hs
View File

@ -3,19 +3,17 @@
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.ByteString
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.String.QQ
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
@ -27,28 +25,23 @@ import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.IO
import System.Posix.Directory.ByteString
import System.Posix.Env.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Temp.ByteString
import System.Posix.Types
import qualified System.Posix.Process.ByteString
as SPPB
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import Streamly.External.Posix.DirStream
import qualified Streamly.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy as L
@ -115,6 +108,36 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
let logfile = ldir </> lfile
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where
action fd = do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo fd stdOutput
-- dup stderr
void $ dupTo fd stdError
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
@ -193,27 +216,6 @@ toProcessError exe args mps = case mps of
Nothing -> Left $ NoSuchPid exe args
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath

53
lib/GHCup/Utils/Logger.hs
View File

@ -1,28 +1,59 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Utils.Logger where
import GHCup.Utils
import Control.Monad.Logger
import HPath
import HPath.IO
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.IO.Error
import qualified Data.ByteString as B
import qualified Data.ByteString as B
data LoggerConfig = LoggerConfig {
lcPrintDebug :: Bool
, outter :: B.ByteString -> IO ()
}
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let l = case level of
LevelDebug -> if lcPrintDebug then toLogStr (style Bold $ color Blue "[ Debug ]") else mempty
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelDebug -> if lcPrintDebug
then toLogStr (style Bold $ color Blue "[ Debug ]")
else mempty
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
outter out
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug: "
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
initGHCupFileLogging context = do
logs <- ghcupLogsDir
let logfile = logs </> context
createDirIfMissing newDirPerms logs
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile

88
lib/GHCup/Utils/Prelude.hs
View File

@ -1,15 +1,10 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Utils.Prelude where
@ -21,20 +16,12 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Data
import Data.Monoid ( (<>) )
import Data.String
import Data.Text ( Text )
import Data.Versions
import GHC.Base
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import System.IO.Error
import qualified Data.ByteString.Lazy as L
@ -45,7 +32,6 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Language.Haskell.TH.Syntax as TH
@ -197,84 +183,20 @@ hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
Right r -> pure r
deriving instance Data Versioning
deriving instance Lift Versioning
deriving instance Data Version
deriving instance Lift Version
deriving instance Data SemVer
deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess
deriving instance Data PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
vver :: QuasiQuoter
vver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . version
mver :: QuasiQuoter
mver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . mess
sver :: QuasiQuoter
sver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . semver
vers :: QuasiQuoter
vers = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . versioning
pver :: QuasiQuoter
pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . pvp
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'

48
lib/GHCup/Utils/String/QQ.hs Normal file
View File

@ -0,0 +1,48 @@
{-# LANGUAGE TemplateHaskell #-}
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
--
-- The "s" quoter contains a multi-line string with no interpolation at all,
-- except that the leading newline is trimmed and carriage returns stripped.
--
-- @
-- {-\# LANGUAGE QuasiQuotes #-}
-- import Data.Text (Text)
-- import Data.String.QQ
-- foo :: Text -- "String", "ByteString" etc also works
-- foo = [s|
-- Well here is a
-- multi-line string!
-- |]
-- @
--
-- Any instance of the IsString type is permitted.
--
-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
--
module GHCup.Utils.String.QQ
( s
)
where
import Data.Char
import GHC.Exts ( IsString(..) )
import Language.Haskell.TH.Quote
-- | QuasiQuoter for a non-interpolating ASCII IsString literal.
-- The pattern portion is undefined.
s :: QuasiQuoter
s = QuasiQuoter
(\s' -> case and $ fmap isAscii s' of
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
False -> fail "Not ascii"
)
(error "Cannot use q as a pattern")
(error "Cannot use q as a type")
(error "Cannot use q as a dec")
where
removeCRs = filter (/= '\r')
trimLeadingNewline ('\n' : xs) = xs
trimLeadingNewline xs = xs

89
lib/GHCup/Utils/Version/QQ.hs Normal file
View File

@ -0,0 +1,89 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.Version.QQ where
import Data.Data
import Data.Text ( Text )
import Data.Versions
import GHC.Base
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import qualified Data.Text as T
import qualified Language.Haskell.TH.Syntax as TH
deriving instance Data Versioning
deriving instance Lift Versioning
deriving instance Data Version
deriving instance Lift Version
deriving instance Data SemVer
deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess
deriving instance Data PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
vver :: QuasiQuoter
vver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . version
mver :: QuasiQuoter
mver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . mess
sver :: QuasiQuoter
sver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . semver
vers :: QuasiQuoter
vers = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . versioning
pver :: QuasiQuoter
pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . pvp
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)

3
lib/GHCup/Version.hs
View File

@ -3,8 +3,9 @@
module GHCup.Version where
import GHCup.Utils.Version.QQ
import Data.Versions
import GHCup.Utils.Prelude
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.0|]