From f1bb92eaa464bc745ab39cf0c81fd89786ceede9 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Wed, 22 Nov 2023 23:53:22 -0600 Subject: [PATCH 01/44] Bump the compiler service over 35 and almost to 38. 35 is where a lot of APIs changed. The main culprits seem to be https://github.com/dotnet/fsharp/commit/78bb83aca6cba3d85dee111211d4c0c99a37595d and https://github.com/dotnet/fsharp/pull/8805. This commit fails in many of the same ways, but 38 goes with F# and .NET 5, which are not quite targetable by the project upgrader right now, so I'll go in stages. The hope is that according to https://github.com/dotnet/fsharp/issues/6161 and https://github.com/dotnet/fsharp/issues/6535 the mscorlib errors will eventually be solved. --- src/Kl.Make/Kl.Make.fsproj | 2 +- src/Kl.Make/Syntax.fs | 37 ++++++++++++++++++++++--------------- src/Kl.Make/Writer.fs | 2 +- 3 files changed, 24 insertions(+), 17 deletions(-) diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index b72a571..8f1114b 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index 2378456..0561426 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -10,8 +10,9 @@ module internal Kl.Make.Syntax open System -open FSharp.Compiler.Ast +open FSharp.Compiler.SyntaxTree open FSharp.Compiler.Range +open FSharp.Compiler.XmlDoc let private fileName = "file.fs" // Picked large values for line, col because there will be an unpredictable @@ -53,7 +54,7 @@ let matchClause pat body = None, body, loc, - SequencePointInfoForTarget.SequencePointAtTarget) + DebugPointForTarget.Yes) let nameTypeSimplePat s synType = SynSimplePat.Typed( SynSimplePat.Id(ident s, None, true, false, false, loc), @@ -75,7 +76,8 @@ let simpleBinding pat value = None, value, loc, - SequencePointInfoForBinding.NoSequencePointAtLetBinding) + DebugPointForBinding +.NoDebugPointAtLetBinding) let letAttrsMultiParamBinding attrs name paramz body = SynBinding.Binding( None, @@ -92,7 +94,7 @@ let letAttrsMultiParamBinding attrs name paramz body = longIdentWithDots [name], None, None, - SynConstructorArgs.Pats( + SynArgPats.Pats( [tuplePat (List.map (fun (s, synType) -> unparenTypedPat (namePat s) synType) @@ -102,7 +104,8 @@ let letAttrsMultiParamBinding attrs name paramz body = None, body, loc, - SequencePointInfoForBinding.SequencePointAtBinding loc) + DebugPointForBinding +.DebugPointAtBinding loc) let letBindingAccessWithAttrs attrs access name paramz body = SynBinding.Binding( access, @@ -119,14 +122,15 @@ let letBindingAccessWithAttrs attrs access name paramz body = longIdentWithDots [name], None, None, - SynConstructorArgs.Pats( + SynArgPats.Pats( List.map (fun (s, synType) -> typedPat (namePat s) synType) paramz), None, loc), None, body, loc, - SequencePointInfoForBinding.SequencePointAtBinding loc) + DebugPointForBinding +.DebugPointAtBinding loc) let letAttrsBinding attrs = letBindingAccessWithAttrs attrs None let letBinding = letAttrsBinding [] let letUnitBinding attrs name body = @@ -145,13 +149,14 @@ let letUnitBinding attrs name body = longIdentWithDots [name], None, None, - SynConstructorArgs.Pats [unitPat], + SynArgPats.Pats [unitPat], None, loc), None, body, loc, - SequencePointInfoForBinding.SequencePointAtBinding loc) + DebugPointForBinding +.DebugPointAtBinding loc) let parenExpr expr = SynExpr.Paren(expr, loc, None, loc) let parens = function | SynExpr.Paren _ as e -> e @@ -192,7 +197,8 @@ let ifExpr condition consequent alternative = condition, consequent, Some alternative, - SequencePointInfoForBinding.NoSequencePointAtInvisibleBinding, + DebugPointForBinding +.NoDebugPointAtInvisibleBinding, false, loc, loc) @@ -213,17 +219,17 @@ let tryWithExpr body e handler = None, handler, loc, - SequencePointInfoForTarget.SequencePointAtTarget)], + DebugPointForTarget.Yes)], loc, loc, - SequencePointInfoForTry.SequencePointAtTry loc, - SequencePointInfoForWith.SequencePointAtWith loc) + DebugPointAtTry.Yes loc, + DebugPointAtWith.Yes loc) let rec sequentialExpr = function | [] -> failwith "sequential cannot be empty" | [expr] -> expr | expr :: rest -> SynExpr.Sequential( - SequencePointInfoForSeq.SequencePointsAtSeq, + DebugPointAtSequential.Both, true, expr, sequentialExpr rest, @@ -266,7 +272,8 @@ let matchLambdaExpr clauses = false, loc, clauses, - SequencePointInfoForBinding.SequencePointAtBinding loc, + DebugPointForBinding +.DebugPointAtBinding loc, loc) let openDecl parts = SynModuleDecl.Open(longIdentWithDots parts, loc) let letAttrsDecl attrs name paramz body = diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index 66467db..951c1b3 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -1,6 +1,6 @@ module internal Writer -open FSharp.Compiler.Ast +open FSharp.Compiler.SyntaxTree let private join (sep: string) (strings: string list) = System.String.Join(sep, strings |> List.toArray) From be777b323df74cf3b7a15bf051950c0cb8a68993 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Thu, 23 Nov 2023 01:01:40 -0600 Subject: [PATCH 02/44] Upgrade to .NET 5 and Compiler Service 38. The lambda changes are from https://github.com/dotnet/fsharp/pull/10166 --- src/Kl.Get/Kl.Get.fsproj | 2 +- src/Kl.Make/Kl.Make.fsproj | 4 ++-- src/Kl.Make/Syntax.fs | 3 +++ src/Kl.Make/Writer.fs | 4 ++-- src/Kl.Tests/Kl.Tests.fsproj | 2 +- 5 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Kl.Get/Kl.Get.fsproj b/src/Kl.Get/Kl.Get.fsproj index 9b0d625..21e0087 100644 --- a/src/Kl.Get/Kl.Get.fsproj +++ b/src/Kl.Get/Kl.Get.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + netcoreapp5.0 Kl.Get Kl.Get Kl diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index 8f1114b..09cd73e 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + netcoreapp5.0 Kl.Make Kl.Make Kl @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index 0561426..74c19bb 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -251,6 +251,7 @@ let rec lambdaExpr paramz body = false, SynSimplePats.SimplePats([], loc), body, + None, loc) | [s, synType] -> SynExpr.Lambda( @@ -258,6 +259,7 @@ let rec lambdaExpr paramz body = false, SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), body, + None, loc) | (s, synType) :: paramz -> SynExpr.Lambda( @@ -265,6 +267,7 @@ let rec lambdaExpr paramz body = false, SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), lambdaExpr paramz body, + None, loc) parens expr let matchLambdaExpr clauses = diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index 951c1b3..c315379 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -55,8 +55,8 @@ let rec private writeExpr = function | SynExpr.TryWith(body, _, [SynMatchClause.Clause(pat, _, handler, _, _)], _, _, _, _) -> sprintf "(try %s; with %s -> %s)" (writeExpr body) (writePat pat) (writeExpr handler) | SynExpr.MatchLambda(_, _, clauses, _, _) -> List.map writeClause clauses |> join "; " |> sprintf "(function %s)" - | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _), body, _) -> sprintf "(fun () -> %s)" (writeExpr body) - | SynExpr.Lambda(_, _, SynSimplePats.SimplePats(pats, _), body, _) -> sprintf "(fun %s -> %s)" (List.map writeSimplePat pats |> join " ") (writeExpr body) + | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _), body, _, _) -> sprintf "(fun () -> %s)" (writeExpr body) + | SynExpr.Lambda(_, _, SynSimplePats.SimplePats(pats, _), body, _, _) -> sprintf "(fun %s -> %s)" (List.map writeSimplePat pats |> join " ") (writeExpr body) | SynExpr.App(_, true, f, x, _) -> sprintf "%s %s" (writeExpr x) (writeExpr f) | SynExpr.App(_, _, f, x, _) -> sprintf "(%s %s)" (writeExpr f) (writeExpr x) | x -> failwithf "SynExpr case not supported: %O" x diff --git a/src/Kl.Tests/Kl.Tests.fsproj b/src/Kl.Tests/Kl.Tests.fsproj index 83cf844..3b37ed3 100644 --- a/src/Kl.Tests/Kl.Tests.fsproj +++ b/src/Kl.Tests/Kl.Tests.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + netcoreapp5.0 Kl.Tests Kl.Tests Kl From e2bd8540921f179c8d4032502e352423373592f6 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Thu, 23 Nov 2023 01:02:33 -0600 Subject: [PATCH 03/44] Handle the changes to long identifiers in FCS 38. https://github.com/dotnet/fsharp/pull/13057 is the PR in question; I suspect I've done something wrong as there's a whole page of errors. However, the errors don't have to do with mscorlib! --- src/Kl.Make/Syntax.fs | 2 +- src/Kl.Make/Writer.fs | 12 +++++++----- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index 74c19bb..ed1e307 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -278,7 +278,7 @@ let matchLambdaExpr clauses = DebugPointForBinding .DebugPointAtBinding loc, loc) -let openDecl parts = SynModuleDecl.Open(longIdentWithDots parts, loc) +let openDecl parts = SynModuleDecl.Open(SynOpenDeclTarget.ModuleOrNamespace(longIdent parts, loc), loc) let letAttrsDecl attrs name paramz body = SynModuleDecl.Let(false, [letAttrsBinding attrs name paramz body], loc) let letAttrsUncurriedDecl attrs name paramz body = diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index c315379..28bc39b 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -6,7 +6,9 @@ let private join (sep: string) (strings: string list) = System.String.Join(sep, let private writeIdent (x: Ident) = if String.forall (System.Char.IsLetter) x.idText then x.idText else sprintf "``%s``" x.idText -let private writeLongIdent (x: LongIdentWithDots) = List.map writeIdent x.Lid |> join "." +let private writeLongIdent (x: LongIdent) = List.map writeIdent x |> join "." + +let private writeLongIdentWithDots (x: LongIdentWithDots) = List.map writeIdent x.Lid |> join "." let private escapeChar = function | x when x < ' ' -> int x |> sprintf "\\u%02x" @@ -25,7 +27,7 @@ let private writeConst = function | _ -> failwith "SynConst case not supported" let private writeType = function - | SynType.LongIdent x -> writeLongIdent x + | SynType.LongIdent x -> writeLongIdentWithDots x | _ -> failwith "SynType case not supported" let rec private writeSimplePat = function @@ -34,7 +36,7 @@ let rec private writeSimplePat = function | _ -> failwith "SynSimplePat case not supported" let rec private writePat = function - | SynPat.LongIdent(x, _, _, _, _, _) -> writeLongIdent x + | SynPat.LongIdent(x, _, _, _, _, _) -> writeLongIdentWithDots x | SynPat.Named(_, ident, _, _, _) -> writeIdent ident | SynPat.Paren(x, _) -> writePat x |> sprintf "(%s)" | SynPat.ArrayOrList(false, pats, _) -> List.map writePat pats |> join "; " |> sprintf "[%s]" @@ -43,7 +45,7 @@ let rec private writePat = function let rec private writeExpr = function | SynExpr.Paren(x, _, _, _) -> writeExpr x |> sprintf "(%s)" | SynExpr.Ident x -> writeIdent x - | SynExpr.LongIdent(_, x, _, _) -> writeLongIdent x + | SynExpr.LongIdent(_, x, _, _) -> writeLongIdentWithDots x | SynExpr.Const(x, _) -> writeConst x | SynExpr.Tuple(false, xs, _, _) -> List.map writeExpr xs |> join ", " |> sprintf "(%s)" | SynExpr.ArrayOrList(false, xs, _) -> List.map writeExpr xs |> join "; " |> sprintf "[%s]" @@ -69,7 +71,7 @@ let private writeBinding = function sprintf "%s = %s" (writePat pat) (writeExpr value) let private writeDecl = function - | SynModuleDecl.Open(x, _) -> writeLongIdent x |> sprintf "open %s" + | SynModuleDecl.Open(SynOpenDeclTarget.ModuleOrNamespace(x, _), _) -> writeLongIdent x |> sprintf "open %s" | SynModuleDecl.Let(recursive, binding :: bindings, _) -> sprintf "let%s %s%s" (if recursive then " rec" else "") (writeBinding binding) (List.map (writeBinding >> sprintf "\r\nand %s") bindings |> join "") | _ -> failwith "SynModuleDecl case not supported" From 696d445cf19723107d2f12e92fd746018e32f48f Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Thu, 23 Nov 2023 01:25:29 -0600 Subject: [PATCH 04/44] Get Kl.Make compiling. Upgraded to 6.0, was guided by missing assembly errors in `dotnet run --project Kl.Make`. There are warnings about the mismatch between FCS 38 and F# 6, but a) The projects are tracked together so it's arguably better to pin the latter. b) There are a bunch of changes between 38 and the oldest 6-friendly version, 41. --- src/Kl.Get/Kl.Get.fsproj | 2 +- src/Kl.Make/Kl.Make.fsproj | 2 +- src/Kl.Make/Loader.fs | 2 +- src/Kl.Tests/Kl.Tests.fsproj | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Kl.Get/Kl.Get.fsproj b/src/Kl.Get/Kl.Get.fsproj index 21e0087..f2298d2 100644 --- a/src/Kl.Get/Kl.Get.fsproj +++ b/src/Kl.Get/Kl.Get.fsproj @@ -1,7 +1,7 @@  - netcoreapp5.0 + net6.0 Kl.Get Kl.Get Kl diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index 09cd73e..436174a 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -1,7 +1,7 @@  - netcoreapp5.0 + net6.0 Kl.Make Kl.Make Kl diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index 5231d32..ff4188b 100644 --- a/src/Kl.Make/Loader.fs +++ b/src/Kl.Make/Loader.fs @@ -13,7 +13,7 @@ open ShenSharp.Shared let private dllName = sprintf "%s.dll" GeneratedModule let private pdbName = sprintf "%s.pdb" GeneratedModule -let private deps = ["Kl.dll"] +let private deps = ["Kl.dll"; "System.Runtime"; "System.Runtime.Numerics"; "System.Collections"; "System.Net.Requests"; "System.Net.WebClient"] let private sharedMetadataPath = fromRoot ["src"; "Shared.fs"] let private import sourcePath = diff --git a/src/Kl.Tests/Kl.Tests.fsproj b/src/Kl.Tests/Kl.Tests.fsproj index 3b37ed3..f6000f6 100644 --- a/src/Kl.Tests/Kl.Tests.fsproj +++ b/src/Kl.Tests/Kl.Tests.fsproj @@ -1,7 +1,7 @@  - netcoreapp5.0 + net6.0 Kl.Tests Kl.Tests Kl From fae34662937ba2e5800dd0502ea3d44643625d9d Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Thu, 23 Nov 2023 01:40:00 -0600 Subject: [PATCH 05/44] Target net6.0 with the Shen* projects. The compilation process appears to be broken indeed. There are a whole bunch of ununsed warnings during compile and no Shen code runs. https://github.com/dotnet/fsharp/blob/main/release-notes.md#fsharp-compiler-service-3900 is the next FCS upgrade to handle. https://fsharp.github.io/fsharp-compiler-docs/fsharp-core-notes.html suggests that the compiler/runtime mismatch is less than ideal but shouldn't be a showstopper. --- src/Shen.Repl/Shen.Repl.fsproj | 2 +- src/Shen.TestSuite/Shen.TestSuite.fsproj | 2 +- src/Shen.Tests/Shen.Tests.fsproj | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Shen.Repl/Shen.Repl.fsproj b/src/Shen.Repl/Shen.Repl.fsproj index 4616269..14d5383 100644 --- a/src/Shen.Repl/Shen.Repl.fsproj +++ b/src/Shen.Repl/Shen.Repl.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net6.0 Shen.Repl Shen.Repl Shen.Repl diff --git a/src/Shen.TestSuite/Shen.TestSuite.fsproj b/src/Shen.TestSuite/Shen.TestSuite.fsproj index 50b6f84..254a0aa 100644 --- a/src/Shen.TestSuite/Shen.TestSuite.fsproj +++ b/src/Shen.TestSuite/Shen.TestSuite.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net6.0 Shen.TestSuite Shen.TestSuite Shen.TestSuite diff --git a/src/Shen.Tests/Shen.Tests.fsproj b/src/Shen.Tests/Shen.Tests.fsproj index c87adf5..6793a57 100644 --- a/src/Shen.Tests/Shen.Tests.fsproj +++ b/src/Shen.Tests/Shen.Tests.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net6.0 Shen.Tests Shen.Tests Shen.Tests From 77276d1302de8d48092df90da09995ee7c892bde Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Thu, 23 Nov 2023 01:54:33 -0600 Subject: [PATCH 06/44] Upgrade to FCS 39. --- src/Kl.Make/Kl.Make.fsproj | 2 +- src/Kl.Make/Loader.fs | 8 ++++---- src/Kl.Make/Syntax.fs | 3 ++- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index 436174a..fcac01b 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index ff4188b..15b3457 100644 --- a/src/Kl.Make/Loader.fs +++ b/src/Kl.Make/Loader.fs @@ -19,18 +19,18 @@ let private sharedMetadataPath = fromRoot ["src"; "Shared.fs"] let private import sourcePath = List.collect (fun f -> combine [sourcePath; f] |> File.ReadAllText |> readAll) -let private filterMessages severity messages = Seq.filter (fun (m: FSharpErrorInfo) -> m.Severity = severity) messages +let private filterMessages severity messages = Seq.filter (fun (m: FSharpDiagnostic) -> m.Severity = severity) messages let private logWarnings messages = - messages |> filterMessages FSharpErrorSeverity.Warning |> Seq.iter (fun (m: FSharpErrorInfo) -> printfn "%O" m) + messages |> filterMessages FSharpDiagnosticSeverity.Warning |> Seq.iter (fun (m: FSharpDiagnostic) -> printfn "%O" m) let private raiseErrors messages = - let errors = filterMessages FSharpErrorSeverity.Error messages + let errors = filterMessages FSharpDiagnosticSeverity.Error messages raise(Exception(String.Join("\r\n\r\n", Seq.map string errors))) let private handleResults (value, messages) = logWarnings messages - if filterMessages FSharpErrorSeverity.Error messages |> Seq.length > 0 + if filterMessages FSharpDiagnosticSeverity.Error messages |> Seq.length > 0 then raiseErrors messages else value diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index ed1e307..5e03840 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -11,7 +11,8 @@ module internal Kl.Make.Syntax open System open FSharp.Compiler.SyntaxTree -open FSharp.Compiler.Range +open FSharp.Compiler.Text.Range +open FSharp.Compiler.Text.Pos open FSharp.Compiler.XmlDoc let private fileName = "file.fs" From 90541df49b2fe0bb31cd251b4d05ea1f4934fc6f Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Thu, 23 Nov 2023 02:35:52 -0600 Subject: [PATCH 07/44] Upgrade to FCS 40. --- src/Kl.Make/Kl.Make.fsproj | 2 +- src/Kl.Make/Loader.fs | 9 ++++---- src/Kl.Make/Syntax.fs | 46 +++++++++++++++++--------------------- src/Kl.Make/Writer.fs | 12 +++++----- 4 files changed, 31 insertions(+), 38 deletions(-) diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index fcac01b..1be10a0 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index 15b3457..ae138c0 100644 --- a/src/Kl.Make/Loader.fs +++ b/src/Kl.Make/Loader.fs @@ -2,7 +2,8 @@ open System open System.IO -open FSharp.Compiler.SourceCodeServices +open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.Diagnostics open FSharp.Compiler.Text open Kl open Kl.Values @@ -46,10 +47,8 @@ let private parseFile (checker: FSharpChecker) file = let result = checker.ParseFile(file, input, parsingOptions) |> Async.RunSynchronously - logWarnings result.Errors - match result.ParseTree with - | Some tree -> tree - | None -> raiseErrors result.Errors + logWarnings result.Diagnostics + result.ParseTree // TODO: specify arguments to exclude mscorlib.dll diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index 5e03840..c095ae7 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -10,10 +10,10 @@ module internal Kl.Make.Syntax open System -open FSharp.Compiler.SyntaxTree +open FSharp.Compiler.Syntax +open FSharp.Compiler.Xml open FSharp.Compiler.Text.Range -open FSharp.Compiler.Text.Pos -open FSharp.Compiler.XmlDoc +open FSharp.Compiler.Text.Position let private fileName = "file.fs" // Picked large values for line, col because there will be an unpredictable @@ -50,7 +50,7 @@ let listPat pats = SynPat.ArrayOrList(false, pats, loc) let tuplePat pats = SynPat.Paren(SynPat.Tuple(false, pats, loc), loc) let unitPat = SynPat.Paren(SynPat.Const(SynConst.Unit, loc), loc) let matchClause pat body = - SynMatchClause.Clause( + SynMatchClause.SynMatchClause( pat, None, body, @@ -62,9 +62,9 @@ let nameTypeSimplePat s synType = synType, loc) let simpleBinding pat value = - SynBinding.Binding( + SynBinding.SynBinding( None, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, [], @@ -77,12 +77,11 @@ let simpleBinding pat value = None, value, loc, - DebugPointForBinding -.NoDebugPointAtLetBinding) + DebugPointAtBinding.NoneAtLet) let letAttrsMultiParamBinding attrs name paramz body = - SynBinding.Binding( + SynBinding.SynBinding( None, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, attrs, @@ -105,12 +104,11 @@ let letAttrsMultiParamBinding attrs name paramz body = None, body, loc, - DebugPointForBinding -.DebugPointAtBinding loc) + DebugPointAtBinding.Yes loc) let letBindingAccessWithAttrs attrs access name paramz body = - SynBinding.Binding( + SynBinding.SynBinding( access, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, attrs, @@ -130,14 +128,13 @@ let letBindingAccessWithAttrs attrs access name paramz body = None, body, loc, - DebugPointForBinding -.DebugPointAtBinding loc) + DebugPointAtBinding.Yes loc) let letAttrsBinding attrs = letBindingAccessWithAttrs attrs None let letBinding = letAttrsBinding [] let letUnitBinding attrs name body = - SynBinding.Binding( + SynBinding.SynBinding( None, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, attrs, @@ -156,8 +153,7 @@ let letUnitBinding attrs name body = None, body, loc, - DebugPointForBinding -.DebugPointAtBinding loc) + DebugPointAtBinding.Yes loc) let parenExpr expr = SynExpr.Paren(expr, loc, None, loc) let parens = function | SynExpr.Paren _ as e -> e @@ -166,7 +162,7 @@ let unitExpr = SynExpr.Const(SynConst.Unit, loc) let boolExpr b = SynExpr.Const(SynConst.Bool b, loc) let intExpr n = SynExpr.Const(SynConst.Int32 n, loc) let decimalExpr n = SynExpr.Const(SynConst.Decimal n, loc) -let stringExpr s = SynExpr.Const(SynConst.String(s, loc), loc) +let stringExpr s = SynExpr.Const(SynConst.String(s, SynStringKind.Regular, loc), loc) let idExpr s = SynExpr.Ident(ident s) let longIdExpr parts = SynExpr.LongIdent(false, longIdentWithDots parts, None, loc) let indexSetExpr obj index value = @@ -198,8 +194,7 @@ let ifExpr condition consequent alternative = condition, consequent, Some alternative, - DebugPointForBinding -.NoDebugPointAtInvisibleBinding, + DebugPointAtBinding.NoneAtInvisible, false, loc, loc) @@ -215,7 +210,7 @@ let tryWithExpr body e handler = SynExpr.TryWith( body, loc, - [SynMatchClause.Clause( + [SynMatchClause.SynMatchClause( namePat e, None, handler, @@ -276,8 +271,7 @@ let matchLambdaExpr clauses = false, loc, clauses, - DebugPointForBinding -.DebugPointAtBinding loc, + DebugPointAtBinding.Yes loc, loc) let openDecl parts = SynModuleDecl.Open(SynOpenDeclTarget.ModuleOrNamespace(longIdent parts, loc), loc) let letAttrsDecl attrs name paramz body = diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index 28bc39b..cd070bb 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -1,6 +1,6 @@ module internal Writer -open FSharp.Compiler.SyntaxTree +open FSharp.Compiler.Syntax let private join (sep: string) (strings: string list) = System.String.Join(sep, strings |> List.toArray) @@ -23,7 +23,7 @@ let private writeConst = function | SynConst.Bool false -> "false" | SynConst.Int32 x -> sprintf "%i" x | SynConst.Decimal x -> sprintf "%Mm" x - | SynConst.String(x, _) -> writeString x + | SynConst.String(x, _, _) -> writeString x | _ -> failwith "SynConst case not supported" let private writeType = function @@ -50,11 +50,11 @@ let rec private writeExpr = function | SynExpr.Tuple(false, xs, _, _) -> List.map writeExpr xs |> join ", " |> sprintf "(%s)" | SynExpr.ArrayOrList(false, xs, _) -> List.map writeExpr xs |> join "; " |> sprintf "[%s]" | SynExpr.Sequential(_, _, x, y, _) -> sprintf "(%s; %s)" (writeExpr x) (writeExpr y) - | SynExpr.LetOrUse(_, _, [SynBinding.Binding(_, _, _, _, _, _, _, pat, _, value, _, _)], body, _) -> + | SynExpr.LetOrUse(_, _, [SynBinding.SynBinding(_, _, _, _, _, _, _, pat, _, value, _, _)], body, _) -> sprintf "(let %s = %s in %s)" (writePat pat) (writeExpr value) (writeExpr body) | SynExpr.IfThenElse(ifExpr, thenExpr, Some elseExpr, _, _, _, _) -> sprintf "(if (%s) then (%s) else (%s))" (writeExpr ifExpr) (writeExpr thenExpr) (writeExpr elseExpr) - | SynExpr.TryWith(body, _, [SynMatchClause.Clause(pat, _, handler, _, _)], _, _, _, _) -> + | SynExpr.TryWith(body, _, [SynMatchClause.SynMatchClause(pat, _, handler, _, _)], _, _, _, _) -> sprintf "(try %s; with %s -> %s)" (writeExpr body) (writePat pat) (writeExpr handler) | SynExpr.MatchLambda(_, _, clauses, _, _) -> List.map writeClause clauses |> join "; " |> sprintf "(function %s)" | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _), body, _, _) -> sprintf "(fun () -> %s)" (writeExpr body) @@ -64,10 +64,10 @@ let rec private writeExpr = function | x -> failwithf "SynExpr case not supported: %O" x and private writeClause = function - | SynMatchClause.Clause(pat, _, body, _, _) -> sprintf "| %s -> %s" (writePat pat) (writeExpr body) + | SynMatchClause.SynMatchClause(pat, _, body, _, _) -> sprintf "| %s -> %s" (writePat pat) (writeExpr body) let private writeBinding = function - | SynBinding.Binding(_, _, _, _, _, _, _, pat, _, value, _, _) -> + | SynBinding.SynBinding(_, _, _, _, _, _, _, pat, _, value, _, _) -> sprintf "%s = %s" (writePat pat) (writeExpr value) let private writeDecl = function From 9e6e0b9733dcd6a14da4e28f415fd36d0e529d3e Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Thu, 23 Nov 2023 23:57:06 -0600 Subject: [PATCH 08/44] Upgrade to FCS 41.0.7. --- src/Kl.Make/Kl.Make.fsproj | 2 +- src/Kl.Make/Syntax.fs | 54 +++++++++++++++++++++++--------------- src/Kl.Make/Writer.fs | 25 +++++++++--------- 3 files changed, 47 insertions(+), 34 deletions(-) diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index 1be10a0..2779dd9 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index c095ae7..f0fea50 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -33,9 +33,10 @@ let attrs xs : SynAttributeList list = [{ let ident s = new Ident(s, loc) let longIdent parts = List.map ident parts let longIdentWithDots parts = - LongIdentWithDots.LongIdentWithDots( + SynLongIdent.SynLongIdent( List.map ident parts, - List.replicate (List.length parts - 1) loc) + List.replicate (List.length parts - 1) loc, + []) let argInfo s = SynArgInfo.SynArgInfo([], false, Some(ident s)) let nullArgInfo = SynArgInfo.SynArgInfo([], false, None) let anonType = SynType.Anon loc @@ -43,7 +44,7 @@ let longType parts = SynType.LongIdent(longIdentWithDots parts) let shortType s = longType [s] let listType t = SynType.App(shortType "list", None, [t], [], None, true, loc) let wildPat = SynPat.Wild loc -let namePat s = SynPat.Named(wildPat, ident s, false, None, loc) +let namePat s = SynPat.Named(SynIdent(ident s, None), false, None, loc) let unparenTypedPat pat synType = SynPat.Typed(pat, synType, loc) let typedPat pat synType = SynPat.Paren(unparenTypedPat pat synType, loc) let listPat pats = SynPat.ArrayOrList(false, pats, loc) @@ -55,7 +56,8 @@ let matchClause pat body = None, body, loc, - DebugPointForTarget.Yes) + DebugPointAtTarget.Yes, + {ArrowRange = Some loc; BarRange = Some loc}) let nameTypeSimplePat s synType = SynSimplePat.Typed( SynSimplePat.Id(ident s, None, true, false, false, loc), @@ -77,7 +79,8 @@ let simpleBinding pat value = None, value, loc, - DebugPointAtBinding.NoneAtLet) + DebugPointAtBinding.NoneAtLet, + {EqualsRange = Some loc; LetKeyword = Some loc}) let letAttrsMultiParamBinding attrs name paramz body = SynBinding.SynBinding( None, @@ -104,7 +107,8 @@ let letAttrsMultiParamBinding attrs name paramz body = None, body, loc, - DebugPointAtBinding.Yes loc) + DebugPointAtBinding.Yes loc, + {EqualsRange = Some loc; LetKeyword = Some loc}) let letBindingAccessWithAttrs attrs access name paramz body = SynBinding.SynBinding( access, @@ -128,7 +132,8 @@ let letBindingAccessWithAttrs attrs access name paramz body = None, body, loc, - DebugPointAtBinding.Yes loc) + DebugPointAtBinding.Yes loc, + {EqualsRange = Some loc; LetKeyword = Some loc}) let letAttrsBinding attrs = letBindingAccessWithAttrs attrs None let letBinding = letAttrsBinding [] let letUnitBinding attrs name body = @@ -153,7 +158,8 @@ let letUnitBinding attrs name body = None, body, loc, - DebugPointAtBinding.Yes loc) + DebugPointAtBinding.Yes loc, + {EqualsRange = Some loc; LetKeyword = Some loc}) let parenExpr expr = SynExpr.Paren(expr, loc, None, loc) let parens = function | SynExpr.Paren _ as e -> e @@ -168,7 +174,7 @@ let longIdExpr parts = SynExpr.LongIdent(false, longIdentWithDots parts, None, l let indexSetExpr obj index value = SynExpr.DotIndexedSet( obj, - [SynIndexerArg.One index], + index, value, loc, loc, @@ -197,7 +203,7 @@ let ifExpr condition consequent alternative = DebugPointAtBinding.NoneAtInvisible, false, loc, - loc) + {IfKeyword = loc; IsElif = false; ElseKeyword = None; ThenKeyword = loc; IfToThenRange = loc}) parens expr let letExpr symbol value body = SynExpr.LetOrUse( @@ -205,27 +211,28 @@ let letExpr symbol value body = false, [simpleBinding (namePat symbol) value], body, - loc) + loc, + {InKeyword = Some loc}) let tryWithExpr body e handler = SynExpr.TryWith( body, - loc, [SynMatchClause.SynMatchClause( namePat e, None, handler, loc, - DebugPointForTarget.Yes)], - loc, + DebugPointAtTarget.Yes, + {ArrowRange = Some loc; BarRange = Some loc})], loc, DebugPointAtTry.Yes loc, - DebugPointAtWith.Yes loc) + DebugPointAtWith.Yes loc, + {TryKeyword = loc; TryToWithRange = loc; WithKeyword = loc; WithToEndRange = loc}) let rec sequentialExpr = function | [] -> failwith "sequential cannot be empty" | [expr] -> expr | expr :: rest -> SynExpr.Sequential( - DebugPointAtSequential.Both, + DebugPointAtSequential.SuppressNeither, true, expr, sequentialExpr rest, @@ -248,7 +255,8 @@ let rec lambdaExpr paramz body = SynSimplePats.SimplePats([], loc), body, None, - loc) + loc, + {ArrowRange = Some loc}) | [s, synType] -> SynExpr.Lambda( false, @@ -256,7 +264,8 @@ let rec lambdaExpr paramz body = SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), body, None, - loc) + loc, + {ArrowRange = Some loc}) | (s, synType) :: paramz -> SynExpr.Lambda( false, @@ -264,7 +273,8 @@ let rec lambdaExpr paramz body = SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), lambdaExpr paramz body, None, - loc) + loc, + {ArrowRange = Some loc}) parens expr let matchLambdaExpr clauses = SynExpr.MatchLambda( @@ -300,5 +310,7 @@ let moduleFile nameParts decls = PreXmlDoc.Empty, [], None, - loc)], - (false, false))) + loc, + {ModuleKeyword = Some loc; NamespaceKeyword = Some loc})], + (false, false), + {CodeComments = []; ConditionalDirectives = []})) diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index cd070bb..bfca1c8 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -8,7 +8,7 @@ let private writeIdent (x: Ident) = if String.forall (System.Char.IsLetter) x.id let private writeLongIdent (x: LongIdent) = List.map writeIdent x |> join "." -let private writeLongIdentWithDots (x: LongIdentWithDots) = List.map writeIdent x.Lid |> join "." +let private writeSynLongIdent (x: SynLongIdent) = List.map writeIdent x.LongIdent |> join "." let private escapeChar = function | x when x < ' ' -> int x |> sprintf "\\u%02x" @@ -27,7 +27,7 @@ let private writeConst = function | _ -> failwith "SynConst case not supported" let private writeType = function - | SynType.LongIdent x -> writeLongIdentWithDots x + | SynType.LongIdent x -> writeSynLongIdent x | _ -> failwith "SynType case not supported" let rec private writeSimplePat = function @@ -36,8 +36,8 @@ let rec private writeSimplePat = function | _ -> failwith "SynSimplePat case not supported" let rec private writePat = function - | SynPat.LongIdent(x, _, _, _, _, _) -> writeLongIdentWithDots x - | SynPat.Named(_, ident, _, _, _) -> writeIdent ident + | SynPat.LongIdent(x, _, _, _, _, _) -> writeSynLongIdent x + | SynPat.Named(SynIdent(ident, _), _, _, _) -> writeIdent ident | SynPat.Paren(x, _) -> writePat x |> sprintf "(%s)" | SynPat.ArrayOrList(false, pats, _) -> List.map writePat pats |> join "; " |> sprintf "[%s]" | x -> failwithf "SynPat case not supported: %O" x @@ -45,29 +45,29 @@ let rec private writePat = function let rec private writeExpr = function | SynExpr.Paren(x, _, _, _) -> writeExpr x |> sprintf "(%s)" | SynExpr.Ident x -> writeIdent x - | SynExpr.LongIdent(_, x, _, _) -> writeLongIdentWithDots x + | SynExpr.LongIdent(_, x, _, _) -> writeSynLongIdent x | SynExpr.Const(x, _) -> writeConst x | SynExpr.Tuple(false, xs, _, _) -> List.map writeExpr xs |> join ", " |> sprintf "(%s)" | SynExpr.ArrayOrList(false, xs, _) -> List.map writeExpr xs |> join "; " |> sprintf "[%s]" | SynExpr.Sequential(_, _, x, y, _) -> sprintf "(%s; %s)" (writeExpr x) (writeExpr y) - | SynExpr.LetOrUse(_, _, [SynBinding.SynBinding(_, _, _, _, _, _, _, pat, _, value, _, _)], body, _) -> + | SynExpr.LetOrUse(_, _, [SynBinding.SynBinding(_, _, _, _, _, _, _, pat, _, value, _, _, _)], body, _, _) -> sprintf "(let %s = %s in %s)" (writePat pat) (writeExpr value) (writeExpr body) | SynExpr.IfThenElse(ifExpr, thenExpr, Some elseExpr, _, _, _, _) -> sprintf "(if (%s) then (%s) else (%s))" (writeExpr ifExpr) (writeExpr thenExpr) (writeExpr elseExpr) - | SynExpr.TryWith(body, _, [SynMatchClause.SynMatchClause(pat, _, handler, _, _)], _, _, _, _) -> + | SynExpr.TryWith(body, [SynMatchClause.SynMatchClause(pat, _, handler, _, _, _)], _, _, _, _) -> sprintf "(try %s; with %s -> %s)" (writeExpr body) (writePat pat) (writeExpr handler) | SynExpr.MatchLambda(_, _, clauses, _, _) -> List.map writeClause clauses |> join "; " |> sprintf "(function %s)" - | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _), body, _, _) -> sprintf "(fun () -> %s)" (writeExpr body) - | SynExpr.Lambda(_, _, SynSimplePats.SimplePats(pats, _), body, _, _) -> sprintf "(fun %s -> %s)" (List.map writeSimplePat pats |> join " ") (writeExpr body) + | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _), body, _, _, _) -> sprintf "(fun () -> %s)" (writeExpr body) + | SynExpr.Lambda(_, _, SynSimplePats.SimplePats(pats, _), body, _, _, _) -> sprintf "(fun %s -> %s)" (List.map writeSimplePat pats |> join " ") (writeExpr body) | SynExpr.App(_, true, f, x, _) -> sprintf "%s %s" (writeExpr x) (writeExpr f) | SynExpr.App(_, _, f, x, _) -> sprintf "(%s %s)" (writeExpr f) (writeExpr x) | x -> failwithf "SynExpr case not supported: %O" x and private writeClause = function - | SynMatchClause.SynMatchClause(pat, _, body, _, _) -> sprintf "| %s -> %s" (writePat pat) (writeExpr body) + | SynMatchClause.SynMatchClause(pat, _, body, _, _, _) -> sprintf "| %s -> %s" (writePat pat) (writeExpr body) let private writeBinding = function - | SynBinding.SynBinding(_, _, _, _, _, _, _, pat, _, value, _, _) -> + | SynBinding.SynBinding(_, _, _, _, _, _, _, pat, _, value, _, _, _) -> sprintf "%s = %s" (writePat pat) (writeExpr value) let private writeDecl = function @@ -77,7 +77,7 @@ let private writeDecl = function | _ -> failwith "SynModuleDecl case not supported" let private writeModule = function - | SynModuleOrNamespace.SynModuleOrNamespace(_, _, _, decls, _, _, _, _) -> + | SynModuleOrNamespace.SynModuleOrNamespace(_, _, _, decls, _, _, _, _, _) -> sprintf "module Shen.Kernel\r\n\r\n%s" (List.map writeDecl decls |> join "\r\n\r\n") let writeFile = function @@ -89,6 +89,7 @@ let writeFile = function _, _, modules, + _, _)) -> List.map writeModule modules |> join "\r\n\r\n" | _ -> failwith "ParsedInput case not supported" From 9c9d65896d56de193ca226a92377bc441386d524 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 01:06:37 -0600 Subject: [PATCH 09/44] Simplify reference to Kl. --- src/Kl.Make/Loader.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index ae138c0..7561348 100644 --- a/src/Kl.Make/Loader.fs +++ b/src/Kl.Make/Loader.fs @@ -14,7 +14,7 @@ open ShenSharp.Shared let private dllName = sprintf "%s.dll" GeneratedModule let private pdbName = sprintf "%s.pdb" GeneratedModule -let private deps = ["Kl.dll"; "System.Runtime"; "System.Runtime.Numerics"; "System.Collections"; "System.Net.Requests"; "System.Net.WebClient"] +let private deps = ["Kl"; "System.Runtime"; "System.Runtime.Numerics"; "System.Collections"; "System.Net.Requests"; "System.Net.WebClient"] let private sharedMetadataPath = fromRoot ["src"; "Shared.fs"] let private import sourcePath = From 112001cda6f3b02c6010b0bd078eec2aa5ab6ef5 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 15:01:38 -0600 Subject: [PATCH 10/44] Switch all projects over to net6.0. Supporting netstandard2.1 is not recommended per https://devblogs.microsoft.com/dotnet/the-future-of-net-standard/ (.NET 5) and causes runtime mismatches. If it's feasible the compatibility can be added back later. --- src/Kl.Make/Compiler.fs | 2 +- src/Kl/Kl.fsproj | 2 +- src/Shen/Shen.fsproj | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Kl.Make/Compiler.fs b/src/Kl.Make/Compiler.fs index a83e4a7..7d475df 100644 --- a/src/Kl.Make/Compiler.fs +++ b/src/Kl.Make/Compiler.fs @@ -252,5 +252,5 @@ let buildMetadataFile name copyright version config = meta ["System"; "Reflection"; "AssemblyFileVersion"] version meta ["System"; "Reflection"; "AssemblyInformationalVersion"] <| version.Substring(0, version.Length - 2) meta ["System"; "Reflection"; "AssemblyConfiguration"] config - meta ["System"; "Runtime"; "Versioning"; "TargetFramework"] ".NETStandard,Version=v2.1" + meta ["System"; "Runtime"; "Versioning"; "TargetFramework"] ".NETCoreApp,Version=v6.0" ] diff --git a/src/Kl/Kl.fsproj b/src/Kl/Kl.fsproj index 5f7f185..2dff723 100644 --- a/src/Kl/Kl.fsproj +++ b/src/Kl/Kl.fsproj @@ -1,7 +1,7 @@  - netstandard2.1 + net6.0 Kl Kl Kl diff --git a/src/Shen/Shen.fsproj b/src/Shen/Shen.fsproj index 287e88c..4975306 100644 --- a/src/Shen/Shen.fsproj +++ b/src/Shen/Shen.fsproj @@ -1,7 +1,7 @@  - netstandard2.1 + net6.0 Shen Shen Shen From 3776f871310b816a31d54d58201e990266bd0d2d Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 15:50:52 -0600 Subject: [PATCH 11/44] Fix .NET Standard -> .NET Core warnings. --- src/Kl.Get/GetKl.fs | 10 +++++++--- src/Kl.Make/Loader.fs | 2 ++ src/Kl/Builtins.fs | 14 +++++++++----- src/Kl/Interop.fs | 2 +- 4 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/Kl.Get/GetKl.fs b/src/Kl.Get/GetKl.fs index 3ef3728..904252e 100644 --- a/src/Kl.Get/GetKl.fs +++ b/src/Kl.Get/GetKl.fs @@ -3,7 +3,7 @@ open System open System.IO open System.IO.Compression -open System.Net +open System.Net.Http open ShenSharp.Shared let url = sprintf "https://github.com/Shen-Language/shen-sources/releases/download/shen-%s/%s.zip" KernelRevision KernelFolderName @@ -22,8 +22,12 @@ let main _ = printfn "Extracted folder: \"%s\"" extractedFolder printfn "Kernel folder: \"%s\"" kernelFolder printfn "Downloading sources package..." - use client = new WebClient() - client.DownloadFile(url, zipPath) + async { + use client = new HttpClient() + use zip = new FileStream(zipPath, FileMode.Create) + let! req = client.GetStreamAsync url |> Async.AwaitTask + do! req.CopyToAsync zip |> Async.AwaitTask + } |> Async.RunSynchronously printfn "Extracting sources package..." safeDelete kernelFolder ZipFile.ExtractToDirectory(zipPath, root) diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index 7561348..b8cf44f 100644 --- a/src/Kl.Make/Loader.fs +++ b/src/Kl.Make/Loader.fs @@ -87,6 +87,8 @@ let make sourcePath sourceFiles outputPath = let metadataAst = buildMetadataFile GeneratedModule Copyright Revision BuildConfig printfn "Compiling kernel..." emit checker [ast; sharedAst; metadataAst] + // let (errors, _) = checker.Compile([|"fsc.exe"; "-a"; "Kernel.fs"; $"-o:%s{dllName}"; "--targetprofile:netcore"; "--target:library"|]) |> Async.RunSynchronously + // handleResults ((), errors) printfn "Copying artifacts to output path..." move dllName (combine [outputPath; dllName]) printfn "Done." diff --git a/src/Kl/Builtins.fs b/src/Kl/Builtins.fs index fac5e9c..f73eed2 100644 --- a/src/Kl/Builtins.fs +++ b/src/Kl/Builtins.fs @@ -3,7 +3,7 @@ open System open System.Diagnostics open System.IO -open System.Net +open System.Net.Http open Values open Interop open Evaluator @@ -339,12 +339,16 @@ let ``kl_shen-sharp.globals`` globals = function let ``kl_shen-sharp.http-post`` _ = function | [Str url; Str payload] -> - use client = new WebClient() - Str(client.UploadString(url, payload)) + async { + use client = new HttpClient() + use payload = new StringContent(payload) + let! resp = client.PostAsync(url, payload) |> Async.AwaitTask + return! resp.Content.ReadAsStringAsync() |> Async.AwaitTask + } |> Async.RunSynchronously |> Str | args -> argsErr "shen-sharp.http-post" ["string"] args let ``kl_shen-sharp.curl`` _ = function | [Str url] -> - use client = new WebClient() - Str(client.DownloadString(url)) + use client = new HttpClient() + client.GetStringAsync(url) |> Async.AwaitTask |> Async.RunSynchronously |> Str | args -> argsErr "shen-sharp.curl" ["string"] args diff --git a/src/Kl/Interop.fs b/src/Kl/Interop.fs index dddee4e..6bf3607 100644 --- a/src/Kl/Interop.fs +++ b/src/Kl/Interop.fs @@ -160,7 +160,7 @@ let reference globals (name: string) = if File.Exists name then AppDomain.CurrentDomain.Load(name) else - let mscorlibPath = UriBuilder(typedefof.Assembly.CodeBase).Uri.LocalPath + let mscorlibPath = UriBuilder(typedefof.Assembly.Location).Uri.LocalPath let standardPathRoot = Path.GetDirectoryName(mscorlibPath) let inStandardPath = Path.Combine(standardPathRoot, name) if File.Exists name From 0e7a1097e1f571aec1935aa9655aa07a550db34b Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 18:05:34 -0600 Subject: [PATCH 12/44] Enable type information to be output in lambdas. The toplevel generated code looked like `let rec ``kl_shen.repl`` =...` when it should have looked like `let rec ``kl_shen.repl`` (globals: Globals) =...`. We handle the params inline and add a case for the type information. --- src/Kl.Make/Writer.fs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index bfca1c8..fbdbe6f 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -36,8 +36,9 @@ let rec private writeSimplePat = function | _ -> failwith "SynSimplePat case not supported" let rec private writePat = function - | SynPat.LongIdent(x, _, _, _, _, _) -> writeSynLongIdent x + | SynPat.LongIdent(x, _, _, pats, _, _) -> sprintf "%s %s" (writeSynLongIdent x) (List.map writePat pats.Patterns |> join " ") | SynPat.Named(SynIdent(ident, _), _, _, _) -> writeIdent ident + | SynPat.Typed(pat, typ, _) -> sprintf "%s: %s" (writePat pat) (writeType typ) | SynPat.Paren(x, _) -> writePat x |> sprintf "(%s)" | SynPat.ArrayOrList(false, pats, _) -> List.map writePat pats |> join "; " |> sprintf "[%s]" | x -> failwithf "SynPat case not supported: %O" x From 6a1eaf3748ff61053f3332176f35ee07532f3d61 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 18:07:03 -0600 Subject: [PATCH 13/44] Revert typo. --- src/Kl.Make/Loader.fs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index b8cf44f..7561348 100644 --- a/src/Kl.Make/Loader.fs +++ b/src/Kl.Make/Loader.fs @@ -87,8 +87,6 @@ let make sourcePath sourceFiles outputPath = let metadataAst = buildMetadataFile GeneratedModule Copyright Revision BuildConfig printfn "Compiling kernel..." emit checker [ast; sharedAst; metadataAst] - // let (errors, _) = checker.Compile([|"fsc.exe"; "-a"; "Kernel.fs"; $"-o:%s{dllName}"; "--targetprofile:netcore"; "--target:library"|]) |> Async.RunSynchronously - // handleResults ((), errors) printfn "Copying artifacts to output path..." move dllName (combine [outputPath; dllName]) printfn "Done." From 24e658192dbba159fb03cbcdd423356302256775 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 18:41:48 -0600 Subject: [PATCH 14/44] Fix infix applications. This is subtly wrong, but as we only use the `op_` names in the compiler, outputting them in prefix form is fine. To be fully general, I suppose one would build out a lookup of https://learn.microsoft.com/en-us/dotnet/fsharp/language-reference/operator-overloading#overloaded-operator-names --- src/Kl.Make/Writer.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index fbdbe6f..b440f6b 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -60,7 +60,6 @@ let rec private writeExpr = function | SynExpr.MatchLambda(_, _, clauses, _, _) -> List.map writeClause clauses |> join "; " |> sprintf "(function %s)" | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _), body, _, _, _) -> sprintf "(fun () -> %s)" (writeExpr body) | SynExpr.Lambda(_, _, SynSimplePats.SimplePats(pats, _), body, _, _, _) -> sprintf "(fun %s -> %s)" (List.map writeSimplePat pats |> join " ") (writeExpr body) - | SynExpr.App(_, true, f, x, _) -> sprintf "%s %s" (writeExpr x) (writeExpr f) | SynExpr.App(_, _, f, x, _) -> sprintf "(%s %s)" (writeExpr f) (writeExpr x) | x -> failwithf "SynExpr case not supported: %O" x From 90200b6c4ee0ac14448c0734dc623d25944aa43d Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 18:43:15 -0600 Subject: [PATCH 15/44] Build the kernel with dotnet instead of FCS. --- src/Shen.Kernel/Shen.Kernel.fsproj | 16 ++++++++++++++++ src/Shen.sln | 6 ++++++ src/Shen/Shen.fsproj | 7 +------ 3 files changed, 23 insertions(+), 6 deletions(-) create mode 100644 src/Shen.Kernel/Shen.Kernel.fsproj diff --git a/src/Shen.Kernel/Shen.Kernel.fsproj b/src/Shen.Kernel/Shen.Kernel.fsproj new file mode 100644 index 0000000..891e481 --- /dev/null +++ b/src/Shen.Kernel/Shen.Kernel.fsproj @@ -0,0 +1,16 @@ + + + + net6.0 + true + + + + + + + + + + + diff --git a/src/Shen.sln b/src/Shen.sln index 04cf9f7..b40f401 100644 --- a/src/Shen.sln +++ b/src/Shen.sln @@ -22,6 +22,8 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Shen.Tests", "Shen.Tests\Sh EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Shen", "Shen\Shen.fsproj", "{1885A119-975D-43F6-8A8D-8200C89A943C}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Shen.Kernel", "Shen.Kernel\Shen.Kernel.fsproj", "{4B06E862-B41A-4FAD-808B-BC8095E7000B}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -48,6 +50,10 @@ Global {1885A119-975D-43F6-8A8D-8200C89A943C}.Debug|Any CPU.Build.0 = Debug|Any CPU {1885A119-975D-43F6-8A8D-8200C89A943C}.Release|Any CPU.ActiveCfg = Release|Any CPU {1885A119-975D-43F6-8A8D-8200C89A943C}.Release|Any CPU.Build.0 = Release|Any CPU + {4B06E862-B41A-4FAD-808B-BC8095E7000B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {4B06E862-B41A-4FAD-808B-BC8095E7000B}.Debug|Any CPU.Build.0 = Debug|Any CPU + {4B06E862-B41A-4FAD-808B-BC8095E7000B}.Release|Any CPU.ActiveCfg = Release|Any CPU + {4B06E862-B41A-4FAD-808B-BC8095E7000B}.Release|Any CPU.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE diff --git a/src/Shen/Shen.fsproj b/src/Shen/Shen.fsproj index 4975306..9af5377 100644 --- a/src/Shen/Shen.fsproj +++ b/src/Shen/Shen.fsproj @@ -16,12 +16,7 @@ - - - - - ..\..\kernel\dotnet\$(Configuration)\Shen.Kernel.dll - + From b554dba36183644e6196393e7653b8d77afd0867 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 24 Nov 2023 18:49:45 -0600 Subject: [PATCH 16/44] Bump kernel to 22.4. --- src/Shared.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shared.fs b/src/Shared.fs index e74f82e..b482b37 100644 --- a/src/Shared.fs +++ b/src/Shared.fs @@ -13,7 +13,7 @@ let Copyright = "Copyright let Revision = "0.10.0.0" [] -let KernelRevision = "22.2" +let KernelRevision = "22.4" [] let KernelFolderName = "ShenOSKernel-" + KernelRevision From ee1c4ec3ad1e60933f081fe0c0c86edf726593ec Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 25 Nov 2023 21:06:10 -0600 Subject: [PATCH 17/44] Use task blocks. --- src/Kl.Get/GetKl.fs | 8 ++++---- src/Kl/Builtins.fs | 16 ++++++++++------ 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Kl.Get/GetKl.fs b/src/Kl.Get/GetKl.fs index 904252e..d6b9666 100644 --- a/src/Kl.Get/GetKl.fs +++ b/src/Kl.Get/GetKl.fs @@ -22,12 +22,12 @@ let main _ = printfn "Extracted folder: \"%s\"" extractedFolder printfn "Kernel folder: \"%s\"" kernelFolder printfn "Downloading sources package..." - async { + (task { use client = new HttpClient() use zip = new FileStream(zipPath, FileMode.Create) - let! req = client.GetStreamAsync url |> Async.AwaitTask - do! req.CopyToAsync zip |> Async.AwaitTask - } |> Async.RunSynchronously + let! req = client.GetStreamAsync url + do! req.CopyToAsync zip + }).Wait () printfn "Extracting sources package..." safeDelete kernelFolder ZipFile.ExtractToDirectory(zipPath, root) diff --git a/src/Kl/Builtins.fs b/src/Kl/Builtins.fs index f73eed2..1735901 100644 --- a/src/Kl/Builtins.fs +++ b/src/Kl/Builtins.fs @@ -339,16 +339,20 @@ let ``kl_shen-sharp.globals`` globals = function let ``kl_shen-sharp.http-post`` _ = function | [Str url; Str payload] -> - async { + task { use client = new HttpClient() use payload = new StringContent(payload) - let! resp = client.PostAsync(url, payload) |> Async.AwaitTask - return! resp.Content.ReadAsStringAsync() |> Async.AwaitTask - } |> Async.RunSynchronously |> Str + let! resp = client.PostAsync(url, payload) + let! content = resp.Content.ReadAsStringAsync() + return content |> Str + } |> Async.AwaitTask |> Async.RunSynchronously | args -> argsErr "shen-sharp.http-post" ["string"] args let ``kl_shen-sharp.curl`` _ = function | [Str url] -> - use client = new HttpClient() - client.GetStringAsync(url) |> Async.AwaitTask |> Async.RunSynchronously |> Str + task { + use client = new HttpClient() + let! content = client.GetStringAsync(url) + return content |> Str + } |> Async.AwaitTask |> Async.RunSynchronously | args -> argsErr "shen-sharp.curl" ["string"] args From 2097b68d2b427e3dfdbcba13a0e3e6b950cb8ea0 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 03:42:17 -0500 Subject: [PATCH 18/44] Fix mangled newlines. It's not clear whether \u%02x literals ever worked, but 4-padded escapes work (as does a special case for newlines, which seem to be the main outputs; the only other Unicode literals I can find are part of shen.funexstring, also fixed here). --- src/Kl.Make/Writer.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index b440f6b..8ce6d0f 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -11,7 +11,7 @@ let private writeLongIdent (x: LongIdent) = List.map writeIdent x |> join "." let private writeSynLongIdent (x: SynLongIdent) = List.map writeIdent x.LongIdent |> join "." let private escapeChar = function - | x when x < ' ' -> int x |> sprintf "\\u%02x" + | x when x < ' ' -> int x |> sprintf "\\u%04x" | x when x > '~' -> int x |> sprintf "\\u%04x" | x -> sprintf "%c" x From dbad6bdf2951719f9c75f130c756a0b31315a7bf Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 04:48:56 -0500 Subject: [PATCH 19/44] Remove DLL emitter. There is most certainly more dead code to shake. --- src/Kl.Make/BuildRuntime.fs | 3 +-- src/Kl.Make/Loader.fs | 23 +---------------------- 2 files changed, 2 insertions(+), 24 deletions(-) diff --git a/src/Kl.Make/BuildRuntime.fs b/src/Kl.Make/BuildRuntime.fs index 91d0ea9..5b1ce8e 100644 --- a/src/Kl.Make/BuildRuntime.fs +++ b/src/Kl.Make/BuildRuntime.fs @@ -4,7 +4,6 @@ open Kl.Values open Loader open ShenSharp.Shared -let outputPath = fromRoot ["kernel"; "dotnet"; BuildConfig] let sourcePath = fromRoot ["kernel"; "klambda"] let sourceFiles = [ "toplevel.kl" @@ -25,7 +24,7 @@ let sourceFiles = [ "init.kl" ] -let buildRuntime () = make sourcePath sourceFiles outputPath +let buildRuntime () = make sourcePath sourceFiles [] let main _ = separateThread128MB buildRuntime diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index 7561348..a86e20c 100644 --- a/src/Kl.Make/Loader.fs +++ b/src/Kl.Make/Loader.fs @@ -50,21 +50,6 @@ let private parseFile (checker: FSharpChecker) file = logWarnings result.Diagnostics result.ParseTree -// TODO: specify arguments to exclude mscorlib.dll - -let private emit (checker: FSharpChecker) asts = - let (errors, _) = - checker.Compile( - asts, - GeneratedModule, - dllName, - deps, - pdbName, - false, - true) - |> Async.RunSynchronously - handleResults ((), errors) - let private move source destination = if File.Exists destination then File.Delete destination @@ -77,16 +62,10 @@ let private filterDefuns excluded = | _ -> false // Exclude all non-defuns too List.filter filter -let make sourcePath sourceFiles outputPath = +let make sourcePath sourceFiles = let checker = FSharpChecker.Create() let exprs = import sourcePath sourceFiles |> filterDefuns ["cd"] printfn "Translating kernel..." let ast = buildInstallationFile GeneratedModule exprs File.WriteAllText("Kernel.fs", writeFile ast) - let sharedAst = parseFile checker sharedMetadataPath - let metadataAst = buildMetadataFile GeneratedModule Copyright Revision BuildConfig - printfn "Compiling kernel..." - emit checker [ast; sharedAst; metadataAst] - printfn "Copying artifacts to output path..." - move dllName (combine [outputPath; dllName]) printfn "Done." From 63ecfa1ba392486b161a5a3d6994ceb7a6a578b9 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 04:49:56 -0500 Subject: [PATCH 20/44] Update to .NET 8 and the associated FCS. --- src/Kl.Get/Kl.Get.fsproj | 2 +- src/Kl.Make/Compiler.fs | 2 +- src/Kl.Make/Kl.Make.fsproj | 4 ++-- src/Kl.Make/Syntax.fs | 25 ++++++++++++------------ src/Kl.Make/Writer.fs | 7 ++++--- src/Kl.Tests/Kl.Tests.fsproj | 2 +- src/Kl/Kl.fsproj | 2 +- src/Shen.Kernel/Shen.Kernel.fsproj | 2 +- src/Shen.Repl/Shen.Repl.fsproj | 2 +- src/Shen.TestSuite/Shen.TestSuite.fsproj | 2 +- src/Shen.Tests/Shen.Tests.fsproj | 2 +- src/Shen/Shen.fsproj | 2 +- 12 files changed, 28 insertions(+), 26 deletions(-) diff --git a/src/Kl.Get/Kl.Get.fsproj b/src/Kl.Get/Kl.Get.fsproj index f2298d2..f3ed4a6 100644 --- a/src/Kl.Get/Kl.Get.fsproj +++ b/src/Kl.Get/Kl.Get.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Kl.Get Kl.Get Kl diff --git a/src/Kl.Make/Compiler.fs b/src/Kl.Make/Compiler.fs index 7d475df..6c0bfdc 100644 --- a/src/Kl.Make/Compiler.fs +++ b/src/Kl.Make/Compiler.fs @@ -252,5 +252,5 @@ let buildMetadataFile name copyright version config = meta ["System"; "Reflection"; "AssemblyFileVersion"] version meta ["System"; "Reflection"; "AssemblyInformationalVersion"] <| version.Substring(0, version.Length - 2) meta ["System"; "Reflection"; "AssemblyConfiguration"] config - meta ["System"; "Runtime"; "Versioning"; "TargetFramework"] ".NETCoreApp,Version=v6.0" + meta ["System"; "Runtime"; "Versioning"; "TargetFramework"] ".NETCoreApp,Version=v8.0" ] diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index 2779dd9..21f0261 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Kl.Make Kl.Make Kl @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index f0fea50..9afe841 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -11,6 +11,7 @@ module internal Kl.Make.Syntax open System open FSharp.Compiler.Syntax +open FSharp.Compiler.SyntaxTrivia open FSharp.Compiler.Xml open FSharp.Compiler.Text.Range open FSharp.Compiler.Text.Position @@ -31,7 +32,6 @@ let attrs xs : SynAttributeList list = [{ Range = loc }] let ident s = new Ident(s, loc) -let longIdent parts = List.map ident parts let longIdentWithDots parts = SynLongIdent.SynLongIdent( List.map ident parts, @@ -48,7 +48,7 @@ let namePat s = SynPat.Named(SynIdent(ident s, None), false, None, loc) let unparenTypedPat pat synType = SynPat.Typed(pat, synType, loc) let typedPat pat synType = SynPat.Paren(unparenTypedPat pat synType, loc) let listPat pats = SynPat.ArrayOrList(false, pats, loc) -let tuplePat pats = SynPat.Paren(SynPat.Tuple(false, pats, loc), loc) +let tuplePat pats = SynPat.Paren(SynPat.Tuple(false, pats, [], loc), loc) let unitPat = SynPat.Paren(SynPat.Const(SynConst.Unit, loc), loc) let matchClause pat body = SynMatchClause.SynMatchClause( @@ -80,7 +80,7 @@ let simpleBinding pat value = value, loc, DebugPointAtBinding.NoneAtLet, - {EqualsRange = Some loc; LetKeyword = Some loc}) + {EqualsRange = Some loc; InlineKeyword = Some loc; LeadingKeyword = SynLeadingKeyword.Let loc}) let letAttrsMultiParamBinding attrs name paramz body = SynBinding.SynBinding( None, @@ -108,7 +108,7 @@ let letAttrsMultiParamBinding attrs name paramz body = body, loc, DebugPointAtBinding.Yes loc, - {EqualsRange = Some loc; LetKeyword = Some loc}) + {EqualsRange = Some loc; InlineKeyword = Some loc; LeadingKeyword = SynLeadingKeyword.Let loc}) let letBindingAccessWithAttrs attrs access name paramz body = SynBinding.SynBinding( access, @@ -133,7 +133,7 @@ let letBindingAccessWithAttrs attrs access name paramz body = body, loc, DebugPointAtBinding.Yes loc, - {EqualsRange = Some loc; LetKeyword = Some loc}) + {EqualsRange = Some loc; InlineKeyword = Some loc; LeadingKeyword = SynLeadingKeyword.Let loc}) let letAttrsBinding attrs = letBindingAccessWithAttrs attrs None let letBinding = letAttrsBinding [] let letUnitBinding attrs name body = @@ -159,7 +159,7 @@ let letUnitBinding attrs name body = body, loc, DebugPointAtBinding.Yes loc, - {EqualsRange = Some loc; LetKeyword = Some loc}) + {EqualsRange = Some loc; InlineKeyword = Some loc; LeadingKeyword = SynLeadingKeyword.Let loc}) let parenExpr expr = SynExpr.Paren(expr, loc, None, loc) let parens = function | SynExpr.Paren _ as e -> e @@ -252,7 +252,7 @@ let rec lambdaExpr paramz body = SynExpr.Lambda( false, false, - SynSimplePats.SimplePats([], loc), + SynSimplePats.SimplePats([], [], loc), body, None, loc, @@ -261,7 +261,7 @@ let rec lambdaExpr paramz body = SynExpr.Lambda( false, false, - SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), + SynSimplePats.SimplePats([nameTypeSimplePat s synType], [], loc), body, None, loc, @@ -270,7 +270,7 @@ let rec lambdaExpr paramz body = SynExpr.Lambda( false, false, - SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), + SynSimplePats.SimplePats([nameTypeSimplePat s synType], [], loc), lambdaExpr paramz body, None, loc, @@ -283,7 +283,7 @@ let matchLambdaExpr clauses = clauses, DebugPointAtBinding.Yes loc, loc) -let openDecl parts = SynModuleDecl.Open(SynOpenDeclTarget.ModuleOrNamespace(longIdent parts, loc), loc) +let openDecl parts = SynModuleDecl.Open(SynOpenDeclTarget.ModuleOrNamespace(longIdentWithDots parts, loc), loc) let letAttrsDecl attrs name paramz body = SynModuleDecl.Let(false, [letAttrsBinding attrs name paramz body], loc) let letAttrsUncurriedDecl attrs name paramz body = @@ -311,6 +311,7 @@ let moduleFile nameParts decls = [], None, loc, - {ModuleKeyword = Some loc; NamespaceKeyword = Some loc})], + {LeadingKeyword = SynModuleOrNamespaceLeadingKeyword.Module loc})], (false, false), - {CodeComments = []; ConditionalDirectives = []})) + {CodeComments = []; ConditionalDirectives = []}, + Set.empty)) diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index 8ce6d0f..16bcc7d 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -58,8 +58,8 @@ let rec private writeExpr = function | SynExpr.TryWith(body, [SynMatchClause.SynMatchClause(pat, _, handler, _, _, _)], _, _, _, _) -> sprintf "(try %s; with %s -> %s)" (writeExpr body) (writePat pat) (writeExpr handler) | SynExpr.MatchLambda(_, _, clauses, _, _) -> List.map writeClause clauses |> join "; " |> sprintf "(function %s)" - | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _), body, _, _, _) -> sprintf "(fun () -> %s)" (writeExpr body) - | SynExpr.Lambda(_, _, SynSimplePats.SimplePats(pats, _), body, _, _, _) -> sprintf "(fun %s -> %s)" (List.map writeSimplePat pats |> join " ") (writeExpr body) + | SynExpr.Lambda(_, _, SynSimplePats.SimplePats([], _, _), body, _, _, _) -> sprintf "(fun () -> %s)" (writeExpr body) + | SynExpr.Lambda(_, _, SynSimplePats.SimplePats(pats, _, _), body, _, _, _) -> sprintf "(fun %s -> %s)" (List.map writeSimplePat pats |> join " ") (writeExpr body) | SynExpr.App(_, _, f, x, _) -> sprintf "(%s %s)" (writeExpr f) (writeExpr x) | x -> failwithf "SynExpr case not supported: %O" x @@ -71,7 +71,7 @@ let private writeBinding = function sprintf "%s = %s" (writePat pat) (writeExpr value) let private writeDecl = function - | SynModuleDecl.Open(SynOpenDeclTarget.ModuleOrNamespace(x, _), _) -> writeLongIdent x |> sprintf "open %s" + | SynModuleDecl.Open(SynOpenDeclTarget.ModuleOrNamespace(x, _), _) -> writeSynLongIdent x |> sprintf "open %s" | SynModuleDecl.Let(recursive, binding :: bindings, _) -> sprintf "let%s %s%s" (if recursive then " rec" else "") (writeBinding binding) (List.map (writeBinding >> sprintf "\r\nand %s") bindings |> join "") | _ -> failwith "SynModuleDecl case not supported" @@ -90,6 +90,7 @@ let writeFile = function _, modules, _, + _, _)) -> List.map writeModule modules |> join "\r\n\r\n" | _ -> failwith "ParsedInput case not supported" diff --git a/src/Kl.Tests/Kl.Tests.fsproj b/src/Kl.Tests/Kl.Tests.fsproj index f6000f6..9673f3e 100644 --- a/src/Kl.Tests/Kl.Tests.fsproj +++ b/src/Kl.Tests/Kl.Tests.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Kl.Tests Kl.Tests Kl diff --git a/src/Kl/Kl.fsproj b/src/Kl/Kl.fsproj index 2dff723..da44c09 100644 --- a/src/Kl/Kl.fsproj +++ b/src/Kl/Kl.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Kl Kl Kl diff --git a/src/Shen.Kernel/Shen.Kernel.fsproj b/src/Shen.Kernel/Shen.Kernel.fsproj index 891e481..feeb339 100644 --- a/src/Shen.Kernel/Shen.Kernel.fsproj +++ b/src/Shen.Kernel/Shen.Kernel.fsproj @@ -1,7 +1,7 @@ - net6.0 + net8.0 true diff --git a/src/Shen.Repl/Shen.Repl.fsproj b/src/Shen.Repl/Shen.Repl.fsproj index 14d5383..b3bec2b 100644 --- a/src/Shen.Repl/Shen.Repl.fsproj +++ b/src/Shen.Repl/Shen.Repl.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Shen.Repl Shen.Repl Shen.Repl diff --git a/src/Shen.TestSuite/Shen.TestSuite.fsproj b/src/Shen.TestSuite/Shen.TestSuite.fsproj index 254a0aa..d55be99 100644 --- a/src/Shen.TestSuite/Shen.TestSuite.fsproj +++ b/src/Shen.TestSuite/Shen.TestSuite.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Shen.TestSuite Shen.TestSuite Shen.TestSuite diff --git a/src/Shen.Tests/Shen.Tests.fsproj b/src/Shen.Tests/Shen.Tests.fsproj index 6793a57..c0b9c02 100644 --- a/src/Shen.Tests/Shen.Tests.fsproj +++ b/src/Shen.Tests/Shen.Tests.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Shen.Tests Shen.Tests Shen.Tests diff --git a/src/Shen/Shen.fsproj b/src/Shen/Shen.fsproj index 9af5377..4a4f327 100644 --- a/src/Shen/Shen.fsproj +++ b/src/Shen/Shen.fsproj @@ -1,7 +1,7 @@  - net6.0 + net8.0 Shen Shen Shen From caa47291890508cb7b95a40d845be44955764d42 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 20:20:04 -0500 Subject: [PATCH 21/44] Add stubs for the new S series output model. The latter two fails may need to move into an inner function. I opt to keep ShenSharp as a pure byte-oriented implementation. We could shim the string stuff as well. --- src/Kl/Builtins.fs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Kl/Builtins.fs b/src/Kl/Builtins.fs index 1735901..62488d4 100644 --- a/src/Kl/Builtins.fs +++ b/src/Kl/Builtins.fs @@ -226,6 +226,18 @@ let kl_exit _ = function | [Int x] -> exit x | args -> argsErr "exit" ["integer"] args +let ``kl_shen.char-stoutput?`` _ = function + | [Pipe _] -> False + | args -> argsErr "shen.char-stoutput?" ["stream"] args + +let ``kl_shen.char-stinput?`` _ = function + | [Pipe _] -> False + | args -> argsErr "shen.char-stinput?" ["stream"] args + +let ``kl_shen.write-string`` _ = failwith "write-string not implemented" + +let ``kl_shen.read-unit-string`` _ = failwith "read-unit-string not implemented" + let ``kl_clr.alias`` globals = function | [Str alias; Str original] -> setAlias globals alias original From 15cca8bbba25cb96e6dbf44b13686a70792a6e24 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 20:21:01 -0500 Subject: [PATCH 22/44] Target 38.1. As written, the version from GitHub doesn't work and is a little different than the zip package on the Shen website. The latter is what works better: It doesn't need dict and doesn't contain initialise any more. 38.2 should work about the same. Since the paths have not changed, you will need to extract the files to kernel and rename their KLambda directory to klamnbda. --- src/Shared.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shared.fs b/src/Shared.fs index b482b37..6e68592 100644 --- a/src/Shared.fs +++ b/src/Shared.fs @@ -13,7 +13,7 @@ let Copyright = "Copyright let Revision = "0.10.0.0" [] -let KernelRevision = "22.4" +let KernelRevision = "38.1" [] let KernelFolderName = "ShenOSKernel-" + KernelRevision From 0ddc102187eba5befcfb17ed0b12c019d295b7dc Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 20:22:54 -0500 Subject: [PATCH 23/44] Compile source files used by the Lisp loader. (in the official distribution) --- src/Kl.Make/BuildRuntime.fs | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/src/Kl.Make/BuildRuntime.fs b/src/Kl.Make/BuildRuntime.fs index 5b1ce8e..63339d7 100644 --- a/src/Kl.Make/BuildRuntime.fs +++ b/src/Kl.Make/BuildRuntime.fs @@ -6,22 +6,20 @@ open ShenSharp.Shared let sourcePath = fromRoot ["kernel"; "klambda"] let sourceFiles = [ - "toplevel.kl" - "core.kl" - "sys.kl" - "dict.kl" - "sequent.kl" - "yacc.kl" - "reader.kl" - "prolog.kl" - "track.kl" - "load.kl" - "writer.kl" - "macros.kl" - "declarations.kl" - "types.kl" - "t-star.kl" - "init.kl" + "sys.kl" + "writer.kl" + "core.kl" + "reader.kl" + "declarations.kl" + "toplevel.kl" + "macros.kl" + "load.kl" + "prolog.kl" + "sequent.kl" + "track.kl" + "t-star.kl" + "yacc.kl" + "types.kl" ] let buildRuntime () = make sourcePath sourceFiles From d2efe41342e2b08c2d040a7ffd35fd0ceff69545 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 20:23:16 -0500 Subject: [PATCH 24/44] shen.repl -> shen.shen for startup. --- src/Shen.Repl/RunRepl.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shen.Repl/RunRepl.fs b/src/Shen.Repl/RunRepl.fs index 06b7f5d..2ce5f8f 100644 --- a/src/Shen.Repl/RunRepl.fs +++ b/src/Shen.Repl/RunRepl.fs @@ -49,7 +49,7 @@ let private runRepl args () = try let globals = newRuntime () if evalOptions globals args then - toCons [Sym "shen.repl"] |> eval globals |> ignore + toCons [Sym "shen.shen"] |> eval globals |> ignore with e -> printfn "Unhandled error: %s" e.Message From 06a23d8f36a566d1f19318b7ff0106216f65893a Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 20:23:28 -0500 Subject: [PATCH 25/44] add-macro -> record-macro It's not clear whether the first argument is a string or symbol; This is untested. --- src/Shen/Runtime.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shen/Runtime.fs b/src/Shen/Runtime.fs index d19c0ae..2fe1d05 100644 --- a/src/Shen/Runtime.fs +++ b/src/Shen/Runtime.fs @@ -78,4 +78,4 @@ let defineMacro globals name native = let f _ = function | [x] -> native x | args -> argsErr name ["value"] args - ``kl_shen.add-macro`` globals [Func <| Compiled(1, f)] |> ignore + ``kl_shen.record-macro`` globals [Str name; Func <| Compiled(1, f)] |> ignore From 1724429e311f721930883d6f2bbb929d59929685 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 20:23:51 -0500 Subject: [PATCH 26/44] Remove call to initialise. initialise is where the global settings used to live. Now these are scattered as toplevels around the KL files, mostly in declarations. However, our translator drops everything except defuns. TODO: Refactor that filter to sort toplevel expressions by type instead of dropping everything, sort through the non-defuns, and replace this with a sequence of toplevel sets. --- src/Kl.Make/Compiler.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Kl.Make/Compiler.fs b/src/Kl.Make/Compiler.fs index 6c0bfdc..96ac336 100644 --- a/src/Kl.Make/Compiler.fs +++ b/src/Kl.Make/Compiler.fs @@ -235,7 +235,6 @@ let buildInstallationFile name exprs = (List.concat [ List.map installDefun exprs - [appExprN (idExpr "kl_shen.initialise") [(idExpr "globals"); (listExpr [])] |> appIgnore] [idExpr "globals"] ])) ] From 25a3eabc377ce3f0e6907faf47b7e8f37439eeb4 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sat, 11 May 2024 20:25:09 -0500 Subject: [PATCH 27/44] FIXME: Add globals necessary to start the REPL. This does not result in a running REPL, but one which prints its banner and can be killed using ^C. Every expression I've tried fails with various errors but does not crash the runtime. --- src/Kl/Startup.fs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Kl/Startup.fs b/src/Kl/Startup.fs index 68efb83..7f763f7 100644 --- a/src/Kl/Startup.fs +++ b/src/Kl/Startup.fs @@ -21,6 +21,15 @@ let baseGlobals () = "*stoutput*", console "*sterror*", console "*home-directory*", Str Environment.CurrentDirectory + "*hush*", False + "*version*", Str "38.1" + "shen.*tc*", False + "shen.*history*", Empty + "shen.*package*", Empty + "*macros*", Empty + "shen.*special*", Empty + "shen.*extraspecial*", Empty + "*maximum-print-sequence-size*", Int 20 ] let functions = [ "if", Compiled(3, kl_if) From 45148de0d9a0b604cfa5ab5e7426191a95167da7 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sun, 12 May 2024 17:12:55 -0500 Subject: [PATCH 28/44] Use 38.2. It's available on GitHub now (but for our purposes also on the Shen website). --- src/Kl/Startup.fs | 2 +- src/Shared.fs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Kl/Startup.fs b/src/Kl/Startup.fs index 7f763f7..1751dc8 100644 --- a/src/Kl/Startup.fs +++ b/src/Kl/Startup.fs @@ -22,7 +22,7 @@ let baseGlobals () = "*sterror*", console "*home-directory*", Str Environment.CurrentDirectory "*hush*", False - "*version*", Str "38.1" + "*version*", Str "38.2" "shen.*tc*", False "shen.*history*", Empty "shen.*package*", Empty diff --git a/src/Shared.fs b/src/Shared.fs index 6e68592..475107a 100644 --- a/src/Shared.fs +++ b/src/Shared.fs @@ -13,7 +13,7 @@ let Copyright = "Copyright let Revision = "0.10.0.0" [] -let KernelRevision = "38.1" +let KernelRevision = "38.2" [] let KernelFolderName = "ShenOSKernel-" + KernelRevision From fac263b71d893d99f277c1daf2e4f2300552570d Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sun, 12 May 2024 21:23:15 -0500 Subject: [PATCH 29/44] Load the necessary files from the GitHub source distribution. --- src/Kl.Make/BuildRuntime.fs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Kl.Make/BuildRuntime.fs b/src/Kl.Make/BuildRuntime.fs index 63339d7..5088a10 100644 --- a/src/Kl.Make/BuildRuntime.fs +++ b/src/Kl.Make/BuildRuntime.fs @@ -6,6 +6,7 @@ open ShenSharp.Shared let sourcePath = fromRoot ["kernel"; "klambda"] let sourceFiles = [ + "dict.kl" "sys.kl" "writer.kl" "core.kl" @@ -20,6 +21,7 @@ let sourceFiles = [ "t-star.kl" "yacc.kl" "types.kl" + "init.kl" ] let buildRuntime () = make sourcePath sourceFiles From eed01623bbe6e6692360fdf81077b5beb62b9c40 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sun, 12 May 2024 21:24:24 -0500 Subject: [PATCH 30/44] Revert "FIXME: Add globals necessary to start the REPL." This reverts commit 25a3eabc377ce3f0e6907faf47b7e8f37439eeb4. --- src/Kl/Startup.fs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Kl/Startup.fs b/src/Kl/Startup.fs index 1751dc8..68efb83 100644 --- a/src/Kl/Startup.fs +++ b/src/Kl/Startup.fs @@ -21,15 +21,6 @@ let baseGlobals () = "*stoutput*", console "*sterror*", console "*home-directory*", Str Environment.CurrentDirectory - "*hush*", False - "*version*", Str "38.2" - "shen.*tc*", False - "shen.*history*", Empty - "shen.*package*", Empty - "*macros*", Empty - "shen.*special*", Empty - "shen.*extraspecial*", Empty - "*maximum-print-sequence-size*", Int 20 ] let functions = [ "if", Compiled(3, kl_if) From eba9b06679c98c3fbe4033e57c83b74ec0ba47f4 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sun, 12 May 2024 21:25:19 -0500 Subject: [PATCH 31/44] Revert "shen.repl -> shen.shen for startup." This reverts commit d2efe41342e2b08c2d040a7ffd35fd0ceff69545. --- src/Shen.Repl/RunRepl.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shen.Repl/RunRepl.fs b/src/Shen.Repl/RunRepl.fs index 2ce5f8f..06b7f5d 100644 --- a/src/Shen.Repl/RunRepl.fs +++ b/src/Shen.Repl/RunRepl.fs @@ -49,7 +49,7 @@ let private runRepl args () = try let globals = newRuntime () if evalOptions globals args then - toCons [Sym "shen.shen"] |> eval globals |> ignore + toCons [Sym "shen.repl"] |> eval globals |> ignore with e -> printfn "Unhandled error: %s" e.Message From a6810cb3530c8bf048cd04ca2ff072f232f39a49 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sun, 12 May 2024 21:25:24 -0500 Subject: [PATCH 32/44] Revert "Remove call to initialise." This reverts commit 1724429e311f721930883d6f2bbb929d59929685. --- src/Kl.Make/Compiler.fs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Kl.Make/Compiler.fs b/src/Kl.Make/Compiler.fs index 96ac336..6c0bfdc 100644 --- a/src/Kl.Make/Compiler.fs +++ b/src/Kl.Make/Compiler.fs @@ -235,6 +235,7 @@ let buildInstallationFile name exprs = (List.concat [ List.map installDefun exprs + [appExprN (idExpr "kl_shen.initialise") [(idExpr "globals"); (listExpr [])] |> appIgnore] [idExpr "globals"] ])) ] From a4227964814c7ecef6c2970dd266617bcc097222 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Sun, 12 May 2024 21:25:30 -0500 Subject: [PATCH 33/44] Use the new test entrypoint, runme.shen. --- src/Shen.TestSuite/RunTestSuite.fs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Shen.TestSuite/RunTestSuite.fs b/src/Shen.TestSuite/RunTestSuite.fs index 009f28e..eef87bf 100644 --- a/src/Shen.TestSuite/RunTestSuite.fs +++ b/src/Shen.TestSuite/RunTestSuite.fs @@ -14,8 +14,7 @@ let runTestSuite () = define globals "y-or-n?" (Compiled(0, fun _ _ -> Environment.Exit 1; Empty)) changeDirectory globals testFolder let stopwatch = Stopwatch.StartNew() - load globals "README.shen" - load globals "tests.shen" + load globals "runme.shen" printfn "" printfn "%O" stopwatch.Elapsed printfn "" From 288ebefc4ae24840511d1ee90127136a13399e0f Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Mon, 13 May 2024 13:24:58 -0500 Subject: [PATCH 34/44] Use 38.3. --- src/Shared.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shared.fs b/src/Shared.fs index 475107a..8e0bcb9 100644 --- a/src/Shared.fs +++ b/src/Shared.fs @@ -13,7 +13,7 @@ let Copyright = "Copyright let Revision = "0.10.0.0" [] -let KernelRevision = "38.2" +let KernelRevision = "38.3" [] let KernelFolderName = "ShenOSKernel-" + KernelRevision From 142083348c1f20597f10c0c8b28090abcc9567c6 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Mon, 13 May 2024 18:33:09 -0500 Subject: [PATCH 35/44] Use postImport on the globals and add arity for exit. This might not be the best way to fix the builtins, but the convenient leftover was right there. The functions really should be registered in the lambda-form attribute, but arities or types seem to work with fn and allow them to be used in the REPL. --- src/Kl/Startup.fs | 1 + src/Shen/Runtime.fs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Kl/Startup.fs b/src/Kl/Startup.fs index 68efb83..abe537e 100644 --- a/src/Kl/Startup.fs +++ b/src/Kl/Startup.fs @@ -117,6 +117,7 @@ let postImport globals = declareArity "clr.invoke-static" 3 declareType "shen-sharp.http-post" [Sym "string"; Sym "string"] (Sym "string") declareType "shen-sharp.curl" [Sym "string"] (Sym "string") + declareArity "exit" 1 ] List.iter (eval globals >> ignore) declarations globals diff --git a/src/Shen/Runtime.fs b/src/Shen/Runtime.fs index 2fe1d05..5ba7950 100644 --- a/src/Shen/Runtime.fs +++ b/src/Shen/Runtime.fs @@ -10,7 +10,7 @@ open Shen.Kernel /// Creates a new Shen runtime environment. /// [] -let newRuntime = baseGlobals >> install +let newRuntime = baseGlobals >> install >> postImport /// /// Evaluates given Shen syntax and returns result as KL Value. From b7b6f3ce8f3f631738184485fdb65305f5341c03 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Tue, 14 May 2024 17:54:48 -0500 Subject: [PATCH 36/44] Instead of exiting the tests, continue and count failures silently. --- src/Shen.TestSuite/RunTestSuite.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shen.TestSuite/RunTestSuite.fs b/src/Shen.TestSuite/RunTestSuite.fs index eef87bf..14b146e 100644 --- a/src/Shen.TestSuite/RunTestSuite.fs +++ b/src/Shen.TestSuite/RunTestSuite.fs @@ -11,7 +11,7 @@ let testFolder = fromRoot ["kernel"; "tests"] let runTestSuite () = let globals = newRuntime () - define globals "y-or-n?" (Compiled(0, fun _ _ -> Environment.Exit 1; Empty)) + define globals "y-or-n?" (Compiled(1, fun _ _ -> True)) changeDirectory globals testFolder let stopwatch = Stopwatch.StartNew() load globals "runme.shen" From 71592824a318fd31b30a6b2da4d804880bed6f70 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Tue, 14 May 2024 18:41:52 -0500 Subject: [PATCH 37/44] F# 8.0.300 --- src/Kl.Make/Kl.Make.fsproj | 2 +- src/Kl.Make/Syntax.fs | 3 ++- src/Kl.Make/Writer.fs | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Kl.Make/Kl.Make.fsproj b/src/Kl.Make/Kl.Make.fsproj index 21f0261..efa07ba 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index 9afe841..e70fba7 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -236,7 +236,8 @@ let rec sequentialExpr = function true, expr, sequentialExpr rest, - loc) + loc, + SynExprSequentialTrivia.Zero) let tupleExpr vals = parens (SynExpr.Tuple( diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index 16bcc7d..acaddfb 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -50,7 +50,7 @@ let rec private writeExpr = function | SynExpr.Const(x, _) -> writeConst x | SynExpr.Tuple(false, xs, _, _) -> List.map writeExpr xs |> join ", " |> sprintf "(%s)" | SynExpr.ArrayOrList(false, xs, _) -> List.map writeExpr xs |> join "; " |> sprintf "[%s]" - | SynExpr.Sequential(_, _, x, y, _) -> sprintf "(%s; %s)" (writeExpr x) (writeExpr y) + | SynExpr.Sequential(_, _, x, y, _, _) -> sprintf "(%s; %s)" (writeExpr x) (writeExpr y) | SynExpr.LetOrUse(_, _, [SynBinding.SynBinding(_, _, _, _, _, _, _, pat, _, value, _, _, _)], body, _, _) -> sprintf "(let %s = %s in %s)" (writePat pat) (writeExpr value) (writeExpr body) | SynExpr.IfThenElse(ifExpr, thenExpr, Some elseExpr, _, _, _, _) -> From 497679ffd86bfbae058f1795ef44a5d90ab7211e Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Tue, 14 May 2024 22:19:05 -0500 Subject: [PATCH 38/44] Add a regression test for the failing let-in-lambda. --- src/Kl.Tests/ScopeCapture.fs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Kl.Tests/ScopeCapture.fs b/src/Kl.Tests/ScopeCapture.fs index 36af810..1d35a59 100644 --- a/src/Kl.Tests/ScopeCapture.fs +++ b/src/Kl.Tests/ScopeCapture.fs @@ -57,3 +57,7 @@ let ``inner function scope should override outer lexical scope``() = [] let ``inner lexical scope should override outer lexical scope``() = assertEq (Int 2) (run "(let X 1 (let X 2 X))") + +[] +let ``let should work in lambda``() = + assertEq (Int 2) (run "((lambda X (let Y 1 (+ X Y))) 1)") From 0ab748e9c7888fa2af5e0ae9af8d525c09128996 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Tue, 14 May 2024 23:37:38 -0500 Subject: [PATCH 39/44] Add similarly-failing test for freeze. --- src/Kl.Tests/ScopeCapture.fs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Kl.Tests/ScopeCapture.fs b/src/Kl.Tests/ScopeCapture.fs index 1d35a59..3cdbcae 100644 --- a/src/Kl.Tests/ScopeCapture.fs +++ b/src/Kl.Tests/ScopeCapture.fs @@ -61,3 +61,7 @@ let ``inner lexical scope should override outer lexical scope``() = [] let ``let should work in lambda``() = assertEq (Int 2) (run "((lambda X (let Y 1 (+ X Y))) 1)") + +[] +let ``let should work in freeze``() = + assertTrue "((freeze (let X false true)))" From e47efdcc024284cecce06f33788dc48a2e9bad1f Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Wed, 15 May 2024 00:09:49 -0500 Subject: [PATCH 40/44] Fix let in lambda and freeze. Bindings were mistakenly not recurring through themselves when capturing scope. This isn't a problem at the toplevel or in defuns because in those cases the Binding is only ever evaluated and never need their scope captured. --- src/Kl/Evaluator.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Kl/Evaluator.fs b/src/Kl/Evaluator.fs index 117945e..4aa115b 100644 --- a/src/Kl/Evaluator.fs +++ b/src/Kl/Evaluator.fs @@ -11,7 +11,7 @@ let rec private scope locals = function // Bindings, Lambdas and Definintions recur excluding their paramters. | Binding(param, value, body) -> - Binding(param, scope locals value, scope (Map.remove param locals) value) + Binding(param, scope locals value, scope (Map.remove param locals) body) | Anonymous(Some param, body) -> Anonymous(Some param, scope (Map.remove param locals) body) | Definition(name, paramz, body) -> From 05cf27801810db20f0204ff96acabde0ed371c5a Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Wed, 15 May 2024 01:25:03 -0500 Subject: [PATCH 41/44] Skip the right side of type expressions. --- src/Kl/Evaluator.fs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Kl/Evaluator.fs b/src/Kl/Evaluator.fs index 4aa115b..3a7924d 100644 --- a/src/Kl/Evaluator.fs +++ b/src/Kl/Evaluator.fs @@ -75,6 +75,8 @@ let rec private parse ((globals, locals) as env) = function Assignment(intern globals id, parse env value) | Form [Sym "value"; Sym id] when not(Set.contains id locals) -> Retrieval(intern globals id) + | Form [Sym "type"; expr; _] -> + parse env expr | Form(Sym id :: args) when not(Set.contains id locals) -> GlobalCall(intern globals id, List.map (parse env) args) | Form(f :: args) -> From e5dbdd98c5106fa5252d0e9e28418e295b437df8 Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Fri, 11 Oct 2024 14:30:22 -0500 Subject: [PATCH 42/44] Bump kernel to 39.0. --- src/Shared.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shared.fs b/src/Shared.fs index 8e0bcb9..fd94d5d 100644 --- a/src/Shared.fs +++ b/src/Shared.fs @@ -13,7 +13,7 @@ let Copyright = "Copyright let Revision = "0.10.0.0" [] -let KernelRevision = "38.3" +let KernelRevision = "39.0" [] let KernelFolderName = "ShenOSKernel-" + KernelRevision From a0f3727dbc9c518302efa4423ae4ab53a4ed239b Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Tue, 15 Oct 2024 13:44:17 -0500 Subject: [PATCH 43/44] Ensure non-alphanumeric interns are not symbols. The internal `Sym` structure can hold arbitrary strings just fine, but the behavior of `symbol?` broke this test. While the string "fsdf{}.$%2" can be `intern`ed, the Shen source code for `symbol?` specifies that symbols contain only alphanumerics. Implementations differ in how they handle this. Shen/Scheme 39 overrides `symbol?` and `analyse-symbol?` such that `(intern "fsdf{}.$%2")` is a symbol. The SBCL Shen distribution 39.1 as compiled under SBCL 2.4.5 on linux-x86_64 can `intern` the string but does not recognize it as a symbol. We choose to follow this behavior with the potential of creating an override later. --- src/Shen.Tests/Symbols.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Shen.Tests/Symbols.fs b/src/Shen.Tests/Symbols.fs index ceb62be..d803012 100644 --- a/src/Shen.Tests/Symbols.fs +++ b/src/Shen.Tests/Symbols.fs @@ -31,7 +31,7 @@ let ``only non-boolean symbols should be recognized as symbols``() = assertFalse globals "(symbol? (freeze 0))" assertFalse globals "(symbol? (stinput))" assertFalse globals "(symbol? (vector 0))" + assertFalse globals "(symbol? (intern \"fsdf{}.$%2\"))" assertTrue globals "(symbol? abc)" assertTrue globals "(symbol? (intern \"abc\"))" assertTrue globals "(symbol? u87.dfg)" - assertTrue globals "(symbol? (intern \"fsdf{}.$%2\"))" From 4d4596756b62d8cb9f84361ea02d37b878d0f12a Mon Sep 17 00:00:00 2001 From: Jacob MacDonald Date: Tue, 15 Oct 2024 13:51:32 -0500 Subject: [PATCH 44/44] Bump the badge to 39.0. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 324d2eb..3e3c557 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![Shen Version](https://img.shields.io/badge/shen-38.3-blue.svg)](https://github.com/Shen-Language) +[![Shen Version](https://img.shields.io/badge/shen-39.0-blue.svg)](https://github.com/Shen-Language) [![Latest Nuget](https://img.shields.io/nuget/v/ShenSharp.svg)](https://www.nuget.org/packages/ShenSharp) # Shen for the Common Language Runtime