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 diff --git a/src/Kl.Get/GetKl.fs b/src/Kl.Get/GetKl.fs index 3ef3728..d6b9666 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) + (task { + use client = new HttpClient() + use zip = new FileStream(zipPath, FileMode.Create) + 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.Get/Kl.Get.fsproj b/src/Kl.Get/Kl.Get.fsproj index 9b0d625..f3ed4a6 100644 --- a/src/Kl.Get/Kl.Get.fsproj +++ b/src/Kl.Get/Kl.Get.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net8.0 Kl.Get Kl.Get Kl diff --git a/src/Kl.Make/BuildRuntime.fs b/src/Kl.Make/BuildRuntime.fs index 91d0ea9..5088a10 100644 --- a/src/Kl.Make/BuildRuntime.fs +++ b/src/Kl.Make/BuildRuntime.fs @@ -4,28 +4,27 @@ open Kl.Values open Loader open ShenSharp.Shared -let outputPath = fromRoot ["kernel"; "dotnet"; BuildConfig] 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" + "dict.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" + "init.kl" ] -let buildRuntime () = make sourcePath sourceFiles outputPath +let buildRuntime () = make sourcePath sourceFiles [] let main _ = separateThread128MB buildRuntime diff --git a/src/Kl.Make/Compiler.fs b/src/Kl.Make/Compiler.fs index a83e4a7..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"] ".NETStandard,Version=v2.1" + 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 b72a571..efa07ba 100644 --- a/src/Kl.Make/Kl.Make.fsproj +++ b/src/Kl.Make/Kl.Make.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net8.0 Kl.Make Kl.Make Kl @@ -11,7 +11,7 @@ - + diff --git a/src/Kl.Make/Loader.fs b/src/Kl.Make/Loader.fs index 5231d32..a86e20c 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 @@ -13,24 +14,24 @@ 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"; "System.Runtime"; "System.Runtime.Numerics"; "System.Collections"; "System.Net.Requests"; "System.Net.WebClient"] 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 @@ -46,25 +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 - -// 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) + logWarnings result.Diagnostics + result.ParseTree let private move source destination = if File.Exists destination then @@ -78,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." diff --git a/src/Kl.Make/Syntax.fs b/src/Kl.Make/Syntax.fs index 2378456..e70fba7 100644 --- a/src/Kl.Make/Syntax.fs +++ b/src/Kl.Make/Syntax.fs @@ -10,8 +10,11 @@ module internal Kl.Make.Syntax open System -open FSharp.Compiler.Ast -open FSharp.Compiler.Range +open FSharp.Compiler.Syntax +open FSharp.Compiler.SyntaxTrivia +open FSharp.Compiler.Xml +open FSharp.Compiler.Text.Range +open FSharp.Compiler.Text.Position let private fileName = "file.fs" // Picked large values for line, col because there will be an unpredictable @@ -29,11 +32,11 @@ let attrs xs : SynAttributeList list = [{ Range = loc }] 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 @@ -41,28 +44,29 @@ 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) -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.Clause( + SynMatchClause.SynMatchClause( pat, None, body, loc, - SequencePointInfoForTarget.SequencePointAtTarget) + DebugPointAtTarget.Yes, + {ArrowRange = Some loc; BarRange = Some loc}) let nameTypeSimplePat s synType = SynSimplePat.Typed( SynSimplePat.Id(ident s, None, true, false, false, loc), synType, loc) let simpleBinding pat value = - SynBinding.Binding( + SynBinding.SynBinding( None, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, [], @@ -75,11 +79,12 @@ let simpleBinding pat value = None, value, loc, - SequencePointInfoForBinding.NoSequencePointAtLetBinding) + DebugPointAtBinding.NoneAtLet, + {EqualsRange = Some loc; InlineKeyword = Some loc; LeadingKeyword = SynLeadingKeyword.Let loc}) let letAttrsMultiParamBinding attrs name paramz body = - SynBinding.Binding( + SynBinding.SynBinding( None, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, attrs, @@ -92,7 +97,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,11 +107,12 @@ let letAttrsMultiParamBinding attrs name paramz body = None, body, loc, - SequencePointInfoForBinding.SequencePointAtBinding loc) + DebugPointAtBinding.Yes loc, + {EqualsRange = Some loc; InlineKeyword = Some loc; LeadingKeyword = SynLeadingKeyword.Let loc}) let letBindingAccessWithAttrs attrs access name paramz body = - SynBinding.Binding( + SynBinding.SynBinding( access, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, attrs, @@ -119,20 +125,21 @@ 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) + DebugPointAtBinding.Yes 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 = - SynBinding.Binding( + SynBinding.SynBinding( None, - SynBindingKind.NormalBinding, + SynBindingKind.Normal, false, false, attrs, @@ -145,13 +152,14 @@ let letUnitBinding attrs name body = longIdentWithDots [name], None, None, - SynConstructorArgs.Pats [unitPat], + SynArgPats.Pats [unitPat], None, loc), None, body, loc, - SequencePointInfoForBinding.SequencePointAtBinding loc) + DebugPointAtBinding.Yes 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 @@ -160,13 +168,13 @@ 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 = SynExpr.DotIndexedSet( obj, - [SynIndexerArg.One index], + index, value, loc, loc, @@ -192,10 +200,10 @@ let ifExpr condition consequent alternative = condition, consequent, Some alternative, - SequencePointInfoForBinding.NoSequencePointAtInvisibleBinding, + DebugPointAtBinding.NoneAtInvisible, false, loc, - loc) + {IfKeyword = loc; IsElif = false; ElseKeyword = None; ThenKeyword = loc; IfToThenRange = loc}) parens expr let letExpr symbol value body = SynExpr.LetOrUse( @@ -203,31 +211,33 @@ 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.Clause( + [SynMatchClause.SynMatchClause( namePat e, None, handler, loc, - SequencePointInfoForTarget.SequencePointAtTarget)], - loc, + DebugPointAtTarget.Yes, + {ArrowRange = Some loc; BarRange = Some loc})], loc, - SequencePointInfoForTry.SequencePointAtTry loc, - SequencePointInfoForWith.SequencePointAtWith loc) + DebugPointAtTry.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( - SequencePointInfoForSeq.SequencePointsAtSeq, + DebugPointAtSequential.SuppressNeither, true, expr, sequentialExpr rest, - loc) + loc, + SynExprSequentialTrivia.Zero) let tupleExpr vals = parens (SynExpr.Tuple( @@ -243,32 +253,38 @@ let rec lambdaExpr paramz body = SynExpr.Lambda( false, false, - SynSimplePats.SimplePats([], loc), + SynSimplePats.SimplePats([], [], loc), body, - loc) + None, + loc, + {ArrowRange = Some loc}) | [s, synType] -> SynExpr.Lambda( false, false, - SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), + SynSimplePats.SimplePats([nameTypeSimplePat s synType], [], loc), body, - loc) + None, + loc, + {ArrowRange = Some loc}) | (s, synType) :: paramz -> SynExpr.Lambda( false, false, - SynSimplePats.SimplePats([nameTypeSimplePat s synType], loc), + SynSimplePats.SimplePats([nameTypeSimplePat s synType], [], loc), lambdaExpr paramz body, - loc) + None, + loc, + {ArrowRange = Some loc}) parens expr let matchLambdaExpr clauses = SynExpr.MatchLambda( false, loc, clauses, - SequencePointInfoForBinding.SequencePointAtBinding loc, + DebugPointAtBinding.Yes loc, loc) -let openDecl parts = SynModuleDecl.Open(longIdentWithDots parts, 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 = @@ -295,5 +311,8 @@ let moduleFile nameParts decls = PreXmlDoc.Empty, [], None, - loc)], - (false, false))) + loc, + {LeadingKeyword = SynModuleOrNamespaceLeadingKeyword.Module loc})], + (false, false), + {CodeComments = []; ConditionalDirectives = []}, + Set.empty)) diff --git a/src/Kl.Make/Writer.fs b/src/Kl.Make/Writer.fs index 66467db..acaddfb 100644 --- a/src/Kl.Make/Writer.fs +++ b/src/Kl.Make/Writer.fs @@ -1,15 +1,17 @@ module internal Writer -open FSharp.Compiler.Ast +open FSharp.Compiler.Syntax let private join (sep: string) (strings: string list) = System.String.Join(sep, strings |> List.toArray) 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 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 @@ -21,11 +23,11 @@ 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 - | SynType.LongIdent x -> writeLongIdent x + | SynType.LongIdent x -> writeSynLongIdent x | _ -> failwith "SynType case not supported" let rec private writeSimplePat = function @@ -34,8 +36,9 @@ let rec private writeSimplePat = function | _ -> failwith "SynSimplePat case not supported" let rec private writePat = function - | SynPat.LongIdent(x, _, _, _, _, _) -> writeLongIdent x - | SynPat.Named(_, ident, _, _, _) -> writeIdent ident + | 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 @@ -43,39 +46,38 @@ 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, _, _) -> 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.Binding(_, _, _, _, _, _, _, pat, _, value, _, _)], body, _) -> + | 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, _, _, _, _) -> 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) - | 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.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 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 - | SynModuleDecl.Open(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" 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 @@ -87,6 +89,8 @@ 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 83cf844..9673f3e 100644 --- a/src/Kl.Tests/Kl.Tests.fsproj +++ b/src/Kl.Tests/Kl.Tests.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net8.0 Kl.Tests Kl.Tests Kl diff --git a/src/Kl.Tests/ScopeCapture.fs b/src/Kl.Tests/ScopeCapture.fs index 36af810..3cdbcae 100644 --- a/src/Kl.Tests/ScopeCapture.fs +++ b/src/Kl.Tests/ScopeCapture.fs @@ -57,3 +57,11 @@ 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)") + +[] +let ``let should work in freeze``() = + assertTrue "((freeze (let X false true)))" diff --git a/src/Kl/Builtins.fs b/src/Kl/Builtins.fs index fac5e9c..62488d4 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 @@ -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 @@ -339,12 +351,20 @@ 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)) + task { + use client = new HttpClient() + use payload = new StringContent(payload) + 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 WebClient() - Str(client.DownloadString(url)) + task { + use client = new HttpClient() + let! content = client.GetStringAsync(url) + return content |> Str + } |> Async.AwaitTask |> Async.RunSynchronously | args -> argsErr "shen-sharp.curl" ["string"] args diff --git a/src/Kl/Evaluator.fs b/src/Kl/Evaluator.fs index 117945e..3a7924d 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) -> @@ -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) -> 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 diff --git a/src/Kl/Kl.fsproj b/src/Kl/Kl.fsproj index 5f7f185..da44c09 100644 --- a/src/Kl/Kl.fsproj +++ b/src/Kl/Kl.fsproj @@ -1,7 +1,7 @@  - netstandard2.1 + net8.0 Kl Kl Kl 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/Shared.fs b/src/Shared.fs index e74f82e..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 = "22.2" +let KernelRevision = "39.0" [] let KernelFolderName = "ShenOSKernel-" + KernelRevision diff --git a/src/Shen.Kernel/Shen.Kernel.fsproj b/src/Shen.Kernel/Shen.Kernel.fsproj new file mode 100644 index 0000000..feeb339 --- /dev/null +++ b/src/Shen.Kernel/Shen.Kernel.fsproj @@ -0,0 +1,16 @@ + + + + net8.0 + true + + + + + + + + + + + diff --git a/src/Shen.Repl/Shen.Repl.fsproj b/src/Shen.Repl/Shen.Repl.fsproj index 4616269..b3bec2b 100644 --- a/src/Shen.Repl/Shen.Repl.fsproj +++ b/src/Shen.Repl/Shen.Repl.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net8.0 Shen.Repl Shen.Repl Shen.Repl diff --git a/src/Shen.TestSuite/RunTestSuite.fs b/src/Shen.TestSuite/RunTestSuite.fs index 009f28e..14b146e 100644 --- a/src/Shen.TestSuite/RunTestSuite.fs +++ b/src/Shen.TestSuite/RunTestSuite.fs @@ -11,11 +11,10 @@ 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 "README.shen" - load globals "tests.shen" + load globals "runme.shen" printfn "" printfn "%O" stopwatch.Elapsed printfn "" diff --git a/src/Shen.TestSuite/Shen.TestSuite.fsproj b/src/Shen.TestSuite/Shen.TestSuite.fsproj index 50b6f84..d55be99 100644 --- a/src/Shen.TestSuite/Shen.TestSuite.fsproj +++ b/src/Shen.TestSuite/Shen.TestSuite.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + 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 c87adf5..c0b9c02 100644 --- a/src/Shen.Tests/Shen.Tests.fsproj +++ b/src/Shen.Tests/Shen.Tests.fsproj @@ -1,7 +1,7 @@  - netcoreapp3.1 + net8.0 Shen.Tests Shen.Tests Shen.Tests 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\"))" 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/Runtime.fs b/src/Shen/Runtime.fs index d19c0ae..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. @@ -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 diff --git a/src/Shen/Shen.fsproj b/src/Shen/Shen.fsproj index 287e88c..4a4f327 100644 --- a/src/Shen/Shen.fsproj +++ b/src/Shen/Shen.fsproj @@ -1,7 +1,7 @@  - netstandard2.1 + net8.0 Shen Shen Shen @@ -16,12 +16,7 @@ - - - - - ..\..\kernel\dotnet\$(Configuration)\Shen.Kernel.dll - +