Compare commits

..

1 Commits

Author SHA1 Message Date
14168a41fe Lala 2020-08-27 23:39:47 +02:00
37 changed files with 756 additions and 22198 deletions

View File

@@ -17,7 +17,7 @@ variables:
BIT: "64"
.alpine:64bit:
image: "alpine:3.12"
image: "alpine:edge"
tags:
- x86_64-linux
variables:
@@ -25,7 +25,7 @@ variables:
BIT: "64"
.alpine:32bit:
image: "i386/alpine:3.12"
image: "i386/alpine:edge"
tags:
- x86_64-linux
variables:
@@ -60,12 +60,7 @@ variables:
script:
- ./.gitlab/script/ghcup_version.sh
variables:
JSON_VERSION: "0.0.3"
artifacts:
expire_in: 2 week
paths:
- golden
when: on_failure
JSON_VERSION: "0.0.2"
.test_ghcup_version:linux:
extends:
@@ -107,29 +102,6 @@ variables:
only:
- tags
######## stack test ########
test:linux:stack:
before_script:
- ./.gitlab/before_script/linux/install_deps_minimal.sh
script:
- ./.gitlab/script/ghcup_stack.sh
extends:
- .debian
######## bootstrap test ########
test:linux:bootstrap_script:
before_script:
- ./.gitlab/before_script/linux/install_deps_minimal.sh
script:
- ./.gitlab/script/ghcup_bootstrap.sh
variables:
GHC_VERSION: "8.8.4"
CABAL_VERSION: "3.2.0.0"
extends:
- .debian
######## linux test ########
test:linux:recommended:

View File

@@ -1,10 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
mkdir -p "${TMPDIR}"
sudo apt-get update -y
sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget

View File

@@ -1,30 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal --store-dir="$(pwd)"/.store "$@"
}
eghcup() {
ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
}
git describe --always
### build
ecabal update
export BOOTSTRAP_HASKELL_NONINTERACTIVE=yes
export BOOTSTRAP_HASKELL_GHC_VERSION=$GHC_VERSION
export BOOTSTRAP_HASKELL_CABAL_VERSION=$CABAL_VERSION
./bootstrap-haskell
[ "$(ghc --numeric-version)" = "${GHC_VERSION}" ]

View File

@@ -1,21 +0,0 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
git describe --always
### build
curl -L -O https://get.haskellstack.org/stable/linux-x86_64.tar.gz
tar xf linux-x86_64.tar.gz
cp stack-*-linux-*/stack "$CI_PROJECT_DIR"/.local/bin/stack
chmod +x "$CI_PROJECT_DIR"/.local/bin/stack
mkdir -p "$CI_PROJECT_DIR"/.stack_root
export TAR_OPTIONS=--no-same-owner
stack --allow-different-user --stack-root "$CI_PROJECT_DIR"/.stack_root build
stack --allow-different-user --stack-root "$CI_PROJECT_DIR"/.stack_root test

View File

@@ -20,28 +20,22 @@ git describe --always
ecabal update
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
elif [ "${OS}" = "LINUX" ] ; then
if [ "${BIT}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar ghcup-test
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
fi
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
fi
ecabal haddock -w ghc-${GHC_VERSION} -ftar
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
@@ -93,18 +87,6 @@ eghcup set ${GHC_VERSION}
eghcup rm 8.4.4
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
# install hls
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
elif [ "${OS}" = "LINUX" ] ; then
if [ "${BIT}" = "64" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
fi
fi
eghcup rm $(ghc --numeric-version)
eghcup upgrade

View File

@@ -1,24 +1,5 @@
# Revision history for ghcup
## 0.1.12 -- ????-??-??
* improve TUI:
- separators between tools sections
- reverse list order so latest is on top
- expand the blues selected bar
- show new latest versions in bright white
## 0.1.11 -- 2020-09-23
* Add support for installing haskell-language-server, wrt #65
* When compiling GHC from source create a bindist first, store that bindist in `~/.ghcup/cache` and install it, wrt #51
* Allow to compile over existing version (`ghcup compile ghc -v 8.6.5 -b 8.6.5`) and replace it wrt #59
* simplify installing from custom bindist wrt #60
- `ghcup install ghc -u <url> <version>`
* fix bug when cabal isn't marked executable in bindist
* fix bug when `~/.ghcup` is a valid symlink wrt #49
* Drop support for compiling cabal from source (the old bootstrap script is discontinued)
## 0.1.10 -- 2020-08-14
* Show stray Cabals (useful for pre-releases or compiled ones)

View File

@@ -9,15 +9,11 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
## Table of Contents
* [Installation](#installation)
* [Simple bootstrap](#simple-bootstrap)
* [Manual install](#manual-install)
* [Vim integration](#vim-integration)
* [Usage](#usage)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Cross support](#cross-support)
* [XDG support](#xdg-support)
* [Installing custom bindists](#installing-custom-bindists)
* [Design goals](#design-goals)
* [How](#how)
* [Known users](#known-users)
@@ -41,10 +37,6 @@ Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) lik
export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
```
### Vim integration
See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
## Usage
See `ghcup --help`.
@@ -115,22 +107,6 @@ Then you can control the locations via XDG environment variables as such:
* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir
* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
### Installing custom bindists
There are a couple of good use cases to install custom bindists:
1. manually built bindists (e.g. with patches)
- example: `ghcup install ghc -u 'file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz' 8.10.2-eff`
2. GHC head CI bindists
- example: `ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27' head`
3. DWARF bindists
- example: `ghcup install ghc -u 'https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz' 8.10.2-dwarf`
Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
GHCup always needs to know which version the bindist corresponds to (this is not automatically
detected).
## Design goals
1. simplicity
@@ -163,17 +139,6 @@ In addition this script can also install `cabal-install`.
## Known problems
### Custom ghc version names
When installing ghc bindists with custom version names as outlined in
[installing custom bindists](#installing-custom-bindists), then cabal might
be unable to find the correct `ghc-pkg` (also see [#73](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/73))
if you use `cabal build --with-compiler=ghc-foo`. Instead, point it to the full path, such as:
`cabal build --with-compiler=$HOME/.ghcup/ghc/<version-name>/bin/ghc` or set that GHC version
as the current one via: `ghcup set ghc <version-name>`.
This problem doesn't exist for regularly installed GHC versions.
### Limited distributions supported
Currently only GNU/Linux distributions compatible with the [upstream GHC](https://www.haskell.org/ghc/download_ghc_8_6_1.html#binaries) binaries are supported.

View File

@@ -8,6 +8,7 @@ import GHCup
import GHCup.Download
import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
@@ -55,7 +56,7 @@ validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
validate dls = do
ref <- liftIO $ newIORef 0
-- verify binary downloads --
-- * verify binary downloads * --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
@@ -122,7 +123,6 @@ validate dls = do
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Old = False
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
@@ -193,7 +193,7 @@ validateTarballs dls = do
where
downloadAll dli = do
dirs <- liftIO getDirs
let settings = Settings True False Never Curl False dirs
let settings = Settings True False Never Curl False dirs defExecCb
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

View File

@@ -1,11 +1,9 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module BrickMain where
@@ -16,122 +14,106 @@ import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import Brick
import Brick.BChan
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List ( listSelectedFocusedAttr
, listSelectedAttr
, listAttr
)
import Brick.Widgets.List
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bool
import Data.ByteString ( ByteString )
import Data.Functor
import Data.List
import Data.Maybe
import Data.Char
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector
, (!?)
)
import Data.Vector ( Vector )
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import HPath
import HPath.IO hiding ( hideError )
import Prelude hiding ( abs, appendFile, writeFile )
import System.Exit
import System.IO.Unsafe
import System.Posix.Types
import URI.ByteString
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
data SubProcess = SubProcess {
procName :: String
, exited :: Maybe (Either ProcessError ())
, procId :: Maybe ProcessID
, logLine :: Maybe ByteString
}
data AppData = AppData
{ lr :: [ListResult]
data AppState = AppState {
lr :: LR
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
}
deriving Show
data AppSettings = AppSettings
{ showAll :: Bool
}
deriving Show
, mproc :: Maybe SubProcess
}
data AppInternalState = AppInternalState
{ clr :: Vector ListResult
, ix :: Int
}
deriving Show
data MyAppEvent = LogLine ByteString
| StartProc String
| GotProcId ProcessID
| EndProc (Either ProcessError ())
data AppState = AppState
{ appData :: AppData
, appSettings :: AppSettings
, appState :: AppInternalState
}
deriving Show
type LR = GenericList String Vector ListResult
keyHandlers :: [ ( Char
, AppSettings -> String
, AppState -> EventM n (Next AppState)
)
]
keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
keyHandlers =
[ ('q', const "Quit" , halt)
, ('i', const "Install" , withIOAction install')
, ('u', const "Uninstall", withIOAction del')
, ('s', const "Set" , withIOAction set')
, ('c', const "ChangeLog", withIOAction changelog')
, ( 'a'
, (\AppSettings {..} ->
if showAll then "Hide old versions" else "Show all versions"
)
, hideShowHandler
)
[ ('q', "Quit" , halt)
, ('i', "Install" , withIOAction install')
, ('u', "Uninstall", withIOAction del')
, ('s', "Set" , withIOAction set')
, ('c', "ChangeLog", withIOAction changelog')
]
where
hideShowHandler (AppState {..}) =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
newInternalState = constructList appData newAppSettings (Just appState)
in continue (AppState appData newAppSettings newInternalState)
ui :: AppState -> Widget String
ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..}
= ( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ (header <=> hBorder <=> renderList' appState))
)
)
<=> footer
ui AppState {..} =
case mproc of
Just _ -> logDialog
Nothing ->
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ renderList renderItem True lr)
)
)
<=> ( withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
)
where
footer =
withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s as)) keyHandlers)
header =
(minHSize 2 $ emptyWidget)
<+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool")
<+> (minHSize 15 $ str "Version")
<+> (padLeft (Pad 1) $ minHSize 25 $ str "Tags")
<+> (padLeft (Pad 5) $ str "Notes")
renderList' = withDefAttr listAttr . drawListElements renderItem True
renderItem _ b listResult@(ListResult {..}) =
logDialog = case mproc of
Nothing -> emptyWidget
Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap . decUTF8Safe $ logLine
Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap $ ""
renderItem b ListResult {..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
@@ -142,93 +124,34 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..}
dim = if lNoBindist
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
else id
hooray
| elem Latest lTag && not lInstalled =
withAttr "hooray"
| otherwise = id
active = if b then forceAttr "active" else id
in hooray $ active $ dim
in dim
( marks
<+> (( padLeft (Pad 2)
$ minHSize 6
$ (printTool lTool)
)
<+> ( padLeft (Pad 2)
$ minHSize 20
$ ((if b then withAttr "active" else id)
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
)
)
<+> (minHSize 15 $ (str ver))
<+> (let l = catMaybes . fmap printTag $ sort lTag
in padLeft (Pad 1) $ minHSize 25 $ if null l
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) l
<+> (padLeft (Pad 1) $ if null lTag
then emptyWidget
else
foldr1 (\x y -> x <+> str "," <+> y)
$ (fmap printTag $ sort lTag)
)
<+> ( padLeft (Pad 5)
$ let notes = printNotes listResult
in if null notes
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) $ notes
)
<+> (vLimit 1 $ fill ' ')
)
printTag Recommended = Just $ withAttr "recommended" $ str "recommended"
printTag Latest = Just $ withAttr "latest" $ str "latest"
printTag Prerelease = Just $ withAttr "prerelease" $ str "prerelease"
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing
printTag (UnknownTag t) = Just $ str t
printTool Cabal = str "cabal"
printTool GHC = str "GHC"
printTool GHCup = str "GHCup"
printTool HLS = str "HLS"
printNotes ListResult {..} =
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
)
++ (if fromSrc then [withAttr "compiled" $ str "compiled"] else mempty)
++ (if lStray then [withAttr "stray" $ str "stray"] else mempty)
-- | Draws the list elements.
--
-- Evaluates the underlying container up to, and a bit beyond, the
-- selected element. The exact amount depends on available height
-- for drawing and 'listItemHeight'. At most, it will evaluate up to
-- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the
-- available height.
drawListElements :: (Int -> Bool -> ListResult -> Widget String)
-> Bool
-> AppInternalState
-> Widget String
drawListElements drawElem foc is@(AppInternalState clr _) =
Widget Greedy Greedy $
let
es = clr
listSelected = fmap fst $ listSelectedElement' is
drawnElements = flip V.imap es $ \i' e ->
let addSeparator w = case es !? (i' - 1) of
Just e' | lTool e' /= lTool e ->
hBorder <=> w
_ -> w
isSelected = Just i' == listSelected
elemWidget = drawElem i' isSelected e
selItemAttr = if foc
then withDefAttr listSelectedFocusedAttr
else withDefAttr listSelectedAttr
makeVisible = if isSelected then visible . selItemAttr else id
in addSeparator $ makeVisible elemWidget
in render
$ viewport "GHCup" Vertical
$ vBox
$ V.toList drawnElements
printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest"
printTag Prerelease = withAttr "prerelease" $ str "prerelease"
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState e String
app :: App AppState MyAppEvent String
app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler
, appStartEvent = return
@@ -244,13 +167,9 @@ defaultAttributes = attrMap
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("hls-powered" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
, ("compiled" , Vty.defAttr `Vty.withForeColor` Vty.blue)
, ("stray" , Vty.defAttr `Vty.withForeColor` Vty.blue)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
, ("hooray" , Vty.defAttr `Vty.withForeColor` Vty.brightWhite)
]
@@ -261,27 +180,35 @@ dimAttributes = attrMap
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
eventHandler :: AppState -> BrickEvent n MyAppEvent -> EventM n (Next AppState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState { appState = (moveCursor appState Up), .. })
continue (AppState (listMoveUp lr) dls pfreq mproc)
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState { appState = (moveCursor appState Down), .. })
continue (AppState (listMoveDown lr) dls pfreq mproc)
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
Just (_, _, handler) -> handler as
eventHandler st _ = continue st
moveCursor :: AppInternalState -> Direction -> AppInternalState
moveCursor ais@(AppInternalState {..}) direction =
let newIx = if direction == Down then ix + 1 else ix - 1
in case clr !? newIx of
Just _ -> AppInternalState { ix = newIx, .. }
Nothing -> ais
eventHandler st (AppEvent (StartProc str')) = continue st
{ mproc = Just SubProcess { procName = str'
, exited = Nothing
, procId = Nothing
, logLine = Nothing
}
}
eventHandler st@AppState { mproc = Just sp } (AppEvent (GotProcId pid)) =
continue st { mproc = Just sp { procId = Just pid } }
eventHandler st@AppState { mproc = Just sp } (AppEvent (EndProc exited)) =
continue st { mproc = Just sp { exited = Just exited, procId = Nothing } }
eventHandler st@AppState { mproc = Just sp } (AppEvent (LogLine bs)) =
continue st { mproc = Just sp { logLine = Just bs } }
eventHandler st (AppEvent _) = error "noes" -- TODO
eventHandler st _ = continue st
-- | Suspend the current UI and run an IO action in terminal. If the
@@ -289,110 +216,56 @@ moveCursor ais@(AppInternalState {..}) direction =
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
-> AppState
-> EventM n (Next AppState)
withIOAction action as = case listSelectedElement' (appState as) of
withIOAction action as = case listSelectedElement (lr as) of
Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do
action as (ix, e) >>= \case
Left err -> putStrLn $ ("Error: " <> err)
Right _ -> putStrLn "Success"
getAppData Nothing (pfreq . appData $ as) >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
-- | Update app data and list internal state based on new evidence.
-- This synchronises @AppInternalState@ with @AppData@
-- and @AppSettings@.
updateList :: AppData -> AppState -> AppState
updateList appD (AppState {..}) =
let newInternalState = constructList appD appSettings (Just appState)
in AppState { appState = newInternalState
, appData = appD
, appSettings = appSettings
}
constructList :: AppData
-> AppSettings
-> Maybe AppInternalState
-> AppInternalState
constructList appD appSettings mapp =
replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp
listSelectedElement' :: AppInternalState -> Maybe (Int, ListResult)
listSelectedElement' (AppInternalState {..}) = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int
selectLatest v =
case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
Just ix -> ix
Nothing -> 0
-- | Replace the @appState@ or construct it based on a filter function
-- and a new @[ListResult]@ evidence.
-- When passed an existing @appState@, tries to keep the selected element.
replaceLR :: (ListResult -> Bool)
-> [ListResult]
-> Maybe AppInternalState
-> AppInternalState
replaceLR filterF lr s =
let oldElem = s >>= listSelectedElement'
newVec = V.fromList . filter filterF $ lr
newSelected =
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
Just ix -> ix
Nothing -> selectLatest newVec
in AppInternalState newVec newSelected
where
toolEqual e1 e2 =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
filterVisible :: Bool -> ListResult -> Bool
filterVisible showAll e | lInstalled e = True
| showAll = True
| otherwise = not (elem Old (lTag e))
Just (ix, e) -> do
liftIO $ forkIO $ void $ action as (ix, e)
continue as
-- apps <- (fmap . fmap)
-- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
-- $ getAppState Nothing (pfreq as)
-- case apps of
-- Right nas -> do
-- putStrLn "Press enter to continue"
-- _ <- getLine
-- pure nas
-- Left err -> throwIO $ userError err
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
install' AppState { appData = AppData {..} } (_, ListResult {..}) = do
install' AppState {..} (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
let
run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
, ArchiveResult
#endif
, UnknownArchive
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate
, TarDirDoesNotExist
]
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate
, TarDirDoesNotExist
]
(run $ do
case lTool of
GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
HLS -> liftE $ installHLSBin dls lVer pfreq $> ()
)
>>= \case
VRight _ -> pure $ Right ()
@@ -415,13 +288,12 @@ set' _ (_, ListResult {..}) = do
let run =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
. runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
(run $ do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
GHCup -> pure ()
)
>>= \case
@@ -441,7 +313,6 @@ del' _ (_, ListResult {..}) = do
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
Cabal -> liftE $ rmCabalVer lVer $> ()
HLS -> liftE $ rmHLSVer lVer $> ()
GHCup -> pure ()
)
>>= \case
@@ -450,15 +321,15 @@ del' _ (_, ListResult {..}) = do
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
changelog' AppState { appData = AppData {..} } (_, ListResult {..}) = do
changelog' AppState {..} (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Just uri -> do
let cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left [i|#{e}|]
@@ -478,6 +349,7 @@ settings' = unsafePerformIO $ do
, keepDirs = Never
, downloader = Curl
, verbose = False
, execCb = (\_ _ _ _ _ -> liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "settings'")
, ..
}
@@ -492,40 +364,37 @@ logger' = unsafePerformIO
)
brickMain :: Settings
-> Maybe URI
-> LoggerConfig
-> GHCupDownloads
-> PlatformRequest
-> IO ()
brickMain s muri l av pfreq' = do
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain _ muri _ av pfreq' = do
writeIORef uri' muri
writeIORef settings' s
s <- readIORef settings'
-- logger interpreter
writeIORef logger' l
-- writeIORef logger' l
l <- readIORef logger'
let runLogger = myLoggerT l
eAppData <- getAppData (Just av) pfreq'
case eAppData of
Right ad ->
defaultMain
app
(AppState ad
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
)
$> ()
Left e -> do
eApps <- getAppState (Just av) pfreq'
case eApps of
Right as -> do
eventChan <- newBChan 1000
let builder = Vty.mkVty Vty.defaultConfig
initialVty <- builder
writeIORef settings' s{ execCb = brickExecCb eventChan }
customMain initialVty builder (Just eventChan) app (selectLatest as) $> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
exitWith $ ExitFailure 2
where
selectLatest :: AppState -> AppState
selectLatest AppState {..} =
(\ix -> AppState { lr = listMoveTo ix lr, .. })
. fromJust
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
$ (listElements lr)
defaultAppSettings :: AppSettings
defaultAppSettings = AppSettings { showAll = False }
getDownloads' :: IO (Either String GHCupDownloads)
getDownloads' = do
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
getAppState mg pfreq' = do
muri <- readIORef uri'
settings <- readIORef settings'
l <- readIORef logger'
@@ -534,30 +403,31 @@ getDownloads' = do
r <-
runLogger
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ fmap _ghcupDownloads
$ liftE
$ getDownloadsF (maybe GHCupURL OwnSource muri)
. runE
@'[JSONError, DownloadFailed, FileDoesNotExistError]
$ do
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
lV <- lift $ listVersions dls Nothing Nothing pfreq'
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq' Nothing)
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|]
getAppData :: Maybe GHCupDownloads
-> PlatformRequest
-> IO (Either String AppData)
getAppData mg pfreq' = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
brickExecCb :: BChan MyAppEvent -> ExecCb
brickExecCb chan _ fileFd stdoutRead pState lfile = do
liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "brickExecCb"
writeBChan chan (StartProc . T.unpack . decUTF8Safe $ lfile)
readLineTilEOF lineAction stdoutRead
takeMVar pState >>= \case
PExited e@(Left _) -> writeBChan chan (EndProc e)
_ -> error "no"
where
lineAction bs = do
void $ SPIB.fdWrite fileFd (bs <> "\n")
error "blah"
writeBChan chan (LogLine bs)
r <- maybe getDownloads' (pure . Right) mg
runLogger . flip runReaderT settings $ do
case r of
Right dls -> do
lV <- listVersions dls Nothing Nothing pfreq'
pure $ Right $ (AppData (reverse lV) dls pfreq')
Left e -> pure $ Left [i|#{e}|]

View File

@@ -39,6 +39,7 @@ import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Aeson ( eitherDecode )
import Data.Bifunctor
import Data.Char
import Data.Either
@@ -64,15 +65,16 @@ import System.Environment
import System.Exit
import System.IO hiding ( appendFile )
import Text.Read hiding ( lift )
import Text.Layout.Table
import URI.ByteString
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as BLU
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
@@ -116,17 +118,15 @@ prettyToolVer (ToolTag t) = show t
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI
, instBindist :: Maybe DownloadInfo
}
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
| SetHLS SetOptions
data SetOptions = SetOptions
{ sToolVer :: Maybe ToolVersion
@@ -140,7 +140,6 @@ data ListOptions = ListOptions
data RmCommand = RmGHC RmOptions
| RmCabal Version
| RmHLS Version
data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion
@@ -148,6 +147,7 @@ data RmOptions = RmOptions
data CompileCommand = CompileGHC GHCCompileOptions
| CompileCabal CabalCompileOptions
data GHCCompileOptions = GHCCompileOptions
@@ -207,8 +207,8 @@ opts =
( long "keep"
<> metavar "<always|errors|never>"
<> help
"Keep build directories? (default: errors)"
<> value Errors
"Keep build directories? (default: never)"
<> value Never
<> hidden
)
<*> option
@@ -396,29 +396,10 @@ installParser =
)
)
)
<> command
"hls"
( InstallHLS
<$> (info
(installOpts <**> helper)
( progDesc "Install haskell-languge-server"
<> footerDoc (Just $ text installHLSFooter)
)
)
)
)
)
<|> (Right <$> installOpts)
where
installHLSFooter :: String
installHLSFooter = [s|Discussion:
Installs haskell-language-server binaries and wrapper
into "~/.ghcup/bin"
Examples:
# install recommended GHC
ghcup install hls|]
installGHCFooter :: String
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
@@ -426,22 +407,13 @@ Examples:
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install recommended GHC
ghcup install ghc
# install latest GHC
ghcup install ghc latest
# install GHC 8.10.2
ghcup install ghc 8.10.2
# install GHC head fedora bindist
ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
# install GHC head
ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head|]
installOpts :: Parser InstallOptions
installOpts =
(\p (u, v) -> InstallOptions v p u)
(\p u v -> InstallOptions v p u)
<$> (optional
(option
(eitherReader platformParser)
@@ -453,19 +425,18 @@ installOpts =
)
)
)
<*> ( ( (,)
<$> (optional
(option
(eitherReader bindistParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
)
)
)
<*> (Just <$> toolVersionArgument)
<*> (optional
(option
(eitherReader bindistParser)
( short 'u'
<> long "url"
<> metavar "BINDIST_URL"
<> help
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": { \"RegexDir\": \"ghc-.*\"}, \"dlUri\": \"<uri>\" }'"
)
<|> ((,) <$> pure Nothing <*> optional toolVersionArgument)
)
)
<*> optional toolVersionArgument
setParser :: Parser (Either SetCommand SetOptions)
@@ -491,16 +462,6 @@ setParser =
)
)
)
<> command
"hls"
( SetHLS
<$> (info
(setOpts <**> helper)
( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter)
)
)
)
)
)
<|> (Right <$> setOpts)
@@ -515,10 +476,6 @@ setParser =
setCabalFooter = [s|Discussion:
Sets the the current Cabal version.|]
setHLSFooter :: String
setHLSFooter = [s|Discussion:
Sets the the current haskell-language-server version.|]
setOpts :: Parser SetOptions
setOpts = SetOptions <$> optional toolVersionArgument
@@ -561,13 +518,6 @@ rmParser =
(progDesc "Remove Cabal version")
)
)
<> command
"hls"
( RmHLS
<$> (info (versionParser' <**> helper)
(progDesc "Remove haskell-language-server version")
)
)
)
)
<|> (Right <$> rmOpts)
@@ -611,6 +561,16 @@ compileP = subparser
)
)
)
<> command
"cabal"
( CompileCabal
<$> (info
(cabalCompileOpts <**> helper)
( progDesc "Compile Cabal from source"
<> footerDoc (Just $ text compileCabalFooter)
)
)
)
)
where
compileFooter = [s|Discussion:
@@ -631,6 +591,13 @@ Examples:
ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
# build cross compiler
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
compileCabalFooter = [i|Discussion:
Compiles and installs the specified Cabal version
into "~/.ghcup/bin".
Examples:
ghcup compile cabal -j 4 -v 3.2.0.0 -b 8.6.5
ghcup compile cabal -j 4 -v 3.2.0.0 -b /usr/bin/ghc-8.6.5|]
ghcCompileOpts :: Parser GHCCompileOptions
@@ -852,8 +819,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
pure v
bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
bindistParser :: String -> Either String DownloadInfo
bindistParser = eitherDecode . BLU.fromString
toSettings :: Options -> IO Settings
@@ -864,7 +831,7 @@ toSettings Options {..} = do
downloader = optsDownloader
verbose = optVerbose
dirs <- getDirs
pure $ Settings { .. }
pure $ Settings { execCb = (\_ _ _ _ _ -> liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "toSettings"), ..}
upgradeOptsP :: Parser UpgradeOpts
@@ -943,7 +910,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
-- create ~/.ghcup dir
createDirRecursive' baseDir
createDirRecursive newDirPerms baseDir
-- logger interpreter
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]
@@ -959,9 +926,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- Effect interpreters --
-------------------------
let runInstTool' settings' =
let runInstTool =
runLogger
. flip runReaderT settings'
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -980,8 +947,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TarDirDoesNotExist
]
let runInstTool = runInstTool' settings
let
runSetGHC =
runLogger
@@ -1001,15 +966,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
]
let
runSetHLS =
runLogger
. flip runReaderT settings
. runE
@'[ NotInstalled
, TagNotFound
]
let runListGHC = runLogger . flip runReaderT settings
let runRm =
@@ -1036,7 +992,26 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
let runCompileCabal =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -1095,16 +1070,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-----------------------
let installGHC InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
case instBindist of
Nothing -> liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installGHCBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
)
>>= \case
VRight _ -> do
@@ -1112,7 +1082,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
[i|GHC ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
@@ -1136,16 +1106,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
case instBindist of
Nothing -> liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installCabalBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
)
>>= \case
VRight _ -> do
@@ -1153,7 +1118,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed, you may want to run 'ghcup rm cabal #{prettyVer v}' first|]
[i|Cabal ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V NoDownload) -> do
@@ -1168,40 +1133,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do
v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("HLS installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|HLS ver #{prettyVer v} already installed, you may want to run 'ghcup rm hls #{prettyVer v}' first|]
pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available HLS version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended HLS version|]
pure $ ExitFailure 4
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
(runSetGHC $ do
v <- liftE $ fromVersion dls sToolVer GHC
@@ -1228,17 +1159,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 14
let setHLS' SetOptions{..} =
(runSetHLS $ do
v <- liftE $ fromVersion dls sToolVer HLS
liftE $ setHLS (_tvVersion v)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRm $ do
liftE $ rmGHCVer ghcVer
@@ -1259,15 +1179,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15
let rmHLS' tv =
(runRm $ do
liftE $ rmHLSVer tv
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15
res <- case optCommand of
@@ -1279,7 +1190,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
installGHC iopts
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
installCabal iopts
@@ -1289,7 +1199,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
setGHC' sopts
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
Set (Left (SetHLS sopts)) -> setHLS' sopts
List (ListOptions {..}) ->
(runListGHC $ do
@@ -1303,7 +1212,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
rmGHC' rmopts
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
DInfo ->
do
@@ -1333,7 +1241,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
[i|GHC ver #{prettyVer v} already installed|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
@@ -1347,6 +1255,28 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 9
Compile (CompileCabal CabalCompileOptions {..}) ->
(runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
)
>>= \case
VRight _ -> do
runLogger
($(logInfo)
"Cabal successfully compiled and installed"
)
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 10
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 10
Upgrade (uOpts) force -> do
target <- case uOpts of
UpgradeInplace -> do
@@ -1463,145 +1393,49 @@ printListResult raw lr = do
setLocaleEncoding utf8
let
rows =
(\x -> if raw
then x
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
)
. fmap
formatted =
gridString
( (if raw then [] else [column expand left def def])
++ [ column expand left def def
, column expand left def def
, column expand left def def
, column expand left def def
]
)
. (\x -> if raw
then x
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
)
$ fmap
(\ListResult {..} ->
let marks = if
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green " ")
| otherwise -> (color Red " ")
in
(if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
, intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag)
, intercalate ","
$ (if hlsPowered
then [color' Green "hls-powered"]
else mempty
)
++ (if fromSrc then [color' Blue "compiled"] else mempty)
++ (if lStray then [color' Yellow "stray"] else mempty)
++ (if lNoBindist
then [color' Red "no-bindist"]
else mempty
)
]
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
in (if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
, intercalate "," $ (fmap printTag $ sort lTag)
, intercalate ","
$ (if fromSrc then [color' Blue "compiled"] else mempty)
++ (if lStray then [color' Yellow "stray"] else mempty)
++ (if lNoBindist then [color' Red "no-bindist"] else mempty)
]
)
$ lr
let cols =
foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
lengths = fmap maximum . (fmap . fmap) strWidth $ cols
padded = fmap (\xs -> zipWith padTo xs lengths) rows
forM_ padded $ \row -> putStrLn $ intercalate " " row
lr
putStrLn $ formatted
where
printTag Recommended = color' Green "recommended"
printTag Latest = color' Yellow "latest"
printTag Prerelease = color' Red "prerelease"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
printTag Old = ""
color' = case raw of
True -> flip const
False -> color
padTo str' x =
let lstr = strWidth str'
add' = x - lstr
in if add' < 0 then str' else str' ++ replicate add' ' '
-- | Calculate the render width of a string, considering
-- wide characters (counted as double width), ANSI escape codes
-- (not counted), and line breaks (in a multi-line string, the longest
-- line determines the width).
strWidth :: String -> Int
strWidth =
maximum
. (0 :)
. map (foldr (\a b -> charWidth a + b) 0)
. lines
. stripAnsi
-- | Strip ANSI escape sequences from a string.
--
-- >>> stripAnsi "\ESC[31m-1\ESC[m"
-- "-1"
stripAnsi :: String -> String
stripAnsi s' =
case
MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
of
Nothing -> error "Bad ansi escape" -- PARTIAL: should not happen
Just xs -> concat xs
where
-- This parses lots of invalid ANSI escape codes, but that should be fine
ansi =
MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
Void
String
Char
digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
-- | Get the designated render width of a character: 0 for a combining
-- character, 1 for a regular character, 2 for a wide character.
-- (Wide characters are rendered as exactly double width in apps and
-- fonts that support it.) (From Pandoc.)
charWidth :: Char -> Int
charWidth c = case c of
_ | c < '\x0300' -> 1
| c >= '\x0300' && c <= '\x036F' -> 0
| -- combining
c >= '\x0370' && c <= '\x10FC' -> 1
| c >= '\x1100' && c <= '\x115F' -> 2
| c >= '\x1160' && c <= '\x11A2' -> 1
| c >= '\x11A3' && c <= '\x11A7' -> 2
| c >= '\x11A8' && c <= '\x11F9' -> 1
| c >= '\x11FA' && c <= '\x11FF' -> 2
| c >= '\x1200' && c <= '\x2328' -> 1
| c >= '\x2329' && c <= '\x232A' -> 2
| c >= '\x232B' && c <= '\x2E31' -> 1
| c >= '\x2E80' && c <= '\x303E' -> 2
| c == '\x303F' -> 1
| c >= '\x3041' && c <= '\x3247' -> 2
| c >= '\x3248' && c <= '\x324F' -> 1
| -- ambiguous
c >= '\x3250' && c <= '\x4DBF' -> 2
| c >= '\x4DC0' && c <= '\x4DFF' -> 1
| c >= '\x4E00' && c <= '\xA4C6' -> 2
| c >= '\xA4D0' && c <= '\xA95F' -> 1
| c >= '\xA960' && c <= '\xA97C' -> 2
| c >= '\xA980' && c <= '\xABF9' -> 1
| c >= '\xAC00' && c <= '\xD7FB' -> 2
| c >= '\xD800' && c <= '\xDFFF' -> 1
| c >= '\xE000' && c <= '\xF8FF' -> 1
| -- ambiguous
c >= '\xF900' && c <= '\xFAFF' -> 2
| c >= '\xFB00' && c <= '\xFDFD' -> 1
| c >= '\xFE00' && c <= '\xFE0F' -> 1
| -- ambiguous
c >= '\xFE10' && c <= '\xFE19' -> 2
| c >= '\xFE20' && c <= '\xFE26' -> 1
| c >= '\xFE30' && c <= '\xFE6B' -> 2
| c >= '\xFE70' && c <= '\xFEFF' -> 1
| c >= '\xFF01' && c <= '\xFF60' -> 2
| c >= '\xFF61' && c <= '\x16A38' -> 1
| c >= '\x1B000' && c <= '\x1B001' -> 2
| c >= '\x1D000' && c <= '\x1F1FF' -> 1
| c >= '\x1F200' && c <= '\x1F251' -> 2
| c >= '\x1F300' && c <= '\x1F773' -> 1
| c >= '\x20000' && c <= '\x3FFFD' -> 2
| otherwise -> 1
checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads
-> PlatformRequest
@@ -1627,13 +1461,6 @@ checkForUpdates dls pfreq = do
$ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
forM_ (getLatest dls HLS) $ \l -> do
mcabal_ver <- latestInstalled HLS
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn)
[i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
@@ -1649,4 +1476,20 @@ GHCup cache directory: #{toFilePath diCacheDir}
Architecture: #{prettyArch diArch}
Platform: #{prettyPlatform diPlatform}
Version: #{describe_result}|]
where
prettyArch :: Architecture -> String
prettyArch A_64 = "amd64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "PowerPC"
prettyArch A_PowerPC64 = "PowerPC64"
prettyArch A_Sparc = "Sparc"
prettyArch A_Sparc64 = "Sparc64"
prettyArch A_ARM = "ARM"
prettyArch A_ARM64 = "ARM64"
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat

View File

@@ -59,7 +59,7 @@ _done() {
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.11"
_ghver="0.1.10"
_base_url="https://downloads.haskell.org/~ghcup"
case "${_plat}" in
@@ -188,30 +188,7 @@ printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Installation done!"
printf "\\033[0;35m%s\\033[0m\\n" ""
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
printf "\\033[0;35m%s\\033[0m\\n" "Do you want to install haskell-language-server (HLS) now?"
printf "\\033[0;35m%s\\033[0m\\n" "HLS is a language-server that provides IDE-like functionality"
printf "\\033[0;35m%s\\033[0m\\n" "and can integrate with different editors, such as Vim, Emacs, VS Code, Atom, ..."
printf "\\033[0;35m%s\\033[0m\\n" "Also see https://github.com/haskell/haskell-language-server/blob/master/README.md"
printf "\\033[0;35m%s\\033[0m\\n" ""
printf "\\033[0;35m%s\\033[0m\\n" "Answer with YES or NO and press ENTER."
printf "\\033[0;35m%s\\033[0m\\n" ""
while true; do
read -r hls_answer </dev/tty
case $hls_answer in
[Yy]*)
eghcup --cache install hls
break ;;
[Nn]*)
break ;;
*)
echo "Please type YES or NO and press enter.";;
esac
done
echo "In order to run ghc and cabal, you need to adjust your PATH variable."
echo "You may want to source '$GHCUP_DIR/env' in your shell"
echo "configuration to do so (e.g. ~/.bashrc)."
@@ -258,23 +235,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
bash)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi
case "$(uname -s)" in
"Darwin"|"darwin")
if ! grep -q "ghcup-env" "${HOME}/.bash_profile" ; then
echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
fi
;;
esac
break ;;
zsh)
*)
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
fi

View File

@@ -1,52 +0,0 @@
-- Generated by stackage-to-hackage
index-state: 2020-10-05T20:10:01Z
with-compiler: ghc-8.8.4
packages:
./
, 3rdparty/lzma/
, 3rdparty/lzma-clib/
, 3rdparty/zlib/
source-repository-package
type: git
location: https://github.com/haskus/packages.git
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdir: haskus-utils-types
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-io
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-directory
source-repository-package
type: git
location: https://github.com/hasufell/text-conversions.git
tag: 9abf0e5e5664a3178367597c32db19880477a53c
allow-older: *
allow-newer: *
package lzma
ghc-options: -O2
package lzma-clib
ghc-options: -O2
package zlib
ghc-options: -O2
package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package streamly
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

File diff suppressed because it is too large Load Diff

View File

@@ -8,18 +8,6 @@ source-repository-package
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdir: haskus-utils-types
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-io
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-directory
optimization: 2
package streamly
@@ -31,6 +19,6 @@ package ghcup
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
flags: +static
allow-newer: base, ghc-prim, template-haskell

View File

@@ -1159,7 +1159,7 @@ ghcupDownloads:
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-alpine3.10-linux-integer-simple.tar.xz
dlSubdir: ghc-8.10.2-x86_64-unknown-linux
dlSubdir: ghc-8.10.2
dlHash: 14d09a508f2a3a11875c140be8e6c5f6982ac5cd448f089ca10b7adc955fec76
Linux_AmazonLinux:
unknown_versioning: *ghc-8102-64-centos
@@ -1197,6 +1197,10 @@ ghcupDownloads:
2.4.1.0:
viTags: []
viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/changelog
viSourceDL:
dlUri: https://github.com/haskell/cabal/archive/cabal-install-v2.4.1.0.tar.gz
dlSubdir: cabal-cabal-install-v2.4.1.0/cabal-install
dlHash: 61eb64a5addafca026aff9277291f4643fe07e83886f76d059d42c734fed829c
viArch:
A_64:
Linux_Alpine:
@@ -1228,6 +1232,10 @@ ghcupDownloads:
3.0.0.0:
viTags: []
viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/changelog
viSourceDL:
dlUri: https://github.com/haskell/cabal/archive/cabal-install-v3.0.0.0.tar.gz
dlSubdir: cabal-cabal-install-v3.0.0.0/cabal-install
dlHash: c0b26817a7b7c2907e45cb38235ce1157e732211880f62e92eaff4066202e674
viArch:
A_64:
Linux_Alpine:
@@ -1260,6 +1268,10 @@ ghcupDownloads:
- Recommended
- Latest
viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/changelog
viSourceDL:
dlUri: https://github.com/haskell/cabal/archive/cabal-install-v3.2.0.0.tar.gz
dlSubdir: cabal-cabal-install-v3.2.0.0/cabal-install
dlHash: 77202358bdf0b481c09326268ce18880df14194c5aaa840f99510bdd1a124b75
viArch:
A_64:
Linux_Alpine:
@@ -1287,32 +1299,31 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-i386-unknown-linux.tar.xz
dlHash: 2b3ac28549916de5f3379241797eaf60e84b6c001f2abbe73d9fadbbaf768e93
3.4.0.0-rc3:
3.4.0.0-rc1:
viTags:
- Prerelease
viChangeLog: https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.0.0.md
viArch:
A_64:
Linux_Ubuntu:
unknown_versioning: &cabal-3400rc3-ubuntu
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz
dlHash: a97f0362b8cdc78ba4a7891f8b288082dc11e20c64b1b3c8e6c2bd3766446d10
unknown_versioning: &cabal-3400rc1-ubuntu
dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz
dlHash: 4a693eeacf91993d639b0296a366af7aec6899992352595835f7671e5adef4c6
Linux_Alpine:
unknown_versioning:
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-alpine-3.11.6-static-noofd.tar.xz
dlHash: a82c7dc7e46da823f6a982465b9b29e0640a5ce2e5b573d3dd55a47e20740305
dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-x86_64-alpine-3.11.6-static-noofd.tar.xz
dlHash: 143160e1768c9c21bad613f720a37aad34051f41fb3473f5f28c030f9ccb7aca
Linux_UnknownLinux:
unknown_versioning: *cabal-3400rc3-ubuntu
unknown_versioning: *cabal-3400rc1-ubuntu
Darwin:
unknown_versioning:
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-darwin-sierra.tar.xz
dlHash: 4553eaea3031c09ab5156af8d4a62bf1ecbbea2c3b57a876f267cbf4b5a15658
dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-x86_64-darwin-sierra.tar.xz
dlHash: 98e362a57c3b5c1a76f75ede2c2a7c29439902a3e21c3e4f8dcd701e276b164f
FreeBSD:
unknown_versioning:
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-freebsd-12.1-release.tar.xz
dlHash: 44e25e0b0d15361acb369f4bf2206a39d2432a08fb922cc40a9b8a045d0a3a6f
dlUri: http://oleg.fi/cabal-install-3.4.0.0-rc1/cabal-install-3.4.0.0-amd64-freebsd-12.1-release.tar.xz
dlHash: 0035cc5d35db15d254037a9448697e1daff0a6d21b12c8d43d72522c82cc7319
GHCup:
0.1.11:
0.1.10:
viTags:
- Recommended
- Latest
@@ -1322,22 +1333,22 @@ ghcupDownloads:
A_64:
Linux_UnknownLinux:
unknown_versioning: &ghcup-64
dlUri: https://downloads.haskell.org/~ghcup/0.1.11/x86_64-linux-ghcup-0.1.11
dlHash: 99d97c9a1dce76892001e5cffd50cc23bf804f2282998c546d1b965aa2179699
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-linux-ghcup-0.1.10
dlHash: 87661bd127f857b990174ac8d96ad4bd629865306b2058c8cc64d3b36ed317c9
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.11/x86_64-apple-darwin-ghcup-0.1.11
dlHash: 4b91dcd9bfdc40534156b8fadea3f317b3c44af1255169895f4911a221f819c6
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-apple-darwin-ghcup-0.1.10
dlHash: e71666fde6a7700f307e1a55720859d3a042fe27c68ff32f3d1181f4436b7391
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.11/x86_64-portbld-freebsd-ghcup-0.1.11
dlHash: 6f04ce98d3f3eb9299ce74f8264aa956f0dc38a64a3bd12ee048b7f146e9e1b4
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-portbld-freebsd-ghcup-0.1.10
dlHash: b5ef1b0454f1a9c5a62b378c1e9c48c2b794d64a22086adf482b064dfb34e68d
Linux_Alpine:
unknown_versioning: *ghcup-64
A_32:
Linux_UnknownLinux:
unknown_versioning: &ghcup-32
dlUri: https://downloads.haskell.org/~ghcup/0.1.11/i386-linux-ghcup-0.1.11
dlHash: ec339e4c2b8b4d502f66a03c0d3f112cb68cd922dd3c4a6f66323628cf6a76c2
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/i386-linux-ghcup-0.1.10
dlHash: 50ac43199b64bc0724400b0a3db674bef3ec53cf6d41acc04a2c4ca8557e534f
Linux_Alpine:
unknown_versioning: *ghcup-32

File diff suppressed because it is too large Load Diff

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.12
version: 0.1.10
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
@@ -81,9 +81,6 @@ common containers
common cryptohash-sha256
build-depends: cryptohash-sha256 >= 0.11.101.0
common generic-arbitrary
build-depends: generic-arbitrary >=0.1.0
common generics-sop
build-depends: generics-sop >=0.5
@@ -97,13 +94,13 @@ common hpath
build-depends: hpath >=0.11
common hpath-directory
build-depends: hpath-directory >=0.14.1
build-depends: hpath-directory >=0.14
common hpath-filepath
build-depends: hpath-filepath >=0.10.3
common hpath-io
build-depends: hpath-io >=0.14.1
build-depends: hpath-io >=0.14
common hpath-posix
build-depends: hpath-posix >=0.13.2
@@ -111,17 +108,11 @@ common hpath-posix
common http-io-streams
build-depends: http-io-streams >=0.1.2.0
common hspec
build-depends: hspec >=2.7.4
common hspec-golden-aeson
build-depends: hspec-golden-aeson >=0.7
common io-streams
build-depends: io-streams >=1.5
common libarchive
build-depends: libarchive >= 3.0.0.0
build-depends: libarchive >= 2.2.5.0
common lzma
build-depends: lzma >=0.0.0.3
@@ -180,6 +171,9 @@ common strict-base
common string-interpolate
build-depends: string-interpolate >=0.2.0.0
common table-layout
build-depends: table-layout >=0.8
common template-haskell
build-depends: template-haskell >=2.7
@@ -201,12 +195,6 @@ common transformers
common os-release
build-depends: os-release >=1.0.0
common QuickCheck
build-depends: QuickCheck >=2.14.1
common quickcheck-arbitrary-adt
build-depends: quickcheck-arbitrary-adt >=0.3.1.0
common unix
build-depends: unix >=2.7
@@ -252,6 +240,8 @@ common config
PackageImports
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
library
@@ -331,10 +321,6 @@ library
GHCup.Utils.Version.QQ
GHCup.Version
default-extensions:
Strict
StrictData
-- other-modules:
-- other-extensions:
hs-source-dirs: lib
@@ -375,8 +361,10 @@ executable ghcup
, safe
, safe-exceptions
, string-interpolate
, table-layout
, template-haskell
, text
, unix-bytestring
, uri-bytestring
, utf8-string
, versions
@@ -390,10 +378,6 @@ executable ghcup
hs-source-dirs: app/ghcup
default-language: Haskell2010
default-extensions:
Strict
StrictData
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
@@ -429,6 +413,7 @@ executable ghcup-gen
, resourcet
, safe-exceptions
, string-interpolate
, table-layout
, text
, transformers
, uri-bytestring
@@ -447,25 +432,8 @@ executable ghcup-gen
default-language: Haskell2010
test-suite ghcup-test
import:
config
, base
, bytestring
, containers
, QuickCheck
, generic-arbitrary
, hpath
, hspec
, hspec-golden-aeson
, quickcheck-arbitrary-adt
, text
, uri-bytestring
, versions
default-language: Haskell2010
type: exitcode-stdio-1.0
build-depends: ghcup
hs-source-dirs: test
main-is: Main.hs
other-modules:
GHCup.ArbitraryTypes
GHCup.Types.JSONSpec
Spec
main-is: MyLibTest.hs
build-depends: base >=4.12.0.0

File diff suppressed because it is too large Load Diff

View File

@@ -1,19 +1,4 @@
cradle:
cabal:
- path: "./lib"
component: "lib:ghcup"
- path: "./app/ghcup/Main.hs"
component: "ghcup:exe:ghcup"
- path: "./app/ghcup/BrickMain.hs"
component: "ghcup:exe:ghcup"
- path: "./app/ghcup-gen/Main.hs"
component: "ghcup:exe:ghcup-gen"
- path: "./app/ghcup-gen/Validate.hs"
component: "ghcup:exe:ghcup-gen"
- path: "./test"
component: "ghcup:test:ghcup-test"
- path: "."
component: "ghcup:lib:ghcup"

View File

@@ -75,12 +75,9 @@ import Prelude hiding ( abs
import Safe hiding ( at )
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import System.Posix.FilePath ( getSearchPath, takeExtension )
import System.Posix.FilePath ( getSearchPath )
import System.Posix.Files.ByteString
import Text.Regex.Posix
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
@@ -122,7 +119,7 @@ installGHCBindist :: ( MonadFail m
]
m
()
installGHCBindist dlinfo ver pfreq = do
installGHCBindist dlinfo ver (PlatformRequest {..}) = do
let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver)
@@ -131,79 +128,41 @@ installGHCBindist dlinfo ver pfreq = do
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver pfreq
liftE $ postGHCInstall tver
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
-- build system and nothing else.
installPackedGHC :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Path Abs -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> Path Abs -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts
'[ BuildFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(msubdir)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver pfreq)
liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
liftE $ postGHCInstall tver
-- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else.
installUnpackedGHC :: ( MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver (PlatformRequest {..}) = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "./configure"
False
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ make ["install"] (Just path)
pure ()
where
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC' path inst = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "./configure"
False
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
(Just path)
Nothing
lEM $ make ["install"] (Just path)
pure ()
alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
= ["--disable-ld-override"]
| otherwise
= []
| ver >= [vver|8.2.2|]
, Linux Alpine <- _rPlatform = ["--disable-ld-override"]
| otherwise = []
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -313,7 +272,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
installCabal' path inst = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|]
liftIO $ createDirRecursive' inst
liftIO $ createDirRecursive newDirPerms inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
@@ -357,130 +316,6 @@ installCabalBin bDls ver pfreq = do
installCabalBindist dlinfo ver pfreq
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installHLSBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
Settings {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver))
$ (throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installHLS' workdir binDir
-- create symlink if this is the latest version
hlsVers <- lift $ fmap rights $ getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
pure ()
where
-- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked hls bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[CopyError] m ()
installHLS' path inst = do
lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(inst </> toF)
Overwrite
lift $ chmod_777 (inst </> toF)
-- install haskell-language-server-wrapper
let wrapper = [rel|haskell-language-server-wrapper|]
toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper)
(inst </> toF)
Overwrite
lift $ chmod_777 (inst </> toF)
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installHLSBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo HLS ver pfreq bDls
installHLSBindist dlinfo ver pfreq
---------------------
@@ -516,7 +351,7 @@ setGHC ver sghc = do
-- symlink destination
Settings { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
@@ -588,7 +423,7 @@ setCabal ver = do
-- symlink destination
Settings {dirs = Dirs {..}} <- lift ask
liftIO $ createDirRecursive' binDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
$ throwE
@@ -611,55 +446,6 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
setHLS ver = do
Settings { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir
-- Delete old symlinks, since these might have different ghc versions than the
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver
when (bins == []) $ throwE $ NotInstalled HLS (prettyVer ver)
forM_ bins $ \f -> do
let destL = toFilePath f
target <- parseRel . head . B.split _tilde . toFilePath $ f
lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
liftIO $ createSymlink (binDir </> target) destL
-- set haskell-language-server-wrapper symlink
let destL = "haskell-language-server-wrapper-" <> verToBS ver
let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
liftIO $ createSymlink wrapper destL
pure ()
------------------
@@ -684,7 +470,6 @@ data ListResult = ListResult
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool
}
deriving (Eq, Ord, Show)
@@ -718,25 +503,22 @@ listVersions av lt criteria pfreq = do
lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
case t of
-- append stray GHCs
GHC -> do
slr <- strayGHCs avTools
pure $ (sort (slr ++ lr))
Cabal -> do
slr <- strayCabals avTools
pure $ (sort (slr ++ lr))
HLS -> do
slr <- strayHLS avTools
pure $ (sort (slr ++ lr))
GHCup -> pure lr
_ -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria pfreq
cabalvers <- listVersions av (Just Cabal) criteria pfreq
hlsvers <- listVersions av (Just HLS) criteria pfreq
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
pure (ghcvers <> cabalvers <> ghcupvers)
where
strayGHCs :: (MonadCatch m, MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayGHCs avTools = do
@@ -748,7 +530,6 @@ listVersions av lt criteria pfreq = do
Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -762,7 +543,6 @@ listVersions av lt criteria pfreq = do
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -798,35 +578,6 @@ listVersions av lt criteria pfreq = do
, lStray = maybe True (const False) (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
strayHLS :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayHLS avTools = do
hlss <- getInstalledHLSs
fmap catMaybes $ forM hlss $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (== ver)) $ hlsSet
pure $ Just $ ListResult
{ lTool = HLS
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = maybe True (const False) (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
@@ -843,7 +594,6 @@ listVersions av lt criteria pfreq = do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) $ hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
@@ -855,7 +605,6 @@ listVersions av lt criteria pfreq = do
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
GHCup -> do
@@ -868,20 +617,6 @@ listVersions av lt criteria pfreq = do
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, ..
}
HLS -> do
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
lSet <- fmap (maybe False (== v)) $ hlsSet
lInstalled <- hlsInstalled v
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
@@ -973,35 +708,6 @@ rmCabalVer ver = do
(binDir </> [rel|cabal|])
-- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version).
rmHLSVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (prettyVer ver))
isHlsSet <- lift $ hlsSet
Settings {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
when (maybe False (== ver) isHlsSet) $ do
-- delete all set symlinks
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
-- set latest hls
hlsVers <- lift $ fmap rights $ getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver
Nothing -> pure ()
------------------
--[ Debug info ]--
@@ -1060,74 +766,51 @@ compileGHC :: ( MonadMask m
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformRequest {..})
= do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (lift $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
alreadyInstalled <- lift $ ghcInstalled tver
alreadySet <- fmap (maybe False (==tver)) $ lift $ ghcSet (_tvTarget tver)
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
liftE $ runBuildAction
tmpUnpack
(Just ghcdir)
(compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir)
(bindist, bmk) <- liftE $ runBuildAction
tmpUnpack
Nothing
(do
b <- compileBindist bghc ghcdir workdir
bmk <- liftIO $ readFileStrict (build_mk workdir)
pure (b, bmk)
)
when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver
liftE $ installPackedGHC bindist
(view dlSubdir dlInfo)
ghcdir
(tver ^. tvVersion)
pfreq
liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
reThrowAll GHCupSetError $ postGHCInstall tver
-- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
pure ()
reThrowAll GHCupSetError $ postGHCInstall tver
pure ()
where
defaultConf = case _tvTarget tver of
Nothing -> [s|
Nothing -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|]
Just _ -> [s|
Just _ -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
@@ -1135,26 +818,23 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
Stage1Only = YES|]
compileBindist :: ( MonadReader Settings m
, MonadThrow m
, MonadCatch m
, MonadLogger m
, MonadIO m
, MonadFail m
)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> Path Abs
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Path Abs) -- ^ output path of bindist
compileBindist bghc ghcdir workdir = do
compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> Path Abs
-> Excepts
'[ FileDoesNotExistError
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
]
m
()
compile bghc ghcdir workdir = do
lift $ $(logInfo) [i|configuring build|]
liftE $ checkBuildConfig
Settings { dirs = Dirs {..} } <- lift ask
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
cEnv <- liftIO $ getEnvironment
@@ -1176,7 +856,6 @@ Stage1Only = YES|]
)
++ fmap E.encodeUtf8 aargs
)
[rel|ghc-conf|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
| otherwise -> do
@@ -1192,7 +871,6 @@ Stage1Only = YES|]
)
++ fmap E.encodeUtf8 aargs
)
[rel|ghc-conf|]
(Just workdir)
(Just cEnv)
@@ -1205,49 +883,29 @@ Stage1Only = YES|]
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
lift $ $(logInfo) [i|Creating bindist...|]
lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles
workdir
(makeRegexOpts compExtended
execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
c <- liftIO $ readFile (workdir </> tar)
cDigest <-
fmap (T.take 8)
. lift
. throwEither
. E.decodeUtf8'
. B16.encode
. SHA256.hashlazy
$ c
tarName <-
parseRel
[i|ghc-#{prettyTVer tver}-#{prettyPfReq pfreq}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath
Strict
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
pure tarPath
lift $ $(logInfo) [i|Installing...|]
lEM $ make ["install"] (Just workdir)
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
liftIO $ copyFile (build_mk workdir) dest Overwrite
build_mk workdir = workdir </> [rel|mk/build.mk|]
checkBuildConfig :: (MonadCatch m, MonadIO m)
=> Excepts
'[FileDoesNotExistError, InvalidBuildConfig]
'[FileDoesNotExistError , InvalidBuildConfig]
m
()
checkBuildConfig = do
c <- case mbuildConfig of
Just bc -> do
BL.toStrict <$> liftIOException
doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ readFile bc)
BL.toStrict <$> liftIOException doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ readFile bc)
Nothing -> pure defaultConf
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
@@ -1261,6 +919,121 @@ Stage1Only = YES|]
-- | Compile a cabal from source. This behaves wrt symlinks and installation
-- the same as 'installCabalBin'.
compileCabal :: ( MonadReader Settings m
, MonadResource m
, MonadMask m
, MonadLogger m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int
-> Maybe (Path Abs)
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
Settings {dirs = Dirs {..}} <- lift ask
whenM
(lift (cabalInstalled tver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal tver)
-- download source tarball
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
cbin
(binDir </> destFileName)
Overwrite
-- create symlink if this is the latest version
cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
pure ()
where
compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
compile workdir = do
lift $ $(logInfo) [i|Building (this may take a while)...|]
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
ghcEnv <- case bghc of
Right path -> do
-- recover the version from /foo/ghc-6.5.4
bn <- basename path
let dn = toFilePath $ dirname path
let ver = snd . B.break (== _hyphen) . toFilePath $ bn
pure
[ ("GHC" , toFilePath path)
, ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver)
, ("HADDOCK", dn <> "/" <> "haddock" <> ver)
]
Left bver -> do
let v' = verToBS bver
pure
[ ("GHC" , "ghc-" <> v')
, ("GHC_PKG", "ghc-pkg-" <> v')
, ("HADDOCK", "haddock-" <> v')
]
tmp <- lift withGHCupTmpDir
liftIO $ createDirRecursive newDirPerms (tmp </> [rel|bin|])
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
lEM $ execLogged "./bootstrap.sh"
False
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
(Just workdir)
(Just newEnv)
pure $ (tmp </> [rel|bin/cabal|])
---------------------
--[ Upgrade GHCup ]--

View File

@@ -226,7 +226,7 @@ getDownloads urlSource = do
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
else do
liftIO $ createDirRecursive' cacheDir
liftIO $ createDirRecursive newDirPerms cacheDir
getModTime >>= \case
Just modTime -> dlWithMod modTime json_file
Nothing -> do
@@ -330,7 +330,7 @@ download dli dest mfn
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
cp = do
-- destination dir must exist
liftIO $ createDirRecursive' dest
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
@@ -340,7 +340,7 @@ download dli dest mfn
lift $ $(logInfo) [i|downloading: #{uri'}|]
-- destination dir must exist
liftIO $ createDirRecursive' dest
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
destFile <- getDestFile
-- download

View File

@@ -13,6 +13,7 @@ module GHCup.Download.IOStreams where
import GHCup.Download.Utils
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.File

View File

@@ -152,10 +152,3 @@ data ParseError = ParseError String
deriving Show
instance Exception ParseError
data UnexpectedListLength = UnexpectedListLength String
deriving Show
instance Exception UnexpectedListLength

View File

@@ -48,7 +48,7 @@ prettyRequirements :: Requirements -> T.Text
prettyRequirements Requirements {..} =
let d = if not . null $ _distroPKGs
then
"\n Please install the following distro packages: "
"\n Install the following distro packages: "
<> T.intercalate " " _distroPKGs
else ""
n = if not . T.null $ _notes then "\n Note: " <> _notes else ""

View File

@@ -1,6 +1,10 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-|
Module : GHCup.Types
@@ -13,13 +17,15 @@ Portability : POSIX
-}
module GHCup.Types where
import Control.Concurrent.MVar
import Data.ByteString ( ByteString )
import Data.Map.Strict ( Map )
import Data.Text ( Text )
import Data.Versions
import HPath
import URI.ByteString
import System.Posix.Types
import qualified Data.Text as T
import qualified GHC.Generics as GHC
@@ -76,7 +82,6 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
data Tool = GHC
| Cabal
| GHCup
| HLS
deriving (Eq, GHC.Generic, Ord, Show)
@@ -88,7 +93,7 @@ data VersionInfo = VersionInfo
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
}
deriving (Eq, GHC.Generic, Show)
deriving (Eq, Show)
-- | A tag. These are currently attached to a version of a tool.
@@ -96,9 +101,8 @@ data Tag = Latest
| Recommended
| Prerelease
| Base PVP
| Old -- ^ old version are hidden by default in TUI
| UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
deriving (Ord, Eq, Show) -- FIXME: manual JSON instance
data Architecture = A_64
@@ -111,15 +115,6 @@ data Architecture = A_64
| A_ARM64
deriving (Eq, GHC.Generic, Ord, Show)
prettyArch :: Architecture -> String
prettyArch A_64 = "x86_64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "powerpc"
prettyArch A_PowerPC64 = "powerpc64"
prettyArch A_Sparc = "sparc"
prettyArch A_Sparc64 = "sparc64"
prettyArch A_ARM = "arm"
prettyArch A_ARM64 = "aarch64"
data Platform = Linux LinuxDistro
-- ^ must exit
@@ -128,11 +123,6 @@ data Platform = Linux LinuxDistro
| FreeBSD
deriving (Eq, GHC.Generic, Ord, Show)
prettyPlatfrom :: Platform -> String
prettyPlatfrom (Linux distro) = "linux-" ++ prettyDistro distro
prettyPlatfrom Darwin = "darwin"
prettyPlatfrom FreeBSD = "freebsd"
data LinuxDistro = Debian
| Ubuntu
| Mint
@@ -149,19 +139,6 @@ data LinuxDistro = Debian
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
prettyDistro :: LinuxDistro -> String
prettyDistro Debian = "debian"
prettyDistro Ubuntu = "ubuntu"
prettyDistro Mint= "mint"
prettyDistro Fedora = "fedora"
prettyDistro CentOS = "centos"
prettyDistro RedHat = "redhat"
prettyDistro Alpine = "alpine"
prettyDistro AmazonLinux = "amazon"
prettyDistro Gentoo = "gentoo"
prettyDistro Exherbo = "exherbo"
prettyDistro UnknownLinux = "unknown"
-- | An encapsulation of a download. This can be used
-- to download, extract and install a tool.
@@ -170,7 +147,7 @@ data DownloadInfo = DownloadInfo
, _dlSubdir :: Maybe TarDir
, _dlHash :: Text
}
deriving (Eq, GHC.Generic, Show)
deriving (Eq, Show)
@@ -183,14 +160,35 @@ data DownloadInfo = DownloadInfo
-- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, GHC.Generic, Show)
deriving (Eq, Show)
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupInfo
deriving (GHC.Generic, Show)
deriving Show
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving (Eq, Show)
data ProcState = PRunning ProcessID
| PExited (Either ProcessError ())
deriving Eq
type ExecCb = Bool -- verbose
-> Fd -- log file fd
-> Fd -- input fd to read from
-> MVar ProcState -- state of the producing process
-> ByteString -- log filename
-> IO ()
instance Show ExecCb where
show _ = "**ExecCb**"
data Settings = Settings
@@ -203,6 +201,7 @@ data Settings = Settings
-- set on app start
, dirs :: Dirs
, execCb :: ExecCb
}
deriving Show
@@ -249,12 +248,6 @@ data PlatformResult = PlatformResult
}
deriving (Eq, Show)
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat
data PlatformRequest = PlatformRequest
{ _rArch :: Architecture
, _rPlatform :: Platform
@@ -262,13 +255,6 @@ data PlatformRequest = PlatformRequest
}
deriving (Eq, Show)
prettyPfReq :: PlatformRequest -> String
prettyPfReq (PlatformRequest arch plat ver) =
prettyArch arch ++ "-" ++ prettyPlatfrom plat ++ pver
where
pver = case ver of
Just v' -> "-" ++ (T.unpack $ prettyV v')
Nothing -> ""
-- | A GHC identified by the target platform triple
-- and the version.

View File

@@ -55,7 +55,6 @@ instance ToJSON Tag where
toJSON Latest = String "Latest"
toJSON Recommended = String "Recommended"
toJSON Prerelease = String "Prerelease"
toJSON Old = String "old"
toJSON (Base pvp'') = String ("base-" <> prettyPVP pvp'')
toJSON (UnknownTag x ) = String (T.pack x)
@@ -64,7 +63,6 @@ instance FromJSON Tag where
"Latest" -> pure Latest
"Recommended" -> pure Recommended
"Prerelease" -> pure Prerelease
"old" -> pure Old
('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of
Right x -> pure $ Base x
Left e -> fail . show $ e

View File

@@ -36,7 +36,7 @@ import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
#if !defined(TAR)
import Codec.Archive hiding ( Directory )
import Codec.Archive
#endif
import Control.Applicative
import Control.Exception.Safe
@@ -301,150 +301,6 @@ cabalSet = do
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
getInstalledHLSs :: (MonadReader Settings m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledHLSs = do
Settings { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
vs <- forM bins $ \f ->
case
fmap
version
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
pure $ vs
-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs
pure $ elem ver $ vers
-- Return the currently set hls version, if any.
hlsSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
Settings {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath hlsBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
-- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader Settings m
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions = do
h <- hlsSet
vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h'
pure $ fmap
(\bin ->
version
. decUTF8Safe
. fromJust
. B.stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
$ bin
)
bins
pure . rights . concat . maybeToList $ vers
-- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader Settings m, MonadIO m)
=> Version
-> m [Path Rel]
hlsServerBinaries ver = do
Settings { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe (Path Rel))
hlsWrapperBinary ver = do
Settings { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
case wrapper of
[] -> pure $ Nothing
[x] -> pure $ Just x
_ -> throwM $ UnexpectedListLength
"There were multiple hls wrapper binaries for a single version"
-- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader Settings m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader Settings m, MonadIO m, MonadCatch m) => m [Path Rel]
hlsSymlinks = do
Settings { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
( fmap (== SymbolicLink)
. liftIO
. getFileType
. (binDir </>)
)
oldSyms
-----------------------------------------
@@ -694,7 +550,7 @@ make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing
execLogged mymake True args workdir Nothing
-- | Try to apply patches in order. Fails with 'PatchFailed'
@@ -740,8 +596,8 @@ getChangeLog dls tool (Right tag) =
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory (cleaned up depending on Settings)
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
=> Path Abs -- ^ build directory
-> Maybe (Path Abs) -- ^ install location (e.g. for GHC)
-> Excepts e m a
-> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do
@@ -765,25 +621,3 @@ runBuildAction bdir instdir action = do
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir
pure v
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: Path b -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirRecursive newDirPerms
$ p
where
isSymlinkDir e = do
ft <- getFileType p
case ft of
SymbolicLink -> do
rp <- canonicalizePath p
rft <- getFileType rp
case rft of
Directory -> pure ()
_ -> throwIO e
_ -> throwIO e

View File

@@ -72,14 +72,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode
, _stdOut :: ByteString
@@ -121,30 +113,31 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
=> 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
-> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
execLogged exe spath args chdir env = do
Settings {dirs = Dirs {..}, ..} <- ask
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
logfile <- (logsDir </>) <$> parseRel (lfile <> ".log")
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
closeFd
(action verbose)
(action verbose execCb)
where
action verbose fd = do
lfile = fromMaybe exe $ BS.stripPrefix "./" exe
action verbose cb fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout
pState <- newEmptyMVar
done <- newEmptyMVar
pState <- newEmptyMVar
done <- newEmptyMVar
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged1"
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ (if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
$ (do
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged"
cb verbose fd stdoutRead pState lfile)
-- fork the subprocess
pid <- SPPB.forkProcess $ do
@@ -157,115 +150,57 @@ execLogged exe spath args lfile chdir env = do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
void $ SPPB.executeFile exe spath args env
putMVar pState (PRunning pid)
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
putMVar pState (either (const False) (const True) e)
void $ swapMVar pState (PExited e)
void $ race (takeMVar done) (threadDelay (1000000 * 3))
closeFd stdoutRead
pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
readLineTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readLineTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
printToRegion fileFd fdIn size pState = do
void $ displayConsoleRegions $ do
rs <-
liftIO
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle
(\(ex :: SomeException) -> do
ps <- liftIO $ takeMVar pState
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
throw ex
)
$ readTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = \inBs -> go inBs
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs
-- Consecutively read from Fd in 512 chunks until we hit
-- newline or EOF.
readLine :: MonadIO m
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = \inBs -> go inBs
where
go inBs = do
-- if buffer is not empty, process it first
mbs <- if BS.length inBs == 0
-- otherwise attempt read
then liftIO
$ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
$ fmap Just
$ SPIB.fdRead fd 512
else pure $ Just inBs
case mbs of
Nothing -> pure ("", "", True)
Just bs -> do
-- split on newline
let (line, rest) = BS.span (/= _lf) bs
if
| BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-- if rest is empty, then there was no newline, process further
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readTilEOF ~action' fd' = go mempty
where
go bs' = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which
@@ -450,3 +385,76 @@ chmod_777 (toFilePath -> fp) = do
$(logDebug) [i|chmod 777 #{fp}|]
liftIO $ setFileMode fp exe_mode
-- | The default callback for logging/printing on 'execLogged'.
defExecCb :: ExecCb
defExecCb verbose fd stdoutRead pState lfile = if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6
where
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readLineTilEOF lineAction fdIn
where
lineAction :: ByteString -> IO ()
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion :: Fd -> Fd -> Int -> IO ()
printToRegion fileFd fdIn size = do
void $ displayConsoleRegions $ do
rs <-
liftIO
. fmap Sq.fromList
. sequence
. replicate size
. openConsoleRegion
$ Linear
flip runStateT mempty
$ handle
(\(ex :: SomeException) -> do
let closeEventually = readMVar pState >>= \case
PExited (Right _) -> forM_ rs (liftIO . closeConsoleRegion)
_ -> threadDelay 500 >> closeEventually
void $ liftIO $ race closeEventually (threadDelay (1000000 * 3))
throw ex
)
$ readLineTilEOF (lineAction rs) fdIn
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction :: (MonadMask m, MonadIO m)
=> Seq ConsoleRegion
-> ByteString
-> StateT (Seq ByteString) m ()
lineAction rs = \bs' -> do
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
modify (swapRegs bs')
regs <- get
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. decUTF8Safe
. trim w
. (\b -> "[ " <> lfile <> " ] " <> b)
$ bs
swapRegs :: a -> Seq a -> Seq a
swapRegs bs = \regs -> if
| Sq.length regs < size -> regs |> bs
| otherwise -> Sq.drop 1 regs |> bs
-- trim output line to terminal width
trim :: Int -> ByteString -> ByteString
trim w = \bs -> if
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
| otherwise -> bs

View File

@@ -15,7 +15,6 @@ Here we define our main logger.
module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Utils
import Control.Monad
import Control.Monad.IO.Class
@@ -70,7 +69,7 @@ initGHCupFileLogging context = do
Settings {dirs = Dirs {..}} <- ask
let logfile = logsDir </> context
liftIO $ do
createDirRecursive' logsDir
createDirRecursive newDirPerms logsDir
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile

View File

@@ -31,13 +31,11 @@ import Data.ByteString ( ByteString )
import Data.String
import Data.Text ( Text )
import Data.Versions
import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
import qualified Data.Text as T
@@ -277,13 +275,3 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode
decUTF8Safe' :: L.ByteString -> Text
decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
-- | Escape a version for use in regex
escapeVerRex :: Version -> ByteString
escapeVerRex = B.pack . go . B.unpack . verToBS
where
go [] = []
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
| otherwise = x : go xs

View File

@@ -22,11 +22,11 @@ import qualified Data.Text as T
-- | This reflects the API version of the YAML.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.3.yaml|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.yaml|]
-- | The current ghcup version.
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.12|]
ghcUpVer = [pver|0.1.10|]
-- | ghcup version as numeric string.
numericVer :: String

View File

@@ -1,70 +0,0 @@
resolver: lts-16.17
packages:
- .
extra-deps:
- 3rdparty/lzma
- 3rdparty/lzma-clib
- 3rdparty/zlib
- git: https://github.com/haskus/packages.git
commit: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdirs:
- haskus-utils-types
- git: https://github.com/hasufell/hpath.git
commit: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdirs:
- hpath-io
- hpath-directory
- git: https://github.com/hasufell/text-conversions.git
commit: 9abf0e5e5664a3178367597c32db19880477a53c
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
- QuickCheck-2.14.1@sha256:01e46d7b0a8d3148288ec977625f62d5516ebb5031a50c63f0453863301b4a79,7736
- ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
- base64-bytestring-1.1.0.0@sha256:190264fef9e65d9085f00ccda419137096d1dc94777c58272bc96821dc7f37c3,2334
- brick-0.55@sha256:f98736eca0cd694837062e06da4655eed969d53b789dfd919716e9b6f5b4c5ce,15858
- brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
- brotli-streams-0.0.0.0@sha256:1af1e22f67b8bfd6ad0d05e61825e7a178d738f689ebbb21c1aab5f1bbcae176,2331
- chs-cabal-0.1.1.0@sha256:20ec6a9fb5ab6991f1a4adf157c537bd5d3b98d08d3c09c387c954c7c50bd011,1153
- chs-deps-0.1.0.0@sha256:0cdada6d2c682c41b20331b8c63c2ecfc7e806928585195fd544c9d41f3074fd,2496
- composition-prelude-3.0.0.0@sha256:7407835ce8c1e0e2fd6febd25391b12989b216773e685e3cf95bd89072af0ecc,1149
- haskus-utils-data-1.3@sha256:f62c4e49021b463185d043f7b69c727b63af641a71d7edd582d9f4f98e80e500,1466
- haskus-utils-variant-3.0@sha256:8d51e45d3b664e61ccc25a58b37c0ccc4ee7537138b9fee21cd15c356906dd34,2159
- hpath-0.11.0@sha256:12b8405bee13d0007d644a888ef8407069ce7bbbd76970f8746b801447124ade,1440
- hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
- hpath-posix-0.13.2@sha256:eec4ff2b00dc86be847aca0f409fc8f6212ffd2170ec36a17dc9a52b46562392,1615
- http-io-streams-0.1.4.0@sha256:9a74a059daeddf7a41d361919190b9f4d4292f05e0e4bdf156e2098a116a8145,3582
- libarchive-3.0.0.0@sha256:e4157b307acf16cca0ec3d398ac5093cc06f092b33a9743be559ef0f6c6ae52f,11204
- os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
- primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963
- primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427
- random-1.2.0@sha256:4321209c8faedc034810ea8ed0dbc4a36f1a1df97b75af024219f2f533da57de,6094
- splitmix-0.1.0.1@sha256:22f9662e7e8b173421872241edd39350078a9ed4bb9e9f503948c5b483c79276,5253
- streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- tar-bytestring-0.6.3.2@sha256:88f29bed56b688c543a4cb3986402d64b360f76b3fd9b88ac618b8344f8da712,5715
- vty-5.30@sha256:4af3938d7b9e6096e222bf52d0ea5d39873bc6fe19febd34106906306af13730,20857
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
flags:
http-io-streams:
brotli: false
libarchive:
system-libarchive: false
ghcup:
tui: true
system-ghc: true
compiler: ghc-8.8.4
compiler-check: match-exact
ghc-options:
"$locals": -O2
streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
ghcup: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

View File

@@ -1,193 +0,0 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.ArbitraryTypes where
import GHCup.Types
import Data.ByteString ( ByteString )
import Data.Versions
import Data.List.NonEmpty
import HPath
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic
import URI.ByteString
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as T
( toStrict )
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
-----------------
--[ utilities ]--
-----------------
intToText :: Integral a => a -> T.Text
intToText = T.toStrict . B.toLazyText . B.decimal
genVer :: Gen (Int, Int, Int)
genVer =
(\x y z -> (getPositive x, getPositive y, getPositive z))
<$> arbitrary
<*> arbitrary
<*> arbitrary
instance ToADTArbitrary GHCupInfo
----------------------
--[ base arbitrary ]--
----------------------
instance Arbitrary T.Text where
arbitrary = fmap T.pack $ listOf $ elements ['a' .. 'z']
shrink xs = T.pack <$> shrink (T.unpack xs)
instance Arbitrary (NonEmpty Word) where
arbitrary = fmap fromList $ listOf1 $ arbitrary
-- utf8 encoded bytestring
instance Arbitrary ByteString where
arbitrary = fmap (E.encodeUtf8 . T.pack) $ listOf $ elements ['a' .. 'z']
---------------------
--[ uri arbitrary ]--
---------------------
instance Arbitrary Scheme where
arbitrary = oneof [ Scheme <$> pure "http", Scheme <$> pure "https" ]
instance Arbitrary Host where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Port where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (URIRef Absolute) where
arbitrary =
URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> (Query <$> pure []) <*> pure Nothing
-------------------------
--[ version arbitrary ]--
-------------------------
instance Arbitrary Mess where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ mess
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Version where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ version
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary SemVer where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ semver
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary PVP where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ pvp
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Versioning where
arbitrary = Ideal <$> arbitrary
-----------------------
--[ ghcup arbitrary ]--
-----------------------
instance Arbitrary Requirements where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary DownloadInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary LinuxDistro where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Platform where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tag where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Architecture where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary VersionInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (Path Rel) where
arbitrary =
(either (error . show) id . parseRel . E.encodeUtf8 . T.pack)
<$> (listOf1 $ elements ['a' .. 'z'])
instance Arbitrary TarDir where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary
shrink = genericShrink
-- our maps are nested... the default size easily blows up most ppls ram
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Tool v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Version) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Platform v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Versioning) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary

View File

@@ -1,17 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.Types.JSONSpec where
import GHCup.ArbitraryTypes ()
import GHCup.Types
import GHCup.Types.JSON ()
import Test.Aeson.GenericSpecs
import Test.Hspec
spec :: Spec
spec = do
roundtripAndGoldenSpecs (Proxy @GHCupInfo)

View File

@@ -1,12 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
import Test.Hspec.Runner
import Test.Hspec.Formatters
import qualified Spec
main :: IO ()
main =
hspecWith
defaultConfig { configFormatter = Just progress }
$ Spec.spec

4
test/MyLibTest.hs Normal file
View File

@@ -0,0 +1,4 @@
module Main (main) where
main :: IO ()
main = putStrLn "Test suite not yet implemented."

View File

@@ -1,2 +0,0 @@
-- file test/Spec.hs
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}