Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
G
ghcup-hs
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Iterations
Wiki
Requirements
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Test cases
Artifacts
Deploy
Releases
Package Registry
Container Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Code review analytics
Issue analytics
Insights
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Haskell
ghcup-hs
Commits
d3e3ebd6
Verified
Commit
d3e3ebd6
authored
3 years ago
by
Julian Ospald
Browse files
Options
Downloads
Plain Diff
Merge branch 'fix-ghcToolFiles'
parents
ce616d3e
928f4a97
No related branches found
Branches containing commit
Tags
v0.1.15.2-70-g7de552e-18-gead2b76-5-g01715fd-32-g94bd01a-19-gd3e3ebd
Tags containing commit
1 merge request
!106
Fix ghcToolFiles for upcoming GHC build system changes
Pipeline
#38661
canceled
3 years ago
Stage: hlint
Stage: test
Stage: release
Changes
2
Pipelines
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
lib/GHCup/Utils.hs
+14
-41
14 additions, 41 deletions
lib/GHCup/Utils.hs
lib/GHCup/Utils/Prelude.hs
+18
-1
18 additions, 1 deletion
lib/GHCup/Utils/Prelude.hs
with
32 additions
and
42 deletions
lib/GHCup/Utils.hs
+
14
−
41
View file @
d3e3ebd6
...
@@ -766,49 +766,22 @@ ghcToolFiles ver = do
...
@@ -766,49 +766,22 @@ ghcToolFiles ver = do
whenM
(
fmap
not
$
liftIO
$
doesDirectoryExist
ghcdir
)
whenM
(
fmap
not
$
liftIO
$
doesDirectoryExist
ghcdir
)
(
throwE
(
NotInstalled
GHC
ver
))
(
throwE
(
NotInstalled
GHC
ver
))
files
<-
liftIO
$
listDirectory
bindir
files
<-
liftIO
(
listDirectory
bindir
>>=
filterM
(
doesFileExist
.
(
bindir
</>
)))
-- figure out the <ver> suffix, because this might not be `Version` for
pure
(
getUniqueTools
.
groupToolFiles
.
fmap
(
dropSuffix
exeExt
)
$
files
)
-- alpha/rc releases, but x.y.a.somedate.
ghcIsHadrian
<-
liftIO
$
isHadrian
bindir
onlyUnversioned
<-
case
ghcIsHadrian
of
Right
()
->
pure
id
Left
(
fmap
(
dropSuffix
exeExt
)
->
[
ghc
,
ghc_ver
])
|
(
Just
symver
)
<-
stripPrefix
(
ghc
<>
"-"
)
ghc_ver
,
not
(
null
symver
)
->
pure
$
filter
(
\
x
->
not
$
symver
`
isInfixOf
`
x
)
_
->
fail
"Fatal: Could not find internal GHC version"
pure
$
onlyUnversioned
$
fmap
(
dropSuffix
exeExt
)
files
where
where
isNotAnyInfix
xs
t
=
foldr
(
\
a
b
->
not
(
a
`
isInfixOf
`
t
)
&&
b
)
True
xs
-- GHC is moving some builds to Hadrian for bindists,
-- which doesn't create versioned binaries.
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
isHadrian
::
FilePath
-- ^ ghcbin path
->
IO
(
Either
[
String
]
()
)
-- ^ Right for Hadrian
isHadrian
dir
=
do
-- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
-- which also requires us to discover the internal version
-- to filter the correct tool files.
-- We can't use the symlink on windows, so we fall back to some
-- more complicated logic.
fs
<-
fmap
-- regex over-matches
(
filter
(
isNotAnyInfix
[
"haddock"
,
"ghc-pkg"
,
"ghci"
]))
$
liftIO
$
findFiles
dir
(
makeRegexOpts
compExtended
execBlank
-- for cross, this won't be "ghc", but e.g.
-- "armv7-unknown-linux-gnueabihf-ghc"
(
[
s
|
^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$
|]
::
ByteString
)
)
if
|
length
fs
==
1
->
pure
$
Right
()
-- hadrian
|
length
fs
==
2
->
pure
$
Left
(
sortOn
length
fs
)
-- legacy make, result should
-- be ["ghc", "ghc-8.10.4"]
|
otherwise
->
fail
"isHadrian failed!"
groupToolFiles
::
[
FilePath
]
->
[[(
FilePath
,
String
)]]
groupToolFiles
=
groupBy
(
\
(
a
,
_
)
(
b
,
_
)
->
a
==
b
)
.
fmap
(
splitOnPVP
"-"
)
getUniqueTools
::
[[(
FilePath
,
String
)]]
->
[
String
]
getUniqueTools
=
filter
(
isNotAnyInfix
blackListedTools
)
.
nub
.
fmap
fst
.
filter
((
==
""
)
.
snd
)
.
concat
blackListedTools
::
[
String
]
blackListedTools
=
[
"haddock-ghc"
]
isNotAnyInfix
::
[
String
]
->
String
->
Bool
isNotAnyInfix
xs
t
=
foldr
(
\
a
b
->
not
(
a
`
isInfixOf
`
t
)
&&
b
)
True
xs
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
...
...
This diff is collapsed.
Click to expand it.
lib/GHCup/Utils/Prelude.hs
+
18
−
1
View file @
d3e3ebd6
...
@@ -31,7 +31,7 @@ import Control.Monad.IO.Class
...
@@ -31,7 +31,7 @@ import Control.Monad.IO.Class
import
Control.Monad.Reader
import
Control.Monad.Reader
import
Data.Bifunctor
import
Data.Bifunctor
import
Data.ByteString
(
ByteString
)
import
Data.ByteString
(
ByteString
)
import
Data.List
(
nub
)
import
Data.List
(
nub
,
intercalate
)
import
Data.Foldable
import
Data.Foldable
import
Data.String
import
Data.String
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
...
@@ -55,6 +55,7 @@ import GHC.IO.Exception
...
@@ -55,6 +55,7 @@ import GHC.IO.Exception
import
qualified
Data.ByteString
as
B
import
qualified
Data.ByteString
as
B
import
qualified
Data.ByteString.Lazy
as
L
import
qualified
Data.ByteString.Lazy
as
L
import
qualified
Data.Strict.Maybe
as
S
import
qualified
Data.Strict.Maybe
as
S
import
qualified
Data.List.Split
as
Split
import
qualified
Data.Text
as
T
import
qualified
Data.Text
as
T
import
qualified
Data.Text.Encoding
as
E
import
qualified
Data.Text.Encoding
as
E
import
qualified
Data.Text.Encoding.Error
as
E
import
qualified
Data.Text.Encoding.Error
as
E
...
@@ -518,3 +519,19 @@ isNewLine w
...
@@ -518,3 +519,19 @@ isNewLine w
|
w
==
_lf
=
True
|
w
==
_lf
=
True
|
w
==
_cr
=
True
|
w
==
_cr
=
True
|
otherwise
=
False
|
otherwise
=
False
-- | Split on a PVP suffix.
--
-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706" == ("ghc-iserv-dyn", "9.3.20210706")
-- >>> splitOnPVP "-" "ghc-iserv-dyn" == ("ghc-iserv-dyn", "")
splitOnPVP
::
String
->
String
->
(
String
,
String
)
splitOnPVP
c
s
=
case
Split
.
splitOn
c
s
of
[]
->
def
[
_
]
->
def
xs
|
let
l
=
last
xs
,
(
Right
_
)
<-
pvp
(
T
.
pack
l
)
->
(
intercalate
c
(
init
xs
),
l
)
|
otherwise
->
def
where
def
=
(
s
,
""
)
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment