From 47c1639ea209a12d2cc10ca290586b26119610fa Mon Sep 17 00:00:00 2001 From: Pierre Chalamet Date: Thu, 26 Feb 2026 13:04:59 +0100 Subject: [PATCH] feat(type-provider): add FScript export type provider with strict runtime signature checks --- CHANGELOG.md | 2 + FScript.sln | 30 ++ docs/architecture/assemblies-and-roles.md | 15 + docs/specs/README.md | 1 + docs/specs/embedding-fscript-language.md | 11 + docs/specs/fsharp-type-provider.md | 77 ++++ src/FScript.Runtime/ExportSignatures.fs | 53 +++ src/FScript.Runtime/FScript.Runtime.fsproj | 1 + src/FScript.Runtime/ScriptHost.fs | 44 +-- src/FScript.TypeProvider/Contract.fs | 244 +++++++++++++ .../FScript.TypeProvider.fsproj | 43 +++ src/FScript.TypeProvider/Provider.fs | 190 ++++++++++ src/FScript.TypeProvider/ScriptRuntime.fs | 329 ++++++++++++++++++ ...TypeProvider.Tests.Fixtures.Invalid.fsproj | 14 + .../Program.fs | 7 + .../script-invalid.fss | 1 + ...ider.Tests.Fixtures.RuntimeOverride.fsproj | 14 + .../Program.fs | 43 +++ .../script.fss | 1 + ...Provider.Tests.Fixtures.Unsupported.fsproj | 14 + .../Program.fs | 7 + .../script-unsupported.fss | 2 + ...t.TypeProvider.Tests.Fixtures.Valid.fsproj | 14 + .../Program.fs | 10 + .../script.fss | 1 + .../FScript.TypeProvider.Tests.fsproj | 24 ++ tests/FScript.TypeProvider.Tests/Program.fs | 4 + .../TypeProviderIntegrationTests.fs | 72 ++++ 28 files changed, 1230 insertions(+), 38 deletions(-) create mode 100644 docs/specs/fsharp-type-provider.md create mode 100644 src/FScript.Runtime/ExportSignatures.fs create mode 100644 src/FScript.TypeProvider/Contract.fs create mode 100644 src/FScript.TypeProvider/FScript.TypeProvider.fsproj create mode 100644 src/FScript.TypeProvider/Provider.fs create mode 100644 src/FScript.TypeProvider/ScriptRuntime.fs create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Invalid/FScript.TypeProvider.Tests.Fixtures.Invalid.fsproj create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Invalid/Program.fs create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Invalid/script-invalid.fss create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride.fsproj create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/Program.fs create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/script.fss create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/FScript.TypeProvider.Tests.Fixtures.Unsupported.fsproj create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/Program.fs create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/script-unsupported.fss create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Valid/FScript.TypeProvider.Tests.Fixtures.Valid.fsproj create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Valid/Program.fs create mode 100644 tests/FScript.TypeProvider.Tests.Fixtures.Valid/script.fss create mode 100644 tests/FScript.TypeProvider.Tests/FScript.TypeProvider.Tests.fsproj create mode 100644 tests/FScript.TypeProvider.Tests/Program.fs create mode 100644 tests/FScript.TypeProvider.Tests/TypeProviderIntegrationTests.fs diff --git a/CHANGELOG.md b/CHANGELOG.md index b2fd62e..e3fbeee 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,8 @@ All notable changes to FScript are documented in this file. ## [Unreleased] +- Added a new `MagnusOpera.FScript.TypeProvider` package that type-checks scripts at compile time and exposes exported functions as strongly-typed F# members with runtime signature compatibility checks. + ## [0.59.0] diff --git a/FScript.sln b/FScript.sln index be780e6..a583cef 100644 --- a/FScript.sln +++ b/FScript.sln @@ -25,6 +25,10 @@ Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "FScript.LanguageServer", "s EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Cli.Tests", "tests\FScript.Cli.Tests\FScript.Cli.Tests.fsproj", "{9B840598-3B03-457B-B1BE-9701BFD0D40A}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.TypeProvider", "src\FScript.TypeProvider\FScript.TypeProvider.fsproj", "{14D91D30-8E5E-482A-940B-CC55F2DE80AA}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.TypeProvider.Tests", "tests\FScript.TypeProvider.Tests\FScript.TypeProvider.Tests.fsproj", "{42D043DE-8987-4072-8841-DCB2144AC18C}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -143,6 +147,30 @@ Global {9B840598-3B03-457B-B1BE-9701BFD0D40A}.Release|x64.Build.0 = Release|Any CPU {9B840598-3B03-457B-B1BE-9701BFD0D40A}.Release|x86.ActiveCfg = Release|Any CPU {9B840598-3B03-457B-B1BE-9701BFD0D40A}.Release|x86.Build.0 = Release|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Debug|Any CPU.Build.0 = Debug|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Debug|x64.ActiveCfg = Debug|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Debug|x64.Build.0 = Debug|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Debug|x86.ActiveCfg = Debug|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Debug|x86.Build.0 = Debug|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Release|Any CPU.ActiveCfg = Release|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Release|Any CPU.Build.0 = Release|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Release|x64.ActiveCfg = Release|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Release|x64.Build.0 = Release|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Release|x86.ActiveCfg = Release|Any CPU + {14D91D30-8E5E-482A-940B-CC55F2DE80AA}.Release|x86.Build.0 = Release|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Debug|Any CPU.Build.0 = Debug|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Debug|x64.ActiveCfg = Debug|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Debug|x64.Build.0 = Debug|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Debug|x86.ActiveCfg = Debug|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Debug|x86.Build.0 = Debug|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Release|Any CPU.ActiveCfg = Release|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Release|Any CPU.Build.0 = Release|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Release|x64.ActiveCfg = Release|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Release|x64.Build.0 = Release|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Release|x86.ActiveCfg = Release|Any CPU + {42D043DE-8987-4072-8841-DCB2144AC18C}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE @@ -157,5 +185,7 @@ Global {8A28B784-F90B-469C-91BE-F96F63ACEA32} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} {57518676-01F0-4D5B-A53B-7A06DBA9AA04} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} {9B840598-3B03-457B-B1BE-9701BFD0D40A} = {0AB3BF05-4346-4AA6-1389-037BE0695223} + {14D91D30-8E5E-482A-940B-CC55F2DE80AA} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} + {42D043DE-8987-4072-8841-DCB2144AC18C} = {0AB3BF05-4346-4AA6-1389-037BE0695223} EndGlobalSection EndGlobal diff --git a/docs/architecture/assemblies-and-roles.md b/docs/architecture/assemblies-and-roles.md index 04ddec6..c42fe24 100644 --- a/docs/architecture/assemblies-and-roles.md +++ b/docs/architecture/assemblies-and-roles.md @@ -82,6 +82,20 @@ Responsibilities: Use this when: - You want C# ownership of the server host process while reusing existing language services. +### `FScript.TypeProvider` +Role: +- F# compile-time type provider for exported FScript functions. + +Responsibilities: +- Parse and type-check `.fss` scripts during F# compilation. +- Project `[]` functions as strongly-typed static members. +- Resolve compile-time/runtime extern providers. +- Enforce runtime signature compatibility using compile-time fingerprints. + +Use this when: +- You want F# compile-time validation of script contracts. +- You want strongly-typed invocation of exported script functions without hand-written wrappers. + ## Typical composition ### CLI execution path @@ -109,6 +123,7 @@ Use this when: - `FScript.Runtime` depends on `FScript.Language` types. - `FScript.CSharpInterop` depends on both `FScript.Language` and `FScript.Runtime`. - `FScript.LanguageServer` depends on `FScript.CSharpInterop`. +- `FScript.TypeProvider` depends on `FScript.Language` and `FScript.Runtime`. - `FScript` depends on both `FScript.Language` and `FScript.Runtime`. This keeps the language engine reusable while runtime capabilities remain host-configurable. diff --git a/docs/specs/README.md b/docs/specs/README.md index d56a882..4748f49 100644 --- a/docs/specs/README.md +++ b/docs/specs/README.md @@ -17,6 +17,7 @@ Normative behavior for the language, runtime surface, hosting model, and editor/ ## Hosting and security - Embedding `FScript.Language`: [`embedding-fscript-language.md`](./embedding-fscript-language.md) +- F# type provider for exported functions: [`fsharp-type-provider.md`](./fsharp-type-provider.md) - Sandbox and security: [`sandbox-and-security.md`](./sandbox-and-security.md) ## Editor/LSP behavior diff --git a/docs/specs/embedding-fscript-language.md b/docs/specs/embedding-fscript-language.md index 43f6373..5f346ab 100644 --- a/docs/specs/embedding-fscript-language.md +++ b/docs/specs/embedding-fscript-language.md @@ -285,3 +285,14 @@ open FScript.Language let typed = "[] let run x = x" |> FScript.parse |> FScript.infer let descriptors = Descriptor.describeFunctions typed Map.empty ``` + +### 6. Exported function signatures without evaluation +Use `FScript.Runtime.ExportSignatures.fromTypedProgram` when a host needs exported function signatures from typed AST without executing script bodies. + +```fsharp +open FScript.Language +open FScript.Runtime + +let typed = "[] let add (x: int) (y: int) = x + y" |> FScript.parse |> FScript.infer +let signatures = ExportSignatures.fromTypedProgram typed +``` diff --git a/docs/specs/fsharp-type-provider.md b/docs/specs/fsharp-type-provider.md new file mode 100644 index 0000000..49312a1 --- /dev/null +++ b/docs/specs/fsharp-type-provider.md @@ -0,0 +1,77 @@ +# F# Type Provider for FScript Exports + +This specification defines the contract for `MagnusOpera.FScript.TypeProvider`. + +## Purpose + +- Compile-time parse and type-check `.fss` scripts. +- Expose `[]` functions as strongly-typed static methods in F#. +- Allow runtime script replacement with strict signature compatibility checks. + +## Provider entry point + +- Namespace: `FScript.TypeProvider` +- Type provider: `FScriptScriptProvider` + +Static parameters: +- `ScriptPath: string` (required) +- `RootDirectory: string` (optional, defaults to script directory) +- `ExternProviders: string` (optional, semicolon-separated assembly-qualified provider type names) + +## Compile-time behavior + +1. Resolve script path and root directory. +2. Resolve externs using runtime defaults plus configured extern-provider types. +3. Parse with includes from file and run type inference. +4. Collect exported functions. +5. Fail compilation on: + - parse/type errors, + - unsupported exported signature shapes. + +## Exposed members + +For each exported function, generate one static method with mapped .NET/F# types. + +Provider-generated static members: +- `SetRuntimeResolver : (unit -> RuntimeScriptOverride option) -> unit` +- `ClearRuntimeResolver : unit -> unit` + +`RuntimeScriptOverride` fields: +- `RootDirectory: string` +- `EntryFile: string` +- `EntrySource: string` +- `ResolveImportedSource: (string -> string option) option` + +## Supported exported signature mapping (v1) + +Supported: +- `unit` +- `int` -> `int64` +- `float` +- `bool` +- `string` +- `list` +- `option` +- tuples (arity `2..8`) +- `map` -> `Map` + +Rejected: +- records +- unions +- named/custom types +- function values in argument/return positions +- unresolved type variables +- non-string map keys + +## Runtime compatibility policy + +- Provider computes a compile-time fingerprint of all exported function signatures. +- Every invocation loads script via compile-time path or active runtime resolver override. +- Runtime exported signature fingerprint must exactly match compile-time fingerprint. +- Mismatch fails invocation with an error before function execution. + +## Runtime load source selection + +- No resolver set: load compile-time script file. +- Resolver set and returns `Some`: load `EntrySource` with `loadSourceWithIncludes` and optional import resolver. +- Resolver set and returns `None`: fallback to compile-time script file. diff --git a/src/FScript.Runtime/ExportSignatures.fs b/src/FScript.Runtime/ExportSignatures.fs new file mode 100644 index 0000000..da4ba60 --- /dev/null +++ b/src/FScript.Runtime/ExportSignatures.fs @@ -0,0 +1,53 @@ +namespace FScript.Runtime + +open FScript.Language + +module ExportSignatures = + type ExportedFunctionSignature = + { Name: string + ParameterNames: string list + ParameterTypes: Type list + ReturnType: Type } + + let private flattenFunctionType (t: Type) : Type list * Type = + let rec loop (acc: Type list) (current: Type) = + match current with + | TFun (arg, ret) -> loop (arg :: acc) ret + | _ -> List.rev acc, current + loop [] t + + let private flattenParameterNames (expr: Expr) : string list = + let rec loop (acc: string list) (current: Expr) = + match current with + | ELambda (param, body, _) -> loop (param.Name :: acc) body + | _ -> List.rev acc + loop [] expr + + let private fromLet (name: string) (expr: Expr) (exprType: Type) : ExportedFunctionSignature option = + let parameterNames = flattenParameterNames expr + let parameterTypes, returnType = flattenFunctionType exprType + if parameterNames.IsEmpty || parameterTypes.IsEmpty then + None + elif parameterNames.Length <> parameterTypes.Length then + raise (HostCommon.evalError $"Signature mismatch for function '{name}'") + else + Some + { Name = name + ParameterNames = parameterNames + ParameterTypes = parameterTypes + ReturnType = returnType } + + let fromTypedProgram (program: TypeInfer.TypedProgram) : Map = + program + |> List.collect (function + | TypeInfer.TSLet(name, expr, exprType, _, isExported, _) when isExported -> + match fromLet name expr exprType with + | Some signature -> [ signature.Name, signature ] + | None -> [] + | TypeInfer.TSLetRecGroup(bindings, isExported, _) when isExported -> + bindings + |> List.choose (fun (name, expr, exprType, _) -> + fromLet name expr exprType + |> Option.map (fun signature -> signature.Name, signature)) + | _ -> []) + |> Map.ofList diff --git a/src/FScript.Runtime/FScript.Runtime.fsproj b/src/FScript.Runtime/FScript.Runtime.fsproj index c19a90f..791b00b 100644 --- a/src/FScript.Runtime/FScript.Runtime.fsproj +++ b/src/FScript.Runtime/FScript.Runtime.fsproj @@ -31,6 +31,7 @@ + diff --git a/src/FScript.Runtime/ScriptHost.fs b/src/FScript.Runtime/ScriptHost.fs index 1ea6102..319e125 100644 --- a/src/FScript.Runtime/ScriptHost.fs +++ b/src/FScript.Runtime/ScriptHost.fs @@ -36,46 +36,14 @@ module ScriptHost = | TypeInfer.TSLetRecGroup(bindings, isExported, _) when isExported -> bindings |> List.map (fun (name, _, _, _) -> name) | _ -> []) - let private flattenFunctionType (t: Type) : Type list * Type = - let rec loop (acc: Type list) (current: Type) = - match current with - | TFun (arg, ret) -> loop (arg :: acc) ret - | _ -> List.rev acc, current - loop [] t - - let private flattenParameterNames (expr: Expr) : string list = - let rec loop (acc: string list) (current: Expr) = - match current with - | ELambda (param, body, _) -> loop (param.Name :: acc) body - | _ -> List.rev acc - loop [] expr - let private collectFunctionSignatures (program: TypeInfer.TypedProgram) : Map = - let fromLet name expr exprType = - let paramNames = flattenParameterNames expr - let parameterTypes, returnType = flattenFunctionType exprType - if paramNames.IsEmpty || parameterTypes.IsEmpty then - None - elif paramNames.Length <> parameterTypes.Length then - raise (HostCommon.evalError $"Signature mismatch for function '{name}'") - else - Some (name, - { Name = name - ParameterNames = paramNames - ParameterTypes = parameterTypes - ReturnType = returnType }) - program - |> List.collect (function - | TypeInfer.TSLet(name, expr, exprType, _, isExported, _) when isExported -> - match fromLet name expr exprType with - | Some signature -> [ signature ] - | None -> [] - | TypeInfer.TSLetRecGroup(bindings, isExported, _) when isExported -> - bindings - |> List.choose (fun (name, expr, exprType, _) -> fromLet name expr exprType) - | _ -> []) - |> Map.ofList + |> ExportSignatures.fromTypedProgram + |> Map.map (fun _ signature -> + { Name = signature.Name + ParameterNames = signature.ParameterNames + ParameterTypes = signature.ParameterTypes + ReturnType = signature.ReturnType }) let private loadProgram (externs: ExternalFunction list) (program: Program) : LoadedScript = let typed = FScript.inferWithExterns externs program diff --git a/src/FScript.TypeProvider/Contract.fs b/src/FScript.TypeProvider/Contract.fs new file mode 100644 index 0000000..7a47a88 --- /dev/null +++ b/src/FScript.TypeProvider/Contract.fs @@ -0,0 +1,244 @@ +namespace FScript.TypeProvider + +open System +open System.Security.Cryptography +open System.Text +open System.Text.Json +open FScript.Language + +[] +type SupportedType = + | Unit + | Int64 + | Float + | Bool + | String + | List of SupportedType + | Option of SupportedType + | Tuple of SupportedType list + | StringMap of SupportedType + +type FunctionContract = + { Name: string + ParameterNames: string list + ParameterTypes: SupportedType list + ReturnType: SupportedType } + +type ScriptContract = + { ContractId: string + CompileScriptPath: string + CompileRootDirectory: string + ExternProviderTypeNames: string list + Fingerprint: string + Functions: FunctionContract list } + +type RuntimeScriptOverride = + { RootDirectory: string + EntryFile: string + EntrySource: string + ResolveImportedSource: (string -> string option) option } + +type RuntimeScriptResolver = unit -> RuntimeScriptOverride option + +module Contract = + let private tupleMaxArity = 8 + let private toHex (bytes: byte array) = + bytes + |> Array.map (fun b -> b.ToString("X2")) + |> String.concat "" + + let rec canonicalType (t: SupportedType) : string = + match t with + | SupportedType.Unit -> "unit" + | SupportedType.Int64 -> "int64" + | SupportedType.Float -> "float" + | SupportedType.Bool -> "bool" + | SupportedType.String -> "string" + | SupportedType.List inner -> $"list<{canonicalType inner}>" + | SupportedType.Option inner -> $"option<{canonicalType inner}>" + | SupportedType.Tuple items -> + items + |> List.map canonicalType + |> String.concat "*" + |> fun payload -> $"tuple<{payload}>" + | SupportedType.StringMap inner -> $"map" + + let canonicalFunction (f: FunctionContract) = + let args = f.ParameterTypes |> List.map canonicalType |> String.concat "," + $"{f.Name}({args})->{canonicalType f.ReturnType}" + + let fingerprint (functions: FunctionContract list) : string = + let canonical = + functions + |> List.sortBy (fun f -> f.Name) + |> List.map canonicalFunction + |> String.concat "\n" + + use sha = SHA256.Create() + canonical + |> Encoding.UTF8.GetBytes + |> sha.ComputeHash + |> toHex + + [] + type FunctionContractDto = + { Name: string + ParameterNames: string list + ParameterTypes: string list + ReturnType: string } + + [] + type ScriptContractDto = + { ContractId: string + CompileScriptPath: string + CompileRootDirectory: string + ExternProviderTypeNames: string list + Fingerprint: string + Functions: FunctionContractDto list } + + let private splitTopLevel (delimiter: char) (value: string) = + let parts = ResizeArray() + let mutable depth = 0 + let mutable start = 0 + for i = 0 to value.Length - 1 do + let c = value[i] + if c = '<' then depth <- depth + 1 + elif c = '>' then depth <- depth - 1 + elif c = delimiter && depth = 0 then + parts.Add(value.Substring(start, i - start)) + start <- i + 1 + parts.Add(value.Substring(start)) + parts |> Seq.toList + + let rec private parseSupportedType (value: string) : SupportedType = + match value with + | "unit" -> SupportedType.Unit + | "int64" -> SupportedType.Int64 + | "float" -> SupportedType.Float + | "bool" -> SupportedType.Bool + | "string" -> SupportedType.String + | _ when value.StartsWith("list<", StringComparison.Ordinal) && value.EndsWith(">", StringComparison.Ordinal) -> + let inner = value.Substring(5, value.Length - 6) + SupportedType.List (parseSupportedType inner) + | _ when value.StartsWith("option<", StringComparison.Ordinal) && value.EndsWith(">", StringComparison.Ordinal) -> + let inner = value.Substring(7, value.Length - 8) + SupportedType.Option (parseSupportedType inner) + | _ when value.StartsWith("map", StringComparison.Ordinal) -> + let inner = value.Substring("map", StringComparison.Ordinal) -> + let payload = value.Substring(6, value.Length - 7) + let items = + payload + |> splitTopLevel '*' + |> List.map parseSupportedType + SupportedType.Tuple items + | _ -> + invalidOp $"Unsupported serialized type '{value}'." + + let toJson (contract: ScriptContract) = + let dto : ScriptContractDto = + { ContractId = contract.ContractId + CompileScriptPath = contract.CompileScriptPath + CompileRootDirectory = contract.CompileRootDirectory + ExternProviderTypeNames = contract.ExternProviderTypeNames + Fingerprint = contract.Fingerprint + Functions = + contract.Functions + |> List.map (fun fn -> + { Name = fn.Name + ParameterNames = fn.ParameterNames + ParameterTypes = fn.ParameterTypes |> List.map canonicalType + ReturnType = canonicalType fn.ReturnType }) } + JsonSerializer.Serialize(dto) + + let fromJson (json: string) : ScriptContract = + match JsonSerializer.Deserialize(json) with + | null -> invalidOp "Unable to parse script contract payload." + | value -> + { ContractId = value.ContractId + CompileScriptPath = value.CompileScriptPath + CompileRootDirectory = value.CompileRootDirectory + ExternProviderTypeNames = value.ExternProviderTypeNames + Fingerprint = value.Fingerprint + Functions = + value.Functions + |> List.map (fun fn -> + { Name = fn.Name + ParameterNames = fn.ParameterNames + ParameterTypes = fn.ParameterTypes |> List.map parseSupportedType + ReturnType = parseSupportedType fn.ReturnType }) } + + let rec ofFScriptType (typePath: string) (t: Type) : Result = + let recurse childPath child = ofFScriptType childPath child + match t with + | TUnit -> Ok SupportedType.Unit + | TInt -> Ok SupportedType.Int64 + | TFloat -> Ok SupportedType.Float + | TBool -> Ok SupportedType.Bool + | TString -> Ok SupportedType.String + | TList inner -> + recurse $"{typePath} list item" inner + |> Result.map SupportedType.List + | TOption inner -> + recurse $"{typePath} option value" inner + |> Result.map SupportedType.Option + | TTuple items -> + if items.Length < 2 then + Error $"{typePath}: tuples must have arity 2..{tupleMaxArity}." + elif items.Length > tupleMaxArity then + Error $"{typePath}: tuple arity {items.Length} is not supported (max {tupleMaxArity})." + else + items + |> List.mapi (fun i item -> recurse $"{typePath} tuple item #{i + 1}" item) + |> List.fold (fun state next -> + match state, next with + | Error err, _ -> Error err + | _, Error err -> Error err + | Ok acc, Ok value -> Ok (acc @ [ value ])) (Ok []) + |> Result.map SupportedType.Tuple + | TMap (TString, valueType) -> + recurse $"{typePath} map value" valueType + |> Result.map SupportedType.StringMap + | TMap _ -> + Error $"{typePath}: only map is supported." + | TNamed name -> + Error $"{typePath}: named type '{name}' is not supported in exported signatures." + | TRecord _ -> + Error $"{typePath}: record types are not supported in exported signatures." + | TUnion (name, _) -> + Error $"{typePath}: union type '{name}' is not supported in exported signatures." + | TTypeToken -> + Error $"{typePath}: type tokens are not supported in exported signatures." + | TFun _ -> + Error $"{typePath}: function values are not supported in exported signatures." + | TVar id -> + Error $"{typePath}: unresolved generic type variable '{id}' is not supported in exported signatures." + + let fromExportedSignature + (signature: FScript.Runtime.ExportSignatures.ExportedFunctionSignature) + : Result = + let convertParameter index paramType = + ofFScriptType $"Function '{signature.Name}' parameter #{index + 1}" paramType + + let convertedParams = + signature.ParameterTypes + |> List.mapi convertParameter + |> List.fold (fun state next -> + match state, next with + | Error err, _ -> Error err + | _, Error err -> Error err + | Ok acc, Ok value -> Ok (acc @ [ value ])) (Ok []) + + let convertedReturn = + ofFScriptType $"Function '{signature.Name}' return type" signature.ReturnType + + match convertedParams, convertedReturn with + | Ok paramTypes, Ok returnType -> + Ok + { Name = signature.Name + ParameterNames = signature.ParameterNames + ParameterTypes = paramTypes + ReturnType = returnType } + | Error err, _ + | _, Error err -> Error err diff --git a/src/FScript.TypeProvider/FScript.TypeProvider.fsproj b/src/FScript.TypeProvider/FScript.TypeProvider.fsproj new file mode 100644 index 0000000..033b6d4 --- /dev/null +++ b/src/FScript.TypeProvider/FScript.TypeProvider.fsproj @@ -0,0 +1,43 @@ + + + + netstandard2.1 + true + true + true + MagnusOpera.FScript.TypeProvider + 0.0.0 + Magnus Opera + FScript F# Type Provider + Strongly-typed F# type provider for FScript exported functions. + fscript;typeprovider;fsharp;scripting + LICENSE + README.md + FScriptIcon.png + https://github.com/MagnusOpera/FScript + https://github.com/MagnusOpera/FScript.git + git + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/FScript.TypeProvider/Provider.fs b/src/FScript.TypeProvider/Provider.fs new file mode 100644 index 0000000..7180ed9 --- /dev/null +++ b/src/FScript.TypeProvider/Provider.fs @@ -0,0 +1,190 @@ +namespace FScript.TypeProvider + +open System +open System.IO +open System.Reflection +open System.Security.Cryptography +open System.Text +open Microsoft.FSharp.Core.CompilerServices +open Microsoft.FSharp.Quotations +open ProviderImplementation.ProvidedTypes +open FScript.Language +open FScript.Runtime + +[] +type FScriptScriptProvider(config: TypeProviderConfig) as this = + inherit TypeProviderForNamespaces(config, addDefaultProbingLocation = true) + + let providerNamespace = "FScript.TypeProvider" + let assembly = Assembly.GetExecutingAssembly() + + let normalizeParameterNames (names: string list) = + let mutable seen = Set.empty + names + |> List.mapi (fun index rawName -> + let baseName = + if String.IsNullOrWhiteSpace(rawName) || rawName = "_" then + $"arg{index + 1}" + else + rawName + + let rec ensureUnique candidate suffix = + if seen.Contains(candidate) then + ensureUnique $"{baseName}_{suffix}" (suffix + 1) + else + seen <- seen.Add(candidate) + candidate + ensureUnique baseName 2) + + let buildContract + (scriptPath: string) + (rootDirectory: string) + (externProviders: string) + : string * FunctionContract list * string = + let resolvedScriptPath = + if Path.IsPathRooted(scriptPath) then + Path.GetFullPath(scriptPath) + else + Path.GetFullPath(Path.Combine(config.ResolutionFolder, scriptPath)) + + if not (File.Exists(resolvedScriptPath)) then + failwith $"Script file not found: '{resolvedScriptPath}'." + + let resolvedRootDirectory = + if String.IsNullOrWhiteSpace(rootDirectory) then + match Path.GetDirectoryName(resolvedScriptPath) with + | null + | "" -> Directory.GetCurrentDirectory() + | value -> value + elif Path.IsPathRooted(rootDirectory) then + Path.GetFullPath(rootDirectory) + else + Path.GetFullPath(Path.Combine(config.ResolutionFolder, rootDirectory)) + + let externProviderNames = ScriptRuntime.parseExternProviderNames externProviders + let externs = ScriptRuntime.resolveExterns resolvedRootDirectory externProviderNames + let typed = + resolvedScriptPath + |> FScript.parseFileWithIncludes resolvedRootDirectory + |> FScript.inferWithExterns externs + + let functionContracts = + typed + |> ExportSignatures.fromTypedProgram + |> Map.toList + |> List.sortBy fst + |> List.map snd + |> List.map (fun signature -> + match Contract.fromExportedSignature signature with + | Ok value -> value + | Error err -> failwith err) + + let externProviderKey = String.concat ";" externProviderNames + let contractIdSeed = $"{resolvedScriptPath}|{resolvedRootDirectory}|{externProviderKey}" + let contractId = + use sha = SHA256.Create() + contractIdSeed + |> Encoding.UTF8.GetBytes + |> sha.ComputeHash + |> Array.map (fun b -> b.ToString("X2")) + |> String.concat "" + |> fun value -> $"fscript:{value}" + let contractJson = + ScriptRuntime.createContractJson + contractId + resolvedScriptPath + resolvedRootDirectory + externProviderNames + functionContracts + + contractJson, functionContracts, contractId + + let createRootType () = + let rootType = ProvidedTypeDefinition(assembly, providerNamespace, "FScriptScriptProvider", Some typeof, hideObjectMethods = true) + + let parameters = + [ ProvidedStaticParameter("ScriptPath", typeof) + ProvidedStaticParameter("RootDirectory", typeof, "") + ProvidedStaticParameter("ExternProviders", typeof, "") ] + + rootType.DefineStaticParameters( + parameters, + fun generatedTypeName staticArgs -> + try + let scriptPath = staticArgs.[0] :?> string + let rootDirectory = staticArgs.[1] :?> string + let externProviders = staticArgs.[2] :?> string + let contractJson, functions, contractId = buildContract scriptPath rootDirectory externProviders + + let generatedType = ProvidedTypeDefinition(assembly, providerNamespace, generatedTypeName, Some typeof, hideObjectMethods = true) + + let setResolverMethod = + ProvidedMethod( + "SetRuntimeResolver", + [ ProvidedParameter("resolver", typeof) ], + typeof, + isStatic = true, + invokeCode = + (fun args -> + match args with + | [ resolver ] -> + <@@ ScriptRuntime.setResolver contractId (%%resolver: RuntimeScriptResolver) @@> + | _ -> invalidOp "Unexpected argument list for SetRuntimeResolver.")) + + let clearResolverMethod = + ProvidedMethod( + "ClearRuntimeResolver", + [], + typeof, + isStatic = true, + invokeCode = + (fun _ -> + <@@ ScriptRuntime.clearResolver contractId @@>)) + + generatedType.AddMember(setResolverMethod) + generatedType.AddMember(clearResolverMethod) + + for fn in functions do + let functionName = fn.Name + let parameterNames = normalizeParameterNames fn.ParameterNames + let parameters = + (parameterNames, fn.ParameterTypes) + ||> List.zip + |> List.map (fun (name, supportedType) -> + ProvidedParameter(name, RuntimeTypeBridge.toSystemType supportedType)) + let returnType = RuntimeTypeBridge.toSystemType fn.ReturnType + let methodDefinition = + ProvidedMethod( + functionName, + parameters, + returnType, + isStatic = true, + invokeCode = + (fun methodArgs -> + let boxedArgs = + methodArgs + |> List.map (fun arg -> Expr.Coerce(arg, typeof)) + |> fun args -> Expr.NewArray(typeof, args) + let call = <@@ ScriptRuntime.invoke contractJson functionName %%boxedArgs @@> + Expr.Coerce(call, returnType))) + generatedType.AddMember(methodDefinition) + + generatedType + with + | ParseException err -> + let scriptPath = staticArgs.[0] :?> string + failwith $"Failed to parse FScript '{scriptPath}': {err.Message}" + | TypeException err -> + let scriptPath = staticArgs.[0] :?> string + failwith $"Failed to type-check FScript '{scriptPath}': {err.Message}" + | ex -> + let scriptPath = staticArgs.[0] :?> string + failwith $"Failed to build FScript provider for '{scriptPath}': {ex.GetBaseException().Message}") + + rootType + + do + this.AddNamespace(providerNamespace, [ createRootType () ]) + +[] +do () diff --git a/src/FScript.TypeProvider/ScriptRuntime.fs b/src/FScript.TypeProvider/ScriptRuntime.fs new file mode 100644 index 0000000..1f0f5c0 --- /dev/null +++ b/src/FScript.TypeProvider/ScriptRuntime.fs @@ -0,0 +1,329 @@ +namespace FScript.TypeProvider + +#nowarn "3261" + +open System +open System.Collections +open System.Collections.Concurrent +open System.Reflection +open Microsoft.FSharp.Reflection +open FScript.Language +open FScript.Runtime + +module internal RuntimeTypeBridge = + type DotNetType = System.Type + + let private fsharpCoreAssembly = typeof>.Assembly + let private listModuleType = fsharpCoreAssembly.GetType("Microsoft.FSharp.Collections.ListModule", true) + let private mapModuleType = fsharpCoreAssembly.GetType("Microsoft.FSharp.Collections.MapModule", true) + let private listOfSeqMethod = listModuleType.GetMethod("OfSeq", BindingFlags.Public ||| BindingFlags.Static) + let private mapOfSeqMethod = mapModuleType.GetMethod("OfSeq", BindingFlags.Public ||| BindingFlags.Static) + + let private typeNameOrNull (value: obj) = + if isNull value then "null" else value.GetType().FullName + + let rec toSystemType (t: SupportedType) : DotNetType = + match t with + | SupportedType.Unit -> typeof + | SupportedType.Int64 -> typeof + | SupportedType.Float -> typeof + | SupportedType.Bool -> typeof + | SupportedType.String -> typeof + | SupportedType.List inner -> + typedefof>.MakeGenericType([| toSystemType inner |]) + | SupportedType.Option inner -> + typedefof>.MakeGenericType([| toSystemType inner |]) + | SupportedType.Tuple items -> + items + |> List.map toSystemType + |> List.toArray + |> FSharpType.MakeTupleType + | SupportedType.StringMap inner -> + typedefof>.MakeGenericType([| typeof; toSystemType inner |]) + + let private tryGetKeyValuePair (value: obj) : (obj * obj) option = + if isNull value then + None + else + let t = value.GetType() + let keyProp = t.GetProperty("Key") + let valueProp = t.GetProperty("Value") + if isNull keyProp || isNull valueProp then + None + else + Some (keyProp.GetValue(value), valueProp.GetValue(value)) + + let rec toValue (expectedType: SupportedType) (input: obj) : Value = + match expectedType with + | SupportedType.Unit -> VUnit + | SupportedType.Int64 -> + match input with + | :? int64 as value -> VInt value + | _ -> invalidOp $"Expected int64 argument but got '{typeNameOrNull input}'." + | SupportedType.Float -> + match input with + | :? float as value -> VFloat value + | _ -> invalidOp $"Expected float argument but got '{typeNameOrNull input}'." + | SupportedType.Bool -> + match input with + | :? bool as value -> VBool value + | _ -> invalidOp $"Expected bool argument but got '{typeNameOrNull input}'." + | SupportedType.String -> + match input with + | :? string as value -> VString value + | _ -> invalidOp $"Expected string argument but got '{typeNameOrNull input}'." + | SupportedType.List inner -> + match input with + | :? IEnumerable as sequence -> + sequence + |> Seq.cast + |> Seq.map (toValue inner) + |> Seq.toList + |> VList + | _ -> invalidOp $"Expected list argument but got '{typeNameOrNull input}'." + | SupportedType.Option inner -> + if isNull input then + VOption None + else + let inputType = input.GetType() + if not (FSharpType.IsUnion(inputType)) then + invalidOp $"Expected option argument but got '{inputType.FullName}'." + else + let unionCase, fields = FSharpValue.GetUnionFields(input, inputType) + match unionCase.Name, fields with + | "None", _ -> VOption None + | "Some", [| value |] -> VOption (Some (toValue inner value)) + | _ -> invalidOp $"Expected option argument but got '{inputType.FullName}'." + | SupportedType.Tuple itemTypes -> + if isNull input then + invalidOp "Expected tuple argument but got null." + elif not (FSharpType.IsTuple(input.GetType())) then + invalidOp $"Expected tuple argument but got '{input.GetType().FullName}'." + else + let fields = FSharpValue.GetTupleFields(input) + if fields.Length <> itemTypes.Length then + invalidOp $"Expected tuple arity {itemTypes.Length} but got {fields.Length}." + else + (itemTypes, fields |> Array.toList) + ||> List.zip + |> List.map (fun (itemType, fieldValue) -> toValue itemType fieldValue) + |> VTuple + | SupportedType.StringMap inner -> + match input with + | :? IEnumerable as sequence -> + sequence + |> Seq.cast + |> Seq.map (fun item -> + match tryGetKeyValuePair item with + | Some (:? string as key, value) -> MapKey.MKString key, toValue inner value + | Some (key, _) -> + invalidOp $"Expected map key type string but got '{typeNameOrNull key}'." + | None -> + invalidOp "Expected map entries exposing Key/Value.") + |> Seq.toList + |> Map.ofList + |> VMap + | _ -> invalidOp $"Expected map argument but got '{typeNameOrNull input}'." + + let rec fromValue (expectedType: SupportedType) (value: Value) : obj = + match expectedType, value with + | SupportedType.Unit, VUnit -> box () + | SupportedType.Int64, VInt number -> box number + | SupportedType.Float, VFloat number -> box number + | SupportedType.Bool, VBool flag -> box flag + | SupportedType.String, VString text -> box text + | SupportedType.List inner, VList values -> + let itemType = toSystemType inner + let converted = values |> List.map (fromValue inner) |> List.toArray + let typedArray = Array.CreateInstance(itemType, converted.Length) + for i = 0 to converted.Length - 1 do + typedArray.SetValue(converted[i], i) + let ofSeq = listOfSeqMethod.MakeGenericMethod([| itemType |]) + ofSeq.Invoke(null, [| typedArray :> IEnumerable |]) + | SupportedType.Option inner, VOption maybeValue -> + let optionType = toSystemType expectedType + let unionCases = FSharpType.GetUnionCases(optionType) + match maybeValue with + | None -> + let noneCase = unionCases |> Array.find (fun c -> c.Name = "None") + FSharpValue.MakeUnion(noneCase, [||]) + | Some item -> + let someCase = unionCases |> Array.find (fun c -> c.Name = "Some") + let innerValue = fromValue inner item + FSharpValue.MakeUnion(someCase, [| innerValue |]) + | SupportedType.Tuple itemTypes, VTuple values -> + if itemTypes.Length <> values.Length then + invalidOp $"Expected tuple return arity {itemTypes.Length} but got {values.Length}." + else + let tupleType = toSystemType expectedType + let converted = + (itemTypes, values) + ||> List.zip + |> List.map (fun (itemType, itemValue) -> fromValue itemType itemValue) + |> List.toArray + FSharpValue.MakeTuple(converted, tupleType) + | SupportedType.StringMap inner, VMap entries -> + let valueType = toSystemType inner + let tupleType = FSharpType.MakeTupleType([| typeof; valueType |]) + let tupleObjects = + entries + |> Map.toList + |> List.map (fun (key, rawValue) -> + match key with + | MapKey.MKString text -> + let mappedValue = fromValue inner rawValue + FSharpValue.MakeTuple([| box text; mappedValue |], tupleType) + | _ -> + invalidOp "Expected string map keys in script result.") + |> List.toArray + let tupleArray = Array.CreateInstance(tupleType, tupleObjects.Length) + for i = 0 to tupleObjects.Length - 1 do + tupleArray.SetValue(tupleObjects[i], i) + let ofSeq = mapOfSeqMethod.MakeGenericMethod([| typeof; valueType |]) + ofSeq.Invoke(null, [| tupleArray :> IEnumerable |]) + | _ -> + invalidOp $"Value mismatch. Expected '{Contract.canonicalType expectedType}' but got '{Pretty.valueToString value}'." + +module ScriptRuntime = + let private contractCache = ConcurrentDictionary() + let private resolverCache = ConcurrentDictionary() + let private externListType = typeof + + let parseExternProviderNames (externProviders: string) : string list = + externProviders.Split([| ';' |], StringSplitOptions.RemoveEmptyEntries) + |> Array.map (fun item -> item.Trim()) + |> Array.filter (fun item -> not (String.IsNullOrWhiteSpace(item))) + |> Array.toList + + let private invokeExternProvider (ctx: HostContext) (providerType: System.Type) (providerMethod: MethodInfo) : ExternalFunction list = + if providerMethod.ReturnType <> externListType then + invalidOp $"Invalid extern provider '{providerType.FullName}.{providerMethod.Name}': return type must be ExternalFunction list." + + let parameters = providerMethod.GetParameters() + let args = + if parameters.Length = 0 then + [||] + elif parameters.Length = 1 && parameters.[0].ParameterType = typeof then + [| box ctx |] + else + invalidOp + $"Invalid extern provider '{providerType.FullName}.{providerMethod.Name}': expected signature unit -> ExternalFunction list or HostContext -> ExternalFunction list." + + let provided = providerMethod.Invoke(null, args) + if isNull provided then + invalidOp $"Extern provider '{providerType.FullName}.{providerMethod.Name}' returned null." + else + match provided with + | :? (ExternalFunction list) as externs -> externs + | _ -> invalidOp $"Extern provider '{providerType.FullName}.{providerMethod.Name}' returned an invalid value." + + let resolveExterns (rootDirectory: string) (externProviderTypeNames: string list) : ExternalFunction list = + let ctx = { RootDirectory = rootDirectory; DeniedPathGlobs = [] } + let defaults = Registry.all ctx + + let userExterns = + externProviderTypeNames + |> List.collect (fun typeName -> + let providerType = System.Type.GetType(typeName, throwOnError = true) + providerType.GetMethods(BindingFlags.Public ||| BindingFlags.Static) + |> Array.toList + |> List.filter (fun methodInfo -> + methodInfo.GetCustomAttributes(typeof, false).Length > 0) + |> List.collect (fun methodInfo -> invokeExternProvider ctx providerType methodInfo)) + + let allExterns = defaults @ userExterns + let conflicts = + allExterns + |> List.groupBy (fun ext -> ext.Name) + |> List.filter (fun (_, values) -> values.Length > 1) + |> List.map fst + + if conflicts.IsEmpty then + allExterns + else + let conflictText = String.concat ", " conflicts + invalidOp $"External function name conflicts detected: {conflictText}" + + let private getContract (contractJson: string) = + let parsed = Contract.fromJson contractJson + contractCache.GetOrAdd(parsed.ContractId, fun _ -> parsed) + + let setResolver (contractId: string) (resolver: RuntimeScriptResolver) : unit = + resolverCache.[contractId] <- resolver + + let clearResolver (contractId: string) : unit = + resolverCache.TryRemove(contractId) |> ignore + + let private getRuntimeOverride (contractId: string) = + match resolverCache.TryGetValue(contractId) with + | true, resolver -> resolver () + | _ -> None + + let private computeFingerprint (loaded: ScriptHost.LoadedScript) : string = + let functionContracts = + loaded.ExportedFunctionSignatures + |> Map.toList + |> List.map snd + |> List.map (fun signature -> + match Contract.fromExportedSignature + { Name = signature.Name + ParameterNames = signature.ParameterNames + ParameterTypes = signature.ParameterTypes + ReturnType = signature.ReturnType } with + | Ok value -> value + | Error err -> invalidOp err) + Contract.fingerprint functionContracts + + let private loadScript (contract: ScriptContract) : ScriptHost.LoadedScript = + let runtimeOverride = getRuntimeOverride contract.ContractId + let rootDirectory = + match runtimeOverride with + | Some value -> value.RootDirectory + | None -> contract.CompileRootDirectory + let externs = resolveExterns rootDirectory contract.ExternProviderTypeNames + match runtimeOverride with + | Some value -> + let resolver = defaultArg value.ResolveImportedSource (fun _ -> None) + ScriptHost.loadSourceWithIncludes externs value.RootDirectory value.EntryFile value.EntrySource resolver + | None -> + ScriptHost.loadFile externs contract.CompileScriptPath + + let invoke (contractJson: string) (functionName: string) (args: obj array) : obj = + let contract = getContract contractJson + let loaded = loadScript contract + let runtimeFingerprint = computeFingerprint loaded + if not (String.Equals(contract.Fingerprint, runtimeFingerprint, StringComparison.Ordinal)) then + invalidOp + $"Runtime script signature mismatch for contract '{contract.ContractId}'. Expected fingerprint '{contract.Fingerprint}' but found '{runtimeFingerprint}'." + + let functionContract = + contract.Functions + |> List.tryFind (fun f -> f.Name = functionName) + |> Option.defaultWith (fun () -> invalidOp $"Unknown exported function '{functionName}'.") + + if args.Length <> functionContract.ParameterTypes.Length then + invalidOp $"Function '{functionName}' expects {functionContract.ParameterTypes.Length} argument(s), got {args.Length}." + + let valueArgs = + (functionContract.ParameterTypes, args |> Array.toList) + ||> List.zip + |> List.map (fun (argType, argValue) -> RuntimeTypeBridge.toValue argType argValue) + + let result = ScriptHost.invoke loaded functionName valueArgs + RuntimeTypeBridge.fromValue functionContract.ReturnType result + + let createContractJson + (contractId: string) + (compileScriptPath: string) + (compileRootDirectory: string) + (externProviderTypeNames: string list) + (functions: FunctionContract list) + : string = + let contract = + { ContractId = contractId + CompileScriptPath = compileScriptPath + CompileRootDirectory = compileRootDirectory + ExternProviderTypeNames = externProviderTypeNames + Fingerprint = Contract.fingerprint functions + Functions = functions } + Contract.toJson contract diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/FScript.TypeProvider.Tests.Fixtures.Invalid.fsproj b/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/FScript.TypeProvider.Tests.Fixtures.Invalid.fsproj new file mode 100644 index 0000000..e3d6719 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/FScript.TypeProvider.Tests.Fixtures.Invalid.fsproj @@ -0,0 +1,14 @@ + + + net10.0 + Library + + + + + + + + + + diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/Program.fs b/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/Program.fs new file mode 100644 index 0000000..faf1eb2 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/Program.fs @@ -0,0 +1,7 @@ +module InvalidFixture + +open FScript.TypeProvider + +type BadScript = FScriptScriptProvider + +let value = 1 diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/script-invalid.fss b/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/script-invalid.fss new file mode 100644 index 0000000..a7fcbf1 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Invalid/script-invalid.fss @@ -0,0 +1 @@ +[] let broken (x: int) = x + true diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride.fsproj b/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride.fsproj new file mode 100644 index 0000000..8200e6c --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride.fsproj @@ -0,0 +1,14 @@ + + + net10.0 + Exe + + + + + + + + + + diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/Program.fs b/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/Program.fs new file mode 100644 index 0000000..ef027af --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/Program.fs @@ -0,0 +1,43 @@ +open System +open System.IO +open FScript.TypeProvider + +type Script = FScriptScriptProvider + +[] +let main _ = + let root = Directory.GetCurrentDirectory() + let entryPath = Path.Combine(root, "virtual-main.fss") + + Script.SetRuntimeResolver(fun () -> + Some + { RootDirectory = root + EntryFile = entryPath + EntrySource = "[] let add (x: int) (y: int) = x + y + 10" + ResolveImportedSource = None }) + + let updated = Script.add(1L, 2L) + if updated <> 13L then + failwith $"Expected updated add result 13 but got {updated}" + + Script.SetRuntimeResolver(fun () -> + Some + { RootDirectory = root + EntryFile = entryPath + EntrySource = "[] let add (x: int) = x + 1" + ResolveImportedSource = None }) + + let mismatchRejected = + try + Script.add(1L, 2L) |> ignore + false + with + | :? InvalidOperationException -> + true + + Script.ClearRuntimeResolver() + + if not mismatchRejected then + failwith "Expected strict signature mismatch rejection." + + 0 diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/script.fss b/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/script.fss new file mode 100644 index 0000000..f000fa0 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.RuntimeOverride/script.fss @@ -0,0 +1 @@ +[] let add (x: int) (y: int) = x + y diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/FScript.TypeProvider.Tests.Fixtures.Unsupported.fsproj b/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/FScript.TypeProvider.Tests.Fixtures.Unsupported.fsproj new file mode 100644 index 0000000..e3d6719 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/FScript.TypeProvider.Tests.Fixtures.Unsupported.fsproj @@ -0,0 +1,14 @@ + + + net10.0 + Library + + + + + + + + + + diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/Program.fs b/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/Program.fs new file mode 100644 index 0000000..a174950 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/Program.fs @@ -0,0 +1,7 @@ +module UnsupportedFixture + +open FScript.TypeProvider + +type UnsupportedScript = FScriptScriptProvider + +let value = 1 diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/script-unsupported.fss b/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/script-unsupported.fss new file mode 100644 index 0000000..7b79d13 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Unsupported/script-unsupported.fss @@ -0,0 +1,2 @@ +type Person = { Name: string } +[] let readName (person: Person) = person.Name diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Valid/FScript.TypeProvider.Tests.Fixtures.Valid.fsproj b/tests/FScript.TypeProvider.Tests.Fixtures.Valid/FScript.TypeProvider.Tests.Fixtures.Valid.fsproj new file mode 100644 index 0000000..8200e6c --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Valid/FScript.TypeProvider.Tests.Fixtures.Valid.fsproj @@ -0,0 +1,14 @@ + + + net10.0 + Exe + + + + + + + + + + diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Valid/Program.fs b/tests/FScript.TypeProvider.Tests.Fixtures.Valid/Program.fs new file mode 100644 index 0000000..1395106 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Valid/Program.fs @@ -0,0 +1,10 @@ +open FScript.TypeProvider + +type Script = FScriptScriptProvider + +[] +let main _ = + let result = Script.add(1L, 2L) + if result <> 3L then + failwith $"Expected 3 but got {result}" + 0 diff --git a/tests/FScript.TypeProvider.Tests.Fixtures.Valid/script.fss b/tests/FScript.TypeProvider.Tests.Fixtures.Valid/script.fss new file mode 100644 index 0000000..f000fa0 --- /dev/null +++ b/tests/FScript.TypeProvider.Tests.Fixtures.Valid/script.fss @@ -0,0 +1 @@ +[] let add (x: int) (y: int) = x + y diff --git a/tests/FScript.TypeProvider.Tests/FScript.TypeProvider.Tests.fsproj b/tests/FScript.TypeProvider.Tests/FScript.TypeProvider.Tests.fsproj new file mode 100644 index 0000000..f27396f --- /dev/null +++ b/tests/FScript.TypeProvider.Tests/FScript.TypeProvider.Tests.fsproj @@ -0,0 +1,24 @@ + + + + net10.0 + false + false + enable + + + + + + + + + + + + + + + + + diff --git a/tests/FScript.TypeProvider.Tests/Program.fs b/tests/FScript.TypeProvider.Tests/Program.fs new file mode 100644 index 0000000..9ee7eaf --- /dev/null +++ b/tests/FScript.TypeProvider.Tests/Program.fs @@ -0,0 +1,4 @@ +module Program + +[] +let main _ = 0 diff --git a/tests/FScript.TypeProvider.Tests/TypeProviderIntegrationTests.fs b/tests/FScript.TypeProvider.Tests/TypeProviderIntegrationTests.fs new file mode 100644 index 0000000..ae23ced --- /dev/null +++ b/tests/FScript.TypeProvider.Tests/TypeProviderIntegrationTests.fs @@ -0,0 +1,72 @@ +namespace FScript.TypeProvider.Tests + +open System +open System.Diagnostics +open System.IO +open NUnit.Framework + +[] +type TypeProviderIntegrationTests () = + let findRepoRoot () = + let rec loop (path: string) = + if String.IsNullOrWhiteSpace(path) then + invalidOp "Unable to find repository root." + elif File.Exists(Path.Combine(path, "FScript.sln")) then + path + else + let parent = Directory.GetParent(path) + match parent with + | null -> invalidOp "Unable to find repository root." + | value -> loop value.FullName + + loop TestContext.CurrentContext.TestDirectory + + let runProcess (workingDirectory: string) (fileName: string) (arguments: string) = + let startInfo = + ProcessStartInfo( + FileName = fileName, + Arguments = arguments, + WorkingDirectory = workingDirectory, + RedirectStandardOutput = true, + RedirectStandardError = true, + UseShellExecute = false) + + use proc = new Process(StartInfo = startInfo) + proc.Start() |> ignore + let stdout = proc.StandardOutput.ReadToEnd() + let stderr = proc.StandardError.ReadToEnd() + proc.WaitForExit() + proc.ExitCode, stdout, stderr + + [] + member _.``type provider builds valid script fixture`` () = + let repoRoot = findRepoRoot () + let fixturePath = Path.Combine(repoRoot, "tests", "FScript.TypeProvider.Tests.Fixtures.Valid") + let exitCode, stdout, stderr = runProcess repoRoot "dotnet" $"build \"{fixturePath}\" -c Release" + let output = stdout + "\n" + stderr + Assert.That(exitCode, Is.EqualTo(0), $"Expected build success. Output:\n{output}") + + [] + member _.``type provider fails compilation on script type error`` () = + let repoRoot = findRepoRoot () + let fixturePath = Path.Combine(repoRoot, "tests", "FScript.TypeProvider.Tests.Fixtures.Invalid") + let exitCode, stdout, stderr = runProcess repoRoot "dotnet" $"build \"{fixturePath}\" -c Release" + let output = stdout + "\n" + stderr + Assert.That(exitCode, Is.Not.EqualTo(0), "Expected build failure for invalid script.") + Assert.That(output, Does.Contain("Failed to type-check FScript")) + + [] + member _.``type provider fails unsupported exported signature`` () = + let repoRoot = findRepoRoot () + let fixturePath = Path.Combine(repoRoot, "tests", "FScript.TypeProvider.Tests.Fixtures.Unsupported") + let exitCode, stdout, stderr = runProcess repoRoot "dotnet" $"build \"{fixturePath}\" -c Release" + let output = stdout + "\n" + stderr + Assert.That(exitCode, Is.Not.EqualTo(0), "Expected build failure for unsupported signature.") + Assert.That(output, Does.Contain("not supported in exported signatures")) + + [] + member _.``runtime resolver override can replace implementation and mismatch is rejected`` () = + let repoRoot = findRepoRoot () + let fixturePath = Path.Combine(repoRoot, "tests", "FScript.TypeProvider.Tests.Fixtures.RuntimeOverride") + let exitCode, stdout, stderr = runProcess repoRoot "dotnet" $"run --project \"{fixturePath}\" -c Release" + Assert.That(exitCode, Is.EqualTo(0), $"Expected runtime fixture success.\nStdout:\n{stdout}\nStderr:\n{stderr}")