@@ -12,6 +12,7 @@ import { Logger } from 'vscode-languageclient';
1212import { HlsError , MissingToolError , NoMatchingHls } from './errors' ;
1313import {
1414 addPathToProcessPath ,
15+ comparePVP ,
1516 executableExists ,
1617 httpsGetSilently ,
1718 IEnvVars ,
@@ -24,14 +25,23 @@ type Tool = 'hls' | 'ghc' | 'cabal' | 'stack';
2425
2526type ToolConfig = Map < Tool , string > ;
2627
27- export type ReleaseMetadata = Map < string , Map < string , Map < string , string [ ] > > > ;
28-
2928type ManageHLS = 'GHCup' | 'PATH' ;
3029let manageHLS = workspace . getConfiguration ( 'haskell' ) . get ( 'manageHLS' ) as ManageHLS ;
3130
3231// On Windows the executable needs to be stored somewhere with an .exe extension
3332const exeExt = process . platform === 'win32' ? '.exe' : '' ;
3433
34+ /**
35+ * Callback invoked on process termination.
36+ */
37+ type ProcessCallback = (
38+ error : ExecException | null ,
39+ stdout : string ,
40+ stderr : string ,
41+ resolve : ( value : string | PromiseLike < string > ) => void ,
42+ reject : ( reason ?: any ) => void
43+ ) => void ;
44+
3545/**
3646 * Call a process asynchronously.
3747 * While doing so, update the windows with progress information.
@@ -45,7 +55,7 @@ const exeExt = process.platform === 'win32' ? '.exe' : '';
4555 * @param title Title of the action, shown to users if available.
4656 * @param cancellable Can the user cancel this process invocation?
4757 * @param envAdd Extra environment variables for this process only.
48- * @param callback Upon process termination, execute this callback. If given, must resolve promise.
58+ * @param callback Upon process termination, execute this callback. If given, must resolve promise. On error, stderr and stdout are logged regardless of whether the callback has been specified.
4959 * @returns Stdout of the process invocation, trimmed off newlines, or whatever the `callback` resolved to.
5060 */
5161async function callAsync (
@@ -56,13 +66,7 @@ async function callAsync(
5666 title ?: string ,
5767 cancellable ?: boolean ,
5868 envAdd ?: IEnvVars ,
59- callback ?: (
60- error : ExecException | null ,
61- stdout : string ,
62- stderr : string ,
63- resolve : ( value : string | PromiseLike < string > ) => void ,
64- reject : ( reason ?: any ) => void
65- ) => void
69+ callback ?: ProcessCallback
6670) : Promise < string > {
6771 let newEnv : IEnvVars = await resolveServerEnvironmentPATH (
6872 workspace . getConfiguration ( 'haskell' ) . get ( 'serverEnvironment' ) || { }
@@ -89,15 +93,17 @@ async function callAsync(
8993 args ,
9094 { encoding : 'utf8' , cwd : dir , shell : process . platform === 'win32' , env : newEnv } ,
9195 ( err , stdout , stderr ) => {
96+ if ( err ) {
97+ logger . error ( `Error executing '${ command } ' with error code ${ err . code } ` ) ;
98+ logger . error ( `stderr: ${ stderr } ` ) ;
99+ if ( stdout ) {
100+ logger . error ( `stdout: ${ stdout } ` ) ;
101+ }
102+ }
92103 if ( callback ) {
93104 callback ( err , stdout , stderr , resolve , reject ) ;
94105 } else {
95106 if ( err ) {
96- logger . error ( `Error executing '${ command } ' with error code ${ err . code } ` ) ;
97- logger . error ( `stderr: ${ stderr } ` ) ;
98- if ( stdout ) {
99- logger . error ( `stdout: ${ stdout } ` ) ;
100- }
101107 reject (
102108 Error ( `\`${ command } \` exited with exit code ${ err . code } .
103109 Consult the [Extensions Output](https://github.com/haskell/vscode-haskell#investigating-and-reporting-problems)
@@ -112,7 +118,7 @@ async function callAsync(
112118 . on ( 'exit' , ( code , signal ) => {
113119 const msg =
114120 `Execution of '${ command } ' terminated with code ${ code } ` + ( signal ? `and signal ${ signal } ` : '' ) ;
115- logger . info ( msg ) ;
121+ logger . log ( msg ) ;
116122 } )
117123 . on ( 'error' , ( err ) => {
118124 if ( err ) {
@@ -292,7 +298,9 @@ export async function findHaskellLanguageServer(
292298 "Yes, don't ask again"
293299 ) ;
294300 if ( decision === 'Yes' ) {
301+ logger . info ( `User accepted download for ${ toInstall . join ( ', ' ) } .` ) ;
295302 } else if ( decision === "Yes, don't ask again" ) {
303+ logger . info ( `User accepted download for ${ toInstall . join ( ', ' ) } and won't be asked again.` ) ;
296304 workspace . getConfiguration ( 'haskell' ) . update ( 'promptBeforeDownloads' , false ) ;
297305 } else {
298306 [ hlsInstalled , cabalInstalled , stackInstalled , ghcInstalled ] . forEach ( ( tool ) => {
@@ -363,7 +371,9 @@ export async function findHaskellLanguageServer(
363371 "Yes, don't ask again"
364372 ) ;
365373 if ( decision === 'Yes' ) {
374+ logger . info ( `User accepted download for ${ toInstall . join ( ', ' ) } .` ) ;
366375 } else if ( decision === "Yes, don't ask again" ) {
376+ logger . info ( `User accepted download for ${ toInstall . join ( ', ' ) } and won't be asked again.` ) ;
367377 workspace . getConfiguration ( 'haskell' ) . update ( 'promptBeforeDownloads' , false ) ;
368378 } else {
369379 [ hlsInstalled , ghcInstalled ] . forEach ( ( tool ) => {
@@ -410,13 +420,7 @@ async function callGHCup(
410420 args : string [ ] ,
411421 title ?: string ,
412422 cancellable ?: boolean ,
413- callback ?: (
414- error : ExecException | null ,
415- stdout : string ,
416- stderr : string ,
417- resolve : ( value : string | PromiseLike < string > ) => void ,
418- reject : ( reason ?: any ) => void
419- ) => void
423+ callback ?: ProcessCallback
420424) : Promise < string > {
421425 const metadataUrl = workspace . getConfiguration ( 'haskell' ) . metadataURL ;
422426
@@ -510,13 +514,7 @@ export async function getProjectGHCVersion(
510514 false ,
511515 environmentNew ,
512516 ( err , stdout , stderr , resolve , reject ) => {
513- const command : string = 'haskell-language-server-wrapper' + ' ' + args . join ( ' ' ) ;
514517 if ( err ) {
515- logger . error ( `Error executing '${ command } ' with error code ${ err . code } ` ) ;
516- logger . error ( `stderr: ${ stderr } ` ) ;
517- if ( stdout ) {
518- logger . error ( `stdout: ${ stdout } ` ) ;
519- }
520518 // Error message emitted by HLS-wrapper
521519 const regex =
522520 / C r a d l e r e q u i r e s ( .+ ) b u t c o u l d n ' t f i n d i t | T h e p r o g r a m \' ( .+ ) \' v e r s i o n .* i s r e q u i r e d b u t t h e v e r s i o n o f .* c o u l d .* n o t b e d e t e r m i n e d | C a n n o t f i n d t h e p r o g r a m \' ( .+ ) \' \. U s e r - s p e c i f i e d / ;
@@ -576,43 +574,6 @@ export async function findGHCup(context: ExtensionContext, logger: Logger, folde
576574 }
577575}
578576
579- /**
580- * Compare the PVP versions of two strings.
581- * Details: https://github.com/haskell/pvp/
582- *
583- * @param l First version
584- * @param r second version
585- * @returns `1` if l is newer than r, `0` if they are equal and `-1` otherwise.
586- */
587- export function comparePVP ( l : string , r : string ) : number {
588- const al = l . split ( '.' ) ;
589- const ar = r . split ( '.' ) ;
590-
591- let eq = 0 ;
592-
593- for ( let i = 0 ; i < Math . max ( al . length , ar . length ) ; i ++ ) {
594- const el = parseInt ( al [ i ] , 10 ) || undefined ;
595- const er = parseInt ( ar [ i ] , 10 ) || undefined ;
596-
597- if ( el === undefined && er === undefined ) {
598- break ;
599- } else if ( el !== undefined && er === undefined ) {
600- eq = 1 ;
601- break ;
602- } else if ( el === undefined && er !== undefined ) {
603- eq = - 1 ;
604- break ;
605- } else if ( el !== undefined && er !== undefined && el > er ) {
606- eq = 1 ;
607- break ;
608- } else if ( el !== undefined && er !== undefined && el < er ) {
609- eq = - 1 ;
610- break ;
611- }
612- }
613- return eq ;
614- }
615-
616577export async function getStoragePath ( context : ExtensionContext ) : Promise < string > {
617578 let storagePath : string | undefined = await workspace . getConfiguration ( 'haskell' ) . get ( 'releasesDownloadStoragePath' ) ;
618579
@@ -677,7 +638,7 @@ async function getLatestAvailableToolFromGHCup(
677638 }
678639}
679640
680- // complements getLatestHLSfromMetadata , by checking possibly locally compiled
641+ // complements getHLSesfromMetadata , by checking possibly locally compiled
681642// HLS in ghcup
682643// If 'targetGhc' is omitted, picks the latest 'haskell-language-server-wrapper',
683644// otherwise ensures the specified GHC is supported.
@@ -730,14 +691,50 @@ async function toolInstalled(
730691}
731692
732693/**
733- * Given a GHC version, download at least one HLS version that can be used.
734- * This also honours the OS architecture we are on.
694+ * Metadata of release information.
695+ *
696+ * Example of the expected format:
697+ *
698+ * ```
699+ * {
700+ * "1.6.1.0": {
701+ * "A_64": {
702+ * "Darwin": [
703+ * "8.10.6",
704+ * ],
705+ * "Linux_Alpine": [
706+ * "8.10.7",
707+ * "8.8.4",
708+ * ],
709+ * },
710+ * "A_ARM": {
711+ * "Linux_UnknownLinux": [
712+ * "8.10.7"
713+ * ]
714+ * },
715+ * "A_ARM64": {
716+ * "Darwin": [
717+ * "8.10.7"
718+ * ],
719+ * "Linux_UnknownLinux": [
720+ * "8.10.7"
721+ * ]
722+ * }
723+ * }
724+ * }
725+ * ```
726+ *
727+ * consult [ghcup metadata repo](https://github.com/haskell/ghcup-metadata/) for details.
728+ */
729+ export type ReleaseMetadata = Map < string , Map < string , Map < string , string [ ] > > > ;
730+
731+ /**
732+ * Compute Map of supported HLS versions for this platform.
733+ * Fetches HLS metadata information.
735734 *
736735 * @param context Context of the extension, required for metadata.
737- * @param storagePath Path to store binaries, caching information, etc...
738- * @param targetGhc GHC version we want a HLS for.
739736 * @param logger Logger for feedback
740- * @returns
737+ * @returns Map of supported HLS versions or null if metadata could not be fetched.
741738 */
742739async function getHLSesfromMetadata ( context : ExtensionContext , logger : Logger ) : Promise < Map < string , string [ ] > | null > {
743740 const storagePath : string = await getStoragePath ( context ) ;
@@ -746,32 +743,59 @@ async function getHLSesfromMetadata(context: ExtensionContext, logger: Logger):
746743 window . showErrorMessage ( 'Could not get release metadata' ) ;
747744 return null ;
748745 }
749- const plat = match ( process . platform )
750- . with ( 'darwin' , ( _ ) => 'Darwin' )
751- . with ( 'linux' , ( _ ) => 'Linux_UnknownLinux' )
752- . with ( 'win32' , ( _ ) => 'Windows' )
753- . with ( 'freebsd' , ( _ ) => 'FreeBSD' )
746+ const plat : Platform | null = match ( process . platform )
747+ . with ( 'darwin' , ( _ ) => 'Darwin' as Platform )
748+ . with ( 'linux' , ( _ ) => 'Linux_UnknownLinux' as Platform )
749+ . with ( 'win32' , ( _ ) => 'Windows' as Platform )
750+ . with ( 'freebsd' , ( _ ) => 'FreeBSD' as Platform )
754751 . otherwise ( ( _ ) => null ) ;
755752 if ( plat === null ) {
756753 throw new Error ( `Unknown platform ${ process . platform } ` ) ;
757754 }
758- const arch = match ( process . arch )
759- . with ( 'arm' , ( _ ) => 'A_ARM' )
760- . with ( 'arm64' , ( _ ) => 'A_ARM64' )
761- . with ( 'x32' , ( _ ) => 'A_32' )
762- . with ( 'x64' , ( _ ) => 'A_64' )
755+ const arch : Arch | null = match ( process . arch )
756+ . with ( 'arm' , ( _ ) => 'A_ARM' as Arch )
757+ . with ( 'arm64' , ( _ ) => 'A_ARM64' as Arch )
758+ . with ( 'x32' , ( _ ) => 'A_32' as Arch )
759+ . with ( 'x64' , ( _ ) => 'A_64' as Arch )
763760 . otherwise ( ( _ ) => null ) ;
764761 if ( arch === null ) {
765762 throw new Error ( `Unknown architecture ${ process . arch } ` ) ;
766763 }
767764
768- const map : ReleaseMetadata = new Map ( Object . entries ( metadata ) ) ;
765+ return findSupportedHlsPerGhc ( plat , arch , metadata , logger ) ;
766+ }
767+
768+ export type Platform = 'Darwin' | 'Linux_UnknownLinux' | 'Windows' | 'FreeBSD' ;
769+
770+ export type Arch = 'A_ARM' | 'A_ARM64' | 'A_32' | 'A_64' ;
771+
772+ /**
773+ * Find all supported GHC versions per HLS version supported on the given
774+ * platform and architecture.
775+ * @param platform Platform of the host.
776+ * @param arch Arch of the host.
777+ * @param metadata HLS Metadata information.
778+ * @param logger Logger.
779+ * @returns Map from HLS version to GHC versions that are supported.
780+ */
781+ export function findSupportedHlsPerGhc (
782+ platform : Platform ,
783+ arch : Arch ,
784+ metadata : ReleaseMetadata ,
785+ logger : Logger
786+ ) : Map < string , string [ ] > {
787+ logger . info ( `Platform constants: ${ platform } , ${ arch } ` ) ;
769788 const newMap = new Map < string , string [ ] > ( ) ;
770- map . forEach ( ( value , key ) => {
771- const value_ = new Map ( Object . entries ( value ) ) ;
772- const archValues = new Map ( Object . entries ( value_ . get ( arch ) ) ) ;
773- const versions : string [ ] = archValues . get ( plat ) as string [ ] ;
774- newMap . set ( key , versions ) ;
789+ metadata . forEach ( ( supportedArch , hlsVersion ) => {
790+ const supportedOs = supportedArch . get ( arch ) ;
791+ if ( supportedOs ) {
792+ const ghcSupportedOnOs = supportedOs . get ( platform ) ;
793+ if ( ghcSupportedOnOs ) {
794+ logger . log ( `HLS ${ hlsVersion } compatible with GHC Versions: ${ ghcSupportedOnOs } ` ) ;
795+ // copy supported ghc versions to avoid unintended modifications
796+ newMap . set ( hlsVersion , [ ...ghcSupportedOnOs ] ) ;
797+ }
798+ }
775799 } ) ;
776800
777801 return newMap ;
@@ -850,7 +874,7 @@ async function getReleaseMetadata(
850874 */
851875class InstalledTool {
852876 /**
853- * "<name>- <version>" of the installed Tool.
877+ * "\ <name\>-\ <version\ >" of the installed Tool.
854878 */
855879 readonly nameWithVersion : string = '' ;
856880
0 commit comments