@@ -243,7 +243,7 @@ export async function findHaskellLanguageServer(
243
243
}
244
244
// now figure out the project GHC version and the latest supported HLS version
245
245
// we need for it (e.g. this might in fact be a downgrade for old GHCs)
246
- const installableHls = await getLatestSuitableHLS (
246
+ const installableHls = await getLatestHLS (
247
247
context ,
248
248
logger ,
249
249
workingDir ,
@@ -293,7 +293,7 @@ async function callGHCup(
293
293
}
294
294
}
295
295
296
- async function getLatestSuitableHLS (
296
+ async function getLatestHLS (
297
297
context : ExtensionContext ,
298
298
logger : Logger ,
299
299
workingDir : string ,
@@ -308,14 +308,29 @@ async function getLatestSuitableHLS(
308
308
: await getProjectGHCVersion ( wrapper , workingDir , logger ) ;
309
309
310
310
// get installable HLS that supports the project GHC version (this might not be the most recent)
311
- const latestMetadataHls =
312
- projectGhc !== null ? await getLatestHLSforGHC ( context , storagePath , projectGhc , logger ) : null ;
313
- if ( latestMetadataHls === null ) {
314
- const noMatchingHLS = `No HLS version was found for supporting GHC ${ projectGhc } .` ;
315
- window . showErrorMessage ( noMatchingHLS ) ;
316
- throw new Error ( noMatchingHLS ) ;
317
- } else {
311
+ const latestMetadataHls = await getLatestHLSfromMetadata ( context , storagePath , projectGhc , logger ) ;
312
+ const latestGhcupHls = await getLatestHLSfromGHCup ( context , storagePath , projectGhc , logger ) ;
313
+
314
+ if ( latestMetadataHls !== null && latestGhcupHls !== null ) {
315
+ const compare = comparePVP ( latestMetadataHls , latestGhcupHls ) ;
316
+ if ( compare >= 0 ) {
317
+ logger . info ( "Picking HLS according to metadata" ) ;
318
318
return latestMetadataHls ;
319
+ } else {
320
+ logger . info ( "Picking a probably self compiled HLS via ghcup" ) ;
321
+ return latestGhcupHls ;
322
+ }
323
+
324
+ } else if ( latestMetadataHls === null && latestGhcupHls !== null ) {
325
+ logger . info ( "Picking a probably self compiled HLS via ghcup" ) ;
326
+ return latestGhcupHls ;
327
+ } else if ( latestMetadataHls !== null && latestGhcupHls === null ) {
328
+ logger . info ( "Picking HLS according to metadata" ) ;
329
+ return latestMetadataHls ;
330
+ } else {
331
+ const noMatchingHLS = `No HLS version was found for supporting GHC ${ projectGhc } .` ;
332
+ window . showErrorMessage ( noMatchingHLS ) ;
333
+ throw new Error ( noMatchingHLS ) ;
319
334
}
320
335
}
321
336
@@ -499,6 +514,37 @@ export function addPathToProcessPath(extraPath: string): string {
499
514
return PATH . join ( pathSep ) ;
500
515
}
501
516
517
+ // complements getLatestHLSfromMetadata, by checking possibly locally compiled
518
+ // HLS in ghcup
519
+ async function getLatestHLSfromGHCup (
520
+ context : ExtensionContext ,
521
+ storagePath : string ,
522
+ targetGhc : string ,
523
+ logger : Logger
524
+ ) : Promise < string | null > {
525
+ const hlsVersions = await callGHCup (
526
+ context ,
527
+ logger ,
528
+ [ 'list' , '-t' , 'hls' , '-c' , 'installed' , '-r' ] ,
529
+ undefined ,
530
+ false ,
531
+ ) ;
532
+ const latestHlsVersion = hlsVersions . split ( / \r ? \n / ) . pop ( ) ! . split ( ' ' ) [ 1 ] ;
533
+ logger . info ( `LATEST GHCUP HLS: ${ latestHlsVersion } ` ) ;
534
+ let bindir = await callGHCup ( context , logger ,
535
+ [ 'whereis' , 'bindir' ] ,
536
+ undefined ,
537
+ false
538
+ ) ;
539
+
540
+ const hlsBin = path . join ( bindir , `haskell-language-server-${ targetGhc } ~${ latestHlsVersion } ` ) ;
541
+ if ( fs . existsSync ( hlsBin ) ) {
542
+ return latestHlsVersion ;
543
+ } else {
544
+ return null ;
545
+ }
546
+ }
547
+
502
548
/**
503
549
* Given a GHC version, download at least one HLS version that can be used.
504
550
* This also honours the OS architecture we are on.
@@ -509,7 +555,7 @@ export function addPathToProcessPath(extraPath: string): string {
509
555
* @param logger Logger for feedback
510
556
* @returns
511
557
*/
512
- async function getLatestHLSforGHC (
558
+ async function getLatestHLSfromMetadata (
513
559
context : ExtensionContext ,
514
560
storagePath : string ,
515
561
targetGhc : string ,
0 commit comments