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

Add tool-requirements subcommand

Browse Source
This commit is contained in:
Julian Ospald 2020-04-10 17:36:27 +02:00
parent 9602db31ab
commit c706a047ea
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
11 changed files with 241 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
app/ghcup-gen/GHCupInfo.hs Normal file
View File

@ -0,0 +1,11 @@
module GHCupInfo where
import GHCupDownloads
import ToolRequirements
import GHCup.Types
ghcupInfo :: GHCupInfo
ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
, _ghcupDownloads = ghcupDownloads
}

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

@ -9,9 +9,10 @@
module Main where
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import GHCupDownloads
import GHCupInfo
import Data.Aeson ( eitherDecode )
import Data.Aeson.Encode.Pretty
@ -135,7 +136,7 @@ main = do
GenJSON gopts -> do
let
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
ghcupDownloads
ghcupInfo
case gopts of
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
@ -159,7 +160,7 @@ main = do
where
valAndExit f contents = do
av <- case eitherDecode contents of
(GHCupInfo _ av) <- case eitherDecode contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)

94
app/ghcup-gen/ToolRequirements.hs Normal file
View File

@ -0,0 +1,94 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module ToolRequirements where
import GHCup.Types
import GHCup.Utils.String.QQ
import qualified Data.Map as M
-- | Currently 'GHC' is used for both GHC and cabal to simplify
-- this, until we need actual separation.
toolRequirements :: ToolRequirements
toolRequirements = M.fromList
[ ( GHC
, M.fromList
[ ( Nothing
, M.fromList
[ ( Linux UnknownLinux
, M.fromList
[ ( Nothing
, Requirements
[]
[s|You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.|]
)
]
)
, ( Linux Alpine
, M.fromList
[ ( Nothing
, Requirements
[ "curl"
, "gcc"
, "g++"
, "gmp-dev"
, "ncurses-dev"
, "libffi-dev"
, "make"
, "xz"
, "tar"
, "perl"
]
""
)
]
)
, ( Linux Ubuntu
, M.fromList
[ ( Nothing
, Requirements
[ "build-essential"
, "curl"
, "libgmp-dev"
, "libffi-dev"
, "libncurses-dev"
, "libtinfo5"
]
""
)
]
)
, ( Darwin
, M.fromList
[ ( Nothing
, Requirements
[]
"On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again."
)
]
)
, ( FreeBSD
, M.fromList
[ ( Nothing
, Requirements
[ "curl"
, "gcc"
, "gmp"
, "gmake"
, "ncurses"
, "perl5"
, "libffi"
, "libiconv"
]
""
)
]
)
]
)
]
)
]

25
app/ghcup/Main.hs
View File

@ -13,6 +13,8 @@ module Main where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Requirements
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Logger
@ -79,6 +81,7 @@ data Command
| Compile CompileCommand
| Upgrade UpgradeOpts
| NumericVersion
| ToolRequirements
data ToolVersion = ToolVersion Version
| ToolTag Tag
@ -218,6 +221,11 @@ com =
( (\_ -> NumericVersion)
<$> (info (helper) (progDesc "Show the numeric version"))
)
<> command
"tool-requirements"
( (\_ -> ToolRequirements)
<$> (info (helper) (progDesc "Show the requirements for ghc/cabal"))
)
<> commandGroup "Other commands:"
<> hidden
)
@ -615,7 +623,7 @@ main = do
, DownloadFailed
]
dls <-
(GHCupInfo treq dls) <-
( runLogger
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed]
@ -779,6 +787,21 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
runLogger ($(logError) [i|#{e}|]) >> exitFailure
NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
ToolRequirements -> (runLogger $ runE
@'[ NoCompatiblePlatform
, DistroNotFound
, NoToolRequirements
] $ do
platform <- liftE $ getPlatform
req <- (getCommonRequirements platform $ treq)
?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req))
>>= \case
VRight r -> pure r
VLeft e ->
runLogger
($(logError) [i|Error getting tool requirements: #{e}|])
>> exitFailure
pure ()

8
ghcup.cabal
View File

@ -283,6 +283,7 @@ library
GHCup.Download.Utils
GHCup.Errors
GHCup.Platform
GHCup.Requirements
GHCup.Types
GHCup.Types.JSON
GHCup.Types.Optics
@ -368,8 +369,11 @@ executable ghcup-gen
--
main-is: Main.hs
other-modules: GHCupDownloads
Validate
other-modules:
GHCupDownloads
GHCupInfo
ToolRequirements
Validate
-- other-extensions:
build-depends: ghcup

2
lib/GHCup/Download.hs
View File

@ -94,7 +94,7 @@ getDownloads :: ( FromJSONKey Tool
, MonadFail m
)
=> URLSource
-> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo
getDownloads urlSource = do
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of

3
lib/GHCup/Errors.hs
View File

@ -92,6 +92,9 @@ data TooManyRedirs = TooManyRedirs
data PatchFailed = PatchFailed
deriving Show
-- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements
deriving Show
-------------------------

46
lib/GHCup/Requirements.hs Normal file
View File

@ -0,0 +1,46 @@
{-# LANGUAGE OverloadedStrings #-}
module GHCup.Requirements where
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import Control.Applicative
import Data.Maybe
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import qualified Data.Text as T
-- | Get the requirements. Right now this combines GHC and cabal
-- and doesn't do fine-grained distinction. However, the 'ToolRequirements'
-- type allows it.
getCommonRequirements :: PlatformResult
-> ToolRequirements
-> Maybe Requirements
getCommonRequirements pr tr =
preview (ix GHC % ix Nothing % ix (_platform pr) % ix (_distroVersion pr)) tr
<|> preview (ix GHC % ix Nothing % ix (_platform pr) % ix Nothing) tr
<|> preview
( ix GHC
% ix Nothing
% ix (set _Linux UnknownLinux $ _platform pr)
% ix Nothing
)
tr
prettyRequirements :: Requirements -> T.Text
prettyRequirements Requirements {..} =
let d = if not . null $ _distroPKGs
then
"\n Install the following distro packages: "
<> T.intercalate " " _distroPKGs
else ""
n = if not . T.null $ _notes then "\n Note: " <> _notes else ""
in "System requirements " <> d <> n

35
lib/GHCup/Types.hs
View File

@ -12,6 +12,39 @@ import qualified GHC.Generics as GHC
--------------------
--[ GHCInfo Tree ]--
--------------------
data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads
}
deriving (Show, GHC.Generic)
-------------------------
--[ Requirements Tree ]--
-------------------------
type ToolRequirements = Map Tool ToolReqVersionSpec
type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec
type PlatformReqSpec = Map Platform PlatformReqVersionSpec
type PlatformReqVersionSpec = Map (Maybe Versioning) Requirements
data Requirements = Requirements
{ _distroPKGs :: [Text]
, _notes :: Text
}
deriving (Show, GHC.Generic)
---------------------
--[ Download Tree ]--
@ -99,7 +132,7 @@ data DownloadInfo = DownloadInfo
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupDownloads
| OwnSpec GHCupInfo
deriving Show

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

@ -39,6 +39,8 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
instance ToJSON URI where
@ -69,11 +71,11 @@ instance FromJSONKey Versioning where
instance ToJSONKey (Maybe Versioning) where
toJSONKey = toJSONKeyText $ \case
Just x -> prettyV x
Nothing -> T.pack "unknown_version"
Nothing -> T.pack "unknown_versioning"
instance FromJSONKey (Maybe Versioning) where
fromJSONKey = FromJSONKeyTextParser $ \t ->
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
if t == T.pack "unknown_versioning" then pure Nothing else pure $ just t
where
just t = case versioning t of
Right x -> pure x
@ -112,6 +114,19 @@ instance ToJSONKey Architecture where
instance FromJSONKey Architecture where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSONKey (Maybe Version) where
toJSONKey = toJSONKeyText $ \case
Just x -> prettyVer x
Nothing -> T.pack "unknown_version"
instance FromJSONKey (Maybe Version) where
fromJSONKey = FromJSONKeyTextParser $ \t ->
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
where
just t = case version t of
Right x -> pure x
Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
instance ToJSON Version where
toJSON = toJSON . prettyVer

1
lib/GHCup/Types/Optics.hs
View File

@ -19,6 +19,7 @@ makeLenses ''DownloadInfo
makeLenses ''Tag
makeLenses ''VersionInfo
makeLenses ''GHCupInfo
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
uriSchemeL' = lensVL uriSchemeL