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

Yo

Browse Source
This commit is contained in:
Julian Ospald
2020-03-01 00:07:39 +01:00
parent 6489e8430b
commit e1fb60d3b1
11 changed files with 298 additions and 253 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
app/ghcup-gen/AvailableDownloads.hs
View File

@@ -21,7 +21,7 @@ availableDownloads :: AvailableDownloads
availableDownloads = M.fromList
[ ( GHC
, M.fromList
[ ( [ver|8.6.5|]
[ ( [vver|8.6.5|]
, VersionInfo [Latest] $ M.fromList
[ ( A_64
, M.fromList
@@ -61,7 +61,7 @@ availableDownloads = M.fromList
)
]
),
( [ver|8.4.4|]
( [vver|8.4.4|]
, VersionInfo [Latest] $ M.fromList
[ ( A_64
, M.fromList
@@ -105,7 +105,7 @@ availableDownloads = M.fromList
)
, ( Cabal
, M.fromList
[ ( [ver|3.0.0.0|]
[ ( [vver|3.0.0.0|]
, VersionInfo [Recommended, Latest] $ M.fromList
[ ( A_64
, M.fromList

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

@@ -15,7 +15,6 @@ import qualified Data.ByteString.Lazy as L
import Data.Semigroup ( (<>) )
import GHCup.Types.JSON ( )
import Options.Applicative hiding ( style )
import Control.Monad.Logger
import GHCup.Logger
import System.Console.Pretty
import System.Exit

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

@@ -4,32 +4,23 @@
module Validate where
import AvailableDownloads
import GHCup
import GHCup.Types
import GHCup.Types.Optics
import Control.Monad
import Control.Exception.Safe
import Control.Monad.Reader.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( ReaderT
, runReaderT
)
import Control.Monad.Trans.Reader ( runReaderT )
import Data.List
import Data.String.QQ
import Data.String.Interpolate
import Data.Versions
import Data.IORef
import Optics
import System.Exit
import System.Console.Pretty
import System.IO
import Control.Monad.Logger
import qualified Data.Map.Strict as M
import qualified Data.ByteString as B
-- TODO: improve logging

222
app/ghcup/Main.hs
View File

@@ -10,21 +10,13 @@ module Main where
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.ByteString ( ByteString )
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char
import Data.Functor ( (<&>) )
import Data.List ( intercalate )
import qualified Data.Map as M
import Data.Maybe
import Data.Semigroup ( (<>) )
import Data.String.QQ
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Traversable
import Data.Versions
import GHCup
import GHCup.Logger
@@ -32,12 +24,12 @@ import GHCup.File
import GHCup.Prelude
import GHCup.Types
import Haskus.Utils.Variant.Excepts
import HPath
import Options.Applicative hiding ( style )
import System.Console.Pretty
import System.Exit
import URI.ByteString
import Text.Layout.Table
import Data.String.Interpolate
@@ -56,17 +48,22 @@ data Command
| SetGHC SetGHCOptions
| List ListOptions
| Rm RmOptions
| DInfo
data ToolVersion = ToolVersion Version
| ToolTag Tag
data InstallGHCOptions = InstallGHCOptions
{ ghcVer :: Maybe Version
{ ghcVer :: Maybe ToolVersion
}
data InstallCabalOptions = InstallCabalOptions
{ cabalVer :: Maybe Version
{ cabalVer :: Maybe ToolVersion
}
data SetGHCOptions = SetGHCOptions
{ ghcVer :: Maybe Version
{ ghcVer :: Maybe ToolVersion
}
data ListOptions = ListOptions
@@ -100,8 +97,8 @@ opts =
)
<*> com
where
parseUri s =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s)
parseUri s' =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command
com = subparser
@@ -140,41 +137,20 @@ com = subparser
(progDesc "Remove a GHC version installed by ghcup")
)
)
<> command
"debug-info"
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
)
installGHCOpts :: Parser InstallGHCOptions
installGHCOpts = InstallGHCOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to install"
)
)
installGHCOpts = InstallGHCOptions <$> optional toolVersionParser
installCabalOpts :: Parser InstallCabalOptions
installCabalOpts = InstallCabalOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The Cabal version to install"
)
)
installCabalOpts = InstallCabalOptions <$> optional toolVersionParser
setGHCOpts :: Parser SetGHCOptions
setGHCOpts = SetGHCOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to set (default: recommended)"
)
)
setGHCOpts = SetGHCOptions <$> optional toolVersionParser
listOpts :: Parser ListOptions
listOpts =
@@ -183,7 +159,7 @@ listOpts =
(option
(eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
"Tool to list versions for. Default is ghc only."
"Tool to list versions for. Default is all"
)
)
<*> (optional
@@ -198,30 +174,55 @@ listOpts =
)
rmOpts :: Parser RmOptions
rmOpts = RmOptions <$>
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to remove"
)
)
rmOpts =
RmOptions
<$> (option
(eitherReader
(bimap (const "Not a valid version") id . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to remove"
)
)
versionParser :: Parser Version
versionParser = option
(eitherReader (bimap (const "Not a valid version") id . version . T.pack))
(short 'v' <> long "version" <> metavar "VERSION")
toolVersionParser :: Parser ToolVersion
toolVersionParser = verP <|> toolP
where
verP = ToolVersion <$> versionParser
toolP =
ToolTag
<$> (option
(eitherReader
(\s' -> case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
other -> Left ([i|Unknown tag #{other}|])
)
)
(short 't' <> long "tag" <> metavar "TAG")
)
toolParser :: String -> Either String Tool
toolParser s | t == T.pack "ghc" = Right GHC
| t == T.pack "cabal" = Right Cabal
| otherwise = Left ("Unknown tool: " <> s)
where t = T.toLower (T.pack s)
toolParser s' | t == T.pack "ghc" = Right GHC
| t == T.pack "cabal" = Right Cabal
| otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s')
criteriaParser :: String -> Either String ListCriteria
criteriaParser s | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet
| otherwise = Left ("Unknown criteria: " <> s)
where t = T.toLower (T.pack s)
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet
| otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s')
toSettings :: Options -> Settings
@@ -246,49 +247,54 @@ main = do
runLogger
. flip runReaderT settings
. runE
@'[ FileError
@'[ AlreadyInstalled
, ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
, TagNotFound
, AlreadyInstalled
, NotInstalled
, FileDoesNotExistError
, FileError
, JSONError
, NoCompatibleArch
, NoDownload
, NotInstalled
, PlatformResultError
, ProcessError
, TagNotFound
, URLException
]
let runSetGHC =
runLogger
. flip runReaderT settings
. runE @'[NotInstalled , TagNotFound, URLException , JSONError]
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, URLException
, JSONError
, TagNotFound
]
let runListGHC =
runLogger
. flip runReaderT settings
. runE @'[URLException , JSONError]
. runE @'[FileDoesNotExistError , URLException , JSONError]
let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. flip runReaderT settings
. runE @'[NotInstalled]
. runE
@'[PlatformResultError , NoCompatibleArch , DistroNotFound]
case optCommand of
InstallGHC (InstallGHCOptions {..}) ->
void
$ (runInstTool $ do
av <- liftE getDownloads
v <- maybe
( getRecommended av GHC
?? TagNotFound Recommended GHC
)
pure
ghcVer
av <- liftE getDownloads
liftE $ installTool (ToolRequest GHC v)
Nothing
v <- liftE $ fromVersion av ghcVer GHC
liftE $ installTool (ToolRequest GHC v) Nothing
)
>>= \case
VRight _ -> runLogger
@@ -296,20 +302,14 @@ main = do
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
InstallCabal (InstallCabalOptions {..}) ->
void
$ (runInstTool $ do
av <- liftE getDownloads
v <- maybe
( getRecommended av Cabal
?? TagNotFound Recommended Cabal
)
pure
cabalVer
av <- liftE getDownloads
liftE $ installTool (ToolRequest Cabal v)
Nothing
v <- liftE $ fromVersion av cabalVer Cabal
liftE $ installTool (ToolRequest Cabal v) Nothing
)
>>= \case
VRight _ -> runLogger
@@ -317,24 +317,21 @@ main = do
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
SetGHC (SetGHCOptions {..}) ->
void
$ (runSetGHC $ do
av <- liftE getDownloads
v <- maybe
( getRecommended av GHC
?? TagNotFound Recommended GHC
)
pure
ghcVer
v <- liftE $ fromVersion av ghcVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight _ ->
runLogger $ $(logInfo) ([s|GHC successfully set|])
VLeft e -> die (color Red $ show e)
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
List (ListOptions {..}) ->
void
@@ -343,7 +340,8 @@ main = do
)
>>= \case
VRight r -> liftIO $ printListResult r
VLeft e -> die (color Red $ show e)
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Rm (RmOptions {..}) ->
void
@@ -352,11 +350,35 @@ main = do
)
>>= \case
VRight _ -> pure ()
VLeft e -> die (color Red $ show e)
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
DInfo -> do
void
$ (runDebugInfo $ do
liftE $ getDebugInfo
)
>>= \case
VRight dinfo -> putStrLn $ show dinfo
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
pure ()
fromVersion :: Monad m
=> AvailableDownloads
-> Maybe ToolVersion
-> Tool
-> Excepts '[TagNotFound] m Version
fromVersion av Nothing tool =
getRecommended av tool ?? TagNotFound Recommended tool
fromVersion _ (Just (ToolVersion v)) _ = pure v
fromVersion av (Just (ToolTag Latest)) tool =
getLatest av tool ?? TagNotFound Latest tool
fromVersion av (Just (ToolTag Recommended)) tool =
getRecommended av tool ?? TagNotFound Recommended tool
printListResult :: [ListResult] -> IO ()
printListResult lr = do
let