├── .github └── workflows │ └── dotnet-core.yml ├── .gitignore ├── FsLive.Cli ├── FsLive.Cli.fsproj └── fslive.fs ├── FsLive.sln ├── LICENSE.md ├── README.md ├── src ├── CodeModel.fs ├── CommandLine.fs ├── FSharp.Compiler.PortaCode.fsproj ├── FromCompilerService.fs ├── Interpreter.fs ├── LiveCheckEvaluation.fs ├── ProcessCommandLine.fs └── ProjectCracker.fs └── tests ├── FsLive.Cli.Tests.fsproj └── PortaCodeTests.fs /.github/workflows/dotnet-core.yml: -------------------------------------------------------------------------------- 1 | name: .NET Core 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | 12 | strategy: 13 | matrix: 14 | os: [ubuntu-latest, windows-latest] 15 | runs-on: ${{ matrix.os }} 16 | 17 | steps: 18 | - uses: actions/checkout@v2 19 | - name: Setup .NET Core 20 | uses: actions/setup-dotnet@v1 21 | with: 22 | dotnet-version: 3.1.301 23 | - name: Install dependencies 24 | run: dotnet restore 25 | - name: Build 26 | run: dotnet build --configuration Release --no-restore 27 | - name: Test 28 | run: dotnet test --no-restore --verbosity normal 29 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Ignore Visual Studio temporary files, build results, and 2 | ## files generated by popular Visual Studio add-ons. 3 | ## 4 | ## Get latest from https://github.com/github/gitignore/blob/master/VisualStudio.gitignore 5 | 6 | # User-specific files 7 | *.rsuser 8 | *.suo 9 | *.user 10 | *.userosscache 11 | *.sln.docstates 12 | 13 | # User-specific files (MonoDevelop/Xamarin Studio) 14 | *.userprefs 15 | 16 | # Mono auto generated files 17 | mono_crash.* 18 | 19 | # Build results 20 | [Dd]ebug/ 21 | [Dd]ebugPublic/ 22 | [Rr]elease/ 23 | [Rr]eleases/ 24 | x64/ 25 | x86/ 26 | [Aa][Rr][Mm]/ 27 | [Aa][Rr][Mm]64/ 28 | bld/ 29 | [Bb]in/ 30 | [Oo]bj/ 31 | [Ll]og/ 32 | 33 | # Visual Studio 2015/2017 cache/options directory 34 | .vs/ 35 | # Uncomment if you have tasks that create the project's static files in wwwroot 36 | #wwwroot/ 37 | 38 | # Visual Studio 2017 auto generated files 39 | Generated\ Files/ 40 | 41 | # MSTest test Results 42 | [Tt]est[Rr]esult*/ 43 | [Bb]uild[Ll]og.* 44 | 45 | # NUnit 46 | *.VisualState.xml 47 | TestResult.xml 48 | nunit-*.xml 49 | 50 | # Build Results of an ATL Project 51 | [Dd]ebugPS/ 52 | [Rr]eleasePS/ 53 | dlldata.c 54 | 55 | # Benchmark Results 56 | BenchmarkDotNet.Artifacts/ 57 | 58 | # .NET Core 59 | project.lock.json 60 | project.fragment.lock.json 61 | artifacts/ 62 | 63 | # StyleCop 64 | StyleCopReport.xml 65 | 66 | # Files built by Visual Studio 67 | *_i.c 68 | *_p.c 69 | *_h.h 70 | *.ilk 71 | *.meta 72 | *.obj 73 | *.iobj 74 | *.pch 75 | *.pdb 76 | *.ipdb 77 | *.pgc 78 | *.pgd 79 | *.rsp 80 | *.sbr 81 | *.tlb 82 | *.tli 83 | *.tlh 84 | *.tmp 85 | *.tmp_proj 86 | *_wpftmp.csproj 87 | *.log 88 | *.vspscc 89 | *.vssscc 90 | .builds 91 | *.pidb 92 | *.svclog 93 | *.scc 94 | 95 | # Chutzpah Test files 96 | _Chutzpah* 97 | 98 | # Visual C++ cache files 99 | ipch/ 100 | *.aps 101 | *.ncb 102 | *.opendb 103 | *.opensdf 104 | *.sdf 105 | *.cachefile 106 | *.VC.db 107 | *.VC.VC.opendb 108 | 109 | # Visual Studio profiler 110 | *.psess 111 | *.vsp 112 | *.vspx 113 | *.sap 114 | 115 | # Visual Studio Trace Files 116 | *.e2e 117 | 118 | # TFS 2012 Local Workspace 119 | $tf/ 120 | 121 | # Guidance Automation Toolkit 122 | *.gpState 123 | 124 | # ReSharper is a .NET coding add-in 125 | _ReSharper*/ 126 | *.[Rr]e[Ss]harper 127 | *.DotSettings.user 128 | 129 | # JustCode is a .NET coding add-in 130 | .JustCode 131 | 132 | # TeamCity is a build add-in 133 | _TeamCity* 134 | 135 | # DotCover is a Code Coverage Tool 136 | *.dotCover 137 | 138 | # AxoCover is a Code Coverage Tool 139 | .axoCover/* 140 | !.axoCover/settings.json 141 | 142 | # Visual Studio code coverage results 143 | *.coverage 144 | *.coveragexml 145 | 146 | # NCrunch 147 | _NCrunch_* 148 | .*crunch*.local.xml 149 | nCrunchTemp_* 150 | 151 | # MightyMoose 152 | *.mm.* 153 | AutoTest.Net/ 154 | 155 | # Web workbench (sass) 156 | .sass-cache/ 157 | 158 | # Installshield output folder 159 | [Ee]xpress/ 160 | 161 | # DocProject is a documentation generator add-in 162 | DocProject/buildhelp/ 163 | DocProject/Help/*.HxT 164 | DocProject/Help/*.HxC 165 | DocProject/Help/*.hhc 166 | DocProject/Help/*.hhk 167 | DocProject/Help/*.hhp 168 | DocProject/Help/Html2 169 | DocProject/Help/html 170 | 171 | # Click-Once directory 172 | publish/ 173 | 174 | # Publish Web Output 175 | *.[Pp]ublish.xml 176 | *.azurePubxml 177 | # Note: Comment the next line if you want to checkin your web deploy settings, 178 | # but database connection strings (with potential passwords) will be unencrypted 179 | *.pubxml 180 | *.publishproj 181 | 182 | # Microsoft Azure Web App publish settings. Comment the next line if you want to 183 | # checkin your Azure Web App publish settings, but sensitive information contained 184 | # in these scripts will be unencrypted 185 | PublishScripts/ 186 | 187 | # NuGet Packages 188 | *.nupkg 189 | # NuGet Symbol Packages 190 | *.snupkg 191 | # The packages folder can be ignored because of Package Restore 192 | **/[Pp]ackages/* 193 | # except build/, which is used as an MSBuild target. 194 | !**/[Pp]ackages/build/ 195 | # Uncomment if necessary however generally it will be regenerated when needed 196 | #!**/[Pp]ackages/repositories.config 197 | # NuGet v3's project.json files produces more ignorable files 198 | *.nuget.props 199 | *.nuget.targets 200 | 201 | # Microsoft Azure Build Output 202 | csx/ 203 | *.build.csdef 204 | 205 | # Microsoft Azure Emulator 206 | ecf/ 207 | rcf/ 208 | 209 | # Windows Store app package directories and files 210 | AppPackages/ 211 | BundleArtifacts/ 212 | Package.StoreAssociation.xml 213 | _pkginfo.txt 214 | *.appx 215 | *.appxbundle 216 | *.appxupload 217 | 218 | # Visual Studio cache files 219 | # files ending in .cache can be ignored 220 | *.[Cc]ache 221 | # but keep track of directories ending in .cache 222 | !?*.[Cc]ache/ 223 | 224 | # Others 225 | ClientBin/ 226 | ~$* 227 | *~ 228 | *.dbmdl 229 | *.dbproj.schemaview 230 | *.jfm 231 | *.pfx 232 | *.publishsettings 233 | orleans.codegen.cs 234 | 235 | # Including strong name files can present a security risk 236 | # (https://github.com/github/gitignore/pull/2483#issue-259490424) 237 | #*.snk 238 | 239 | # Since there are multiple workflows, uncomment next line to ignore bower_components 240 | # (https://github.com/github/gitignore/pull/1529#issuecomment-104372622) 241 | #bower_components/ 242 | 243 | # RIA/Silverlight projects 244 | Generated_Code/ 245 | 246 | # Backup & report files from converting an old project file 247 | # to a newer Visual Studio version. Backup files are not needed, 248 | # because we have git ;-) 249 | _UpgradeReport_Files/ 250 | Backup*/ 251 | UpgradeLog*.XML 252 | UpgradeLog*.htm 253 | ServiceFabricBackup/ 254 | *.rptproj.bak 255 | 256 | # SQL Server files 257 | *.mdf 258 | *.ldf 259 | *.ndf 260 | 261 | # Business Intelligence projects 262 | *.rdl.data 263 | *.bim.layout 264 | *.bim_*.settings 265 | *.rptproj.rsuser 266 | *- [Bb]ackup.rdl 267 | *- [Bb]ackup ([0-9]).rdl 268 | *- [Bb]ackup ([0-9][0-9]).rdl 269 | 270 | # Microsoft Fakes 271 | FakesAssemblies/ 272 | 273 | # GhostDoc plugin setting file 274 | *.GhostDoc.xml 275 | 276 | # Node.js Tools for Visual Studio 277 | .ntvs_analysis.dat 278 | node_modules/ 279 | 280 | # Visual Studio 6 build log 281 | *.plg 282 | 283 | # Visual Studio 6 workspace options file 284 | *.opt 285 | 286 | # Visual Studio 6 auto-generated workspace file (contains which files were open etc.) 287 | *.vbw 288 | 289 | # Visual Studio LightSwitch build output 290 | **/*.HTMLClient/GeneratedArtifacts 291 | **/*.DesktopClient/GeneratedArtifacts 292 | **/*.DesktopClient/ModelManifest.xml 293 | **/*.Server/GeneratedArtifacts 294 | **/*.Server/ModelManifest.xml 295 | _Pvt_Extensions 296 | 297 | # Paket dependency manager 298 | .paket/paket.exe 299 | paket-files/ 300 | 301 | # FAKE - F# Make 302 | .fake/ 303 | 304 | # CodeRush personal settings 305 | .cr/personal 306 | 307 | # Python Tools for Visual Studio (PTVS) 308 | __pycache__/ 309 | *.pyc 310 | 311 | # Cake - Uncomment if you are using it 312 | # tools/** 313 | # !tools/packages.config 314 | 315 | # Tabs Studio 316 | *.tss 317 | 318 | # Telerik's JustMock configuration file 319 | *.jmconfig 320 | 321 | # BizTalk build output 322 | *.btp.cs 323 | *.btm.cs 324 | *.odx.cs 325 | *.xsd.cs 326 | 327 | # OpenCover UI analysis results 328 | OpenCover/ 329 | 330 | # Azure Stream Analytics local run output 331 | ASALocalRun/ 332 | 333 | # MSBuild Binary and Structured Log 334 | *.binlog 335 | 336 | # NVidia Nsight GPU debugger configuration file 337 | *.nvuser 338 | 339 | # MFractors (Xamarin productivity tool) working folder 340 | .mfractor/ 341 | 342 | # Local History for Visual Studio 343 | .localhistory/ 344 | 345 | # BeatPulse healthcheck temp database 346 | healthchecksdb 347 | 348 | # Backup folder for Package Reference Convert tool in Visual Studio 2017 349 | MigrationBackup/ 350 | 351 | tests/data/ 352 | 353 | \.ionide/ 354 | -------------------------------------------------------------------------------- /FsLive.Cli/FsLive.Cli.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | Exe 4 | netcoreapp3.1 5 | $(DefineConstants);NETSTANDARD2_0 6 | true 7 | true 8 | fslive 9 | ./nupkg 10 | x64 11 | 12 | 13 | fslive-cli 14 | .NET Core Global Tool for FsLive - allows to send files to Fabulous.LiveUpdate and more 15 | Tool;CLI 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /FsLive.Cli/fslive.fs: -------------------------------------------------------------------------------- 1 | // Copyright 2018 Fabulous contributors. See LICENSE.md for license. 2 | 3 | // F# Compiler Daemon sample 4 | // 5 | // Sample use, assumes app has a reference to ELmish.XamrinForms.LiveUpdate: 6 | // 7 | // cd Fabulous\Samples\CounterApp\CounterApp 8 | // adb -d forward tcp:9867 tcp:9867 9 | // dotnet run --project ..\..\..\Fabulous.Cli\Fabulous.Cli.fsproj -- --eval @out.args 10 | // dotnet run --project ..\..\..\Fabulous.Cli\Fabulous.Cli.fsproj -- --watch --webhook:http://localhost:9867/update @out.args 11 | 12 | module FsLive.Driver 13 | 14 | open FSharp.Compiler.PortaCode.ProcessCommandLine 15 | 16 | 17 | #if !TEST 18 | [] 19 | #endif 20 | let main (argv: string[]) = 21 | try 22 | System.Environment.SetEnvironmentVariable("LIVECHECK", "1") 23 | ProcessCommandLine argv 24 | 25 | with e -> 26 | printfn "Error: %s" (e.ToString()) 27 | 1 28 | -------------------------------------------------------------------------------- /FsLive.sln: -------------------------------------------------------------------------------- 1 |  2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 16 4 | VisualStudioVersion = 16.0.30413.136 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FsLive.Cli", "FsLive.Cli\FsLive.Cli.fsproj", "{23640E46-E830-4AB7-9289-E527F6429435}" 7 | EndProject 8 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FsLive.Cli.Tests", "tests\FsLive.Cli.Tests.fsproj", "{810EEB40-5042-4946-B695-5B13E9957807}" 9 | EndProject 10 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Compiler.PortaCode", "src\FSharp.Compiler.PortaCode.fsproj", "{2E0E56A3-44F1-4953-8CE5-4DBC477DBF05}" 11 | EndProject 12 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{569DC946-97D8-4B47-B229-38A137CD388E}" 13 | ProjectSection(SolutionItems) = preProject 14 | .gitignore = .gitignore 15 | LICENSE.md = LICENSE.md 16 | README.md = README.md 17 | EndProjectSection 18 | EndProject 19 | Global 20 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 21 | Debug|Any CPU = Debug|Any CPU 22 | Release|Any CPU = Release|Any CPU 23 | EndGlobalSection 24 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 25 | {23640E46-E830-4AB7-9289-E527F6429435}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 26 | {23640E46-E830-4AB7-9289-E527F6429435}.Debug|Any CPU.Build.0 = Debug|Any CPU 27 | {23640E46-E830-4AB7-9289-E527F6429435}.Release|Any CPU.ActiveCfg = Release|Any CPU 28 | {23640E46-E830-4AB7-9289-E527F6429435}.Release|Any CPU.Build.0 = Release|Any CPU 29 | {810EEB40-5042-4946-B695-5B13E9957807}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 30 | {810EEB40-5042-4946-B695-5B13E9957807}.Debug|Any CPU.Build.0 = Debug|Any CPU 31 | {810EEB40-5042-4946-B695-5B13E9957807}.Release|Any CPU.ActiveCfg = Release|Any CPU 32 | {810EEB40-5042-4946-B695-5B13E9957807}.Release|Any CPU.Build.0 = Release|Any CPU 33 | {2E0E56A3-44F1-4953-8CE5-4DBC477DBF05}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 34 | {2E0E56A3-44F1-4953-8CE5-4DBC477DBF05}.Debug|Any CPU.Build.0 = Debug|Any CPU 35 | {2E0E56A3-44F1-4953-8CE5-4DBC477DBF05}.Release|Any CPU.ActiveCfg = Release|Any CPU 36 | {2E0E56A3-44F1-4953-8CE5-4DBC477DBF05}.Release|Any CPU.Build.0 = Release|Any CPU 37 | EndGlobalSection 38 | GlobalSection(SolutionProperties) = preSolution 39 | HideSolutionNode = FALSE 40 | EndGlobalSection 41 | GlobalSection(ExtensibilityGlobals) = postSolution 42 | SolutionGuid = {B3C43FF7-01BD-44AB-8F62-959C9A0D6E4F} 43 | EndGlobalSection 44 | EndGlobal 45 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright 2018 Fabulous contributors 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FSharp.Compiler.PortaCode 2 | 3 | An F# code format and corresponding interpreter. 4 | 5 | * Currently distributed by source inclusion or 'fslive' tool, no nuget package yet 6 | 7 | * `dotnet fslive` is a live programming "watch my project" command line tool, e.g. 8 | 9 | dotnet fslive foo.fsx 10 | dotnet fslive MyProject.fsproj 11 | 12 | * Used by Fabulous, DiffSharp and others. 13 | 14 | The overall aim of the interpreter is to execute F# code in "unusual" ways, e.g. 15 | 16 | * **Live checking** - Only executing selective slices of code (e.g. `LiveCheck` checks, see below) 17 | 18 | * **Observed execution** - Watch execution by collecting information about the values flowing through different variables, 19 | for use in hover tips. 20 | 21 | * **Symbolic execution** - This is done in cooperation with the target libraries 22 | which must allow injection of symbols into the computational structure, e.g. the injection of 23 | symbolic shape variables into the shapes of tensors, and the collection and processing of 24 | associated constraints on those variables. 25 | 26 | * **Execution without Reflection.Emit** - Some platforms don't support Reflection.Emit. However 27 | be aware that execution on such platforms with this intepreter is approximate with many F# language 28 | features not supported correctly. 29 | 30 | The interpreter is used for the "LiveUpdate" feature of Fabulous, to interpret the Elmish model/view/update application code on-device. 31 | 32 | The interpreter may also be useful for other live checking tools, because you get 33 | escape the whole complication of actual IL generation, Reflection emit and reflection invoke, 34 | and no actual classes etc are generated. 35 | 36 | ### Code format 37 | 38 | The input code format for the interpreter (PortaCode) is derived from FSharp.Compiler.Service expressions, the code is in this repo. 39 | 40 | ### Interpretation 41 | 42 | The semantics of interpretation can differ from the semantics of .NET F# code. Perf is not good but in many live check scenarios you're sitting on a base set of DLLs which are regular .NET code and are efficiently invoked. 43 | 44 | Library calls are implemented by reflection invoke. It's the same interpreter we use on-device for Fabulous. 45 | 46 | ### Command line arguments 47 | 48 | ``` 49 | Usage: arg .. arg [-- ] 50 | @args.rsp [-- ] 51 | ... Project.fsproj ... [-- ] 52 | 53 | The default source is a single project file in the current directory. 54 | The default output is a JSON dump of the PortaCode. 55 | 56 | Arguments: 57 | --once Don't enter watch mode (default: watch the source files of the project for changes) 58 | --send: Send the JSON-encoded contents of the PortaCode to the webhook 59 | --send Equivalent to --send:http://localhost:9867/update 60 | --projarg:arg An MSBuild argument e.g. /p:Configuration=Release 61 | --dump Dump the contents to console after each update 62 | --livecheck Only evaluate those with a LiveCheck attribute. This uses on-demand execution semantics for top-level declarations 63 | Also write an info file based on results of evaluation, and watch for .fsharp/foo.fsx.edit files and use the 64 | contents of those in preference to the source file 65 | All other args are assumed to be extra F# command line arguments, e.g. --define:FOO 66 | ``` 67 | 68 | ### LiveChecks 69 | 70 | * A LiveCheck is a declaration like this: https://github.com/fsprojects/TensorFlow.FSharp/blob/master/examples/NeuralStyleTransfer-dsl.fsx#L109 … 71 | 72 | * The attribute indicates the intent that that specific piece of code (and anything it 73 | depends on) should be run at development time. 74 | 75 | * An example tool is the "fslive.exe" tool from this repo here https://github.com/fsprojects/FSharp.Compiler.PortaCode/blob/master/src/ProcessCommandLine.fs#L46. 76 | Like FsAutoComplete this watches for project changes and then recompiles using FCS and looks for LiveCheck attributes. It then interprets those evaluations 77 | using reflection and collects information about the execution. For example, it detects errors and detects when variables have been bound to particular values 78 | during interpretation. The tool currently emits a ".fsharp/file.fsx.info" file containing extra information about the file "file.fsx" - extra error messages 79 | and extra tooltips. An experimenta FCS modification notices the existence of this file and incorporates the added information into Intellisense results. This 80 | keeps the checker tool totally decoupled from the IDE tooling. 81 | 82 | * This functionality may one day be reconfigured to be an [F# Analyzer](https://medium.com/lambda-factory/introducing-f-analyzers-772487889429). 83 | 84 | 85 | -------------------------------------------------------------------------------- /src/CodeModel.fs: -------------------------------------------------------------------------------- 1 | // Copyright 2018 Fabulous contributors. See LICENSE.md for license. 2 | 3 | module FSharp.Compiler.PortaCode.CodeModel 4 | 5 | type DRange = 6 | { File: string 7 | StartLine: int 8 | StartColumn: int 9 | EndLine: int 10 | EndColumn: int } 11 | override range.ToString() = 12 | sprintf "%s: (%d,%d)-(%d-%d)" range.File range.StartLine range.StartColumn range.EndLine range.EndColumn 13 | 14 | type DDiagnostic = 15 | { Severity: int 16 | Number: int 17 | Message: string 18 | LocationStack: DRange[] } 19 | 20 | member diag.Location = Array.last diag.LocationStack 21 | override diag.ToString() = 22 | let sev = match diag.Severity with 0 -> "info" | 1 -> "warning" | _ -> "error" 23 | match List.ofArray (Array.rev diag.LocationStack) with 24 | | [] -> 25 | sprintf "%s LC%d: %O" sev diag.Number diag.Message 26 | | loc:: t -> 27 | [ sprintf "%O: %s LC%d: %O" loc sev diag.Number diag.Message 28 | for loc in t do 29 | sprintf " stack: %O" loc ] 30 | |> String.concat "\n" 31 | 32 | /// A representation of resolved F# expressions that can be serialized 33 | type DExpr = 34 | | Value of DLocalRef 35 | | ThisValue of DType 36 | | BaseValue of DType 37 | | Application of DExpr * DType[] * DExpr[] * DRange option 38 | | Lambda of DType * DType * DLocalDef * DExpr 39 | | TypeLambda of DGenericParameterDef[] * DExpr 40 | | Quote of DExpr 41 | | IfThenElse of DExpr * DExpr * DExpr 42 | | DecisionTree of DExpr * (DLocalDef[] * DExpr)[] 43 | | DecisionTreeSuccess of int * DExpr[] 44 | | Call of DExpr option * DMemberRef * DType[] * DType[] * DExpr[] * DRange option 45 | | NewObject of DMemberRef * DType[] * DExpr[] * DRange option 46 | | LetRec of ( DLocalDef * DExpr)[] * DExpr 47 | | Let of (DLocalDef * DExpr) * DExpr 48 | | NewRecord of DType * DExpr[] * DRange option 49 | | NewAnonRecord of DFieldRef[] * DExpr[] * DRange option 50 | | ObjectExpr of DType * DExpr * DObjectExprOverrideDef[] * (DType * DObjectExprOverrideDef[])[] 51 | | AnonRecordGet of DExpr * DFieldRef * DRange option 52 | | FSharpFieldGet of DExpr option * DType * DFieldRef * DRange option 53 | | FSharpFieldSet of DExpr option * DType * DFieldRef * DExpr * DRange option 54 | | NewUnionCase of DType * DUnionCaseRef * DExpr[] * DRange option 55 | | UnionCaseGet of DExpr * DType * DUnionCaseRef * DFieldRef 56 | | UnionCaseSet of DExpr * DType * DUnionCaseRef * DFieldRef * DExpr 57 | | UnionCaseTag of DExpr * DType 58 | | UnionCaseTest of DExpr * DType * DUnionCaseRef 59 | | TraitCall of DType[] * string * isInstance: bool * DType[] * DType[] * DExpr[] * DRange option 60 | | NewTuple of DType * DExpr[] 61 | | TupleGet of DType * int * DExpr 62 | | Coerce of DType * DExpr 63 | | NewArray of DType * DExpr[] 64 | | TypeTest of DType * DExpr 65 | | AddressSet of DExpr * DExpr 66 | | ValueSet of Choice * DExpr * DRange option 67 | | Unused 68 | | DefaultValue of DType 69 | | Const of obj * DType 70 | | AddressOf of DExpr 71 | | Sequential of DExpr * DExpr * DRange option 72 | | FastIntegerForLoop of DExpr * DExpr * DExpr * bool 73 | | WhileLoop of DExpr * DExpr 74 | | TryFinally of DExpr * DExpr 75 | | TryWith of DExpr * DLocalDef * DExpr * DLocalDef * DExpr 76 | | NewDelegate of DType * DExpr 77 | | ILFieldGet of DExpr option * DType * string 78 | | ILFieldSet of DExpr option * DType * string * DExpr 79 | | ILAsm of string * DType[] * DExpr[] 80 | 81 | and DType = 82 | | DNamedType of DEntityRef * DType[] 83 | | DFunctionType of DType * DType 84 | | DTupleType of bool * DType[] 85 | | DAnonRecdType of bool * string[] * DType[] 86 | | DArrayType of int * DType 87 | | DByRefType of DType 88 | | DVariableType of string 89 | 90 | and DLocalDef = 91 | { Name: string 92 | IsMutable: bool 93 | LocalType: DType 94 | Range: DRange option 95 | IsCompilerGenerated: bool } 96 | 97 | and DFieldDef = 98 | { Name: string 99 | IsStatic: bool 100 | IsMutable: bool 101 | FieldType: DType 102 | Range: DRange option 103 | IsCompilerGenerated: bool 104 | } 105 | 106 | and DSlotRef = 107 | { Member: DMemberRef 108 | DeclaringType: DType 109 | } 110 | and DMemberDef = 111 | { EnclosingEntity: DEntityRef 112 | Name: string 113 | GenericParameters: DGenericParameterDef[] 114 | ImplementedSlots: DSlotRef[] 115 | IsInstance: bool 116 | IsValue: bool 117 | IsCompilerGenerated: bool 118 | CustomAttributes: DCustomAttributeDef[] 119 | Parameters: DLocalDef[] 120 | ReturnType: DType 121 | Range: DRange option } 122 | 123 | member x.Ref = 124 | { Entity=x.EnclosingEntity 125 | Name= x.Name 126 | GenericArity = x.GenericParameters.Length 127 | ArgTypes = (x.Parameters |> Array.map (fun p -> p.LocalType)) 128 | ReturnType = x.ReturnType } 129 | 130 | and DGenericParameterDef = 131 | { Name: string 132 | InterfaceConstraints: DType[] 133 | BaseTypeConstraint: DType option 134 | DefaultConstructorConstraint: bool 135 | NotNullableValueTypeConstraint: bool 136 | ReferenceTypeConstraint: bool 137 | } 138 | 139 | and DEntityDef = 140 | { QualifiedName: string 141 | Name: string 142 | GenericParameters: DGenericParameterDef[] 143 | BaseType: DType option 144 | DeclaredInterfaces: DType[] 145 | DeclaredFields: DFieldDef[] 146 | DeclaredDispatchSlots: DMemberDef[] 147 | IsUnion: bool 148 | IsRecord: bool 149 | IsStruct: bool 150 | IsInterface: bool 151 | CustomAttributes: DCustomAttributeDef[] 152 | //IsAbstractClass: bool 153 | UnionCases: string[] 154 | Range: DRange option } 155 | member x.Ref = DEntityRef x.QualifiedName 156 | 157 | and DCustomAttributeDef = 158 | { AttributeType: DEntityRef 159 | ConstructorArguments: (DType * obj)[] 160 | NamedArguments: (DType * string * bool * obj)[] 161 | // Range: DRange option 162 | } 163 | 164 | and DEntityRef = DEntityRef of string 165 | 166 | and DMemberRef = 167 | { Entity: DEntityRef 168 | Name: string 169 | GenericArity: int 170 | ArgTypes: DType[] 171 | ReturnType: DType } 172 | 173 | and DLocalRef = 174 | { Name: string 175 | IsThisValue: bool 176 | IsMutable: bool 177 | IsCompilerGenerated: bool 178 | Range: DRange option } 179 | 180 | and DFieldRef = DFieldRef of int * string 181 | 182 | and DUnionCaseRef = DUnionCaseRef of string 183 | 184 | and DObjectExprOverrideDef = 185 | { Name: string 186 | Slot: DSlotRef 187 | GenericParameters: DGenericParameterDef[] 188 | Parameters: DLocalDef[] 189 | Body: DExpr } 190 | 191 | type DDecl = 192 | | DDeclEntity of DEntityDef * DDecl[] 193 | | DDeclMember of DMemberDef * DExpr * isLiveCheck: bool 194 | | InitAction of DExpr * DRange option 195 | 196 | type DFile = 197 | { Code: DDecl[] } 198 | 199 | -------------------------------------------------------------------------------- /src/CommandLine.fs: -------------------------------------------------------------------------------- 1 | // Copyright 2018 Fabulous contributors. See LICENSE.md for license. 2 | 3 | // F# PortaCode command processing (e.g. used by Fabulous.Cli) 4 | 5 | module FSharp.Compiler.PortaCode.ProcessCommandLine 6 | 7 | open FSharp.Compiler.PortaCode.CodeModel 8 | open FSharp.Compiler.PortaCode.Interpreter 9 | open FSharp.Compiler.PortaCode.FromCompilerService 10 | open System 11 | open System.IO 12 | open Microsoft.FSharp.Compiler.SourceCodeServices 13 | open System.Net 14 | open System.Text 15 | 16 | 17 | let checker = FSharpChecker.Create(keepAssemblyContents = true) 18 | 19 | let ProcessCommandLine (argv: string[]) = 20 | let mutable fsproj = None 21 | let mutable eval = false 22 | let mutable watch = false 23 | let mutable webhook = None 24 | let args = 25 | let mutable haveDashes = false 26 | 27 | [| for arg in argv do 28 | let arg = arg.Trim() 29 | if arg.StartsWith("@") then 30 | for line in File.ReadAllLines(arg.[1..]) do 31 | let line = line.Trim() 32 | if not (String.IsNullOrWhiteSpace(line)) then 33 | yield line 34 | elif arg.EndsWith(".fsproj") then 35 | fsproj <- Some arg 36 | elif arg = "--" then haveDashes <- true 37 | elif arg = "--watch" then watch <- true 38 | elif arg = "--eval" then eval <- true 39 | elif arg.StartsWith "--webhook:" then webhook <- Some arg.["--webhook:".Length ..] 40 | else yield arg |] 41 | 42 | if args.Length = 0 && fsproj.IsNone then 43 | match Seq.toList (Directory.EnumerateFiles(Environment.CurrentDirectory, "*.fsproj")) with 44 | | [ ] -> 45 | failwith "no project file found, no compilation arguments given" 46 | | [ file ] -> 47 | printfn "fscd: using implicit project file '%s'" file 48 | fsproj <- Some file 49 | | _ -> 50 | failwith "multiple project files found" 51 | 52 | let options = 53 | match fsproj with 54 | | Some fsprojFile -> 55 | if args.Length > 1 then failwith "can't give both project file and compilation arguments" 56 | match FSharpDaemon.ProjectCracker.load (new System.Collections.Concurrent.ConcurrentDictionary<_,_>()) fsprojFile with 57 | | Ok (options, sourceFiles, _log) -> 58 | let options = { options with SourceFiles = Array.ofList sourceFiles } 59 | let sourceFilesSet = Set.ofList sourceFiles 60 | let options = { options with OtherOptions = options.OtherOptions |> Array.filter (fun s -> not (sourceFilesSet.Contains(s))) } 61 | options 62 | | Error err -> 63 | failwithf "Couldn't parse project file: %A" err 64 | 65 | | None -> 66 | let sourceFiles, otherFlags = args |> Array.partition (fun arg -> arg.EndsWith(".fs") || arg.EndsWith(".fsi") || arg.EndsWith(".fsx")) 67 | let sourceFiles = sourceFiles |> Array.map Path.GetFullPath 68 | 69 | printfn "CurrentDirectory = %s" Environment.CurrentDirectory 70 | let options = checker.GetProjectOptionsFromCommandLineArgs("tmp.fsproj", otherFlags) 71 | let options = { options with SourceFiles = sourceFiles } 72 | options 73 | 74 | //printfn "options = %A" options 75 | 76 | let rec checkFile count sourceFile = 77 | try 78 | let _, checkResults = checker.ParseAndCheckFileInProject(sourceFile, 0, File.ReadAllText(sourceFile), options) |> Async.RunSynchronously 79 | match checkResults with 80 | | FSharpCheckFileAnswer.Aborted -> 81 | printfn "aborted" 82 | Result.Error () 83 | | FSharpCheckFileAnswer.Succeeded res -> 84 | let mutable hasErrors = false 85 | for error in res.Errors do 86 | printfn "%s" (error.ToString()) 87 | if error.Severity = FSharpErrorSeverity.Error then 88 | hasErrors <- true 89 | if hasErrors then 90 | Result.Error () 91 | else 92 | Result.Ok res.ImplementationFile 93 | with 94 | | :? System.IO.IOException when count = 0 -> System.Threading.Thread.Sleep 500; checkFile 1 sourceFile 95 | | exn -> 96 | printfn "%s" (exn.ToString()) 97 | Result.Error () 98 | 99 | let convFile (i: FSharpImplementationFileContents) = 100 | //(i.QualifiedName, i.FileName 101 | { Code = convDecls i.Declarations } 102 | 103 | let jsonFiles (impls: FSharpImplementationFileContents[]) = 104 | let data = Array.map convFile impls 105 | let json = Newtonsoft.Json.JsonConvert.SerializeObject(data) 106 | json 107 | 108 | if watch then 109 | let watchers = 110 | [ for sourceFile in options.SourceFiles do 111 | let path = Path.GetDirectoryName(sourceFile) 112 | let fileName = Path.GetFileName(sourceFile) 113 | printfn "fscd: WATCHING %s in %s" fileName path 114 | let watcher = new FileSystemWatcher(path, fileName) 115 | watcher.NotifyFilter <- NotifyFilters.Attributes ||| NotifyFilters.CreationTime ||| NotifyFilters.FileName ||| NotifyFilters.LastAccess ||| NotifyFilters.LastWrite ||| NotifyFilters.Size ||| NotifyFilters.Security; 116 | let changed = (fun (ev: FileSystemEventArgs) -> 117 | try 118 | printfn "fscd: CHANGE DETECTED for %s, COMPILING...." sourceFile 119 | let rec loop files acc = 120 | match files with 121 | | file :: rest -> 122 | match checkFile 0 (Path.GetFullPath(file)) with 123 | | Result.Error () -> 124 | printfn "fscd: ERRORS for %s" file 125 | | Result.Ok iopt -> 126 | printfn "fscd: COMPILED %s" file 127 | match iopt with 128 | | None -> () 129 | | Some i -> 130 | printfn "fscd: GOT PortaCode for %s" sourceFile 131 | loop rest (i :: acc) 132 | | [] -> 133 | let impls = List.rev acc 134 | match webhook with 135 | | Some hook -> 136 | try 137 | let json = jsonFiles (Array.ofList impls) 138 | printfn "fscd: GOT JSON for %s, length = %d" sourceFile json.Length 139 | use webClient = new WebClient(Encoding = Encoding.UTF8) 140 | printfn "fscd: SENDING TO WEBHOOK... " // : <<<%s>>>... --> %s" json.[0 .. min (json.Length - 1) 100] hook 141 | let resp = webClient.UploadString (hook,"Put",json) 142 | printfn "fscd: RESP FROM WEBHOOK: %s" resp 143 | with err -> 144 | printfn "fscd: ERROR SENDING TO WEBHOOK: %A" (err.ToString()) 145 | 146 | | None -> 147 | () 148 | loop (List.ofArray options.SourceFiles) [] 149 | 150 | with err -> 151 | printfn "fscd: exception: %A" (err.ToString())) 152 | watcher.Changed.Add changed 153 | watcher.Created.Add changed 154 | watcher.Deleted.Add changed 155 | watcher.Renamed.Add changed 156 | yield watcher ] 157 | 158 | for watcher in watchers do 159 | watcher.EnableRaisingEvents <- true 160 | 161 | printfn "Waiting for changes..." 162 | System.Console.ReadLine() |> ignore 163 | for watcher in watchers do 164 | watcher.EnableRaisingEvents <- true 165 | 166 | else 167 | printfn "compiling, options = %A" options 168 | for o in options.OtherOptions do 169 | printfn "compiling, option %s" o 170 | let fileContents = 171 | [| for sourceFile in options.SourceFiles do 172 | match checkFile 0 sourceFile with 173 | | Result.Error _ -> failwith "errors" 174 | | Result.Ok iopt -> 175 | match iopt with 176 | | None -> () // signature file 177 | | Some i -> yield i |] 178 | 179 | printfn "#ImplementationFiles = %d" fileContents.Length 180 | 181 | if eval then 182 | let ctxt = EvalContext() 183 | let fileConvContents = [| for i in fileContents -> convFile i |] 184 | for ds in fileConvContents do 185 | ctxt.AddDecls(ds.Code) 186 | for ds in fileConvContents do 187 | //printfn "eval %A" a 188 | ctxt.EvalDecls (envEmpty, ds.Code) 189 | 190 | else 191 | let fileConvContents = jsonFiles fileContents 192 | 193 | printfn "%A" fileConvContents 194 | 0 195 | 196 | -------------------------------------------------------------------------------- /src/FSharp.Compiler.PortaCode.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | Library 4 | netstandard2.1 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /src/FromCompilerService.fs: -------------------------------------------------------------------------------- 1 | // Copyright 2018 Fabulous contributors. See LICENSE.md for license. 2 | module FSharp.Compiler.PortaCode.FromCompilerService 3 | 4 | open FSharp.Compiler.PortaCode.CodeModel 5 | open System.Collections.Generic 6 | open FSharp.Compiler.SourceCodeServices 7 | open FSharp.Compiler.Range 8 | 9 | let map2 f g (a,b) = (f a, g b) 10 | 11 | module List = 12 | let mapToArray f arr = arr |> Array.ofList |> Array.map f 13 | 14 | module Seq = 15 | let mapToArray f arr = arr |> Array.ofSeq |> Array.map f 16 | 17 | exception IncompleteExpr 18 | 19 | type Convert(includeRanges: bool, tolerateIncomplete: bool) = 20 | 21 | let rec convExpr (expr:FSharpExpr) : DExpr = 22 | 23 | match expr with 24 | | BasicPatterns.AddressOf(lvalueExpr) -> 25 | DExpr.AddressOf(convExpr lvalueExpr) 26 | 27 | | BasicPatterns.AddressSet(lvalueExpr, rvalueExpr) -> 28 | DExpr.AddressSet(convExpr lvalueExpr, convExpr rvalueExpr) 29 | 30 | // FCS TODO: fix FCS quirk with IsNone and IsSome on the option type 31 | | BasicPatterns.Application( BasicPatterns.Call(Some obj, memberOrFunc, tyargs1, tyargs2, [ ]), typeArgs, [ arg ]) when memberOrFunc.CompiledName = "get_IsNone" || memberOrFunc.CompiledName = "get_IsSome" -> 32 | let objExprR = convExpr obj 33 | let mrefR = convMemberRef memberOrFunc 34 | let typeArgs1R = convTypes tyargs1 35 | let typeArgs2R = convTypes tyargs2 36 | let rangeR = convRange expr.Range 37 | DExpr.Call(None, mrefR, typeArgs1R, typeArgs2R, [| objExprR |], rangeR) 38 | 39 | | BasicPatterns.Application(funcExpr, typeArgs, argExprs) -> 40 | let rangeR = convRange (expr.Range |> trimRanges (argExprs |> List.map (fun e -> e.Range))) 41 | DExpr.Application(convExpr funcExpr, convTypes typeArgs, convExprs argExprs, rangeR) 42 | 43 | // The F# Compiler Service inserts "raise 1" for expressions that don't check 44 | | BasicPatterns.Call(_, memberOrFunc, _, _, [ BasicPatterns.Const((:? int as c), _) ]) 45 | when c = 1 && memberOrFunc.CompiledName = "Raise" -> 46 | raise IncompleteExpr 47 | 48 | | BasicPatterns.Call(objExprOpt, memberOrFunc, typeArgs1, typeArgs2, argExprs) -> 49 | let objExprOptR = convExprOpt objExprOpt 50 | let mrefR = convMemberRef memberOrFunc 51 | let typeArgs1R = convTypes typeArgs1 52 | let typeArgs2R = convTypes typeArgs2 53 | let argExprsR = convArgExprs memberOrFunc argExprs 54 | let rangeR = convRange (expr.Range |> trimRanges ((Option.toList objExprOpt @ argExprs) |> List.map (fun e -> e.Range))) 55 | match objExprOptR with 56 | // FCS TODO: Fix quirk with extension members so this isn't needed 57 | | Some objExprR when memberOrFunc.IsExtensionMember || not memberOrFunc.IsInstanceMemberInCompiledCode -> 58 | DExpr.Call(None, mrefR, typeArgs1R, typeArgs2R, Array.append [| objExprR |] argExprsR, rangeR) 59 | | _ -> 60 | DExpr.Call(objExprOptR, mrefR, typeArgs1R, typeArgs2R, argExprsR, rangeR) 61 | 62 | | BasicPatterns.Coerce(targetType, inpExpr) -> 63 | DExpr.Coerce(convType targetType, convExpr inpExpr) 64 | 65 | | BasicPatterns.FastIntegerForLoop(startExpr, limitExpr, consumeExpr, isUp) -> 66 | DExpr.FastIntegerForLoop(convExpr startExpr, convExpr limitExpr, convExpr consumeExpr, isUp) 67 | 68 | | BasicPatterns.ILAsm(asmCode, typeArgs, argExprs) -> 69 | DExpr.ILAsm(asmCode, convTypes typeArgs, convExprs argExprs) 70 | 71 | | BasicPatterns.ILFieldGet (objExprOpt, fieldType, fieldName) -> 72 | DExpr.ILFieldGet(convExprOpt objExprOpt, convType fieldType, fieldName) 73 | 74 | | BasicPatterns.ILFieldSet (objExprOpt, fieldType, fieldName, valueExpr) -> 75 | DExpr.ILFieldSet (convExprOpt objExprOpt, convType fieldType, fieldName, convExpr valueExpr) 76 | 77 | | BasicPatterns.IfThenElse (guardExpr, thenExpr, elseExpr) -> 78 | DExpr.IfThenElse (convExpr guardExpr, convExpr thenExpr, convExpr elseExpr) 79 | 80 | | BasicPatterns.Lambda(lambdaVar, bodyExpr) -> 81 | DExpr.Lambda(convType lambdaVar.FullType, convType bodyExpr.Type, convLocalDef lambdaVar, convExpr bodyExpr) 82 | 83 | | BasicPatterns.Let((bindingVar, bindingExpr), bodyExpr) -> 84 | DExpr.Let((convLocalDef bindingVar, convExpr bindingExpr), convExpr bodyExpr) 85 | 86 | | BasicPatterns.LetRec(recursiveBindings, bodyExpr) -> 87 | DExpr.LetRec(List.mapToArray (map2 convLocalDef convExpr) recursiveBindings, convExpr bodyExpr) 88 | 89 | | BasicPatterns.NewArray(arrayType, argExprs) -> 90 | DExpr.NewArray(convType arrayType, convExprs argExprs) 91 | 92 | | BasicPatterns.NewDelegate(delegateType, delegateBodyExpr) -> 93 | DExpr.NewDelegate(convType delegateType, convExpr delegateBodyExpr) 94 | 95 | | BasicPatterns.NewObject(objCtor, typeArgs, argExprs: FSharpExpr list) -> 96 | let rangeR = convRange (expr.Range |> trimRanges (argExprs |> List.map (fun e -> e.Range))) 97 | DExpr.NewObject(convMemberRef objCtor, convTypes typeArgs, convArgExprs objCtor argExprs, rangeR) 98 | 99 | | BasicPatterns.NewRecord(recordType, argExprs) -> 100 | let rangeR = convRange (expr.Range |> trimRanges (argExprs |> List.map (fun e -> e.Range))) 101 | DExpr.NewRecord(convType recordType, convExprs argExprs, rangeR) 102 | 103 | | BasicPatterns.NewAnonRecord(recordType, argExprs) -> 104 | let rangeR = convRange (expr.Range |> trimRanges (argExprs |> List.map (fun e -> e.Range))) 105 | let fieldRefs = (stripTypeAbbreviations recordType).AnonRecordTypeDetails.SortedFieldNames |> Array.mapi (fun i nm -> DFieldRef (i, nm)) 106 | DExpr.NewAnonRecord(fieldRefs, convExprs argExprs, rangeR) 107 | 108 | | BasicPatterns.NewTuple(tupleType, argExprs) -> 109 | DExpr.NewTuple(convType tupleType, convExprs argExprs) 110 | 111 | | BasicPatterns.NewUnionCase(unionType, unionCase, argExprs) -> 112 | let rangeR = convRange (expr.Range |> trimRanges (argExprs |> List.map (fun e -> e.Range))) 113 | DExpr.NewUnionCase(convType unionType, convUnionCase unionCase, convExprs argExprs, rangeR) 114 | 115 | | BasicPatterns.Quote(quotedExpr) -> 116 | DExpr.Quote(convExpr quotedExpr) 117 | 118 | | BasicPatterns.FSharpFieldGet(objExprOpt, recordOrClassType, fieldInfo) -> 119 | let rangeR = convRange (expr.Range |> trimRanges ((Option.toList objExprOpt) |> List.map (fun e -> e.Range))) 120 | DExpr.FSharpFieldGet(convExprOpt objExprOpt, convType recordOrClassType, convFieldRef fieldInfo, rangeR) 121 | 122 | | BasicPatterns.FSharpFieldSet(objExprOpt, recordOrClassType, fieldInfo, argExpr) -> 123 | let rangeR = convRange (expr.Range |> trimRanges ((Option.toList objExprOpt @ [argExpr]) |> List.map (fun e -> e.Range))) 124 | DExpr.FSharpFieldSet(convExprOpt objExprOpt, convType recordOrClassType, convFieldRef fieldInfo, convExpr argExpr, rangeR) 125 | 126 | | BasicPatterns.Sequential(firstExpr, secondExpr) -> 127 | let rangeR = convRange expr.Range 128 | DExpr.Sequential(convExpr firstExpr, convExpr secondExpr, rangeR) 129 | 130 | | BasicPatterns.TryFinally(bodyExpr, finalizeExpr) -> 131 | DExpr.TryFinally(convExpr bodyExpr, convExpr finalizeExpr) 132 | 133 | | BasicPatterns.TryWith(bodyExpr, filterVar, filterExpr, catchVar, catchExpr) -> 134 | DExpr.TryWith(convExpr bodyExpr, convLocalDef filterVar, convExpr filterExpr, convLocalDef catchVar, convExpr catchExpr) 135 | 136 | | BasicPatterns.TupleGet(tupleType, tupleElemIndex, tupleExpr) -> 137 | DExpr.TupleGet(convType tupleType, tupleElemIndex, convExpr tupleExpr) 138 | 139 | | BasicPatterns.DecisionTree(decisionExpr, decisionTargets) -> 140 | DExpr.DecisionTree(convExpr decisionExpr, List.mapToArray (map2 (List.mapToArray convLocalDef) convExpr) decisionTargets) 141 | 142 | | BasicPatterns.DecisionTreeSuccess (decisionTargetIdx, decisionTargetExprs) -> 143 | DExpr.DecisionTreeSuccess (decisionTargetIdx, convExprs decisionTargetExprs) 144 | 145 | | BasicPatterns.TypeLambda(genericParams, bodyExpr) -> 146 | DExpr.TypeLambda(Array.map convGenericParamDef (Array.ofList genericParams), convExpr bodyExpr) 147 | 148 | | BasicPatterns.TypeTest(ty, inpExpr) -> 149 | DExpr.TypeTest(convType ty, convExpr inpExpr) 150 | 151 | | BasicPatterns.AnonRecordGet(objExpr, anonRecdType, n) -> 152 | let rangeR = expr.Range |> trimRanges [objExpr.Range] |> convRange 153 | let fieldRef = DFieldRef (n, anonRecdType.AnonRecordTypeDetails.SortedFieldNames.[n]) 154 | DExpr.AnonRecordGet(convExpr objExpr, fieldRef, rangeR) 155 | 156 | | BasicPatterns.UnionCaseSet(unionExpr, unionType, unionCase, unionCaseField, valueExpr) -> 157 | DExpr.UnionCaseSet(convExpr unionExpr, convType unionType, convUnionCase unionCase, convUnionCaseField unionCase unionCaseField, convExpr valueExpr) 158 | 159 | | BasicPatterns.UnionCaseGet(unionExpr, unionType, unionCase, unionCaseField) -> 160 | DExpr.UnionCaseGet(convExpr unionExpr, convType unionType, convUnionCase unionCase, convUnionCaseField unionCase unionCaseField) 161 | 162 | | BasicPatterns.UnionCaseTest(unionExpr, unionType, unionCase) -> 163 | DExpr.UnionCaseTest(convExpr unionExpr, convType unionType, convUnionCase unionCase) 164 | 165 | | BasicPatterns.UnionCaseTag(unionExpr, unionType) -> 166 | DExpr.UnionCaseTag(convExpr unionExpr, convType unionType) 167 | 168 | | BasicPatterns.ObjectExpr(objType, baseCallExpr, overrides, interfaceImplementations) -> 169 | DExpr.ObjectExpr(convType objType, convExpr baseCallExpr, Array.map convObjMemberDef (Array.ofList overrides), Array.map (map2 convType (Array.ofList >> Array.map convObjMemberDef)) (Array.ofList interfaceImplementations)) 170 | 171 | | BasicPatterns.TraitCall(sourceTypes, traitName, memberFlags, typeInstantiation, argTypes, argExprs) -> 172 | DExpr.TraitCall(convTypes sourceTypes, traitName, memberFlags.IsInstance, convTypes typeInstantiation, convTypes argTypes, convExprs argExprs, convRange expr.Range) 173 | 174 | | BasicPatterns.ValueSet(valToSet, valueExpr) -> 175 | let valToSetR = 176 | if valToSet.IsModuleValueOrMember then 177 | Choice2Of2 (convMemberRef valToSet) 178 | else 179 | Choice1Of2 (convLocalRef expr.Range valToSet) 180 | let rangeR = convRange expr.Range 181 | DExpr.ValueSet(valToSetR, convExpr valueExpr, rangeR) 182 | 183 | | BasicPatterns.WhileLoop(guardExpr, bodyExpr) -> 184 | DExpr.WhileLoop(convExpr guardExpr, convExpr bodyExpr) 185 | 186 | | BasicPatterns.BaseValue baseType -> 187 | DExpr.BaseValue (convType baseType) 188 | 189 | | BasicPatterns.DefaultValue defaultType -> 190 | DExpr.DefaultValue (convType defaultType) 191 | 192 | | BasicPatterns.ThisValue thisType -> 193 | DExpr.ThisValue (convType thisType) 194 | 195 | | BasicPatterns.Const(constValueObj, constType) -> 196 | DExpr.Const (constValueObj, convType constType) 197 | 198 | | BasicPatterns.Value(valueToGet) -> 199 | DExpr.Value(convLocalRef expr.Range valueToGet) 200 | 201 | | _ -> failwith (sprintf "unrecognized %+A at %A" expr expr.Range) 202 | 203 | and convExprs exprs = 204 | Array.map convExpr (Array.ofList exprs) 205 | 206 | // Trim out the ranges of argument expressions 207 | and trimRanges (rangesToRemove: range list) (range: range) = 208 | // Optional arguments inserted by the F# compiler get ranges identical to 209 | // the whole expression. Don't remove these 210 | //printfn "trimRanges --> " 211 | let rangesToRemove = rangesToRemove |> List.filter (fun m -> not (m = range)) 212 | (range, rangesToRemove) ||> List.fold trimRange 213 | 214 | // Exclude range m2 from m 215 | and trimRange (m1: range) (m2: range) = 216 | let posLeq p1 p2 = not (posGt p1 p2) 217 | let posGeq p1 p2 = not (posLt p1 p2) 218 | let posMin p1 p2 = if posLt p1 p2 then p1 else p2 219 | let posMax p1 p2 = if posLt p1 p2 then p2 else p1 220 | let posPlusOne (p: pos) = mkPos p.Line (p.Column+1) 221 | let posMinusOne (p: pos) = mkPos p.Line (max 0 (p.Column-1)) 222 | let p1, p2 = 223 | // Trim from start 224 | if posLeq m2.Start m1.Start then 225 | posMax m1.Start (posPlusOne m2.End), m1.End 226 | // Trim from end 227 | elif posGeq m2.End m1.End then 228 | m1.Start, posMin m1.End (posMinusOne m2.Start) 229 | // Trim from middle, treated as trim from end, this is an argument "x.foo(y)" 230 | else 231 | m1.Start, posMin m1.End (posMinusOne m2.Start) 232 | 233 | let res = mkRange m1.FileName p1 p2 234 | //printfn "m1 = %A, m2 = %A, res = %A" m1 m2 res 235 | res 236 | 237 | and convExprOpt exprs = 238 | Option.map convExpr exprs 239 | 240 | and convSlot (memb: FSharpAbstractSignature) : DSlotRef = 241 | { Member = 242 | { Entity = convEntityRef (stripTypeAbbreviations memb.DeclaringType).TypeDefinition 243 | Name = memb.Name 244 | GenericArity = memb.MethodGenericParameters.Count 245 | ArgTypes = [| for a in Seq.concat memb.AbstractArguments -> convType a.Type |] 246 | ReturnType = convType memb.AbstractReturnType } 247 | DeclaringType = convType memb.DeclaringType 248 | } 249 | 250 | and convObjMemberDef (memb: FSharpObjectExprOverride) : DObjectExprOverrideDef = 251 | { Slot = convSlot memb.Signature 252 | GenericParameters = convGenericParamDefs memb.GenericParameters 253 | Name = memb.Signature.Name 254 | Parameters = memb.CurriedParameterGroups |> convParamDefs2 255 | Body = convExpr memb.Body } 256 | 257 | and convFieldRef (field: FSharpField) : DFieldRef = 258 | match field.DeclaringEntity with 259 | | None -> failwithf "couldn't find declaring entity of field %s" field.Name 260 | | Some e -> 261 | match e.FSharpFields |> Seq.tryFindIndex (fun field2 -> field2.Name = field.Name) with 262 | | Some index -> DFieldRef (index, field.Name) 263 | | None -> failwithf "couldn't find field %s in type %A" field.Name field.DeclaringEntity 264 | 265 | and convUnionCase (ucase: FSharpUnionCase) : DUnionCaseRef = 266 | DUnionCaseRef (ucase.CompiledName) 267 | 268 | and convUnionCaseField (ucase: FSharpUnionCase) (field: FSharpField) : DFieldRef = 269 | match ucase.UnionCaseFields |> Seq.tryFindIndex (fun field2 -> field2.Name = field.Name) with 270 | | Some index -> DFieldRef (index, field.Name) 271 | | None -> failwithf "couldn't find field %s in type %A" field.Name field.DeclaringEntity 272 | 273 | and convRange (range: range) : DRange option = 274 | if includeRanges then 275 | Some { File = range.FileName; StartLine = range.StartLine; StartColumn = range.StartColumn; EndLine = range.EndLine; EndColumn = range.EndColumn } 276 | else None 277 | 278 | and convLocalDef (value: FSharpMemberOrFunctionOrValue) : DLocalDef = 279 | { Name = value.CompiledName 280 | IsMutable = value.IsMutable 281 | LocalType = convType value.FullType 282 | Range = convRange value.DeclarationLocation 283 | IsCompilerGenerated=value.IsCompilerGenerated } 284 | 285 | and convLocalRef range (value: FSharpMemberOrFunctionOrValue) : DLocalRef = 286 | { Name = value.CompiledName 287 | IsThisValue = (value.IsMemberThisValue || value.IsConstructorThisValue || value.IsBaseValue) 288 | IsMutable = value.IsMutable 289 | IsCompilerGenerated = value.IsCompilerGenerated 290 | Range = convRange range } 291 | 292 | and convMemberDef (memb: FSharpMemberOrFunctionOrValue) : DMemberDef = 293 | assert (memb.IsMember || memb.IsModuleValueOrMember) 294 | { EnclosingEntity = convEntityRef memb.DeclaringEntity.Value 295 | ImplementedSlots = memb.ImplementedAbstractSignatures |> Seq.toArray |> Array.map convSlot 296 | CustomAttributes = memb.Attributes |> Seq.toArray |> Array.map convCustomAttribute 297 | Name = memb.CompiledName 298 | GenericParameters = convGenericParamDefs memb.GenericParameters 299 | Parameters = convParamDefs memb 300 | ReturnType = convReturnType memb 301 | IsInstance = memb.IsInstanceMemberInCompiledCode 302 | IsValue = memb.IsValue 303 | Range = convRange memb.DeclarationLocation 304 | IsCompilerGenerated = memb.IsCompilerGenerated } 305 | 306 | and convMemberRef (memb: FSharpMemberOrFunctionOrValue) = 307 | if not (memb.IsMember || memb.IsModuleValueOrMember) then failwith "can't convert non-member ref" 308 | let paramTypesR = convParamTypes memb 309 | 310 | // TODO: extensions of generic type 311 | if memb.IsExtensionMember && memb.ApparentEnclosingEntity.GenericParameters.Count > 0 && not (memb.CompiledName = "ProgramRunner`2.EnableLiveUpdate" || memb.CompiledName = "ProgramRunner`3.EnableLiveUpdate") then 312 | failwithf "NYI: extension of generic type, needs FCS support: %A::%A" memb.ApparentEnclosingEntity memb 313 | 314 | { Entity=convEntityRef memb.DeclaringEntity.Value 315 | Name= memb.CompiledName 316 | GenericArity = memb.GenericParameters.Count 317 | ArgTypes = paramTypesR 318 | ReturnType = convReturnType memb } 319 | 320 | and convParamTypes (memb: FSharpMemberOrFunctionOrValue) = 321 | let parameters = memb.CurriedParameterGroups 322 | let paramTypesR = parameters |> Seq.concat |> Array.ofSeq |> Array.map (fun p -> p.Type) 323 | // TODO: FCS should do this unit arg elimination for us 324 | let paramTypesR = 325 | match paramTypesR with 326 | | [| pty |] when memb.IsModuleValueOrMember && pty.HasTypeDefinition && pty.TypeDefinition.LogicalName = "unit" -> [| |] 327 | | _ -> paramTypesR |> convTypes 328 | // TODO: FCS should do this instance --> static transformation for us 329 | if memb.IsInstanceMember && not memb.IsInstanceMemberInCompiledCode then 330 | if memb.IsExtensionMember then 331 | Array.append [| DNamedType (convEntityRef memb.ApparentEnclosingEntity, [| |]) |] paramTypesR 332 | else 333 | let instanceType = memb.FullType.GenericArguments.[0] 334 | Array.append [| convType instanceType |] paramTypesR 335 | else 336 | paramTypesR 337 | 338 | and convArgExprs (memb: FSharpMemberOrFunctionOrValue) exprs = 339 | let parameters = memb.CurriedParameterGroups 340 | let paramTypes = parameters |> Seq.concat |> Array.ofSeq |> Array.map (fun p -> p.Type) 341 | // TODO: FCS should do this unit arg elimination for us 342 | match paramTypes, exprs with 343 | | [| pty |] , [ _expr ] when memb.IsModuleValueOrMember && pty.HasTypeDefinition && pty.TypeDefinition.LogicalName = "unit" -> [| |] 344 | | _ -> convExprs exprs 345 | 346 | and convParamDefs (memb: FSharpMemberOrFunctionOrValue) = 347 | let parameters = memb.CurriedParameterGroups 348 | // TODO: FCS should do this unit arg elimination for us 349 | let parameters = 350 | match parameters |> Seq.concat |> Seq.toArray with 351 | | [| p |] when p.Type.HasTypeDefinition && p.Type.TypeDefinition.LogicalName = "unit" -> [| |] 352 | | ps -> ps 353 | let parametersR = 354 | parameters |> Array.map (fun p -> { Name = p.DisplayName; IsMutable = false; LocalType = convType p.Type; Range = convRange p.DeclarationLocation; IsCompilerGenerated=false }) 355 | if memb.IsInstanceMember && not memb.IsInstanceMemberInCompiledCode then 356 | if memb.IsExtensionMember then 357 | let instanceTypeR = DNamedType (convEntityRef memb.ApparentEnclosingEntity, [| |]) 358 | let thisParam = { Name = "$this"; IsMutable = false; LocalType = instanceTypeR; Range = convRange memb.DeclarationLocation; IsCompilerGenerated=true } 359 | Array.append [| thisParam |] parametersR 360 | else 361 | let instanceType = memb.FullType.GenericArguments.[0] 362 | let thisParam = { Name = "$this"; IsMutable = false; LocalType = convType instanceType; Range = convRange memb.DeclarationLocation; IsCompilerGenerated=true } 363 | Array.append [| thisParam |] parametersR 364 | else 365 | parametersR 366 | 367 | and convParamDefs2 (parameters: FSharpMemberOrFunctionOrValue list list) = 368 | // TODO: FCS should do this unit arg elimination for us 369 | let parameters = 370 | match parameters |> Seq.concat |> Seq.toArray with 371 | | [| p |] when p.FullType.HasTypeDefinition && p.FullType.TypeDefinition.LogicalName = "unit" -> [| |] 372 | | ps -> ps 373 | parameters |> Array.map (fun p -> { Name = p.DisplayName; IsMutable = false; LocalType = convType p.FullType; Range = convRange p.DeclarationLocation; IsCompilerGenerated=false }) 374 | 375 | and convReturnType (memb: FSharpMemberOrFunctionOrValue) = 376 | convType memb.ReturnParameter.Type 377 | 378 | and convCustomAttribute (cattr: FSharpAttribute) = 379 | { AttributeType = convEntityRef cattr.AttributeType 380 | ConstructorArguments = cattr.ConstructorArguments |> Seq.toArray |> Array.map (fun (ty, v) -> convType ty, v) 381 | NamedArguments = cattr.NamedArguments |> Seq.toArray |> Array.map (fun (ty, v1, v2, v3) -> convType ty, v1, v2, v3) 382 | //Range = cattr 383 | } 384 | and convEntityDef (entity: FSharpEntity) : DEntityDef = 385 | if entity.IsNamespace then failwith "convEntityDef: can't convert a namespace" 386 | if entity.IsArrayType then failwith "convEntityDef: can't convert an array" 387 | if entity.IsFSharpAbbreviation then failwith "convEntityDef: can't convert a type abbreviation" 388 | { QualifiedName = entity.QualifiedName 389 | Name = entity.CompiledName 390 | BaseType = entity.BaseType |> Option.map convType 391 | DeclaredInterfaces = entity.DeclaredInterfaces |> Seq.toArray |> Array.map convType 392 | DeclaredFields = entity.FSharpFields |> Seq.toArray |> Array.map convField 393 | DeclaredDispatchSlots = entity.MembersFunctionsAndValues |> Seq.toArray |> Array.filter (fun v -> v.IsDispatchSlot) |> Array.map convMemberDef 394 | GenericParameters = convGenericParamDefs entity.GenericParameters 395 | UnionCases = entity.UnionCases |> Seq.mapToArray (fun uc -> uc.Name) 396 | IsUnion = entity.IsFSharpUnion 397 | IsRecord = entity.IsFSharpRecord 398 | IsStruct = entity.IsValueType 399 | IsInterface = entity.IsInterface 400 | CustomAttributes = entity.Attributes |> Seq.toArray |> Array.map convCustomAttribute 401 | Range = convRange entity.DeclarationLocation} 402 | 403 | and convEntityRef (entity: FSharpEntity) : DEntityRef = 404 | if entity.IsNamespace then failwith "convEntityRef: can't convert a namespace" 405 | if entity.IsArrayType then failwith "convEntityRef: can't convert an array" 406 | if entity.IsFSharpAbbreviation then failwith "convEntityRef: can't convert a type abbreviation" 407 | DEntityRef entity.QualifiedName 408 | 409 | and stripTypeAbbreviations (typ: FSharpType) : FSharpType = 410 | if typ.IsAbbreviation then stripTypeAbbreviations typ.AbbreviatedType 411 | else typ 412 | 413 | and isInterfaceType (typ: FSharpType) = 414 | if typ.IsAbbreviation then isInterfaceType typ.AbbreviatedType 415 | else typ.HasTypeDefinition && typ.TypeDefinition.IsInterface 416 | 417 | and convType (typ: FSharpType) = 418 | if typ.IsAbbreviation then convType typ.AbbreviatedType 419 | elif typ.IsFunctionType then DFunctionType (convType typ.GenericArguments.[0], convType typ.GenericArguments.[1]) 420 | elif typ.IsTupleType then DTupleType (false, convTypes typ.GenericArguments) 421 | elif typ.IsStructTupleType then DTupleType (true, convTypes typ.GenericArguments) 422 | elif typ.IsAnonRecordType then DAnonRecdType (false, typ.AnonRecordTypeDetails.SortedFieldNames, convTypes typ.GenericArguments) 423 | elif typ.IsGenericParameter then DVariableType typ.GenericParameter.Name 424 | elif typ.TypeDefinition.IsArrayType then DArrayType (typ.TypeDefinition.ArrayRank, convType typ.GenericArguments.[0]) 425 | elif typ.TypeDefinition.IsByRef then DByRefType (convType typ.GenericArguments.[0]) 426 | else DNamedType (convEntityRef typ.TypeDefinition, convTypes typ.GenericArguments) 427 | 428 | and convTypes (typs: seq) = typs |> Seq.toArray |> Array.map convType 429 | 430 | and convGenericParamDef (gp: FSharpGenericParameter) : DGenericParameterDef = 431 | { Name = gp.Name 432 | InterfaceConstraints = 433 | gp.Constraints 434 | |> Seq.toArray 435 | |> Array.choose (fun c -> 436 | if c.IsCoercesToConstraint then 437 | if isInterfaceType c.CoercesToTarget then Some (convType c.CoercesToTarget) else None 438 | else None) 439 | BaseTypeConstraint = 440 | gp.Constraints 441 | |> Seq.tryPick (fun c -> 442 | if c.IsCoercesToConstraint then 443 | if not (isInterfaceType c.CoercesToTarget) then Some (convType c.CoercesToTarget) 444 | else None 445 | else None) 446 | DefaultConstructorConstraint = gp.Constraints |> Seq.exists (fun c -> c.IsRequiresDefaultConstructorConstraint) 447 | ReferenceTypeConstraint = gp.Constraints |> Seq.exists (fun c -> c.IsReferenceTypeConstraint) 448 | NotNullableValueTypeConstraint = gp.Constraints |> Seq.exists (fun c -> c.IsNonNullableValueTypeConstraint) 449 | } 450 | and convField (f: FSharpField) : DFieldDef = 451 | { Name = f.Name 452 | IsStatic = f.IsStatic 453 | IsMutable = f.IsMutable 454 | FieldType = convType f.FieldType 455 | Range = convRange f.DeclarationLocation 456 | IsCompilerGenerated = f.IsCompilerGenerated 457 | } 458 | and convGenericParamDefs (gps: seq) = gps |> Seq.toArray |> Array.map convGenericParamDef 459 | 460 | let rec convDecl d = 461 | [| match d with 462 | | FSharpImplementationFileDeclaration.Entity (e, subDecls) -> 463 | if e.IsFSharpAbbreviation then () 464 | elif e.IsNamespace then yield! convDecls subDecls 465 | elif e.IsArrayType then () 466 | else 467 | let eR = try convEntityDef e with exn -> failwithf "error converting entity %s\n%A" e.CompiledName exn 468 | let declsR = convDecls subDecls 469 | yield DDeclEntity (eR, declsR) 470 | 471 | | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(v, vs, e) -> 472 | let isLiveCheck = v.Attributes |> Seq.exists (fun attr -> attr.AttributeType.LogicalName.Contains "CheckAttribute") 473 | if isLiveCheck then 474 | printfn "member %s is a LiveCheck!" v.LogicalName 475 | // Skip Equals, GetHashCode, CompareTo compiler-generated methods 476 | //if v.IsValCompiledAsMethod || not v.IsMember then 477 | let vR = try convMemberDef v with exn -> failwithf "error converting defn of %s\n%A" v.CompiledName exn 478 | let eR = try Ok (convExpr e) with exn -> Error exn 479 | match eR with 480 | | Ok eR -> 481 | yield DDeclMember (vR, eR, isLiveCheck) 482 | | Error exn -> 483 | match exn with 484 | | IncompleteExpr when tolerateIncomplete -> () 485 | | _ -> failwithf "error converting rhs of %s\n%A" v.CompiledName exn 486 | 487 | | FSharpImplementationFileDeclaration.InitAction(e) -> 488 | let eR = try Ok (convExpr e) with exn -> Error exn 489 | match eR with 490 | | Ok eR -> 491 | yield DDecl.InitAction (eR, convRange e.Range) 492 | | Error exn -> 493 | match exn with 494 | | IncompleteExpr when tolerateIncomplete -> () 495 | | _ -> failwithf "error converting expression\n%A" exn 496 | |] 497 | 498 | and convDecls decls = 499 | decls |> Array.ofList |> Array.collect convDecl 500 | 501 | member __.ConvertDecls(decls) = convDecls decls -------------------------------------------------------------------------------- /src/LiveCheckEvaluation.fs: -------------------------------------------------------------------------------- 1 | // F# LiveChecking processing 2 | 3 | namespace FSharp.Compiler.PortaCode 4 | 5 | open FSharp.Compiler.PortaCode.CodeModel 6 | open FSharp.Compiler.PortaCode.Interpreter 7 | open FSharp.Compiler.PortaCode.FromCompilerService 8 | open System 9 | open System.Reflection 10 | open System.Collections.Generic 11 | open System.IO 12 | open FSharp.Compiler.SourceCodeServices 13 | open System.Text 14 | 15 | type LiveCheckEvaluation(options: string[], dyntypes, writeinfo, keepRanges, livecheck, tolerateIncompleteExpressions) = 16 | 17 | let mutable assemblyNameId = 0 18 | let emitInfoFile (sourceFile: string) lines = 19 | let infoDir = Path.Combine(Path.GetDirectoryName(sourceFile), ".fsharp") 20 | let infoFile = Path.Combine(infoDir, Path.GetFileName(sourceFile) + ".info") 21 | let lockFile = Path.Combine(infoDir, Path.GetFileName(sourceFile) + ".info.lock") 22 | printfn "writing info file %s..." infoFile 23 | if not (Directory.Exists infoDir) then 24 | Directory.CreateDirectory infoDir |> ignore 25 | try 26 | File.WriteAllLines(infoFile, lines, encoding=Encoding.Unicode) 27 | finally 28 | try if Directory.Exists infoDir && File.Exists lockFile then File.Delete lockFile with _ -> () 29 | 30 | let LISTLIM = 20 31 | 32 | let (|ConsNil|_|) (v: obj) = 33 | let ty = v.GetType() 34 | if Reflection.FSharpType.IsUnion(ty) then 35 | let uc, vs = Reflection.FSharpValue.GetUnionFields(v, ty) 36 | if uc.DeclaringType.IsGenericType && uc.DeclaringType.GetGenericTypeDefinition() = typedefof> then 37 | match vs with 38 | | [| a; b |] -> Some (Some(a,b)) 39 | | [| |] -> Some (None) 40 | | _ -> None 41 | else None 42 | else None 43 | 44 | let rec (|List|_|) n (v: obj) = 45 | if n > LISTLIM then Some [] 46 | else 47 | match v with 48 | | ConsNil (Some (a,List ((+) 1 n) b)) -> Some (a::b) 49 | | ConsNil None -> Some [] 50 | | _ -> None 51 | 52 | /// Format values resulting from live checking using the interpreter 53 | let rec formatValue (value: obj) = 54 | match value with 55 | | null -> "null/None" 56 | | :? string as s -> sprintf "%A" s 57 | | value -> 58 | let ty = value.GetType() 59 | match value with 60 | | _ when ty.Name = "Tensor" || ty.Name = "Shape" -> 61 | // TODO: this is a hack for DiffSharp, consider how to generalize it 62 | value.ToString() 63 | | _ when Reflection.FSharpType.IsTuple(ty) -> 64 | let vs = Reflection.FSharpValue.GetTupleFields(value) 65 | "(" + String.concat "," (Array.map formatValue vs) + ")" 66 | | _ when Reflection.FSharpType.IsFunction(ty) -> 67 | "" 68 | | _ when ty.IsArray -> 69 | let value = (value :?> Array) 70 | if ty.GetArrayRank() = 1 then 71 | "[| " + 72 | String.concat "; " 73 | [ for i in 0 .. min LISTLIM (value.GetLength(0) - 1) -> 74 | formatValue (value.GetValue(i)) ] 75 | + (if value.GetLength(0) > LISTLIM then "; ..." else "") 76 | + " |]" 77 | elif ty.GetArrayRank() = 2 then 78 | "[| " + 79 | String.concat "; \n" 80 | [ for i in 0 .. min (LISTLIM/2) (value.GetLength(0) - 1) -> 81 | String.concat ";" 82 | [ for j in 0 .. min (LISTLIM/2) (value.GetLength(1) - 1) -> 83 | formatValue (value.GetValue(i, j)) ] 84 | + (if value.GetLength(1) > (LISTLIM/2) then "; ..." else "") 85 | ] 86 | + (if value.GetLength(0) > (LISTLIM/2) then "\n ...\n" else "\n") 87 | + " |]" 88 | else 89 | sprintf "array rank %d" value.Rank 90 | | _ when Reflection.FSharpType.IsRecord(ty) -> 91 | let fs = Reflection.FSharpType.GetRecordFields(ty) 92 | let vs = Reflection.FSharpValue.GetRecordFields(value) 93 | "{ " + String.concat "; " [| for (f,v) in Array.zip fs vs -> f.Name + "=" + formatValue v |] + " }" 94 | | List 0 els -> 95 | "[" + String.concat "; " [| for v in els -> formatValue v |] + (if els.Length >= LISTLIM then "; .." else "") + "]" 96 | | _ when Reflection.FSharpType.IsUnion(ty) -> 97 | let uc, vs = Reflection.FSharpValue.GetUnionFields(value, ty) 98 | uc.Name + "(" + String.concat ", " [| for v in vs -> formatValue v |] + ")" 99 | | _ when (value :? System.Collections.IEnumerable) -> 100 | "" 101 | | _ -> 102 | value.ToString() //"unknown value" 103 | 104 | let MAXTOOLTIP = 100 105 | 106 | /// Write an info file containing extra information to make available to F# tooling. 107 | /// This is currently experimental and only experimental additions to F# tooling 108 | /// watch and consume this information. 109 | let writeInfoFile (tooltips: (DRange * (string * obj) list * bool)[]) sourceFile (diags: DDiagnostic[]) = 110 | 111 | let lines = 112 | let ranges = HashSet(HashIdentity.Structural) 113 | let havePreferred = tooltips |> Array.choose (fun (m,_,prefer) -> if prefer then Some m else None) |> Set.ofArray 114 | [| for (range, lines, prefer) in tooltips do 115 | 116 | 117 | // Only emit one line for each range. If live checks are performed twice only 118 | // the first is currently shown. 119 | // 120 | // We have a hack here to prefer some entries over others. FCS returns non-compiler-generated 121 | // locals for curried functions like 122 | // a |> ... |> foo1 123 | // or 124 | // a |> ... |> foo2 x 125 | // 126 | // which become 127 | // a |> ... |> (fun input -> foo input) 128 | // a |> ... |> (fun input -> foo2 x input 129 | // but here a use is reported for "input" over the range of the application expression "foo1" or "foo2 x" 130 | // So we prefer the actual call over these for these ranges. 131 | // 132 | // TODO: report this FCS problem and fix it. 133 | if not (ranges.Contains(range)) && (prefer || not (havePreferred.Contains range)) then 134 | ranges.Add(range) |> ignore 135 | 136 | // Format multiple lines of text into a single line in the output file 137 | let valuesText = 138 | [ for (action, value) in lines do 139 | let action = (if action = "" then "" else action + " ") 140 | let valueText = try formatValue value with e -> sprintf "??? (%s)" e.Message 141 | let valueText = valueText.Replace("\n", "\\n").Replace("\r", "").Replace("\t", "") 142 | let valueText = 143 | if valueText.Length > MAXTOOLTIP then 144 | valueText.[0 .. MAXTOOLTIP-1] + "..." 145 | else 146 | valueText 147 | yield action + valueText ] 148 | |> String.concat "\\n " // special new-line character known by experimental VS tooling + indent 149 | 150 | let sep = (if lines.Length = 1 then " " else "\\n") 151 | let line = sprintf "ToolTip\t%d\t%d\t%d\t%d\tLiveCheck:%s%s" range.StartLine range.StartColumn range.EndLine range.EndColumn sep valuesText 152 | yield line 153 | 154 | for diag in diags do 155 | printfn "%s" (diag.ToString()) 156 | for range in diag.LocationStack do 157 | if Path.GetFullPath(range.File) = Path.GetFullPath(sourceFile) then 158 | let message = 159 | "LiveCheck: " + diag.Message + 160 | ([| for m in Array.rev diag.LocationStack -> sprintf "\n stack: (%d,%d)-(%d,%d) %s" m.StartLine m.StartColumn m.EndLine m.EndColumn m.File |] |> String.concat "") 161 | let message = message.Replace("\t"," ").Replace("\r","").Replace("\n","\\n") 162 | let sev = match diag.Severity with 0 | 1 -> "warning" | _ -> "error" 163 | let line = sprintf "Error\t%d\t%d\t%d\t%d\t%s\t%s\t%d" range.StartLine range.StartColumn range.EndLine range.EndColumn sev message diag.Number 164 | yield line |] 165 | 166 | emitInfoFile sourceFile lines 167 | 168 | let runEntityDeclLiveChecks(entity:DEntityDef, entityR: ResolvedEntity, methDecls: (DMemberDef * DExpr)[]) = 169 | // If a [] attribute occurs on a type, then call the Invoke member on 170 | // the attribute type passing the target type as an attribute. 171 | // 172 | // When a live checking attribute is attached to a type 173 | // we expect the attribute type to implement an Invoke method 174 | // taking the target type and the location information related 175 | // to the check for diagnostic production. 176 | if livecheck then 177 | match entityR with 178 | | REntity (targetType, _) -> 179 | let liveShape = 180 | targetType.GetCustomAttributes(true) |> Array.tryFind (fun a -> 181 | a.GetType().Name.Contains "CheckAttribute") 182 | match liveShape with 183 | | None -> [| |] 184 | | Some attr -> 185 | // Grab the source locations of methods to pass to the checker for better error location reporting 186 | let methLocs = 187 | [| for (membDef, _membBody) in methDecls do 188 | match membDef.Range with 189 | | None -> () 190 | | Some m -> 191 | yield (membDef.Name, m.File, m.StartLine, m.StartColumn, m.EndLine, m.EndColumn) 192 | |] 193 | 194 | let res = 195 | try 196 | protectEval false entity.Range (fun () -> 197 | let loc = defaultArg entity.Range { File=""; StartLine=0; StartColumn=0; EndLine=0; EndColumn=0 } 198 | let args = [| box targetType; box methLocs; box loc.File; box loc.StartLine; box loc.StartColumn; box loc.EndLine; box loc.EndColumn |] 199 | let res = protectInvoke (fun () -> attr.GetType().InvokeMember("Invoke",BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.Instance, null, attr, args)) 200 | let diags = 201 | match res with 202 | | :? (((* severity *) int * (* number *) int * ((* file *) string * int * int * int * int)[] * (* message *) string)[]) as diags -> diags 203 | | _ -> 204 | failwith "incorrect return type from attribute Invoke" 205 | [| for (severity, number, locstack, msg) in diags do 206 | let stack = 207 | [| yield! Option.toList entity.Range 208 | for (file,sl,sc,el,ec) in locstack do 209 | { File=file; StartLine=sl; StartColumn=sc; EndLine=el; EndColumn=ec } |] 210 | { Severity=severity 211 | Number = number 212 | Message = msg 213 | LocationStack = stack } |]) 214 | with exn -> 215 | [| DiagnosticFromException exn |] 216 | res 217 | 218 | | _ -> [| |] 219 | else [| |] 220 | 221 | /// Evaluate the declarations using the interpreter 222 | member t.EvaluateDecls (fileContents: seq) = 223 | let assemblyTable = 224 | dict [| for r in options do 225 | //printfn "typeof.Assembly.Location = %s" typeof.Assembly.Location 226 | if r.StartsWith("-r:") && not (r.Contains(".NETFramework")) && not (r.Contains("Microsoft.NETCore.App")) then 227 | let assemName = r.[3..] 228 | //printfn "Script: pre-loading referenced assembly %s " assemName 229 | match System.Reflection.Assembly.LoadFrom(assemName) with 230 | | null -> 231 | printfn "Script: failed to pre-load referenced assembly %s " assemName 232 | | asm -> 233 | let name = asm.GetName() 234 | yield (name.Name, asm) |] 235 | 236 | let assemblyResolver (nm: Reflection.AssemblyName) = 237 | match assemblyTable.TryGetValue(nm.Name) with 238 | | true, res -> res 239 | | _ -> Reflection.Assembly.Load(nm) 240 | 241 | let tooltips = ResizeArray() 242 | let sink = 243 | if writeinfo then 244 | { new Sink with 245 | 246 | member _.NotifyEstablishEntityDecl(entity, entityR, entityDecls) = 247 | runEntityDeclLiveChecks(entity, entityR, entityDecls) 248 | 249 | member __.NotifyCallAndReturn(mref, callerRange, mdef, _typeArgs, args, res) = 250 | let paramNames = 251 | match mdef with 252 | | Choice1Of2 minfo -> [| for p in minfo.GetParameters() -> p.Name |] 253 | | Choice2Of2 mdef -> [| for p in mdef.Parameters -> p.Name |] 254 | let isValue = 255 | match mdef with 256 | | Choice1Of2 minfo -> false 257 | | Choice2Of2 mdef -> mdef.IsValue 258 | let lines = 259 | [ for (p, arg) in Seq.zip paramNames args do 260 | yield (sprintf "%s:" p, arg) 261 | if isValue then 262 | yield ("value:", res.Value) 263 | else 264 | yield ("return:", res.Value) ] 265 | match mdef with 266 | | Choice1Of2 _ -> () 267 | | Choice2Of2 mdef -> 268 | mdef.Range |> Option.iter (fun r -> 269 | tooltips.Add(r, lines, true)) 270 | match mref with 271 | | None -> () 272 | | Some mref-> 273 | callerRange |> Option.iter (fun r -> 274 | tooltips.Add(r, lines, true)) 275 | 276 | member __.NotifyBindValue(vdef, value) = 277 | printfn "%A: vdef.Name = %s, vdef.IsCompilerGenerated = %b" vdef.Range vdef.Name vdef.IsCompilerGenerated 278 | if not vdef.IsCompilerGenerated then 279 | vdef.Range |> Option.iter (fun r -> tooltips.Add ((r, [("", value.Value)], false))) 280 | 281 | member __.NotifySetField(typ, fdef, value) = 282 | // Class fields for implicit constructors are reported as 'compiler generated' 283 | //if not fdef.IsCompilerGenerated then 284 | fdef.Range |> Option.iter (fun r -> tooltips.Add ((r, [("", value.Value)], false))) 285 | 286 | member __.NotifyGetField(typ, fdef, m, value) = 287 | // Class fields for implicit constructors are reported as 'compiler generated' 288 | //if not fdef.IsCompilerGenerated then 289 | m |> Option.iter (fun r -> tooltips.Add ((r, [("", value.Value)], false))) 290 | 291 | member __.NotifyBindLocal(vdef, value) = 292 | if not vdef.IsCompilerGenerated then 293 | vdef.Range |> Option.iter (fun r -> tooltips.Add ((r, [("", value.Value)], false))) 294 | 295 | member __.NotifyUseLocal(vref, value) = 296 | if not vref.IsCompilerGenerated then 297 | vref.Range |> Option.iter (fun r -> tooltips.Add ((r, [("", value.Value)], false))) 298 | } 299 | |> Some 300 | else 301 | None 302 | 303 | assemblyNameId <- assemblyNameId + 1 304 | let assemblyName = AssemblyName("Eval" + string assemblyNameId) 305 | let ctxt = EvalContext(assemblyName, dyntypes, assemblyResolver, ?sink=sink) 306 | 307 | let fileConvContents = 308 | [| for i in fileContents -> 309 | let code = { Code = Convert(keepRanges, tolerateIncompleteExpressions).ConvertDecls i.Declarations } 310 | i.FileName, code |] 311 | 312 | let allDecls = 313 | [| for (_, contents) in fileConvContents do yield! contents.Code |] 314 | ctxt.AddDecls(allDecls) 315 | 316 | let mutable res = Ok() 317 | for (sourceFile, ds) in fileConvContents do 318 | printfn "evaluating decls.... " 319 | let diags = ctxt.TryEvalDecls (envEmpty, ds.Code, evalLiveChecksOnly=livecheck) 320 | 321 | if writeinfo then 322 | writeInfoFile (tooltips.ToArray()) sourceFile diags 323 | for diag in diags do 324 | printfn "%s" (diag.ToString()) 325 | if diags |> Array.exists (fun diag -> diag.Severity >= 2) then res <- Error () 326 | 327 | printfn "...evaluated decls" 328 | res 329 | 330 | -------------------------------------------------------------------------------- /src/ProcessCommandLine.fs: -------------------------------------------------------------------------------- 1 | // Copyright 2018 Fabulous contributors. See LICENSE.md for license. 2 | 3 | // F# PortaCode command processing (e.g. used by Fabulous.Cli) 4 | 5 | module FSharp.Compiler.PortaCode.ProcessCommandLine 6 | 7 | open FSharp.Compiler.PortaCode.CodeModel 8 | open FSharp.Compiler.PortaCode.Interpreter 9 | open FSharp.Compiler.PortaCode.FromCompilerService 10 | open System 11 | open System.Reflection 12 | open System.Collections.Generic 13 | open System.IO 14 | open FSharp.Compiler.SourceCodeServices 15 | open FSharp.Compiler.Text 16 | open System.Net 17 | open System.Text 18 | 19 | let checker = FSharpChecker.Create(keepAssemblyContents = true) 20 | 21 | let ProcessCommandLine (argv: string[]) = 22 | let mutable fsproj = None 23 | let mutable dump = false 24 | let mutable livecheck = false 25 | let mutable dyntypes = false 26 | let mutable watch = true 27 | let mutable useEditFiles = false 28 | let mutable writeinfo = true 29 | let mutable webhook = None 30 | let mutable otherFlags = [] 31 | let mutable msbuildArgs = [] 32 | let defaultUrl = "http://localhost:9867/update" 33 | let fsharpArgs = 34 | let mutable haveDashes = false 35 | 36 | [| for arg in argv do 37 | let arg = arg.Trim() 38 | if arg.StartsWith("@") then 39 | for line in File.ReadAllLines(arg.[1..]) do 40 | let line = line.Trim() 41 | if not (String.IsNullOrWhiteSpace(line)) then 42 | yield line 43 | elif arg.EndsWith(".fsproj") then 44 | fsproj <- Some arg 45 | elif arg = "--" then haveDashes <- true 46 | elif arg.StartsWith "--projarg:" then msbuildArgs <- msbuildArgs @ [ arg.["----projarg:".Length ..]] 47 | elif arg.StartsWith "--define:" then otherFlags <- otherFlags @ [ arg ] 48 | elif arg = "--once" then watch <- false 49 | elif arg = "--dump" then dump <- true 50 | elif arg = "--livecheck" then 51 | dyntypes <- true 52 | livecheck <- true 53 | writeinfo <- true 54 | //useEditFiles <- true 55 | elif arg = "--enablelivechecks" then 56 | livecheck <- true 57 | elif arg = "--useeditfles" then 58 | useEditFiles <- true 59 | elif arg = "--dyntypes" then 60 | dyntypes <- true 61 | elif arg = "--writeinfo" then 62 | writeinfo <- true 63 | elif arg.StartsWith "--send:" then webhook <- Some arg.["--send:".Length ..] 64 | elif arg = "--send" then webhook <- Some defaultUrl 65 | elif arg = "--version" then 66 | printfn "" 67 | printfn "*** NOTE: if sending the code to a device the versions of CodeModel.fs and Interpreter.fs on the device must match ***" 68 | printfn "" 69 | printfn "CLI tool assembly version: %A" (System.Reflection.Assembly.GetExecutingAssembly().GetName().Version) 70 | printfn "CLI tool name: %s" (System.Reflection.Assembly.GetExecutingAssembly().GetName().Name) 71 | printfn "" 72 | elif arg = "--help" then 73 | printfn "Command line tool for watching and interpreting F# projects" 74 | printfn "" 75 | printfn "Usage: arg .. arg [-- ]" 76 | printfn " @args.rsp [-- ]" 77 | printfn " ... Project.fsproj ... [-- ]" 78 | printfn "" 79 | printfn "The default source is a single project file in the current directory." 80 | printfn "The default output is a JSON dump of the PortaCode." 81 | printfn "" 82 | printfn "Arguments:" 83 | printfn " --once Don't enter watch mode (default: watch the source files of the project for changes)" 84 | printfn " --send: Send the JSON-encoded contents of the PortaCode to the webhook" 85 | printfn " --send Equivalent to --send:%s" defaultUrl 86 | printfn " --projarg:arg An MSBuild argument e.g. /p:Configuration=Release" 87 | printfn " --dump Dump the contents to console after each update" 88 | printfn " --livecheck Only evaluate those with a *CheckAttribute (e.g. LiveCheck or ShapeCheck)" 89 | printfn " This uses on-demand execution semantics for top-level declarations" 90 | printfn " Also write an info file based on results of evaluation." 91 | printfn " Also watch for .fsharp/foo.fsx.edit files and use the contents of those in preference to the source file" 92 | printfn " --dyntypes Dynamically compile and load so full .NET types exist" 93 | printfn " All other args are assumed to be extra F# command line arguments, e.g. --define:FOO" 94 | exit 1 95 | else yield arg |] 96 | 97 | if fsharpArgs.Length = 0 && fsproj.IsNone then 98 | match Seq.toList (Directory.EnumerateFiles(Environment.CurrentDirectory, "*.fsproj")) with 99 | | [ ] -> 100 | failwithf "no project file found, no compilation arguments given and no project file found in \"%s\"" Environment.CurrentDirectory 101 | | [ file ] -> 102 | printfn "fslive: using implicit project file '%s'" file 103 | fsproj <- Some file 104 | | file1 :: file2 :: _ -> 105 | failwithf "multiple project files found, e.g. %s and %s" file1 file2 106 | 107 | let editDirAndFile (fileName: string) = 108 | assert useEditFiles 109 | let infoDir = Path.Combine(Path.GetDirectoryName fileName,".fsharp") 110 | let editFile = Path.Combine(infoDir,Path.GetFileName fileName + ".edit") 111 | if not (Directory.Exists infoDir) then 112 | Directory.CreateDirectory infoDir |> ignore 113 | infoDir, editFile 114 | 115 | let readFile (fileName: string) = 116 | if useEditFiles && watch then 117 | let infoDir, editFile = editDirAndFile fileName 118 | let preferEditFile = 119 | try 120 | Directory.Exists infoDir && File.Exists editFile && File.Exists fileName && File.GetLastWriteTime(editFile) > File.GetLastWriteTime(fileName) 121 | with _ -> 122 | false 123 | if preferEditFile then 124 | printfn "*** preferring %s to %s ***" editFile fileName 125 | File.ReadAllText editFile 126 | else 127 | File.ReadAllText fileName 128 | else 129 | File.ReadAllText fileName 130 | 131 | let options = 132 | match fsproj with 133 | | Some fsprojFile -> 134 | if fsharpArgs.Length > 1 then failwith "can't give both project file and compilation arguments" 135 | match FSharpDaemon.ProjectCracker.load (new System.Collections.Concurrent.ConcurrentDictionary<_,_>()) fsprojFile msbuildArgs with 136 | | Ok (options, sourceFiles, _log) -> 137 | let options = { options with SourceFiles = Array.ofList sourceFiles } 138 | let sourceFilesSet = Set.ofList sourceFiles 139 | let options = { options with OtherOptions = options.OtherOptions |> Array.filter (fun s -> not (sourceFilesSet.Contains(s))) } 140 | Result.Ok options 141 | | Error err -> 142 | failwithf "Couldn't parse project file: %A" err 143 | 144 | | None -> 145 | let sourceFiles, otherFlags2 = fsharpArgs |> Array.partition (fun arg -> arg.EndsWith(".fs") || arg.EndsWith(".fsi") || arg.EndsWith(".fsx")) 146 | let otherFlags =[| yield! otherFlags; yield! otherFlags2 |] 147 | let sourceFiles = sourceFiles |> Array.map Path.GetFullPath 148 | printfn "CurrentDirectory = %s" Environment.CurrentDirectory 149 | 150 | match sourceFiles with 151 | | [| script |] when script.EndsWith(".fsx") -> 152 | let text = readFile script 153 | let otherFlags = Array.append otherFlags [| "--targetprofile:netcore"; |] 154 | let options, errors = checker.GetProjectOptionsFromScript(script, SourceText.ofString text, otherFlags=otherFlags, assumeDotNetFramework=false) |> Async.RunSynchronously 155 | let options = { options with OtherOptions = Array.append options.OtherOptions [| "--target:library" |] } 156 | if errors.Length > 0 then 157 | for error in errors do 158 | printfn "%s" (error.ToString()) 159 | Result.Error () 160 | else 161 | Result.Ok options 162 | | _ -> 163 | let options = checker.GetProjectOptionsFromCommandLineArgs("tmp.fsproj", otherFlags) 164 | let options = { options with SourceFiles = sourceFiles } 165 | Result.Ok options 166 | 167 | match options with 168 | | Result.Error () -> 169 | printfn "fslive: error processing project options or script" 170 | -1 171 | | Result.Ok options -> 172 | let options = { options with OtherOptions = Array.append options.OtherOptions (Array.ofList otherFlags) } 173 | //printfn "options = %A" options 174 | 175 | let rec checkFile count sourceFile = 176 | try 177 | let parseResults, checkResults = checker.ParseAndCheckFileInProject(sourceFile, 0, SourceText.ofString (readFile sourceFile), options) |> Async.RunSynchronously 178 | match checkResults with 179 | | FSharpCheckFileAnswer.Aborted -> 180 | for e in parseResults.Errors do 181 | printfn "Error: %A" e 182 | failwith "unexpected aborted" 183 | Result.Error (parseResults.ParseTree, None, None, None) 184 | 185 | | FSharpCheckFileAnswer.Succeeded res -> 186 | let mutable hasErrors = false 187 | for error in res.Errors do 188 | printfn "%s" (error.ToString()) 189 | if error.Severity = FSharpErrorSeverity.Error then 190 | hasErrors <- true 191 | 192 | if hasErrors then 193 | Result.Error (parseResults.ParseTree, None, Some res.Errors, res.ImplementationFile) 194 | else 195 | Result.Ok (parseResults.ParseTree, res.ImplementationFile) 196 | with 197 | | :? System.IO.IOException when count = 0 -> 198 | System.Threading.Thread.Sleep 500 199 | checkFile 1 sourceFile 200 | | exn -> 201 | printfn "%s" (exn.ToString()) 202 | Result.Error (None, Some exn, None, None) 203 | 204 | let keepRanges = not dump 205 | let tolerateIncompleteExpressions = livecheck && watch 206 | let convFile (i: FSharpImplementationFileContents) = 207 | //(i.QualifiedName, i.FileName 208 | i.FileName, { Code = Convert(keepRanges, tolerateIncompleteExpressions).ConvertDecls i.Declarations } 209 | 210 | let checkFiles files = 211 | let rec loop rest acc = 212 | match rest with 213 | | file :: rest -> 214 | match checkFile 0 (Path.GetFullPath(file)) with 215 | 216 | // Note, if livecheck are on, we continue on regardless of errors 217 | | Result.Error iopt when not livecheck -> 218 | printfn "fslive: ERRORS for %s" file 219 | Result.Error iopt 220 | 221 | | Result.Error ((_, _, _, None) as info) -> Result.Error info 222 | | Result.Ok (_, None) -> Result.Error (None, None, None, None) 223 | | Result.Error (parseTree, _, _, Some implFile) 224 | | Result.Ok (parseTree, Some implFile) -> 225 | printfn "fslive: GOT PortaCode for %s" file 226 | loop rest ((parseTree, implFile) :: acc) 227 | | [] -> Result.Ok (List.rev acc) 228 | loop (List.ofArray files) [] 229 | 230 | let jsonFiles (impls: FSharpImplementationFileContents[]) = 231 | let data = Array.map convFile impls 232 | let json = Newtonsoft.Json.JsonConvert.SerializeObject(data) 233 | json 234 | 235 | let sendToWebHook (hook: string) fileContents = 236 | try 237 | let json = jsonFiles (Array.ofList fileContents) 238 | printfn "fslive: GOT JSON, length = %d" json.Length 239 | use webClient = new WebClient(Encoding = Encoding.UTF8) 240 | printfn "fslive: SENDING TO WEBHOOK... " // : <<<%s>>>... --> %s" json.[0 .. min (json.Length - 1) 100] hook 241 | let resp = webClient.UploadString (hook,"Put",json) 242 | printfn "fslive: RESP FROM WEBHOOK: %s" resp 243 | with err -> 244 | printfn "fslive: ERROR SENDING TO WEBHOOK: %A" (err.ToString()) 245 | 246 | let mutable lastCompileStart = System.DateTime.Now 247 | let changed why _ = 248 | try 249 | printfn "fslive: COMPILING (%s)...." why 250 | lastCompileStart <- System.DateTime.Now 251 | 252 | match checkFiles options.SourceFiles with 253 | | Result.Error res -> Result.Error res 254 | 255 | | Result.Ok allFileContents -> 256 | 257 | let parseTrees = List.choose fst allFileContents 258 | let implFiles = List.map snd allFileContents 259 | match webhook with 260 | | Some hook -> 261 | sendToWebHook hook implFiles 262 | Result.Ok() 263 | | None -> 264 | 265 | if not dump && webhook.IsNone then 266 | printfn "fslive: EVALUATING ALL INPUTS...." 267 | let evaluator = LiveCheckEvaluation(options.OtherOptions, dyntypes, writeinfo, keepRanges, livecheck, tolerateIncompleteExpressions) 268 | match evaluator.EvaluateDecls implFiles with 269 | | Error _ when not watch -> exit 1 270 | | _ -> () 271 | 272 | // The default is to dump 273 | if dump && webhook.IsNone then 274 | let fileConvContents = jsonFiles (Array.ofList implFiles) 275 | 276 | printfn "%A" fileConvContents 277 | Result.Ok() 278 | 279 | with err when watch -> 280 | printfn "fslive: exception: %A" (err.ToString()) 281 | for loc in err.EvalLocationStack do 282 | printfn " --> %O" loc 283 | Result.Error (None, Some err, None, None) 284 | 285 | for o in options.OtherOptions do 286 | printfn "compiling, option %s" o 287 | 288 | if watch then 289 | // Send an immediate changed() event 290 | if webhook.IsNone then 291 | printfn "Sending initial changes... " 292 | changed "initial" () |> ignore 293 | 294 | let mkWatcher (sourceFile: string) = 295 | let path = Path.GetDirectoryName(sourceFile) 296 | let fileName = Path.GetFileName(sourceFile) 297 | printfn "fslive: WATCHING %s in %s" fileName path 298 | let watcher = new FileSystemWatcher(path, fileName) 299 | watcher.NotifyFilter <- NotifyFilters.Attributes ||| NotifyFilters.CreationTime ||| NotifyFilters.FileName ||| NotifyFilters.LastAccess ||| NotifyFilters.LastWrite ||| NotifyFilters.Size ||| NotifyFilters.Security; 300 | 301 | let fileChange msg e = 302 | let lastWriteTime = try max (File.GetCreationTime(sourceFile)) (File.GetLastWriteTime(sourceFile)) with _ -> DateTime.MaxValue 303 | printfn "change %s, lastCOmpileStart=%A, lastWriteTime = %O" sourceFile lastCompileStart lastWriteTime 304 | if lastWriteTime > lastCompileStart then 305 | printfn "changed %s" sourceFile 306 | changed msg e |> ignore 307 | 308 | watcher.Changed.Add (fileChange (sprintf "Changed %s" fileName)) 309 | watcher.Created.Add (fileChange (sprintf "Created %s" fileName)) 310 | watcher.Deleted.Add (fileChange (sprintf "Deleted %s" fileName)) 311 | watcher.Renamed.Add (fileChange (sprintf "Renamed %s" fileName)) 312 | watcher 313 | 314 | let watchers = 315 | [ for sourceFile in options.SourceFiles do 316 | yield mkWatcher sourceFile 317 | if useEditFiles then 318 | yield mkWatcher sourceFile ] 319 | 320 | for watcher in watchers do 321 | watcher.EnableRaisingEvents <- true 322 | 323 | printfn "Waiting for changes... press any key to exit" 324 | System.Console.ReadLine() |> ignore 325 | for watcher in watchers do 326 | watcher.EnableRaisingEvents <- false 327 | 328 | 0 329 | else 330 | match changed "once" () with 331 | | Error _ -> 1 332 | | Ok _ -> 0 333 | 334 | -------------------------------------------------------------------------------- /src/ProjectCracker.fs: -------------------------------------------------------------------------------- 1 | module FSharpDaemon.ProjectCracker 2 | 3 | open System 4 | open System.IO 5 | open System.Collections.Concurrent 6 | open FSharp.Compiler.SourceCodeServices 7 | 8 | module MSBuildPrj = Dotnet.ProjInfo.Inspect 9 | 10 | type NavigateProjectSM = 11 | | NoCrossTargeting of NoCrossTargetingData 12 | | CrossTargeting of string list 13 | and NoCrossTargetingData = 14 | { FscArgs: string list 15 | P2PRefs: MSBuildPrj.ResolvedP2PRefsInfo list 16 | Properties: Map } 17 | 18 | module MSBuildKnownProperties = 19 | let TargetFramework = "TargetFramework" 20 | let DefineConstants = "DefineConstants" 21 | 22 | module Option = 23 | let getOrElse defaultValue option = 24 | match option with 25 | | None -> defaultValue 26 | | Some x -> x 27 | 28 | 29 | type FilePath = string 30 | [] 31 | type ProjectSdkType = 32 | | DotnetSdk of ProjectSdkTypeDotnetSdk 33 | and ProjectSdkTypeVerbose = 34 | { 35 | TargetPath: string 36 | } 37 | and ProjectSdkTypeDotnetSdk = 38 | { 39 | Configuration: string // Debug 40 | TargetFramework: string // netcoreapp1.0 41 | DefineConstants: string 42 | RestoreSuccess: bool // True 43 | Configurations: string list // Debug;Release 44 | TargetFrameworks: string list // netcoreapp1.0;netstandard1.6 45 | TargetPath: string 46 | } 47 | type ExtraProjectInfoData = 48 | { 49 | ProjectOutputType: ProjectOutputType 50 | ProjectSdkType: ProjectSdkType 51 | } 52 | and ProjectOutputType = 53 | | Library 54 | | Exe 55 | | Custom of string 56 | 57 | 58 | type private ProjectParsingSdk = 59 | | DotnetSdk 60 | #if OLDFORMATS 61 | | VerboseSdk 62 | #endif 63 | 64 | type ParsedProject = string * FSharpProjectOptions * ((string * string) list) 65 | type ParsedProjectCache = ConcurrentDictionary 66 | 67 | let chooseByPrefix (prefix: string) (s: string) = 68 | if s.StartsWith(prefix) then Some (s.Substring(prefix.Length)) 69 | else None 70 | 71 | let chooseByPrefix2 prefixes (s: string) = 72 | prefixes 73 | |> List.tryPick (fun prefix -> chooseByPrefix prefix s) 74 | 75 | let splitByPrefix (prefix: string) (s: string) = 76 | if s.StartsWith(prefix) then Some (prefix, s.Substring(prefix.Length)) 77 | else None 78 | 79 | let splitByPrefix2 prefixes (s: string) = 80 | prefixes 81 | |> List.tryPick (fun prefix -> splitByPrefix prefix s) 82 | 83 | let outType rsp = 84 | match List.tryPick (chooseByPrefix "--target:") rsp with 85 | | Some "library" -> ProjectOutputType.Library 86 | | Some "exe" -> ProjectOutputType.Exe 87 | | Some v -> ProjectOutputType.Custom v 88 | | None -> ProjectOutputType.Exe // default if arg is not passed to fsc 89 | 90 | let private outputFileArg = ["--out:"; "-o:"] 91 | 92 | let private makeAbs projDir (f: string) = 93 | if Path.IsPathRooted f then f else Path.Combine(projDir, f) 94 | 95 | let outputFile projDir rsp = 96 | rsp 97 | |> List.tryPick (chooseByPrefix2 outputFileArg) 98 | |> Option.map (makeAbs projDir) 99 | 100 | let isCompileFile (s:string) = 101 | s.EndsWith(".fs") || s.EndsWith (".fsi") 102 | 103 | let compileFiles = 104 | //TODO filter the one without initial - 105 | List.filter isCompileFile 106 | 107 | let references = 108 | List.choose (chooseByPrefix "-r:") 109 | 110 | let useFullPaths projDir (s: string) = 111 | match s |> splitByPrefix2 outputFileArg with 112 | | Some (prefix, v) -> 113 | prefix + (v |> makeAbs projDir) 114 | | None -> 115 | if isCompileFile s then 116 | s |> makeAbs projDir |> Path.GetFullPath 117 | else 118 | s 119 | let msbuildPropProjectOutputType (s: string) = 120 | match s.Trim() with 121 | | MSBuildPrj.MSBuild.ConditionEquals "Exe" -> ProjectOutputType.Exe 122 | | MSBuildPrj.MSBuild.ConditionEquals "Library" -> ProjectOutputType.Library 123 | | x -> ProjectOutputType.Custom x 124 | 125 | let msbuildPropBool (s: string) = 126 | match s.Trim() with 127 | | "" -> None 128 | | Dotnet.ProjInfo.Inspect.MSBuild.ConditionEquals "True" -> Some true 129 | | _ -> Some false 130 | 131 | let msbuildPropStringList (s: string) = 132 | match s.Trim() with 133 | | "" -> [] 134 | | Dotnet.ProjInfo.Inspect.MSBuild.StringList list -> list 135 | | _ -> [] 136 | 137 | let getExtraInfo targetPath props = 138 | let msbuildPropBool prop = 139 | props |> Map.tryFind prop |> Option.bind msbuildPropBool 140 | let msbuildPropStringList prop = 141 | props |> Map.tryFind prop |> Option.map msbuildPropStringList 142 | let msbuildPropString prop = 143 | props |> Map.tryFind prop 144 | 145 | { Configuration = msbuildPropString "Configuration" |> Option.getOrElse "" 146 | TargetFramework = msbuildPropString MSBuildKnownProperties.TargetFramework |> Option.getOrElse "" 147 | DefineConstants = msbuildPropString MSBuildKnownProperties.DefineConstants |> Option.getOrElse "" 148 | TargetPath = targetPath 149 | RestoreSuccess = msbuildPropBool "RestoreSuccess" |> Option.getOrElse false 150 | Configurations = msbuildPropStringList "Configurations" |> Option.getOrElse [] 151 | TargetFrameworks = msbuildPropStringList "TargetFrameworks" |> Option.getOrElse [] } 152 | 153 | let (|MsbuildOk|_|) x = 154 | match x with 155 | | Ok x -> Some x 156 | | Error _ -> None 157 | 158 | let (|MsbuildError|_|) x = 159 | match x with 160 | | Ok _ -> None 161 | | Error x -> Some x 162 | 163 | let runProcess (log: string -> unit) (workingDir: string) (exePath: string) (args: string) = 164 | let psi = System.Diagnostics.ProcessStartInfo() 165 | psi.FileName <- exePath 166 | psi.WorkingDirectory <- workingDir 167 | psi.RedirectStandardOutput <- true 168 | psi.RedirectStandardError <- true 169 | psi.Arguments <- args 170 | psi.CreateNoWindow <- true 171 | psi.UseShellExecute <- false 172 | 173 | use p = new System.Diagnostics.Process() 174 | p.StartInfo <- psi 175 | 176 | p.OutputDataReceived.Add(fun ea -> log (ea.Data)) 177 | 178 | p.ErrorDataReceived.Add(fun ea -> log (ea.Data)) 179 | 180 | printfn "running: %s %s" psi.FileName psi.Arguments 181 | 182 | p.Start() |> ignore 183 | p.BeginOutputReadLine() 184 | p.BeginErrorReadLine() 185 | p.WaitForExit() 186 | 187 | let exitCode = p.ExitCode 188 | 189 | exitCode, (workingDir, exePath, args) 190 | 191 | 192 | let private getProjectOptionsFromProjectFile (cache: ParsedProjectCache) parseAsSdk (file : string) msbuildArgs = 193 | 194 | let rec projInfoOf additionalMSBuildProps (file: string) : ParsedProject = 195 | let projDir = Path.GetDirectoryName file 196 | 197 | match parseAsSdk with 198 | | ProjectParsingSdk.DotnetSdk -> 199 | let projectAssetsJsonPath = Path.Combine(projDir, "obj", "project.assets.json") 200 | if not(File.Exists(projectAssetsJsonPath)) then 201 | failwithf "project '%s' not restored" file 202 | 203 | let getFscArgs = 204 | match parseAsSdk with 205 | | ProjectParsingSdk.DotnetSdk -> 206 | Dotnet.ProjInfo.Inspect.getFscArgs 207 | 208 | let getP2PRefs = Dotnet.ProjInfo.Inspect.getResolvedP2PRefs 209 | let additionalInfo = //needed for extra 210 | [ "OutputType" 211 | "Configuration" 212 | MSBuildKnownProperties.TargetFramework 213 | "RestoreSuccess" 214 | "Configurations" 215 | "TargetFrameworks" 216 | ] 217 | let gp () = Dotnet.ProjInfo.Inspect.getProperties (["TargetPath"; "IsCrossTargetingBuild"; "TargetFrameworks"] @ additionalInfo) 218 | 219 | let results, log = 220 | let loggedMessages = System.Collections.Concurrent.ConcurrentQueue() 221 | 222 | let runCmd exePath args = 223 | let args = args @ msbuildArgs 224 | runProcess loggedMessages.Enqueue projDir exePath (args |> String.concat " ") 225 | 226 | let msbuildExec = 227 | let msbuildPath = 228 | match parseAsSdk with 229 | | ProjectParsingSdk.DotnetSdk -> 230 | Dotnet.ProjInfo.Inspect.MSBuildExePath.DotnetMsbuild "dotnet" 231 | Dotnet.ProjInfo.Inspect.msbuild msbuildPath runCmd 232 | 233 | let additionalArgs = additionalMSBuildProps |> List.map (Dotnet.ProjInfo.Inspect.MSBuild.MSbuildCli.Property) 234 | 235 | let inspect = 236 | match parseAsSdk with 237 | | ProjectParsingSdk.DotnetSdk -> 238 | Dotnet.ProjInfo.Inspect.getProjectInfos 239 | 240 | let infoResult = 241 | file 242 | |> inspect loggedMessages.Enqueue msbuildExec [getFscArgs; getP2PRefs; gp] additionalArgs 243 | 244 | infoResult, (loggedMessages.ToArray() |> Array.toList) 245 | 246 | let todo = 247 | match results with 248 | | MsbuildOk [getFscArgsResult; getP2PRefsResult; gpResult] -> 249 | match getFscArgsResult, getP2PRefsResult, gpResult with 250 | | MsbuildError(MSBuildPrj.MSBuildSkippedTarget), MsbuildError(MSBuildPrj.MSBuildSkippedTarget), MsbuildOk (MSBuildPrj.GetResult.Properties props) -> 251 | // Projects with multiple target frameworks, fails if the target framework is not choosen 252 | let prop key = props |> Map.ofList |> Map.tryFind key 253 | 254 | match prop "IsCrossTargetingBuild", prop "TargetFrameworks" with 255 | | Some (MSBuildPrj.MSBuild.ConditionEquals "true"), Some (MSBuildPrj.MSBuild.StringList tfms) -> 256 | CrossTargeting tfms 257 | | _ -> 258 | failwithf "error getting msbuild info: some targets skipped, found props: %A" props 259 | | MsbuildOk (MSBuildPrj.GetResult.FscArgs fa), MsbuildOk (MSBuildPrj.GetResult.ResolvedP2PRefs p2p), MsbuildOk (MSBuildPrj.GetResult.Properties p) -> 260 | NoCrossTargeting { FscArgs = fa; P2PRefs = p2p; Properties = p |> Map.ofList } 261 | | r -> 262 | failwithf "error getting msbuild info: %A" r 263 | | MsbuildOk r -> 264 | failwithf "error getting msbuild info: internal error, more info returned than expected %A" r 265 | | MsbuildError r -> 266 | match r with 267 | | Dotnet.ProjInfo.Inspect.GetProjectInfoErrors.MSBuildSkippedTarget -> 268 | failwithf "Unexpected MSBuild result, all targets skipped" 269 | | Dotnet.ProjInfo.Inspect.GetProjectInfoErrors.UnexpectedMSBuildResult(r) -> 270 | failwithf "Unexpected MSBuild result %s" r 271 | | Dotnet.ProjInfo.Inspect.GetProjectInfoErrors.MSBuildFailed(exitCode, (workDir, exePath, args)) -> 272 | let logMsg = [ yield "Log: "; yield! log ] |> String.concat (Environment.NewLine) 273 | let msbuildErrorMsg = 274 | [ sprintf "MSBuild failed with exitCode %i" exitCode 275 | sprintf "Working Directory: '%s'" workDir 276 | sprintf "Exe Path: '%s'" exePath 277 | sprintf "Args: '%s'" args ] 278 | |> String.concat " " 279 | 280 | failwithf "%s%s%s" msbuildErrorMsg (Environment.NewLine) logMsg 281 | | _ -> 282 | failwithf "error getting msbuild info: internal error" 283 | 284 | match todo with 285 | | CrossTargeting (tfm :: _) -> 286 | // Atm setting a preferenece is not supported in FSAC 287 | // As workaround, lets choose the first of the target frameworks and use that 288 | file |> projInfo [MSBuildKnownProperties.TargetFramework, tfm] 289 | | CrossTargeting [] -> 290 | failwithf "Unexpected, found cross targeting but empty target frameworks list" 291 | | NoCrossTargeting { FscArgs = rsp; P2PRefs = p2ps; Properties = props } -> 292 | 293 | //TODO cache projects info of p2p ref 294 | let p2pProjects = 295 | p2ps 296 | // do not follow others lang project, is not supported by FCS anyway 297 | |> List.filter (fun p2p -> p2p.ProjectReferenceFullPath.ToLower().EndsWith(".fsproj")) 298 | |> List.map (fun p2p -> 299 | let followP2pArgs = 300 | p2p.TargetFramework 301 | |> Option.map (fun tfm -> MSBuildKnownProperties.TargetFramework, tfm) 302 | |> Option.toList 303 | p2p.ProjectReferenceFullPath |> projInfo followP2pArgs ) 304 | 305 | let tar = 306 | match props |> Map.tryFind "TargetPath" with 307 | | Some t -> t 308 | | None -> failwith "error, 'TargetPath' property not found" 309 | 310 | let rspNormalized = 311 | //workaround, arguments in rsp can use relative paths 312 | rsp |> List.map (useFullPaths projDir) 313 | 314 | let sdkTypeData, log = 315 | match parseAsSdk with 316 | | ProjectParsingSdk.DotnetSdk -> 317 | let extraInfo = getExtraInfo tar props 318 | ProjectSdkType.DotnetSdk(extraInfo), [] 319 | 320 | let po = 321 | { 322 | ProjectId = Some file 323 | ProjectFileName = file 324 | SourceFiles = [||] 325 | OtherOptions = rspNormalized |> Array.ofList 326 | ReferencedProjects = [| |] //p2pProjects |> List.map (fun (x,y,_) -> (x,y)) |> Array.ofList 327 | IsIncompleteTypeCheckEnvironment = false 328 | UseScriptResolutionRules = false 329 | LoadTime = DateTime.Now 330 | UnresolvedReferences = None 331 | OriginalLoadReferences = [] 332 | Stamp = None 333 | ExtraProjectInfo = 334 | Some (box { 335 | ExtraProjectInfoData.ProjectSdkType = sdkTypeData 336 | ExtraProjectInfoData.ProjectOutputType = outType rspNormalized 337 | }) 338 | } 339 | 340 | tar, po, log 341 | 342 | and projInfo additionalMSBuildProps file : ParsedProject = 343 | let key = sprintf "%s;%A" file additionalMSBuildProps 344 | match cache.TryGetValue(key) with 345 | | true, alreadyParsed -> 346 | alreadyParsed 347 | | false, _ -> 348 | let p = file |> projInfoOf additionalMSBuildProps 349 | cache.AddOrUpdate(key, p, fun _ _ -> p) 350 | 351 | 352 | let _, po, log = projInfo [] file 353 | po, log 354 | 355 | let private (|ProjectExtraInfoBySdk|_|) po = 356 | match po.ExtraProjectInfo with 357 | | None -> None 358 | | Some x -> 359 | match x with 360 | | :? ExtraProjectInfoData as extraInfo -> 361 | Some extraInfo 362 | | _ -> None 363 | 364 | let private loadBySdk (cache: ParsedProjectCache) parseAsSdk msbuildArgs file = 365 | let po, log = getProjectOptionsFromProjectFile cache parseAsSdk msbuildArgs file 366 | 367 | let compileFiles = 368 | let sources = compileFiles (po.OtherOptions |> List.ofArray) 369 | match po with 370 | | ProjectExtraInfoBySdk extraInfo -> 371 | match extraInfo.ProjectSdkType with 372 | | ProjectSdkType.DotnetSdk _ -> 373 | sources 374 | | _ -> sources 375 | 376 | Ok (po, Seq.toList compileFiles, (log |> Map.ofList)) 377 | 378 | let load (cache: ParsedProjectCache) msbuildArgs file = 379 | loadBySdk cache ProjectParsingSdk.DotnetSdk msbuildArgs file 380 | 381 | -------------------------------------------------------------------------------- /tests/FsLive.Cli.Tests.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | netcoreapp3.1 4 | Library 5 | false 6 | $(DefineConstants);NETSTANDARD2_0;TEST 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /tests/PortaCodeTests.fs: -------------------------------------------------------------------------------- 1 | module FSharp.Compiler.PortaCode.Tests.Basic 2 | 3 | open System 4 | open System.IO 5 | open NUnit.Framework 6 | open FsUnit 7 | 8 | [] 9 | module TestHelpers = 10 | 11 | let internal SimpleTestCase livecheck dyntypes name code = 12 | let directory = __SOURCE_DIRECTORY__ + "/data" 13 | Directory.CreateDirectory directory |> ignore 14 | Environment.CurrentDirectory <- directory 15 | File.WriteAllText (name + ".fsx", """ 16 | module TestCode 17 | """ + code) 18 | 19 | let args = 20 | [| yield "--once"; 21 | if livecheck then yield "--livecheck"; 22 | if dyntypes then yield "--dyntypes"; 23 | yield name + ".fsx" 24 | |] 25 | let res = FSharp.Compiler.PortaCode.ProcessCommandLine.ProcessCommandLine(args) 26 | Assert.AreEqual(0, res) 27 | 28 | [] 29 | [] 30 | let TestTuples (dyntypes: bool) = 31 | SimpleTestCase false dyntypes "TestTuples" """ 32 | module Tuples = 33 | let x1 = (1, 2) 34 | let x2 = match x1 with (a,b) -> 1 + 2 35 | """ 36 | 37 | [] 38 | [] 39 | let SmokeTestLiveCheck (dyntypes: bool) = 40 | SimpleTestCase true dyntypes "SmokeTestLiveCheck" """ 41 | module SmokeTestLiveCheck = 42 | type LiveCheckAttribute() = 43 | inherit System.Attribute() 44 | 45 | let mutable v = 0 46 | 47 | let x1 = 48 | v <- v + 1 49 | 4 50 | 51 | [] 52 | let x2 = 53 | v <- v + 1 54 | 4 55 | 56 | [] 57 | let x3 = 58 | // For live checking, bindings are executed on-demand 59 | // 'v' is only incremented once - because `x1` is not yet evaluated! 60 | if v <> 1 then failwithf "no way John, v = %d" v 61 | 62 | let y1 = x2 + 3 63 | 64 | // 'v' has not been incremented again - because `x2` is evaluated once! 65 | if v <> 1 then failwithf "no way Jane, v = %d" v 66 | if y1 <> 7 then failwithf "no way Juan, y1 = %d" y1 67 | 68 | let y2 = x1 + 1 69 | 70 | // 'v' has been incremented - because `x1` is now evaluated! 71 | if v <> 2 then failwithf "no way Julie, v = %d" v 72 | if y2 <> 5 then failwithf "no way Jose, y2 = %d, v = %d" y2 v 73 | 74 | let y3 = x1 + 1 75 | 76 | // 'v' is not incremented again - because `x1` is already evaluated! 77 | if v <> 2 then failwithf "no way Julie, v = %d" v 78 | if y3 <> 5 then failwithf "no way Jose, y3 = %d, v = %d" y3 v 79 | 80 | 5 81 | 82 | let x4 : int = failwith "no way" 83 | """ 84 | 85 | [] 86 | [] 87 | let SmokeTestShapeCheck (dyntypes: bool) = 88 | SimpleTestCase true dyntypes "SmokeTestShapeCheck" """ 89 | module SmokeTestShapeCheck = 90 | type ShapeCheckAttribute() = 91 | inherit System.Attribute() 92 | 93 | let mutable v = 0 94 | 95 | let x1 = 96 | v <- v + 1 97 | 4 98 | 99 | [] 100 | let x2 = 101 | v <- v + 1 102 | 4 103 | 104 | [] 105 | let x3 = 106 | // For live checking, bindings are executed on-demand 107 | // 'v' is only incremented once - because `x1` is not yet evaluated! 108 | if v <> 1 then failwithf "no way John, v = %d" v 109 | 110 | let y1 = x2 + 3 111 | 112 | // 'v' has not been incremented again - because `x2` is evaluated once! 113 | if v <> 1 then failwithf "no way Jane, v = %d" v 114 | if y1 <> 7 then failwithf "no way Juan, y1 = %d" y1 115 | 116 | let y2 = x1 + 1 117 | 118 | // 'v' has been incremented - because `x1` is now evaluated! 119 | if v <> 2 then failwithf "no way Julie, v = %d" v 120 | if y2 <> 5 then failwithf "no way Jose, y2 = %d, v = %d" y2 v 121 | 122 | let y3 = x1 + 1 123 | 124 | // 'v' is not incremented again - because `x1` is already evaluated! 125 | if v <> 2 then failwithf "no way Julie, v = %d" v 126 | if y3 <> 5 then failwithf "no way Jose, y3 = %d, v = %d" y3 v 127 | 128 | 5 129 | 130 | let x4 : int = failwith "no way" 131 | """ 132 | [] 133 | [] 134 | let PlusOperator (dyntypes: bool) = 135 | SimpleTestCase false dyntypes "PlusOperator" """ 136 | module PlusOperator = 137 | let x1 = 1 + 1 138 | let x5 = 1.0 + 2.0 139 | let x6 = 1.0f + 2.0f 140 | let x7 = 10uy + 9uy 141 | let x8 = 10us + 9us 142 | let x9 = 10u + 9u 143 | let x10 = 10UL + 9UL 144 | let x11 = 10y + 9y 145 | let x12 = 10s + 9s 146 | let x14 = 10 + 9 147 | let x15 = 10L + 9L 148 | let x16 = 10.0M + 11.0M 149 | let x17 = "a" + "b" 150 | """ 151 | 152 | [] 153 | [] 154 | let ImplementClassOverride(dyntypes: bool) = 155 | SimpleTestCase false dyntypes "ImplementClassOverride" """ 156 | 157 | type UserType() = 158 | override x.ToString() = "a" 159 | let f () = 160 | let u = UserType() 161 | let s = u.ToString() 162 | if s <> "a" then failwithf "unexpected, got '%s', expected 'a'" s 163 | 164 | f() 165 | """ 166 | 167 | 168 | //[] 169 | //[] 170 | //let ImplementClassOverrideInGenericClass(dyntypes: bool) = 171 | // SimpleTestCase false dyntypes "ImplementClassOverrideInGenericClass" """ 172 | 173 | //type UserType<'T>(x:'T) = 174 | // override _.ToString() : string = unbox x 175 | //let f () = 176 | // let u : UserType = UserType("a") 177 | // let s = u.ToString() 178 | // if s <> "a" then failwithf "unexpected, got '%s', expected 'a'" s 179 | 180 | //f() 181 | //""" 182 | 183 | 184 | [] 185 | [] 186 | let SetMapCount(dyntypes: bool) = 187 | SimpleTestCase false dyntypes "SetMapCount" """ 188 | 189 | let f () = 190 | let l = [ 1; 2; 3 ] 191 | let s = Set.ofList [ 1; 2; 3 ] 192 | let m = Map.ofList [ (1,1) ] 193 | if l.Length <> 3 then failwith "unexpected" 194 | if s.Count <> 3 then failwith "unexpected" 195 | if m.Count <> 1 then failwith "unexpected" 196 | 197 | f() 198 | """ 199 | 200 | [] 201 | [] 202 | let CustomAttributeSmokeTest(dyntypes: bool) = 203 | SimpleTestCase false dyntypes "CustomAttributeSmokeTest" """ 204 | 205 | open System 206 | [] 207 | type UserType() = member x.P = 1 208 | 209 | let attrs = typeof.GetCustomAttributes(typeof, true) 210 | if attrs.Length <> 1 then failwith "unexpected" 211 | 212 | """ 213 | 214 | [] 215 | [] 216 | let CustomAttributeWithArgs(dyntypes: bool) = 217 | SimpleTestCase false dyntypes "CustomAttributeWithArgs" """ 218 | 219 | open System 220 | [] 221 | type UserType() = member x.P = 1 222 | 223 | let attrs = typeof.GetCustomAttributes(typeof, true) 224 | if attrs.Length <> 1 then failwith "unexpected" 225 | if (attrs.[0] :?> ObsoleteAttribute).Message <> "abc" then failwith "unexpected" 226 | 227 | """ 228 | 229 | [] 230 | [] 231 | let ArrayOfUserDefinedUnionType(dyntypes: bool) = 232 | SimpleTestCase false dyntypes "ArrayOfUserDefinedUnionType" """ 233 | 234 | type UserType = A of int | B 235 | let f () = 236 | let a = [| UserType.A 1 |] 237 | if a.Length <> 1 then failwith "unexpected" 238 | 239 | f() 240 | """ 241 | 242 | [] 243 | [] 244 | let ArrayOfUserDefinedRecordType(dyntypes: bool) = 245 | SimpleTestCase false dyntypes "ArrayOfUserDefinedUnionRecordType" """ 246 | 247 | type UserType = { X: int; Y: string } 248 | let f () = 249 | let a = [| { X = 1; Y = "a" } |] 250 | if a.Length <> 1 then failwith "unexpected" 251 | 252 | f() 253 | """ 254 | 255 | 256 | [] 257 | [] 258 | let ArrayOfUserDefinedAnonRecordType(dyntypes: bool) = 259 | SimpleTestCase false dyntypes "ArrayOfUserDefinedUnionRecordType" """ 260 | 261 | let f () = 262 | let a = [| {| X = 1; Y = "a" |} |] 263 | if a.Length <> 1 then failwith "unexpected" 264 | if a.[0].X <> 1 then failwith "unexpected" 265 | if a.[0].Y <> "a" then failwith "unexpected" 266 | 267 | f() 268 | """ 269 | 270 | [] 271 | [] 272 | let SetOfUserDefinedUnionType(dyntypes: bool) = 273 | SimpleTestCase false dyntypes "SetOfUserDefinedUnionType" """ 274 | 275 | type UserType = A of int | B 276 | let f () = 277 | let a = set [| UserType.A 1 |] 278 | if a.Count <> 1 then failwith "unexpected" 279 | 280 | f() 281 | """ 282 | 283 | [] 284 | [] 285 | let MinusOperator (dyntypes: bool) = 286 | SimpleTestCase false dyntypes "MinusOperator" """ 287 | module MinusOperator = 288 | let x1 = 1 - 1 289 | let x5 = 1.0 - 2.0 290 | let x6 = 1.0f - 2.0f 291 | let x7 = 10uy - 9uy 292 | let x8 = 10us - 9us 293 | let x9 = 10u - 9u 294 | let x10 = 10UL - 9UL 295 | let x11 = 10y - 9y 296 | let x12 = 10s - 9s 297 | let x14 = 10 - 9 298 | let x15 = 10L - 9L 299 | let x16 = 10.0M - 11.0M 300 | """ 301 | 302 | [] 303 | [] 304 | let Options (dyntypes: bool) = 305 | SimpleTestCase false dyntypes "Options" """ 306 | module Options = 307 | let x2 = None : int option 308 | let x3 = Some 3 : int option 309 | let x5 = x2.IsNone 310 | let x6 = x3.IsNone 311 | let x7 = x2.IsSome 312 | let x8 = x3.IsSome 313 | """ 314 | 315 | [] 316 | [] 317 | let Exceptions (dyntypes: bool) = 318 | SimpleTestCase false dyntypes "Exceptions" """ 319 | module Exceptions = 320 | let x2 = try invalidArg "a" "wtf" with :? System.ArgumentException -> () 321 | let x4 = try failwith "hello" with e -> () 322 | let x5 = try 1 with e -> failwith "fail!" 323 | if x5 <> 1 then failwith "fail! fail!" 324 | """ 325 | 326 | [] 327 | [] 328 | let TestEvalIsNone (dyntypes: bool) = 329 | SimpleTestCase false dyntypes "TestEvalIsNone" """ 330 | let x3 = (Some 3).IsNone 331 | """ 332 | 333 | [] 334 | [] 335 | let TestEvalUnionCaseInGenericCode (dyntypes: bool) = 336 | SimpleTestCase false dyntypes "TestEvalUnionCaseInGenericCofe" """ 337 | let f<'T>(x:'T) = Some x 338 | 339 | let y = f 3 340 | printfn "y = %A, y.GetType() = %A" y (y.GetType()) 341 | """ 342 | [] 343 | [] 344 | let TestEvalNewOnClass(dyntypes: bool) = 345 | SimpleTestCase false dyntypes "TestEvalNewOnClass" """ 346 | type C(x: int) = 347 | member __.X = x 348 | 349 | let y = C(3) 350 | let z = if y.X <> 3 then failwith "fail!" else 1 351 | """ 352 | 353 | [] 354 | [] 355 | let TestExtrinsicFSharpExtensionOnClass1(dyntypes: bool) = 356 | SimpleTestCase false dyntypes "TestExtrinsicFSharpExtensionOnClass1" """ 357 | type System.String with 358 | member x.GetLength() = x.Length 359 | 360 | let y = "a".GetLength() 361 | let z = if y <> 1 then failwith "fail!" else 1 362 | """ 363 | 364 | [] 365 | [] 366 | let TestExtrinsicFSharpExtensionOnClass2(dyntypes: bool) = 367 | SimpleTestCase false dyntypes "TestExtrinsicFSharpExtensionOnClass2" """ 368 | type System.String with 369 | member x.GetLength2(y:int) = x.Length + y 370 | 371 | let y = "ab".GetLength2(5) 372 | let z = if y <> 7 then failwith "fail!" else 1 373 | """ 374 | 375 | [] 376 | [] 377 | let TestExtrinsicFSharpExtensionOnClass3(dyntypes: bool) = 378 | SimpleTestCase false dyntypes "TestExtrinsicFSharpExtensionOnClass3" """ 379 | type System.String with 380 | static member GetLength3(x:string) = x.Length 381 | 382 | let y = System.String.GetLength3("abc") 383 | let z = if y <> 3 then failwith "fail!" else 1 384 | """ 385 | 386 | [] 387 | [] 388 | let TestExtrinsicFSharpExtensionOnClass4(dyntypes: bool) = 389 | SimpleTestCase false dyntypes "TestExtrinsicFSharpExtensionOnClass4" """ 390 | type System.String with 391 | member x.LengthProp = x.Length 392 | 393 | let y = "abcd".LengthProp 394 | let z = if y <> 4 then failwith "fail!" else 1 395 | """ 396 | 397 | [] 398 | [] 399 | let TestTopMutables(dyntypes: bool) = 400 | SimpleTestCase false dyntypes "TestTopFunctionIsNotValue" """ 401 | let mutable x = 0 402 | if x <> 0 then failwith "failure A!" else 1 403 | let y(c:int) = 404 | (x <- x + 1 405 | x) 406 | let z1 = y(3) 407 | if x <> 1 then failwith "failure B!" else 1 408 | let z2 = y(4) 409 | if x <> 2 then failwith "failure C!" else 1 410 | if z1 <> 1 || z2 <> 2 then failwith "failure D!" else 1 411 | """ 412 | 413 | [] 414 | [] 415 | let TestTopFunctionIsNotValue(dyntypes: bool) = 416 | SimpleTestCase false dyntypes "TestTopFunctionIsNotValue" """ 417 | let mutable x = 0 418 | if x <> 0 then failwith "failure A!" else 1 419 | let y(c:int) = 420 | (x <- x + 1 421 | x) 422 | let z1 = y(1) 423 | if x <> 1 then failwith "failure B!" else 1 424 | let z2 = y(2) 425 | if x <> 2 then failwith "failure C!" else 1 426 | if z1 <> 1 || z2 <> 2 then failwith "failure D!" else 1 427 | """ 428 | 429 | [] 430 | [] 431 | let TestTopUnitValue(dyntypes: bool) = 432 | SimpleTestCase false dyntypes "TestTopUnitValue" """ 433 | let mutable x = 0 434 | if x <> 0 then failwith "fail!" 435 | """ 436 | 437 | [] 438 | [] 439 | let TestEvalSetterOnClass(dyntypes: bool) = 440 | SimpleTestCase false dyntypes "TestEvalSetterOnClass" """ 441 | type C(x: int) = 442 | let mutable y = x 443 | member __.Y with get() = y and set v = y <- v 444 | 445 | printfn "initializing..." 446 | let c = C(3) 447 | if c.Y <> 3 then failwithf "fail!, c.Y = %d, expected 3" c.Y 448 | printfn "assigning..." 449 | c.Y <- 4 450 | if c.Y <> 4 then failwith "fail! fail!" 451 | """ 452 | 453 | [] 454 | [] 455 | let TestLengthOnList(dyntypes: bool) = 456 | SimpleTestCase false dyntypes "TestLengthOnList" """ 457 | let x = [1;2;3].Length 458 | if x <> 3 then failwith "fail! fail!" 459 | """ 460 | [] 461 | [] 462 | let TestEvalLocalFunctionOnClass(dyntypes: bool) = 463 | SimpleTestCase false dyntypes "TestEvalLocalFunctionOnClass" """ 464 | type C(x: int) = 465 | let f x = x + 1 466 | member __.Y with get() = f x 467 | 468 | let c = C(3) 469 | if c.Y <> 4 then failwith "fail!" 470 | """ 471 | 472 | [] 473 | [] 474 | let TestEquals(dyntypes: bool) = 475 | SimpleTestCase false dyntypes "TestEquals" """ 476 | let x = (1 = 2) 477 | """ 478 | 479 | 480 | [] 481 | [] 482 | let TestTypeTest(dyntypes: bool) = 483 | SimpleTestCase false dyntypes "TestTypeTest" """ 484 | let x = match box 1 with :? int as a -> a | _ -> failwith "fail!" 485 | if x <> 1 then failwith "fail fail!" 486 | """ 487 | 488 | 489 | [] 490 | [] 491 | let TestTypeTest2(dyntypes: bool) = 492 | SimpleTestCase false dyntypes "TestTypeTest2" """ 493 | let x = match box 2 with :? string as a -> failwith "fail!" | _ -> 1 494 | if x <> 1 then failwith "fail fail!" 495 | """ 496 | 497 | // Known limitation of FSharp Compiler Service 498 | //[] 499 | // let GenericThing() = 500 | // SimpleTestCase false dyntypes "GenericThing" """ 501 | //let f () = 502 | // let g x = x 503 | // g 3, g 4, g 504 | //let a, b, (c: int -> int) = f() 505 | //if a <> 3 then failwith "fail!" 506 | //if b <> 4 then failwith "fail fail!" 507 | //if c 5 <> 5 then failwith "fail fail fail!" 508 | // """ 509 | 510 | [] 511 | [] 512 | let DateTime(dyntypes: bool) = 513 | SimpleTestCase false dyntypes "DateTime" """ 514 | let v1 = System.DateTime.Now 515 | let v2 = v1.Date 516 | let mutable v3 = System.DateTime.Now 517 | let v4 = v3.Date 518 | """ 519 | 520 | [] 521 | [] 522 | let LocalMutation(dyntypes: bool) = 523 | SimpleTestCase false dyntypes "LocalMutation" """ 524 | let f () = 525 | let mutable x = 1 526 | x <- x + 1 527 | x <- x + 1 528 | x 529 | if f() <> 3 then failwith "fail fail!" 530 | """ 531 | 532 | 533 | [] 534 | [] 535 | let SimpleInheritFromObj(dyntypes: bool) = 536 | SimpleTestCase false dyntypes "SimpleInheritFromObj" """ 537 | type C() = 538 | inherit obj() 539 | member val x = 1 with get, set 540 | 541 | let c = C() 542 | if c.x <> 1 then failwith "fail fail!" 543 | c.x <- 3 544 | if c.x <> 3 then failwith "fail fail!" 545 | """ 546 | 547 | [] 548 | [] 549 | let SimpleInheritFromConcreteClass(dyntypes: bool) = 550 | SimpleTestCase false dyntypes "SimpleInheritFromObj" """ 551 | type C() = 552 | inherit System.Text.ASCIIEncoding() 553 | member val x = 1 with get, set 554 | 555 | let c = C() 556 | if c.CodePage <> System.Text.ASCIIEncoding().CodePage then failwith "nope" 557 | 558 | """ 559 | 560 | [] 561 | [] 562 | let SimpleInterfaceImpl(dyntypes) = 563 | SimpleTestCase false dyntypes "SimpleInterfaceImpl" """ 564 | open System 565 | type C() = 566 | interface IComparable with 567 | member x.CompareTo(y:obj) = 17 568 | 569 | let c = C() 570 | let v = (c :> IComparable).CompareTo(c) 571 | if v <> 17 then failwithf "fail fail! expected 17, got %d" v 572 | """ 573 | 574 | [] 575 | [] 576 | let SimpleInterfaceDecl(dyntypes) = 577 | SimpleTestCase false dyntypes "SimpleInterfaceDecl" """ 578 | 579 | type IComparable2 = 580 | abstract CompareTo: obj -> int 581 | 582 | if typeof.Name <> "IComparable2" then failwith "bad name" 583 | 584 | type C() = 585 | interface IComparable2 with 586 | member x.CompareTo(y:obj) = 17 587 | 588 | let c = C() 589 | let v = (c :> IComparable2).CompareTo(c) 590 | 591 | if v <> 17 then failwithf "fail fail! expected 17, got %d" v 592 | """ 593 | 594 | 595 | [] 596 | [] 597 | let SimpleAbstractClassDecl(dyntypes) = 598 | SimpleTestCase false dyntypes "SimpleAbstractClassDecl" """ 599 | 600 | [] 601 | type Comparable2() = 602 | abstract CompareTo: obj -> int 603 | 604 | if typeof.Name <> "Comparable2" then failwith "bad name" 605 | 606 | type C() = 607 | inherit Comparable2() 608 | override x.CompareTo(y:obj) = 17 609 | 610 | if typeof.Name <> "C" then failwith "bad name" 611 | let c = C() 612 | let v = c.CompareTo(c) 613 | 614 | if v <> 17 then failwithf "fail fail! expected 17, got %d" v 615 | """ 616 | 617 | [] 618 | [] 619 | let SimpleInheritGenericInstantiationDecl(dyntypes) = 620 | SimpleTestCase false dyntypes "SimpleInheritGenericInstantiationDecl" """ 621 | 622 | type BaseClass(x: int) = 623 | member _.X = x 624 | 625 | if typeof.Name <> "BaseClass" then failwith "bad name" 626 | 627 | type C() = 628 | inherit System.Collections.Generic.List() 629 | override x.Equals(y:obj) = true 630 | 631 | if typeof.Name <> "C" then failwith "bad name" 632 | let c = C() 633 | let v = c.Equals(c) 634 | 635 | if v <> true then failwithf "fail fail! expected true, got %b" v 636 | """ 637 | 638 | [] 639 | [] 640 | let SimpleInterfaceImpl2(dyntypes) = 641 | SimpleTestCase false dyntypes "SimpleInterfaceImpl" """ 642 | open System.Collections 643 | open System.Collections.Generic 644 | type C() = 645 | interface IEnumerator with 646 | member x.MoveNext() = false 647 | member x.Current = box 1 648 | member x.Reset() = () 649 | 650 | let c = C() :> IEnumerator 651 | if c.MoveNext() <> false then failwith "fail fail!" 652 | """ 653 | 654 | [] 655 | [] 656 | let SimpleInterfaceImplGenericClass(dyntypes) = 657 | SimpleTestCase false dyntypes "SimpleInterfaceImpl" """ 658 | open System.Collections 659 | open System.Collections.Generic 660 | type C<'T>() = 661 | interface IEnumerator with 662 | member x.MoveNext() = false 663 | member x.Current = box 1 664 | member x.Reset() = () 665 | 666 | let c = C() :> IEnumerator 667 | if c.MoveNext() <> false then failwith "fail fail!" 668 | """ 669 | 670 | [] 671 | [] 672 | let SimpleGenericInterfaceImpl(dyntypes) = 673 | SimpleTestCase false dyntypes "SimpleGenericInterfaceImpl" """ 674 | open System.Collections 675 | open System.Collections.Generic 676 | type C() = 677 | interface IEnumerator with 678 | member x.Current = 17 679 | member x.Dispose() = () 680 | interface IEnumerator with 681 | member x.MoveNext() = false 682 | member x.Current = box 10 683 | member x.Reset() = () 684 | 685 | let c = new C() :> IEnumerator 686 | if c.Current <> 17 then failwith "fail fail!" 687 | if c.Reset() <> () then failwith "fail fail 2!" 688 | if c.MoveNext() <> false then failwith "fail fail!" 689 | """ 690 | 691 | [] 692 | [] 693 | let GenericMethodWithConstraint(dyntypes) = 694 | SimpleTestCase false dyntypes "GenericMethodWithConstraint" """ 695 | 696 | open System 697 | let f<'T when 'T :> IComparable> (x: 'T) = (x, x) 698 | 699 | let (a,b) = f 3.0 700 | 701 | if a <> 3.0 then failwith "fail fail!" 702 | if b <> 3.0 then failwith "fail fail!" 703 | """ 704 | 705 | [] 706 | [] 707 | let GenericClassWithConstraint(dyntypes) = 708 | SimpleTestCase false dyntypes "GenericClassWithConstraint" """ 709 | 710 | open System 711 | type C<'T when 'T :> IComparable> (x: 'T) = 712 | member _.Call() = (x, x) 713 | 714 | let (a,b) = C(3.0).Call() 715 | 716 | if a <> 3.0 then failwith "fail fail!" 717 | if b <> 3.0 then failwith "fail fail!" 718 | """ 719 | 720 | [] 721 | [] 722 | let GenericMethodInGenericClassWithConstraint(dyntypes) = 723 | SimpleTestCase false dyntypes "GenericClassWithConstraint" """ 724 | 725 | open System 726 | type C<'T when 'T :> IComparable> (x: 'T) = 727 | member _.Call<'U when 'U :> IComparable>(y) = (x, y) 728 | 729 | let (a,b) = C(3.0).Call(4.0) 730 | 731 | if a <> 3.0 then failwith "fail fail!" 732 | if b <> 4.0 then failwith "fail fail!" 733 | """ 734 | 735 | [] 736 | [] 737 | let UnionTypeWithOverride(dyntypes) = 738 | SimpleTestCase false dyntypes "UnionTypeWithOverride" """ 739 | 740 | type UnionType = 741 | | A 742 | | B 743 | override x.ToString() = "dd" 744 | 745 | if A.ToString() <> "dd" then failwith "fail fail! 1" 746 | """ 747 | 748 | [] 749 | [] 750 | let SimpleClass(dyntypes) = 751 | SimpleTestCase false dyntypes "SimpleClass" """ 752 | 753 | type C(x: int, y: int) = 754 | member _.X = x 755 | member _.Y = y 756 | member _.XY = x + y 757 | 758 | let c = C(3,4) 759 | if c.X <> 3 then failwith "fail fail! 1" 760 | if c.Y <> 4 then failwith "fail fail! 2" 761 | if c.XY <> 7 then failwith "fail fail! 3" 762 | """ 763 | 764 | [] 765 | [] 766 | let SimpleModule(dyntypes) = 767 | SimpleTestCase false dyntypes "SimpleClass" """ 768 | 769 | module M = 770 | let f x y = printfn "hello"; printfn "hello"; printfn "hello"; printfn "hello"; x + y 771 | 772 | let c = M.f 3 4 773 | if c <> 7 then failwith "fail fail! 1" 774 | """ 775 | 776 | [] 777 | //[] 778 | let SimpleClassSelfConstructionNoArguments(dyntypes) = 779 | SimpleTestCase false dyntypes "SimpleClass" """ 780 | 781 | type C() = 782 | member _.X = 1 783 | member _.Y = 2 784 | new (x: int, y: int, z: int) = C() 785 | 786 | let c = C(3,4,5) // interpretation calls self constructor 787 | if c.X <> 1 then failwith "fail fail! 1" 788 | if c.Y <> 2 then failwith "fail fail! 2" 789 | """ 790 | 791 | [] 792 | //[] 793 | let SimpleClassSelfConstructionWithArguments(dyntypes) = 794 | SimpleTestCase false dyntypes "SimpleClass" """ 795 | 796 | type C(x: int, y: int) = 797 | member _.X = x 798 | member _.Y = y 799 | member _.XY = x + y 800 | new (x: int, y: int, z: int) = C(x, y) 801 | 802 | let c = C(3,4,5) // interpretation calls self constructor 803 | if c.X <> 3 then failwith "fail fail! 1" 804 | if c.Y <> 4 then failwith "fail fail! 2" 805 | if c.XY <> 7 then failwith "fail fail! 3" 806 | """ 807 | 808 | [] 809 | [] 810 | let SimpleClassWithInnerFunctions(dyntypes) = 811 | SimpleTestCase false dyntypes "SimpleClass" """ 812 | 813 | type C(x: int, y: int) = 814 | let f x = x + 1 815 | member _.FX = f x 816 | 817 | let c = C(3,4) 818 | if c.FX <> 4 then failwith "fail fail! 4" 819 | """ 820 | 821 | [] 822 | [] 823 | let SimpleStruct(dyntypes) = 824 | SimpleTestCase false dyntypes "SimpleStruct" """ 825 | 826 | [] 827 | type C(x: int, y: int) = 828 | member _.X = x 829 | member _.Y = y 830 | member _.XY = x + y 831 | 832 | let c = C(3,4) 833 | if c.X <> 3 then failwith "fail fail! 1" 834 | if c.Y <> 4 then failwith "fail fail! 2" 835 | if c.XY <> 7 then failwith "fail fail! 3" 836 | """ 837 | 838 | [] 839 | [] 840 | let SimpleGenericInterfaceImplPassedAsArg(dyntypes) = 841 | SimpleTestCase false dyntypes "SimpleGenericInterfaceImplPassedAsArg" """ 842 | open System.Collections 843 | open System.Collections.Generic 844 | type C() = 845 | interface IEnumerable with 846 | member x.GetEnumerator() = (x :> _) 847 | interface IEnumerable with 848 | member x.GetEnumerator() = (x :> _) 849 | interface IEnumerator with 850 | member x.Current = 1 851 | member x.Dispose() = () 852 | interface IEnumerator with 853 | member x.MoveNext() = false 854 | member x.Current = box 1 855 | member x.Reset() = () 856 | 857 | let c = new C() |> Seq.map id |> Seq.toArray 858 | if c.Length <> 0 then failwith "fail fail!" 859 | """ 860 | 861 | [] 862 | [] 863 | let LetRecSmoke(dyntypes: bool) = 864 | SimpleTestCase false dyntypes "LetRecSmoke" """ 865 | let even a = 866 | let rec even x = (if x = 0 then true else odd (x-1)) 867 | and odd x = (if x = 0 then false else even (x-1)) 868 | even a 869 | 870 | if even 11 then failwith "fail!" 871 | if not (even 10) then failwith "fail fail!" 872 | """ 873 | 874 | [] 875 | [] 876 | let FastIntegerForLoop(dyntypes: bool) = 877 | SimpleTestCase false dyntypes "FastIntegerForLoop" """ 878 | 879 | let f () = 880 | let mutable res = 0 881 | for i in 0 .. 10 do 882 | res <- res + i 883 | res 884 | 885 | if f() <> List.sum [ 0 .. 10 ] then failwith "fail!" 886 | """ 887 | 888 | 889 | [] 890 | [] 891 | let TryGetValueSmoke(dyntypes: bool) = 892 | SimpleTestCase false dyntypes "TryGetValueSmoke" """ 893 | let m = dict [ (1,"2") ] 894 | let f() = 895 | match m.TryGetValue 1 with 896 | | true, v -> if v <> "2" then failwith "fail!" 897 | | _ -> failwith "fail2!" 898 | 899 | f() 900 | """ 901 | 902 | [] 903 | [] 904 | let TestCallUnitFunction(dyntypes: bool) = 905 | SimpleTestCase false dyntypes "TestCallUnitFunction" """ 906 | let theRef = FSharp.Core.LanguagePrimitives.GenericZeroDynamic() 907 | """ 908 | 909 | 910 | // tests needed: 911 | // 2D arrays 912 | --------------------------------------------------------------------------------