├── .gitattributes ├── .gitignore ├── Examples ├── AssemblyInfo.fs ├── Examples.fsproj ├── Program.fs └── SignUp.jpi ├── FsLexYacc.Runtime ├── AssemblyInfo.fs ├── FsLexYacc.Runtime.fsproj ├── Lexing.fs └── Parsing.fs ├── JsonPi.sln ├── JsonPiInterpreter ├── AssemblyInfo.fs ├── JsonPiInterpreter.fsproj ├── PiJsonData.fs ├── PiLexerInternal.fs ├── PiLexerInternal.fsl ├── PiParser.fs ├── PiParserInternal.fs ├── PiParserInternal.fsy ├── PiProcessor.fs ├── PiRuntime.fs └── PiTrace.fs ├── JsonPiREPL ├── JsonPiREPL.fsproj ├── PiRepl.fs ├── PiReplLexer.fs ├── PiReplParser.fs ├── PiReplParser.fsi └── Program.fs ├── LICENSE ├── README.md └── Tests ├── AssemblyInfo.fs ├── BasicTests.fs ├── PiTest.fs ├── Program.fs └── Tests.fsproj /.gitattributes: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | # Set default behavior to automatically normalize line endings. 3 | ############################################################################### 4 | * text=auto 5 | 6 | ############################################################################### 7 | # Set default behavior for command prompt diff. 8 | # 9 | # This is need for earlier builds of msysgit that does not have it on by 10 | # default for csharp files. 11 | # Note: This is only used by command line 12 | ############################################################################### 13 | #*.cs diff=csharp 14 | 15 | ############################################################################### 16 | # Set the merge driver for project and solution files 17 | # 18 | # Merging from the command prompt will add diff markers to the files if there 19 | # are conflicts (Merging from VS is not affected by the settings below, in VS 20 | # the diff markers are never inserted). Diff markers may cause the following 21 | # file extensions to fail to load in VS. An alternative would be to treat 22 | # these files as binary and thus will always conflict and require user 23 | # intervention with every merge. To do so, just uncomment the entries below 24 | ############################################################################### 25 | #*.sln merge=binary 26 | #*.csproj merge=binary 27 | #*.vbproj merge=binary 28 | #*.vcxproj merge=binary 29 | #*.vcproj merge=binary 30 | #*.dbproj merge=binary 31 | #*.fsproj merge=binary 32 | #*.lsproj merge=binary 33 | #*.wixproj merge=binary 34 | #*.modelproj merge=binary 35 | #*.sqlproj merge=binary 36 | #*.wwaproj merge=binary 37 | 38 | ############################################################################### 39 | # behavior for image files 40 | # 41 | # image files are treated as binary by default. 42 | ############################################################################### 43 | #*.jpg binary 44 | #*.png binary 45 | #*.gif binary 46 | 47 | ############################################################################### 48 | # diff behavior for common document formats 49 | # 50 | # Convert binary document formats to text before diffing them. This feature 51 | # is only available from the command line. Turn it on by uncommenting the 52 | # entries below. 53 | ############################################################################### 54 | #*.doc diff=astextplain 55 | #*.DOC diff=astextplain 56 | #*.docx diff=astextplain 57 | #*.DOCX diff=astextplain 58 | #*.dot diff=astextplain 59 | #*.DOT diff=astextplain 60 | #*.pdf diff=astextplain 61 | #*.PDF diff=astextplain 62 | #*.rtf diff=astextplain 63 | #*.RTF diff=astextplain 64 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Ignore Visual Studio temporary files, build results, and 2 | ## files generated by popular Visual Studio add-ons. 3 | 4 | # User-specific files 5 | *.suo 6 | *.user 7 | *.userosscache 8 | *.sln.docstates 9 | 10 | # User-specific files (MonoDevelop/Xamarin Studio) 11 | *.userprefs 12 | 13 | # Build results 14 | [Dd]ebug/ 15 | [Dd]ebugPublic/ 16 | [Rr]elease/ 17 | [Rr]eleases/ 18 | [Xx]64/ 19 | [Xx]86/ 20 | [Bb]uild/ 21 | bld/ 22 | [Bb]in/ 23 | [Oo]bj/ 24 | 25 | # Visual Studio 2015 cache/options directory 26 | .vs/ 27 | # Uncomment if you have tasks that create the project's static files in wwwroot 28 | #wwwroot/ 29 | 30 | # MSTest test Results 31 | [Tt]est[Rr]esult*/ 32 | [Bb]uild[Ll]og.* 33 | 34 | # NUNIT 35 | *.VisualState.xml 36 | TestResult.xml 37 | 38 | # Build Results of an ATL Project 39 | [Dd]ebugPS/ 40 | [Rr]eleasePS/ 41 | dlldata.c 42 | 43 | # DNX 44 | project.lock.json 45 | artifacts/ 46 | 47 | *_i.c 48 | *_p.c 49 | *_i.h 50 | *.ilk 51 | *.meta 52 | *.obj 53 | *.pch 54 | *.pdb 55 | *.pgc 56 | *.pgd 57 | *.rsp 58 | *.sbr 59 | *.tlb 60 | *.tli 61 | *.tlh 62 | *.tmp 63 | *.tmp_proj 64 | *.log 65 | *.vspscc 66 | *.vssscc 67 | .builds 68 | *.pidb 69 | *.svclog 70 | *.scc 71 | 72 | # Chutzpah Test files 73 | _Chutzpah* 74 | 75 | # Visual C++ cache files 76 | ipch/ 77 | *.aps 78 | *.ncb 79 | *.opendb 80 | *.opensdf 81 | *.sdf 82 | *.cachefile 83 | *.VC.db 84 | 85 | # Visual Studio profiler 86 | *.psess 87 | *.vsp 88 | *.vspx 89 | *.sap 90 | 91 | # TFS 2012 Local Workspace 92 | $tf/ 93 | 94 | # Guidance Automation Toolkit 95 | *.gpState 96 | 97 | # ReSharper is a .NET coding add-in 98 | _ReSharper*/ 99 | *.[Rr]e[Ss]harper 100 | *.DotSettings.user 101 | 102 | # JustCode is a .NET coding add-in 103 | .JustCode 104 | 105 | # TeamCity is a build add-in 106 | _TeamCity* 107 | 108 | # DotCover is a Code Coverage Tool 109 | *.dotCover 110 | 111 | # NCrunch 112 | _NCrunch_* 113 | .*crunch*.local.xml 114 | nCrunchTemp_* 115 | 116 | # MightyMoose 117 | *.mm.* 118 | AutoTest.Net/ 119 | 120 | # Web workbench (sass) 121 | .sass-cache/ 122 | 123 | # Installshield output folder 124 | [Ee]xpress/ 125 | 126 | # DocProject is a documentation generator add-in 127 | DocProject/buildhelp/ 128 | DocProject/Help/*.HxT 129 | DocProject/Help/*.HxC 130 | DocProject/Help/*.hhc 131 | DocProject/Help/*.hhk 132 | DocProject/Help/*.hhp 133 | DocProject/Help/Html2 134 | DocProject/Help/html 135 | 136 | # Click-Once directory 137 | publish/ 138 | 139 | # Publish Web Output 140 | *.[Pp]ublish.xml 141 | *.azurePubxml 142 | 143 | # TODO: Un-comment the next line if you do not want to checkin 144 | # your web deploy settings because they may include unencrypted 145 | # passwords 146 | #*.pubxml 147 | *.publishproj 148 | 149 | # NuGet Packages 150 | *.nupkg 151 | # The packages folder can be ignored because of Package Restore 152 | **/packages/* 153 | # except build/, which is used as an MSBuild target. 154 | !**/packages/build/ 155 | # Uncomment if necessary however generally it will be regenerated when needed 156 | #!**/packages/repositories.config 157 | # NuGet v3's project.json files produces more ignoreable files 158 | *.nuget.props 159 | *.nuget.targets 160 | 161 | # Microsoft Azure Build Output 162 | csx/ 163 | *.build.csdef 164 | 165 | # Microsoft Azure Emulator 166 | ecf/ 167 | rcf/ 168 | 169 | # Microsoft Azure ApplicationInsights config file 170 | ApplicationInsights.config 171 | 172 | # Windows Store app package directory 173 | AppPackages/ 174 | BundleArtifacts/ 175 | 176 | # Visual Studio cache files 177 | # files ending in .cache can be ignored 178 | *.[Cc]ache 179 | # but keep track of directories ending in .cache 180 | !*.[Cc]ache/ 181 | 182 | # Others 183 | ClientBin/ 184 | [Ss]tyle[Cc]op.* 185 | ~$* 186 | *~ 187 | *.dbmdl 188 | *.dbproj.schemaview 189 | *.pfx 190 | *.publishsettings 191 | node_modules/ 192 | orleans.codegen.cs 193 | 194 | # RIA/Silverlight projects 195 | Generated_Code/ 196 | 197 | # Backup & report files from converting an old project file 198 | # to a newer Visual Studio version. Backup files are not needed, 199 | # because we have git ;-) 200 | _UpgradeReport_Files/ 201 | Backup*/ 202 | UpgradeLog*.XML 203 | UpgradeLog*.htm 204 | 205 | # SQL Server files 206 | *.mdf 207 | *.ldf 208 | 209 | # Business Intelligence projects 210 | *.rdl.data 211 | *.bim.layout 212 | *.bim_*.settings 213 | 214 | # Microsoft Fakes 215 | FakesAssemblies/ 216 | 217 | # GhostDoc plugin setting file 218 | *.GhostDoc.xml 219 | 220 | # Node.js Tools for Visual Studio 221 | .ntvs_analysis.dat 222 | 223 | # Visual Studio 6 build log 224 | *.plg 225 | 226 | # Visual Studio 6 workspace options file 227 | *.opt 228 | 229 | # Visual Studio LightSwitch build output 230 | **/*.HTMLClient/GeneratedArtifacts 231 | **/*.DesktopClient/GeneratedArtifacts 232 | **/*.DesktopClient/ModelManifest.xml 233 | **/*.Server/GeneratedArtifacts 234 | **/*.Server/ModelManifest.xml 235 | _Pvt_Extensions 236 | 237 | # LightSwitch generated files 238 | GeneratedArtifacts/ 239 | ModelManifest.xml 240 | 241 | # Paket dependency manager 242 | .paket/paket.exe 243 | 244 | # FAKE - F# Make 245 | .fake/ 246 | 247 | # REPLBinaries 248 | !.REPLBinaries/Linux-x64/publish/* 249 | !.REPLBinaries/** -------------------------------------------------------------------------------- /Examples/AssemblyInfo.fs: -------------------------------------------------------------------------------- 1 | namespace Tennis.AssemblyInfo 2 | 3 | open System.Reflection 4 | open System.Runtime.CompilerServices 5 | open System.Runtime.InteropServices 6 | 7 | // General Information about an assembly is controlled through the following 8 | // set of attributes. Change these attribute values to modify the information 9 | // associated with an assembly. 10 | [] 11 | [] 12 | [] 13 | [] 14 | [] 15 | [] 16 | [] 17 | [] 18 | 19 | // Setting ComVisible to false makes the types in this assembly not visible 20 | // to COM components. If you need to access a type in this assembly from 21 | // COM, set the ComVisible attribute to true on that type. 22 | [] 23 | 24 | // The following GUID is for the ID of the typelib if this project is exposed to COM 25 | [] 26 | 27 | // Version information for an assembly consists of the following four values: 28 | // 29 | // Major Version 30 | // Minor Version 31 | // Build Number 32 | // Revision 33 | // 34 | // You can specify all the values or you can default the Build and Revision Numbers 35 | // by using the '*' as shown below: 36 | // [] 37 | [] 38 | [] 39 | 40 | do 41 | () -------------------------------------------------------------------------------- /Examples/Examples.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | Exe 5 | netcoreapp2.0 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /Examples/Program.fs: -------------------------------------------------------------------------------- 1 | open System 2 | 3 | open JsonPi 4 | open JsonPi.Data 5 | 6 | type TennisApi (data:obj option) = 7 | interface IPiExtension with 8 | member this.OnOutput (channel:PiJsonObject) (outNames:PiJsonArray) = 9 | match outNames with 10 | | [| api; a; b; c; |] -> 11 | match (api, a, b, c) with 12 | | (PiName (apiId, _, _), player, date, PiName (resultId, _, _)) when apiId = "Signup" -> 13 | // RobinswoodFridayTennis 14 | let proc = 15 | match PiParser.ParseFromString (resultId + ";") with 16 | | AssemblyEntryProcess p -> p 17 | | _ -> failwith "bad" 18 | 19 | Some( proc ) 20 | | _ -> 21 | None 22 | | _ -> 23 | None 24 | 25 | member this.OnInput (channel:PiJsonObject) (outNames:PiJsonArray) (inpNames:PiJsonArray) : PiJsonObject option = 26 | printfn "Input extension" 27 | None 28 | 29 | let TennisResolver (nameType:PiIdentifier) (data:obj option) = 30 | match nameType with 31 | | "TennisApi" -> Some( TennisApi(data) :> IPiExtension) 32 | | _ -> None 33 | 34 | [] 35 | let main argv = 36 | let program = PiParser.ParseFromFile "..\\..\\..\\Signup.jpi" 37 | let pjson = WriteJsonToString program 38 | 39 | let pp = PiProcessor(Some(TennisResolver)) 40 | pp.RunProgram(program) 41 | 42 | 0 // return an integer exit code 43 | -------------------------------------------------------------------------------- /Examples/SignUp.jpi: -------------------------------------------------------------------------------- 1 | module TennisServer 2 | new (RobinswoodFridayTennis:TennisApi) 3 | ( 4 | !(RobinswoodFridayTennis(api, params);) 5 | )|( 6 | !( 7 | TennisServer.Signup(player, date, result) 8 | RobinswoodFridayTennis 9 | ; 10 | ) 11 | ) 12 | 13 | 14 | using TennisServer 15 | 16 | new (Me) = 17 | { 18 | "PlayerName" : "Glen" 19 | } 20 | new (SessionDate) = "2018/4/6" 21 | 22 | TennisServer.Signup 23 | return(result) 24 | 25 | choose 26 | when [result=Confirmed]Console then ; 27 | default 28 | Console; 29 | end 30 | -------------------------------------------------------------------------------- /FsLexYacc.Runtime/AssemblyInfo.fs: -------------------------------------------------------------------------------- 1 | // Auto-Generated by FAKE; do not edit 2 | namespace System 3 | open System.Reflection 4 | 5 | [] 6 | [] 7 | [] 8 | [] 9 | [] 10 | do () 11 | 12 | module internal AssemblyVersionInformation = 13 | let [] AssemblyTitle = "FsLexYacc.Runtime" 14 | let [] AssemblyProduct = "FsLexYacc.Runtime" 15 | let [] AssemblyDescription = "FsLex/FsYacc lexer/parser generation tools" 16 | let [] AssemblyVersion = "7.0.6" 17 | let [] AssemblyFileVersion = "7.0.6" 18 | -------------------------------------------------------------------------------- /FsLexYacc.Runtime/FsLexYacc.Runtime.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | netcoreapp2.0 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /FsLexYacc.Runtime/Lexing.fs: -------------------------------------------------------------------------------- 1 | // (c) Microsoft Corporation 2005-2009. 2 | 3 | #nowarn "47" // recursive initialization of LexBuffer 4 | 5 | 6 | #if INTERNALIZED_FSLEXYACC_RUNTIME 7 | namespace Internal.Utilities.Text.Lexing 8 | 9 | #else 10 | namespace Microsoft.FSharp.Text.Lexing 11 | #endif 12 | 13 | open System.Collections.Generic 14 | 15 | // REVIEW: This type showed up on a parsing-intensive performance measurement. Consider whether it can be a struct-record later when we have this feature. -jomo 16 | #if INTERNALIZED_FSLEXYACC_RUNTIME 17 | type internal Position = 18 | #else 19 | type Position = 20 | #endif 21 | { pos_fname : string; 22 | pos_lnum : int; 23 | #if INTERNALIZED_FSLEXYACC_RUNTIME 24 | pos_orig_lnum : int; 25 | #endif 26 | pos_bol : int; 27 | pos_cnum : int; } 28 | member x.FileName = x.pos_fname 29 | member x.Line = x.pos_lnum 30 | #if INTERNALIZED_FSLEXYACC_RUNTIME 31 | member x.OriginalLine = x.pos_orig_lnum 32 | #endif 33 | member x.Char = x.pos_cnum 34 | member x.AbsoluteOffset = x.pos_cnum 35 | member x.StartOfLine = x.pos_bol 36 | member x.StartOfLineAbsoluteOffset = x.pos_bol 37 | member x.Column = x.pos_cnum - x.pos_bol 38 | member pos.NextLine = 39 | { pos with 40 | #if INTERNALIZED_FSLEXYACC_RUNTIME 41 | pos_orig_lnum = pos.OriginalLine + 1; 42 | #endif 43 | pos_lnum = pos.Line+1; 44 | pos_bol = pos.AbsoluteOffset } 45 | member pos.EndOfToken(n) = {pos with pos_cnum=pos.pos_cnum + n } 46 | member pos.AsNewLinePos() = pos.NextLine 47 | member pos.ShiftColumnBy(by) = {pos with pos_cnum = pos.pos_cnum + by} 48 | static member Empty = 49 | { pos_fname=""; 50 | pos_lnum= 0; 51 | #if INTERNALIZED_FSLEXYACC_RUNTIME 52 | pos_orig_lnum = 0; 53 | #endif 54 | pos_bol= 0; 55 | pos_cnum=0 } 56 | static member FirstLine(filename) = 57 | { pos_fname=filename; 58 | #if INTERNALIZED_FSLEXYACC_RUNTIME 59 | pos_orig_lnum = 1; 60 | #endif 61 | pos_lnum= 1; 62 | pos_bol= 0; 63 | pos_cnum=0 } 64 | 65 | #if INTERNALIZED_FSLEXYACC_RUNTIME 66 | type internal LexBufferFiller<'char> = 67 | #else 68 | type LexBufferFiller<'char> = 69 | #endif 70 | { fillSync : (LexBuffer<'char> -> unit) option 71 | fillAsync : (LexBuffer<'char> -> Async) option } 72 | 73 | and [] 74 | #if INTERNALIZED_FSLEXYACC_RUNTIME 75 | internal LexBuffer<'char>(filler: LexBufferFiller<'char>) as this = 76 | #else 77 | LexBuffer<'char>(filler: LexBufferFiller<'char>) as this = 78 | #endif 79 | let context = new Dictionary(1) in 80 | let extendBufferSync = (fun () -> match filler.fillSync with Some refill -> refill this | None -> invalidOp "attempt to read synchronously from an asynchronous lex buffer") 81 | let extendBufferAsync = (fun () -> match filler.fillAsync with Some refill -> refill this | None -> invalidOp "attempt to read asynchronously from a synchronous lex buffer") 82 | let mutable buffer=[||]; 83 | /// number of valid charactes beyond bufferScanStart 84 | let mutable bufferMaxScanLength=0; 85 | /// count into the buffer when scanning 86 | let mutable bufferScanStart=0; 87 | /// number of characters scanned so far 88 | let mutable bufferScanLength=0; 89 | /// length of the scan at the last accepting state 90 | let mutable lexemeLength=0; 91 | /// action related to the last accepting state 92 | let mutable bufferAcceptAction=0; 93 | let mutable eof = false; 94 | let mutable startPos = Position.Empty ; 95 | let mutable endPos = Position.Empty 96 | 97 | // Throw away all the input besides the lexeme 98 | 99 | let discardInput () = 100 | let keep = Array.sub buffer bufferScanStart bufferScanLength 101 | let nkeep = keep.Length 102 | Array.blit keep 0 buffer 0 nkeep; 103 | bufferScanStart <- 0; 104 | bufferMaxScanLength <- nkeep 105 | 106 | 107 | member lexbuf.EndOfScan () : int = 108 | // Printf.eprintf "endOfScan, lexBuffer.lexemeLength = %d\n" lexBuffer.lexemeLength; 109 | if bufferAcceptAction < 0 then 110 | failwith "unrecognized input" 111 | 112 | // Printf.printf "endOfScan %d state %d on unconsumed input '%c' (%d)\n" a s (Char.chr inp) inp; 113 | // Printf.eprintf "accept, lexeme = %s\n" (lexeme lexBuffer); 114 | lexbuf.StartPos <- endPos; 115 | lexbuf.EndPos <- endPos.EndOfToken(lexbuf.LexemeLength); 116 | bufferAcceptAction 117 | 118 | member lexbuf.StartPos 119 | with get() = startPos 120 | and set(b) = startPos <- b 121 | 122 | member lexbuf.EndPos 123 | with get() = endPos 124 | and set(b) = endPos <- b 125 | 126 | member lexbuf.Lexeme = Array.sub buffer bufferScanStart lexemeLength 127 | member lexbuf.LexemeChar(n) = buffer.[n+bufferScanStart] 128 | 129 | member lexbuf.BufferLocalStore = (context :> IDictionary<_,_>) 130 | member lexbuf.LexemeLength with get() : int = lexemeLength and set v = lexemeLength <- v 131 | member internal lexbuf.Buffer with get() : 'char[] = buffer and set v = buffer <- v 132 | member internal lexbuf.BufferMaxScanLength with get() = bufferMaxScanLength and set v = bufferMaxScanLength <- v 133 | member internal lexbuf.BufferScanLength with get() = bufferScanLength and set v = bufferScanLength <- v 134 | member internal lexbuf.BufferScanStart with get() : int = bufferScanStart and set v = bufferScanStart <- v 135 | member internal lexbuf.BufferAcceptAction with get() = bufferAcceptAction and set v = bufferAcceptAction <- v 136 | member internal lexbuf.RefillBuffer = extendBufferSync 137 | member internal lexbuf.AsyncRefillBuffer = extendBufferAsync 138 | 139 | static member LexemeString(lexbuf:LexBuffer) = 140 | new System.String(lexbuf.Buffer,lexbuf.BufferScanStart,lexbuf.LexemeLength) 141 | 142 | member lexbuf.IsPastEndOfStream 143 | with get() = eof 144 | and set(b) = eof <- b 145 | 146 | member lexbuf.DiscardInput() = discardInput () 147 | 148 | member x.BufferScanPos = bufferScanStart + bufferScanLength 149 | 150 | member lexbuf.EnsureBufferSize n = 151 | if lexbuf.BufferScanPos + n >= buffer.Length then 152 | let repl = Array.zeroCreate (lexbuf.BufferScanPos + n) 153 | Array.blit buffer bufferScanStart repl bufferScanStart bufferScanLength; 154 | buffer <- repl 155 | 156 | static member FromReadFunctions (syncRead : ('char[] * int * int -> int) option, asyncRead : ('char[] * int * int -> Async) option) : LexBuffer<'char> = 157 | let extension= Array.zeroCreate 4096 158 | let fillers = 159 | { fillSync = 160 | match syncRead with 161 | | None -> None 162 | | Some read -> 163 | Some (fun lexBuffer -> 164 | let n = read(extension,0,extension.Length) 165 | lexBuffer.EnsureBufferSize n; 166 | Array.blit extension 0 lexBuffer.Buffer lexBuffer.BufferScanPos n; 167 | lexBuffer.BufferMaxScanLength <- lexBuffer.BufferScanLength + n); 168 | fillAsync = 169 | match asyncRead with 170 | | None -> None 171 | | Some read -> 172 | Some (fun lexBuffer -> 173 | async { 174 | let! n = read(extension,0,extension.Length) 175 | lexBuffer.EnsureBufferSize n; 176 | Array.blit extension 0 lexBuffer.Buffer lexBuffer.BufferScanPos n; 177 | lexBuffer.BufferMaxScanLength <- lexBuffer.BufferScanLength + n }) } 178 | new LexBuffer<_>(fillers) 179 | 180 | // A full type signature is required on this method because it is used at more specific types within its own scope 181 | static member FromFunction (f : 'char[] * int * int -> int) : LexBuffer<'char> = LexBuffer<_>.FromReadFunctions(Some(f),None) 182 | static member FromAsyncFunction (f : 'char[] * int * int -> Async) : LexBuffer<'char> = LexBuffer<_>.FromReadFunctions(None,Some(f)) 183 | 184 | static member FromCharFunction f : LexBuffer = 185 | LexBuffer.FromFunction(fun (buff,start,len) -> 186 | let buff2 = Array.zeroCreate len 187 | let n = f buff2 len 188 | Array.blit buff2 0 buff start len 189 | n) 190 | static member FromByteFunction f : LexBuffer = 191 | LexBuffer.FromFunction(fun (buff,start,len) -> 192 | let buff2 = Array.zeroCreate len 193 | let n = f buff2 len 194 | Array.blit buff2 0 buff start len 195 | n) 196 | 197 | // A full type signature is required on this method because it is used at more specific types within its own scope 198 | static member FromArray (s: 'char[]) : LexBuffer<'char> = 199 | let lexBuffer = 200 | new LexBuffer<_> 201 | { fillSync = Some (fun _ -> ()); 202 | fillAsync = Some (fun _ -> async { return () }) } 203 | let buffer = Array.copy s 204 | lexBuffer.Buffer <- buffer; 205 | lexBuffer.BufferMaxScanLength <- buffer.Length; 206 | lexBuffer 207 | 208 | static member FromBytes (arr) = LexBuffer.FromArray(arr) 209 | static member FromChars (arr) = LexBuffer.FromArray(arr) 210 | static member FromString (s:string) = LexBuffer.FromChars (s.ToCharArray()) 211 | 212 | static member FromTextReader (tr:System.IO.TextReader) : LexBuffer = 213 | LexBuffer.FromFunction(tr.Read) 214 | 215 | static member FromBinaryReader (br:System.IO.BinaryReader) : LexBuffer = 216 | LexBuffer.FromFunction(br.Read) 217 | 218 | static member FromStream (stream:System.IO.Stream) : LexBuffer = 219 | LexBuffer.FromReadFunctions(Some(stream.Read),Some(fun (buf,offset,len) -> stream.AsyncRead(buf,offset=offset,count=len))) 220 | 221 | module GenericImplFragments = 222 | let startInterpret(lexBuffer:LexBuffer<_>)= 223 | lexBuffer.BufferScanStart <- lexBuffer.BufferScanStart + lexBuffer.LexemeLength; 224 | lexBuffer.BufferMaxScanLength <- lexBuffer.BufferMaxScanLength - lexBuffer.LexemeLength; 225 | lexBuffer.BufferScanLength <- 0; 226 | lexBuffer.LexemeLength <- 0; 227 | lexBuffer.BufferAcceptAction <- -1; 228 | 229 | let afterRefill (trans: uint16[] array,sentinel,lexBuffer:LexBuffer<_>,scanUntilSentinel,endOfScan,state,eofPos) = 230 | // end of file occurs if we couldn't extend the buffer 231 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 232 | let snew = int trans.[state].[eofPos] // == EOF 233 | if snew = sentinel then 234 | endOfScan() 235 | else 236 | if lexBuffer.IsPastEndOfStream then failwith "End of file on lexing stream"; 237 | lexBuffer.IsPastEndOfStream <- true; 238 | // Printf.printf "state %d --> %d on eof\n" state snew; 239 | scanUntilSentinel(lexBuffer,snew) 240 | else 241 | scanUntilSentinel(lexBuffer, state) 242 | 243 | let onAccept (lexBuffer:LexBuffer<_>,a) = 244 | lexBuffer.LexemeLength <- lexBuffer.BufferScanLength; 245 | lexBuffer.BufferAcceptAction <- a; 246 | 247 | open GenericImplFragments 248 | 249 | [] 250 | #if INTERNALIZED_FSLEXYACC_RUNTIME 251 | type internal AsciiTables(trans: uint16[] array, accept: uint16[]) = 252 | #else 253 | type AsciiTables(trans: uint16[] array, accept: uint16[]) = 254 | #endif 255 | let rec scanUntilSentinel(lexBuffer, state) = 256 | let sentinel = 255 * 256 + 255 257 | // Return an endOfScan after consuming the input 258 | let a = int accept.[state] 259 | if a <> sentinel then 260 | onAccept (lexBuffer,a) 261 | 262 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 263 | lexBuffer.DiscardInput(); 264 | lexBuffer.RefillBuffer (); 265 | // end of file occurs if we couldn't extend the buffer 266 | afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,lexBuffer.EndOfScan,state,256 (* == EOF *) ) 267 | else 268 | // read a character - end the scan if there are no further transitions 269 | let inp = int(lexBuffer.Buffer.[lexBuffer.BufferScanPos]) 270 | let snew = int trans.[state].[inp] 271 | if snew = sentinel then 272 | lexBuffer.EndOfScan() 273 | else 274 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 275 | // Printf.printf "state %d --> %d on '%c' (%d)\n" state snew (Char.chr inp) inp; 276 | scanUntilSentinel(lexBuffer, snew) 277 | 278 | /// Interpret tables for an ascii lexer generated by fslex. 279 | member tables.Interpret(initialState,lexBuffer : LexBuffer) = 280 | startInterpret(lexBuffer) 281 | scanUntilSentinel(lexBuffer, initialState) 282 | 283 | /// Interpret tables for an ascii lexer generated by fslex. 284 | member tables.AsyncInterpret(initialState,lexBuffer : LexBuffer) = 285 | 286 | let rec scanUntilSentinel(lexBuffer,state) : Async = 287 | async { 288 | let sentinel = 255 * 256 + 255 289 | // Return an endOfScan after consuming the input 290 | let a = int accept.[state] 291 | if a <> sentinel then 292 | onAccept (lexBuffer,a) 293 | 294 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 295 | lexBuffer.DiscardInput(); 296 | do! lexBuffer.AsyncRefillBuffer (); 297 | // end of file occurs if we couldn't extend the buffer 298 | return! afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,endOfScan,state,256 (* == EOF *) ) 299 | else 300 | // read a character - end the scan if there are no further transitions 301 | let inp = int(lexBuffer.Buffer.[lexBuffer.BufferScanPos]) 302 | let snew = int trans.[state].[inp] 303 | if snew = sentinel then 304 | return! endOfScan() 305 | else 306 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 307 | return! scanUntilSentinel(lexBuffer,snew) 308 | } 309 | and endOfScan() = 310 | async { return lexBuffer.EndOfScan() } 311 | startInterpret(lexBuffer) 312 | scanUntilSentinel(lexBuffer, initialState) 313 | 314 | 315 | static member Create(trans,accept) = new AsciiTables(trans,accept) 316 | 317 | [] 318 | #if INTERNALIZED_FSLEXYACC_RUNTIME 319 | type internal UnicodeTables(trans: uint16[] array, accept: uint16[]) = 320 | #else 321 | type UnicodeTables(trans: uint16[] array, accept: uint16[]) = 322 | #endif 323 | let sentinel = 255 * 256 + 255 324 | let numUnicodeCategories = 30 325 | let numLowUnicodeChars = 128 326 | let numSpecificUnicodeChars = (trans.[0].Length - 1 - numLowUnicodeChars - numUnicodeCategories)/2 327 | let lookupUnicodeCharacters (state,inp) = 328 | let inpAsInt = int inp 329 | // Is it a fast ASCII character? 330 | if inpAsInt < numLowUnicodeChars then 331 | int trans.[state].[inpAsInt] 332 | else 333 | // Search for a specific unicode character 334 | let baseForSpecificUnicodeChars = numLowUnicodeChars 335 | let rec loop i = 336 | if i >= numSpecificUnicodeChars then 337 | // OK, if we failed then read the 'others' entry in the alphabet, 338 | // which covers all Unicode characters not covered in other 339 | // ways 340 | let baseForUnicodeCategories = numLowUnicodeChars+numSpecificUnicodeChars*2 341 | let unicodeCategory = System.Globalization.CharUnicodeInfo.GetUnicodeCategory(inp) 342 | //System.Console.WriteLine("inp = {0}, unicodeCategory = {1}", [| box inp; box unicodeCategory |]); 343 | int trans.[state].[baseForUnicodeCategories + int32 unicodeCategory] 344 | else 345 | // This is the specific unicode character 346 | let c = char (int trans.[state].[baseForSpecificUnicodeChars+i*2]) 347 | //System.Console.WriteLine("c = {0}, inp = {1}, i = {2}", [| box c; box inp; box i |]); 348 | // OK, have we found the entry for a specific unicode character? 349 | if c = inp 350 | then int trans.[state].[baseForSpecificUnicodeChars+i*2+1] 351 | else loop(i+1) 352 | 353 | loop 0 354 | let eofPos = numLowUnicodeChars + 2*numSpecificUnicodeChars + numUnicodeCategories 355 | 356 | let rec scanUntilSentinel(lexBuffer,state) = 357 | // Return an endOfScan after consuming the input 358 | let a = int accept.[state] 359 | if a <> sentinel then 360 | onAccept(lexBuffer,a) 361 | 362 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 363 | lexBuffer.DiscardInput(); 364 | lexBuffer.RefillBuffer (); 365 | // end of file occurs if we couldn't extend the buffer 366 | afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,lexBuffer.EndOfScan,state,eofPos) 367 | else 368 | // read a character - end the scan if there are no further transitions 369 | let inp = lexBuffer.Buffer.[lexBuffer.BufferScanPos] 370 | 371 | // Find the new state 372 | let snew = lookupUnicodeCharacters (state,inp) 373 | 374 | if snew = sentinel then 375 | lexBuffer.EndOfScan() 376 | else 377 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 378 | // Printf.printf "state %d --> %d on '%c' (%d)\n" s snew (char inp) inp; 379 | scanUntilSentinel(lexBuffer,snew) 380 | 381 | // Each row for the Unicode table has format 382 | // 128 entries for ASCII characters 383 | // A variable number of 2*UInt16 entries for SpecificUnicodeChars 384 | // 30 entries, one for each UnicodeCategory 385 | // 1 entry for EOF 386 | 387 | member tables.Interpret(initialState,lexBuffer : LexBuffer) = 388 | startInterpret(lexBuffer) 389 | scanUntilSentinel(lexBuffer, initialState) 390 | 391 | member tables.AsyncInterpret(initialState,lexBuffer : LexBuffer) = 392 | 393 | let rec scanUntilSentinel(lexBuffer, state) = 394 | async { 395 | // Return an endOfScan after consuming the input 396 | let a = int accept.[state] 397 | if a <> sentinel then 398 | onAccept(lexBuffer,a) 399 | 400 | if lexBuffer.BufferScanLength = lexBuffer.BufferMaxScanLength then 401 | lexBuffer.DiscardInput(); 402 | lexBuffer.RefillBuffer (); 403 | // end of file occurs if we couldn't extend the buffer 404 | return! afterRefill (trans,sentinel,lexBuffer,scanUntilSentinel,endOfScan,state,eofPos) 405 | else 406 | // read a character - end the scan if there are no further transitions 407 | let inp = lexBuffer.Buffer.[lexBuffer.BufferScanPos] 408 | 409 | // Find the new state 410 | let snew = lookupUnicodeCharacters (state,inp) 411 | 412 | if snew = sentinel then 413 | return! endOfScan() 414 | else 415 | lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; 416 | return! scanUntilSentinel(lexBuffer, snew) 417 | } 418 | and endOfScan() = 419 | async { return lexBuffer.EndOfScan() } 420 | startInterpret(lexBuffer) 421 | scanUntilSentinel(lexBuffer, initialState) 422 | 423 | static member Create(trans,accept) = new UnicodeTables(trans,accept) 424 | -------------------------------------------------------------------------------- /FsLexYacc.Runtime/Parsing.fs: -------------------------------------------------------------------------------- 1 | // (c) Microsoft Corporation 2005-2009. 2 | 3 | #if INTERNALIZED_FSLEXYACC_RUNTIME 4 | 5 | namespace Internal.Utilities.Text.Parsing 6 | open Internal.Utilities 7 | open Internal.Utilities.Text.Lexing 8 | 9 | #else 10 | namespace Microsoft.FSharp.Text.Parsing 11 | open Microsoft.FSharp.Text.Lexing 12 | #endif 13 | 14 | 15 | 16 | open System 17 | open System.Collections.Generic 18 | 19 | #if INTERNALIZED_FSLEXYACC_RUNTIME 20 | type internal IParseState = 21 | #else 22 | type IParseState = 23 | #endif 24 | abstract InputRange: int -> Position * Position 25 | abstract InputEndPosition: int -> Position 26 | abstract InputStartPosition: int -> Position 27 | abstract ResultRange: Position * Position 28 | abstract GetInput: int -> obj 29 | abstract ParserLocalStore : IDictionary 30 | abstract RaiseError<'b> : unit -> 'b 31 | 32 | //------------------------------------------------------------------------- 33 | // This context is passed to the error reporter when a syntax error occurs 34 | 35 | [] 36 | #if INTERNALIZED_FSLEXYACC_RUNTIME 37 | type internal ParseErrorContext<'tok> 38 | #else 39 | type ParseErrorContext<'tok> 40 | #endif 41 | (//lexbuf: LexBuffer<_>, 42 | stateStack:int list, 43 | parseState: IParseState, 44 | reduceTokens: int list, 45 | currentToken: 'tok option, 46 | reducibleProductions: int list list, 47 | shiftableTokens: int list , 48 | message : string) = 49 | //member x.LexBuffer = lexbuf 50 | member x.StateStack = stateStack 51 | member x.ReduceTokens = reduceTokens 52 | member x.CurrentToken = currentToken 53 | member x.ParseState = parseState 54 | member x.ReducibleProductions = reducibleProductions 55 | member x.ShiftTokens = shiftableTokens 56 | member x.Message = message 57 | 58 | 59 | //------------------------------------------------------------------------- 60 | // This is the data structure emitted as code by FSYACC. 61 | 62 | #if INTERNALIZED_FSLEXYACC_RUNTIME 63 | type internal Tables<'tok> = 64 | #else 65 | type Tables<'tok> = 66 | #endif 67 | { reductions: (IParseState -> obj) array; 68 | endOfInputTag: int; 69 | tagOfToken: 'tok -> int; 70 | dataOfToken: 'tok -> obj; 71 | actionTableElements: uint16[]; 72 | actionTableRowOffsets: uint16[]; 73 | reductionSymbolCounts: uint16[]; 74 | immediateActions: uint16[]; 75 | gotos: uint16[]; 76 | sparseGotoTableRowOffsets: uint16[]; 77 | stateToProdIdxsTableElements: uint16[]; 78 | stateToProdIdxsTableRowOffsets: uint16[]; 79 | productionToNonTerminalTable: uint16[]; 80 | /// For fsyacc.exe, this entry is filled in by context from the generated parser file. If no 'parse_error' function 81 | /// is defined by the user then ParseHelpers.parse_error is used by default (ParseHelpers is opened 82 | /// at the top of the generated parser file) 83 | parseError: ParseErrorContext<'tok> -> unit; 84 | numTerminals: int; 85 | tagOfErrorTerminal: int } 86 | 87 | //------------------------------------------------------------------------- 88 | // An implementation of stacks. 89 | 90 | // This type is in System.dll so for the moment we can't use it in FSharp.Core.dll 91 | //type Stack<'a> = System.Collections.Generic.Stack<'a> 92 | 93 | #if INTERNALIZED_FSLEXYACC_RUNTIME 94 | type Stack<'a>(n) = 95 | #else 96 | type internal Stack<'a>(n) = 97 | #endif 98 | let mutable contents = Array.zeroCreate<'a>(n) 99 | let mutable count = 0 100 | 101 | member buf.Ensure newSize = 102 | let oldSize = Array.length contents 103 | if newSize > oldSize then 104 | let old = contents 105 | contents <- Array.zeroCreate (max newSize (oldSize * 2)); 106 | Array.blit old 0 contents 0 count; 107 | 108 | member buf.Count = count 109 | member buf.Pop() = count <- count - 1 110 | member buf.Peep() = contents.[count - 1] 111 | member buf.Top(n) = [ for x in contents.[max 0 (count-n)..count - 1] -> x ] |> List.rev 112 | member buf.Push(x) = 113 | buf.Ensure(count + 1); 114 | contents.[count] <- x; 115 | count <- count + 1 116 | 117 | member buf.IsEmpty = (count = 0) 118 | #if __DEBUG 119 | member buf.PrintStack() = 120 | for i = 0 to (count - 1) do 121 | #if FX_NO_CONSOLE 122 | () 123 | #else 124 | System.Console.Write("{0}{1}",(contents.[i]),if i=count-1 then ":" else "-") 125 | #endif 126 | #endif 127 | exception RecoverableParseError 128 | exception Accept of obj 129 | 130 | #if __DEBUG 131 | module Flags = 132 | let mutable debug = false 133 | #endif 134 | 135 | #if INTERNALIZED_FSLEXYACC_RUNTIME 136 | module internal Implementation = 137 | #else 138 | module Implementation = 139 | #endif 140 | 141 | // Definitions shared with fsyacc 142 | let anyMarker = 0xffff 143 | let shiftFlag = 0x0000 144 | let reduceFlag = 0x4000 145 | let errorFlag = 0x8000 146 | let acceptFlag = 0xc000 147 | let actionMask = 0xc000 148 | 149 | let actionValue action = action &&& (~~~ actionMask) 150 | let actionKind action = action &&& actionMask 151 | 152 | //------------------------------------------------------------------------- 153 | // Read the tables written by FSYACC. 154 | 155 | type AssocTable(elemTab:uint16[], offsetTab:uint16[]) = 156 | let cache = new Dictionary<_,_>(2000) 157 | 158 | member t.readAssoc (minElemNum,maxElemNum,defaultValueOfAssoc,keyToFind) = 159 | // do a binary chop on the table 160 | let elemNumber : int = (minElemNum+maxElemNum)/2 161 | if elemNumber = maxElemNum 162 | then defaultValueOfAssoc 163 | else 164 | let x = int elemTab.[elemNumber*2] 165 | if keyToFind = x then 166 | int elemTab.[elemNumber*2+1] 167 | elif keyToFind < x then t.readAssoc (minElemNum ,elemNumber,defaultValueOfAssoc,keyToFind) 168 | else t.readAssoc (elemNumber+1,maxElemNum,defaultValueOfAssoc,keyToFind) 169 | 170 | member t.Read(rowNumber ,keyToFind) = 171 | 172 | // First check the sparse lookaside table 173 | // Performance note: without this lookaside table the binary chop in readAssoc 174 | // takes up around 10% of of parsing time 175 | // for parsing intensive samples such as the bootstrapped F# compiler. 176 | // 177 | // Note: using a .NET Dictionary for this int -> int table looks like it could be sub-optimal. 178 | // Some other better sparse lookup table may be better. 179 | let mutable res = 0 180 | let cacheKey = (rowNumber <<< 16) ||| keyToFind 181 | let ok = cache.TryGetValue(cacheKey, &res) 182 | if ok then res 183 | else 184 | let headOfTable = int offsetTab.[rowNumber] 185 | let firstElemNumber = headOfTable + 1 186 | let numberOfElementsInAssoc = int elemTab.[headOfTable*2] 187 | let defaultValueOfAssoc = int elemTab.[headOfTable*2+1] 188 | let res = t.readAssoc (firstElemNumber,(firstElemNumber+numberOfElementsInAssoc),defaultValueOfAssoc,keyToFind) 189 | cache.[cacheKey] <- res 190 | res 191 | 192 | // Read all entries in the association table 193 | // Used during error recovery to find all valid entries in the table 194 | member x.ReadAll(n) = 195 | let headOfTable = int offsetTab.[n] 196 | let firstElemNumber = headOfTable + 1 197 | let numberOfElementsInAssoc = int32 elemTab.[headOfTable*2] 198 | let defaultValueOfAssoc = int elemTab.[headOfTable*2+1] 199 | [ for i in firstElemNumber .. (firstElemNumber+numberOfElementsInAssoc-1) -> 200 | (int elemTab.[i*2], int elemTab.[i*2+1]) ], defaultValueOfAssoc 201 | 202 | type IdxToIdxListTable(elemTab:uint16[], offsetTab:uint16[]) = 203 | 204 | // Read all entries in a row of the table 205 | member x.ReadAll(n) = 206 | let headOfTable = int offsetTab.[n] 207 | let firstElemNumber = headOfTable + 1 208 | let numberOfElements = int32 elemTab.[headOfTable] 209 | [ for i in firstElemNumber .. (firstElemNumber+numberOfElements-1) -> int elemTab.[i] ] 210 | 211 | //------------------------------------------------------------------------- 212 | // interpret the tables emitted by FSYACC. 213 | 214 | [] 215 | [] 216 | type ValueInfo = 217 | val value: obj 218 | val startPos: Position 219 | val endPos: Position 220 | new(value,startPos,endPos) = { value=value; startPos=startPos;endPos=endPos } 221 | 222 | let interpret (tables: Tables<'tok>) lexer (lexbuf : LexBuffer<_>) initialState = 223 | let localStore = new Dictionary() in 224 | localStore.["LexBuffer"] <- lexbuf; 225 | #if __DEBUG 226 | if Flags.debug then System.Console.WriteLine("\nParser: interpret tables"); 227 | #endif 228 | let stateStack : Stack = new Stack<_>(100) 229 | stateStack.Push(initialState); 230 | let valueStack = new Stack(100) 231 | let mutable haveLookahead = false 232 | let mutable lookaheadToken = Unchecked.defaultof<'tok> 233 | let mutable lookaheadEndPos = Unchecked.defaultof 234 | let mutable lookaheadStartPos = Unchecked.defaultof 235 | let mutable finished = false 236 | // After an error occurs, we suppress errors until we've shifted three tokens in a row. 237 | let mutable errorSuppressionCountDown = 0 238 | 239 | // When we hit the end-of-file we don't fail straight away but rather keep permitting shift 240 | // and reduce against the last token in the token stream 20 times or until we've accepted 241 | // or exhausted the stack. This allows error recovery rules of the form 242 | // input : realInput EOF | realInput error EOF | error EOF 243 | // where consuming one EOF to trigger an error doesn't result in overall parse failure 244 | // catastrophe and the loss of intermediate results. 245 | // 246 | let mutable inEofCountDown = false 247 | let mutable eofCountDown = 20 // Number of EOFs to supply at the end for error recovery 248 | // The 100 here means a maximum of 100 elements for each rule 249 | let ruleStartPoss = (Array.zeroCreate 100 : Position array) 250 | let ruleEndPoss = (Array.zeroCreate 100 : Position array) 251 | let ruleValues = (Array.zeroCreate 100 : obj array) 252 | let lhsPos = (Array.zeroCreate 2 : Position array) 253 | let reductions = tables.reductions 254 | let actionTable = new AssocTable(tables.actionTableElements, tables.actionTableRowOffsets) 255 | let gotoTable = new AssocTable(tables.gotos, tables.sparseGotoTableRowOffsets) 256 | let stateToProdIdxsTable = new IdxToIdxListTable(tables.stateToProdIdxsTableElements, tables.stateToProdIdxsTableRowOffsets) 257 | 258 | let parseState = 259 | { new IParseState with 260 | member p.InputRange(n) = ruleStartPoss.[n-1], ruleEndPoss.[n-1]; 261 | member p.InputStartPosition(n) = ruleStartPoss.[n-1] 262 | member p.InputEndPosition(n) = ruleEndPoss.[n-1]; 263 | member p.GetInput(n) = ruleValues.[n-1]; 264 | member p.ResultRange = (lhsPos.[0], lhsPos.[1]); 265 | member p.ParserLocalStore = (localStore :> IDictionary<_,_>); 266 | member p.RaiseError() = raise RecoverableParseError (* NOTE: this binding tests the fairly complex logic associated with an object expression implementing a generic abstract method *) 267 | } 268 | 269 | #if __DEBUG 270 | let report haveLookahead lookaheadToken = 271 | if haveLookahead then sprintf "%A" lookaheadToken 272 | else "[TBC]" 273 | #endif 274 | 275 | // Pop the stack until we can shift the 'error' token. If 'tokenOpt' is given 276 | // then keep popping until we can shift both the 'error' token and the token in 'tokenOpt'. 277 | // This is used at end-of-file to make sure we can shift both the 'error' token and the 'EOF' token. 278 | let rec popStackUntilErrorShifted(tokenOpt) = 279 | // Keep popping the stack until the "error" terminal is shifted 280 | #if __DEBUG 281 | if Flags.debug then System.Console.WriteLine("popStackUntilErrorShifted"); 282 | #endif 283 | if stateStack.IsEmpty then 284 | #if __DEBUG 285 | if Flags.debug then 286 | System.Console.WriteLine("state stack empty during error recovery - generating parse error"); 287 | #endif 288 | failwith "parse error"; 289 | 290 | let currState = stateStack.Peep() 291 | #if __DEBUG 292 | if Flags.debug then 293 | System.Console.WriteLine("In state {0} during error recovery", currState); 294 | #endif 295 | 296 | let action = actionTable.Read(currState, tables.tagOfErrorTerminal) 297 | 298 | if actionKind action = shiftFlag && 299 | (match tokenOpt with 300 | | None -> true 301 | | Some(token) -> 302 | let nextState = actionValue action 303 | actionKind (actionTable.Read(nextState, tables.tagOfToken(token))) = shiftFlag) then 304 | 305 | #if __DEBUG 306 | if Flags.debug then System.Console.WriteLine("shifting error, continuing with error recovery"); 307 | #endif 308 | let nextState = actionValue action 309 | // The "error" non terminal needs position information, though it tends to be unreliable. 310 | // Use the StartPos/EndPos from the lex buffer 311 | valueStack.Push(ValueInfo(box (), lexbuf.StartPos, lexbuf.EndPos)); 312 | stateStack.Push(nextState) 313 | else 314 | if valueStack.IsEmpty then 315 | failwith "parse error"; 316 | #if __DEBUG 317 | if Flags.debug then 318 | System.Console.WriteLine("popping stack during error recovery"); 319 | #endif 320 | valueStack.Pop(); 321 | stateStack.Pop(); 322 | popStackUntilErrorShifted(tokenOpt) 323 | 324 | while not finished do 325 | if stateStack.IsEmpty then 326 | finished <- true 327 | else 328 | let state = stateStack.Peep() 329 | #if __DEBUG 330 | if Flags.debug then (Console.Write("{0} value(state), state ",valueStack.Count); stateStack.PrintStack()) 331 | #endif 332 | let action = 333 | let immediateAction = int tables.immediateActions.[state] 334 | if not (immediateAction = anyMarker) then 335 | // Action has been pre-determined, no need to lookahead 336 | // Expecting it to be a Reduce action on a non-fakeStartNonTerminal ? 337 | immediateAction 338 | else 339 | // Lookahead required to determine action 340 | if not haveLookahead then 341 | if lexbuf.IsPastEndOfStream then 342 | // When the input runs out, keep supplying the last token for eofCountDown times 343 | if eofCountDown>0 then 344 | haveLookahead <- true 345 | eofCountDown <- eofCountDown - 1 346 | inEofCountDown <- true 347 | else 348 | haveLookahead <- false 349 | else 350 | lookaheadToken <- lexer lexbuf 351 | lookaheadStartPos <- lexbuf.StartPos 352 | lookaheadEndPos <- lexbuf.EndPos 353 | haveLookahead <- true; 354 | 355 | let tag = 356 | if haveLookahead then tables.tagOfToken lookaheadToken 357 | else tables.endOfInputTag 358 | 359 | // Printf.printf "state %d\n" state 360 | actionTable.Read(state,tag) 361 | 362 | let kind = actionKind action 363 | if kind = shiftFlag then ( 364 | if errorSuppressionCountDown > 0 then 365 | errorSuppressionCountDown <- errorSuppressionCountDown - 1; 366 | #if __DEBUG 367 | if Flags.debug then Console.WriteLine("shifting, reduced errorRecoverylevel to {0}\n", errorSuppressionCountDown); 368 | #endif 369 | let nextState = actionValue action 370 | if not haveLookahead then failwith "shift on end of input!"; 371 | let data = tables.dataOfToken lookaheadToken 372 | valueStack.Push(ValueInfo(data, lookaheadStartPos, lookaheadEndPos)); 373 | stateStack.Push(nextState); 374 | #if __DEBUG 375 | if Flags.debug then Console.WriteLine("shift/consume input {0}, shift to state {1}", report haveLookahead lookaheadToken, nextState); 376 | #endif 377 | haveLookahead <- false 378 | 379 | ) elif kind = reduceFlag then 380 | let prod = actionValue action 381 | let reduction = reductions.[prod] 382 | let n = int tables.reductionSymbolCounts.[prod] 383 | // pop the symbols, populate the values and populate the locations 384 | #if __DEBUG 385 | if Flags.debug then Console.Write("reduce popping {0} values/states, lookahead {1}", n, report haveLookahead lookaheadToken); 386 | #endif 387 | 388 | lhsPos.[0] <- Position.Empty; 389 | lhsPos.[1] <- Position.Empty; 390 | for i = 0 to n - 1 do 391 | if valueStack.IsEmpty then failwith "empty symbol stack"; 392 | let topVal = valueStack.Peep() 393 | valueStack.Pop(); 394 | stateStack.Pop(); 395 | ruleValues.[(n-i)-1] <- topVal.value; 396 | ruleStartPoss.[(n-i)-1] <- topVal.startPos; 397 | ruleEndPoss.[(n-i)-1] <- topVal.endPos; 398 | if lhsPos.[1] = Position.Empty then lhsPos.[1] <- topVal.endPos; 399 | if not (topVal.startPos = Position.Empty) then lhsPos.[0] <- topVal.startPos 400 | done; 401 | 402 | try 403 | // Printf.printf "reduce %d\n" prod; 404 | let redResult = reduction parseState 405 | valueStack.Push(ValueInfo(redResult, lhsPos.[0], lhsPos.[1])); 406 | let currState = stateStack.Peep() 407 | let newGotoState = gotoTable.Read(int tables.productionToNonTerminalTable.[prod], currState) 408 | stateStack.Push(newGotoState) 409 | #if __DEBUG 410 | if Flags.debug then Console.WriteLine(" goto state {0}", newGotoState) 411 | #endif 412 | with 413 | | Accept res -> 414 | finished <- true; 415 | valueStack.Push(ValueInfo(res, lhsPos.[0], lhsPos.[1])) 416 | | RecoverableParseError -> 417 | #if __DEBUG 418 | if Flags.debug then Console.WriteLine("RecoverableParseErrorException...\n"); 419 | #endif 420 | popStackUntilErrorShifted(None); 421 | // User code raised a Parse_error. Don't report errors again until three tokens have been shifted 422 | errorSuppressionCountDown <- 3 423 | elif kind = errorFlag then ( 424 | #if __DEBUG 425 | if Flags.debug then Console.Write("ErrorFlag... "); 426 | #endif 427 | // Silently discard inputs and don't report errors 428 | // until three tokens in a row have been shifted 429 | #if __DEBUG 430 | if Flags.debug then printfn "error on token '%A' " (if haveLookahead then Some(lookaheadToken) else None); 431 | #endif 432 | if errorSuppressionCountDown > 0 then 433 | // If we're in the end-of-file count down then we're very keen to 'Accept'. 434 | // We can only do this by repeatedly popping the stack until we can shift both an 'error' token 435 | // and an EOF token. 436 | if inEofCountDown && eofCountDown < 10 then 437 | #if __DEBUG 438 | if Flags.debug then printfn "poppin stack, lokking to shift both 'error' and that token, during end-of-file error recovery" ; 439 | #endif 440 | popStackUntilErrorShifted(if haveLookahead then Some(lookaheadToken) else None); 441 | 442 | // If we don't haveLookahead then the end-of-file count down is over and we have no further options. 443 | if not haveLookahead then 444 | failwith "parse error: unexpected end of file" 445 | 446 | #if __DEBUG 447 | if Flags.debug then printfn "discarding token '%A' during error suppression" (if haveLookahead then Some(lookaheadToken) else None); 448 | #endif 449 | // Discard the token 450 | haveLookahead <- false 451 | // Try again to shift three tokens 452 | errorSuppressionCountDown <- 3 453 | else ( 454 | 455 | let currentToken = if haveLookahead then Some(lookaheadToken) else None 456 | let actions,defaultAction = actionTable.ReadAll(state) 457 | let explicit = Set.ofList [ for (tag,_action) in actions -> tag ] 458 | 459 | let shiftableTokens = 460 | [ for (tag,action) in actions do 461 | if (actionKind action) = shiftFlag then 462 | yield tag 463 | if actionKind defaultAction = shiftFlag then 464 | for tag in 0 .. tables.numTerminals-1 do 465 | if not (explicit.Contains(tag)) then 466 | yield tag ] in 467 | 468 | let stateStack = stateStack.Top(12) in 469 | let reducibleProductions = 470 | [ for state in stateStack do 471 | yield stateToProdIdxsTable.ReadAll(state) ] 472 | 473 | let reduceTokens = 474 | [ for (tag,action) in actions do 475 | if actionKind(action) = reduceFlag then 476 | yield tag 477 | if actionKind(defaultAction) = reduceFlag then 478 | for tag in 0 .. tables.numTerminals-1 do 479 | if not (explicit.Contains(tag)) then 480 | yield tag ] in 481 | //let activeRules = stateStack |> List.iter (fun state -> 482 | let errorContext = new ParseErrorContext<'tok>(stateStack,parseState, reduceTokens,currentToken,reducibleProductions, shiftableTokens, "syntax error") 483 | tables.parseError(errorContext); 484 | popStackUntilErrorShifted(None); 485 | errorSuppressionCountDown <- 3; 486 | #if __DEBUG 487 | if Flags.debug then System.Console.WriteLine("generated syntax error and shifted error token, haveLookahead = {0}\n", haveLookahead); 488 | #endif 489 | ) 490 | ) elif kind = acceptFlag then 491 | finished <- true 492 | #if __DEBUG 493 | else 494 | if Flags.debug then System.Console.WriteLine("ALARM!!! drop through case in parser"); 495 | #endif 496 | done; 497 | // OK, we're done - read off the overall generated value 498 | valueStack.Peep().value 499 | 500 | #if INTERNALIZED_FSLEXYACC_RUNTIME 501 | type internal Tables<'tok> with 502 | #else 503 | type Tables<'tok> with 504 | #endif 505 | member tables.Interpret (lexer,lexbuf,initialState) = 506 | Implementation.interpret tables lexer lexbuf initialState 507 | 508 | #if INTERNALIZED_FSLEXYACC_RUNTIME 509 | module internal ParseHelpers = 510 | #else 511 | module ParseHelpers = 512 | #endif 513 | let parse_error (_s:string) = () 514 | let parse_error_rich = (None : (ParseErrorContext<_> -> unit) option) 515 | -------------------------------------------------------------------------------- /JsonPi.sln: -------------------------------------------------------------------------------- 1 |  2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio 15 4 | VisualStudioVersion = 15.0.27428.2037 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "JsonPiInterpreter", "JsonPiInterpreter\JsonPiInterpreter.fsproj", "{02F6511D-9D91-422C-A900-8A6B0FBAD141}" 7 | EndProject 8 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FsLexYacc.Runtime", "FsLexYacc.Runtime\FsLexYacc.Runtime.fsproj", "{6895D0C9-EC0A-4B11-9A4B-84ABBC2DDB29}" 9 | EndProject 10 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Tests", "Tests\Tests.fsproj", "{9F3F3C89-4DEF-46EA-AE8F-DA0E1F87D04B}" 11 | EndProject 12 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Examples", "Examples\Examples.fsproj", "{D847EFEA-1D77-46AA-8B42-6DE374C4D328}" 13 | EndProject 14 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "JsonPiREPL", "JsonPiREPL\JsonPiREPL.fsproj", "{D27FDD26-BB7A-49F5-8454-EC492E161EDC}" 15 | EndProject 16 | Global 17 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 18 | Debug|Any CPU = Debug|Any CPU 19 | Release|Any CPU = Release|Any CPU 20 | EndGlobalSection 21 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 22 | {02F6511D-9D91-422C-A900-8A6B0FBAD141}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 23 | {02F6511D-9D91-422C-A900-8A6B0FBAD141}.Debug|Any CPU.Build.0 = Debug|Any CPU 24 | {02F6511D-9D91-422C-A900-8A6B0FBAD141}.Release|Any CPU.ActiveCfg = Release|Any CPU 25 | {02F6511D-9D91-422C-A900-8A6B0FBAD141}.Release|Any CPU.Build.0 = Release|Any CPU 26 | {6895D0C9-EC0A-4B11-9A4B-84ABBC2DDB29}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 27 | {6895D0C9-EC0A-4B11-9A4B-84ABBC2DDB29}.Debug|Any CPU.Build.0 = Debug|Any CPU 28 | {6895D0C9-EC0A-4B11-9A4B-84ABBC2DDB29}.Release|Any CPU.ActiveCfg = Release|Any CPU 29 | {6895D0C9-EC0A-4B11-9A4B-84ABBC2DDB29}.Release|Any CPU.Build.0 = Release|Any CPU 30 | {9F3F3C89-4DEF-46EA-AE8F-DA0E1F87D04B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 31 | {9F3F3C89-4DEF-46EA-AE8F-DA0E1F87D04B}.Debug|Any CPU.Build.0 = Debug|Any CPU 32 | {9F3F3C89-4DEF-46EA-AE8F-DA0E1F87D04B}.Release|Any CPU.ActiveCfg = Release|Any CPU 33 | {9F3F3C89-4DEF-46EA-AE8F-DA0E1F87D04B}.Release|Any CPU.Build.0 = Release|Any CPU 34 | {D847EFEA-1D77-46AA-8B42-6DE374C4D328}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 35 | {D847EFEA-1D77-46AA-8B42-6DE374C4D328}.Debug|Any CPU.Build.0 = Debug|Any CPU 36 | {D847EFEA-1D77-46AA-8B42-6DE374C4D328}.Release|Any CPU.ActiveCfg = Release|Any CPU 37 | {D847EFEA-1D77-46AA-8B42-6DE374C4D328}.Release|Any CPU.Build.0 = Release|Any CPU 38 | {D27FDD26-BB7A-49F5-8454-EC492E161EDC}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 39 | {D27FDD26-BB7A-49F5-8454-EC492E161EDC}.Debug|Any CPU.Build.0 = Debug|Any CPU 40 | {D27FDD26-BB7A-49F5-8454-EC492E161EDC}.Release|Any CPU.ActiveCfg = Release|Any CPU 41 | {D27FDD26-BB7A-49F5-8454-EC492E161EDC}.Release|Any CPU.Build.0 = Release|Any CPU 42 | EndGlobalSection 43 | GlobalSection(SolutionProperties) = preSolution 44 | HideSolutionNode = FALSE 45 | EndGlobalSection 46 | GlobalSection(ExtensibilityGlobals) = postSolution 47 | SolutionGuid = {CA0EC12D-21D3-49E8-A48C-E196750101D6} 48 | EndGlobalSection 49 | EndGlobal 50 | -------------------------------------------------------------------------------- /JsonPiInterpreter/AssemblyInfo.fs: -------------------------------------------------------------------------------- 1 | namespace JsonPiInterpreter.AssemblyInfo 2 | 3 | open System.Reflection 4 | open System.Runtime.CompilerServices 5 | open System.Runtime.InteropServices 6 | 7 | // General Information about an assembly is controlled through the following 8 | // set of attributes. Change these attribute values to modify the information 9 | // associated with an assembly. 10 | [] 11 | [] 12 | [] 13 | [] 14 | [] 15 | [] 16 | [] 17 | [] 18 | 19 | // Setting ComVisible to false makes the types in this assembly not visible 20 | // to COM components. If you need to access a type in this assembly from 21 | // COM, set the ComVisible attribute to true on that type. 22 | [] 23 | 24 | // The following GUID is for the ID of the typelib if this project is exposed to COM 25 | [] 26 | 27 | // Version information for an assembly consists of the following four values: 28 | // 29 | // Major Version 30 | // Minor Version 31 | // Build Number 32 | // Revision 33 | // 34 | // You can specify all the values or you can default the Build and Revision Numbers 35 | // by using the '*' as shown below: 36 | // [] 37 | [] 38 | [] 39 | 40 | do 41 | () -------------------------------------------------------------------------------- /JsonPiInterpreter/JsonPiInterpreter.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | netcoreapp2.0 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /JsonPiInterpreter/PiJsonData.fs: -------------------------------------------------------------------------------- 1 | module JsonPi.Data 2 | 3 | open System 4 | open System.IO 5 | 6 | type PiJsonPair = { 7 | Label : string; 8 | mutable Value : obj 9 | } 10 | 11 | type PiJsonObject = PiJsonPair list 12 | 13 | type PiJsonArray = obj array 14 | 15 | type PiIdentifier = string 16 | 17 | type IPiExtension = 18 | abstract member OnOutput : PiJsonObject -> PiJsonArray -> PiJsonObject option 19 | abstract member OnInput : PiJsonObject -> PiJsonArray -> PiJsonArray -> PiJsonObject option 20 | 21 | type PiExtensionResolver = (PiIdentifier -> obj option -> IPiExtension option) 22 | 23 | let GetMemberValue<'T> (json:PiJsonObject) (label:string) = 24 | let {Value = value} = json |> List.find ( fun {Label=l} -> l = label) 25 | value :?> 'T 26 | 27 | let TryGetMemberValue<'T> (json:PiJsonObject) (label:string) = 28 | match json |> List.tryFind ( fun {Label=l} -> l = label) with 29 | | Some({Value = value}) -> Some(value :?> 'T) 30 | | None -> None 31 | 32 | let SetMemberValue (json:PiJsonObject) (label:string) (value:obj) = 33 | match json |> List.tryFind ( fun {Label=l} -> l = label) with 34 | | Some(m) -> 35 | m.Value <- value 36 | | None -> 37 | failwith "Member not found" 38 | 39 | let CreateName (id:PiIdentifier) (nametype:PiIdentifier option) (data:obj option) = 40 | match (nametype, data) with 41 | | (None, None) -> 42 | [ 43 | { Label="Type"; Value="PiName" :> obj}; 44 | { Label="Id"; Value=id :> obj}; 45 | ] 46 | | (Some(t), None) -> 47 | [ 48 | { Label=String.Intern("Type"); Value="PiName" :> obj}; 49 | { Label=String.Intern("Id"); Value=id :> obj}; 50 | { Label=String.Intern("NameType"); Value=t :> obj}; 51 | ] 52 | | (None, Some(d)) -> 53 | [ 54 | { Label=String.Intern("Type"); Value="PiName" :> obj}; 55 | { Label=String.Intern("Id"); Value=id :> obj}; 56 | { Label=String.Intern("Data"); Value=d}; 57 | ] 58 | | (Some(t), Some(d)) -> 59 | [ 60 | { Label=String.Intern("Type"); Value="PiName" :> obj}; 61 | { Label=String.Intern("Id"); Value=id :> obj}; 62 | { Label=String.Intern("NameType"); Value=t :> obj}; 63 | { Label=String.Intern("Data"); Value=d}; 64 | ] 65 | 66 | let (|PiName|_|) (data:obj) = 67 | match data with 68 | | :? PiJsonObject as json -> 69 | match GetMemberValue json "Type" with 70 | | "PiName" -> Some( (GetMemberValue json "Id", TryGetMemberValue json "NameType", TryGetMemberValue json "Data") ) 71 | | _ -> None 72 | | _ -> None 73 | 74 | let CreatePrefixUnobservable () = 75 | [ 76 | { Label="Type"; Value="Prefix.Unobservable" :> obj}; 77 | ]; 78 | 79 | let (|PrefixUnobservable|_|) (data:obj) = 80 | match data with 81 | | :? PiJsonObject as json -> 82 | match GetMemberValue json "Type" with 83 | | "Prefix.Unobservable" -> Some() 84 | | _ -> None 85 | | _ -> None 86 | 87 | let CreatePrefixOutput (channel:PiJsonObject) (paramList: PiJsonObject list) = 88 | let paramArray = paramList |> List.map (fun p -> p :> obj) |> List.toArray 89 | [ 90 | { Label="Type"; Value="Prefix.Output" :> obj}; 91 | { Label="Channel"; Value=channel :> obj}; 92 | { Label="Params"; Value=paramArray :> obj}; 93 | ]; 94 | 95 | let (|PrefixOutput|_|) (data:obj) = 96 | match data with 97 | | :? PiJsonObject as json -> 98 | match GetMemberValue json "Type" with 99 | | "Prefix.Output" -> Some( (GetMemberValue json "Channel", GetMemberValue json "Params") ) 100 | | _ -> None 101 | | _ -> None 102 | 103 | let CreatePrefixInput (channel:PiJsonObject) (typedparamList:PiJsonObject list) = 104 | let typedparamArray = typedparamList |> List.map (fun p -> p :> obj) |> List.toArray 105 | [ 106 | { Label="Type"; Value="Prefix.Input" :> obj}; 107 | { Label="Channel"; Value=channel :> obj}; 108 | { Label="Params"; Value=typedparamArray :> obj}; 109 | ]; 110 | 111 | let (|PrefixInput|_|) (data:obj) = 112 | match data with 113 | | :? PiJsonObject as json -> 114 | match GetMemberValue json "Type" with 115 | | "Prefix.Input" -> Some( (GetMemberValue json "Channel", GetMemberValue json "Params") ) 116 | | _ -> None 117 | | _ -> None 118 | 119 | let CreatePrefixMatch (leftParams:PiJsonObject list) (rightParams:PiJsonObject list) (prefix:PiJsonObject) = 120 | let leftParamArray = leftParams |> List.map (fun p -> p :> obj) |> List.toArray 121 | let rightParamArray = rightParams |> List.map (fun p -> p :> obj) |> List.toArray 122 | [ 123 | { Label="Type"; Value="Prefix.Match" :> obj}; 124 | { Label="ParamsLeft"; Value=leftParamArray :> obj}; 125 | { Label="ParamsRight"; Value=rightParamArray :> obj}; 126 | { Label="Prefix"; Value=prefix :> obj}; 127 | ]; 128 | 129 | let (|PrefixMatch|_|) (data:obj) = 130 | match data with 131 | | :? PiJsonObject as json -> 132 | match GetMemberValue json "Type" with 133 | | "Prefix.Match" -> Some( (GetMemberValue json "ParamsLeft", GetMemberValue json "ParamsRight", GetMemberValue json "Prefix") ) 134 | | _ -> None 135 | | _ -> None 136 | 137 | let rec GetPrefixChannel (prefix:PiJsonObject) = 138 | match prefix with 139 | | PrefixInput (channel, _) 140 | | PrefixOutput (channel, _) -> channel 141 | | PrefixMatch (_, _, matchPfx) -> GetPrefixChannel matchPfx 142 | | _ -> failwith "bad" 143 | 144 | let CreateSummationInaction() = 145 | [ 146 | { Label="Type"; Value="Summation.Inaction" :> obj}; 147 | ]; 148 | 149 | let (|SummationInaction|_|) (data:obj) = 150 | match data with 151 | | :? PiJsonObject as json -> 152 | match GetMemberValue json "Type" with 153 | | "Summation.Inaction" -> Some() 154 | | _ -> None 155 | | _ -> None 156 | 157 | let CreateSummationPrefix (prefix:PiJsonObject) (proc:PiJsonObject) = 158 | [ 159 | { Label="Type"; Value="Summation.Prefix" :> obj}; 160 | { Label="Prefix"; Value=prefix :> obj}; 161 | { Label="Process"; Value=proc :> obj}; 162 | ]; 163 | 164 | let (|SummationPrefix|_|) (data:obj) = 165 | match data with 166 | | :? PiJsonObject as json -> 167 | match GetMemberValue json "Type" with 168 | | "Summation.Prefix" -> Some( (GetMemberValue json "Prefix", GetMemberValue json "Process") ) 169 | | _ -> None 170 | | _ -> None 171 | 172 | let CreateSummationSum (sums:PiJsonObject list) = 173 | let sumsArray = sums |> List.map (fun s -> s :> obj) |> List.toArray 174 | [ 175 | { Label="Type"; Value="Summation.Sum" :> obj}; 176 | { Label="Summations"; Value=sumsArray :> obj}; 177 | ]; 178 | 179 | let (|SummationSum|_|) (data:obj) = 180 | match data with 181 | | :? PiJsonObject as json -> 182 | match GetMemberValue json "Type" with 183 | | "Summation.Sum" -> Some(GetMemberValue json "Summations" ) 184 | | _ -> None 185 | | _ -> None 186 | 187 | let CreateProcessBindingRef (id:PiIdentifier) = 188 | [ 189 | { Label="Type"; Value="Process.BindingRef" :> obj}; 190 | { Label="Id"; Value=id :> obj}; 191 | ]; 192 | 193 | let (|ProcessBindingRef|_|) (data:obj) = 194 | match data with 195 | | :? PiJsonObject as json -> 196 | match GetMemberValue json "Type" with 197 | | "Process.BindingRef" -> Some(GetMemberValue json "Id" ) 198 | | _ -> None 199 | | _ -> None 200 | 201 | let CreateProcessModuleRef (id:PiIdentifier) (inAssemblyOpt:PiIdentifier option) (continuation:PiJsonObject) = 202 | match inAssemblyOpt with 203 | | Some(inAssembly) -> 204 | [ 205 | { Label="Type"; Value="Process.ModuleRef" :> obj}; 206 | { Label="Id"; Value=id :> obj}; 207 | { Label="InAssembly"; Value=inAssembly :> obj}; 208 | { Label="Continuation"; Value=continuation :> obj}; 209 | ]; 210 | | None -> 211 | [ 212 | { Label="Type"; Value="Process.ModuleRef" :> obj}; 213 | { Label="Id"; Value=id :> obj}; 214 | { Label="Continuation"; Value=continuation :> obj}; 215 | ]; 216 | 217 | let (|ProcessModuleRef|_|) (data:obj) = 218 | match data with 219 | | :? PiJsonObject as json -> 220 | match GetMemberValue json "Type" with 221 | | "Process.ModuleRef" -> Some( (GetMemberValue json "Id", TryGetMemberValue json "InAssembly", GetMemberValue json "Continuation") ) 222 | | _ -> None 223 | | _ -> None 224 | 225 | let CreateProcessBinding (id:PiIdentifier) (proc:PiJsonObject) (continuation:PiJsonObject) = 226 | [ 227 | { Label="Type"; Value="Process.Binding" :> obj}; 228 | { Label="Id"; Value=id :> obj}; 229 | { Label="Process"; Value=proc :> obj}; 230 | { Label="Continuation"; Value=continuation :> obj}; 231 | ]; 232 | 233 | let (|ProcessBinding|_|) (data:obj) = 234 | match data with 235 | | :? PiJsonObject as json -> 236 | match GetMemberValue json "Type" with 237 | | "Process.Binding" -> Some( (GetMemberValue json "Id", GetMemberValue json "Process", GetMemberValue json "Continuation") ) 238 | | _ -> None 239 | | _ -> None 240 | 241 | let CreateProcessSummation (sum:PiJsonObject) = 242 | [ 243 | { Label="Type"; Value="Process.Summation" :> obj}; 244 | { Label="Summation"; Value=sum :> obj}; 245 | ]; 246 | 247 | let (|ProcessSummation|_|) (data:obj) = 248 | match data with 249 | | :? PiJsonObject as json -> 250 | match GetMemberValue json "Type" with 251 | | "Process.Summation" -> Some( GetMemberValue json "Summation" ) 252 | | _ -> None 253 | | _ -> None 254 | 255 | let CreateProcessRestriction (name:PiJsonObject) (continuation:PiJsonObject) = 256 | [ 257 | { Label="Type"; Value="Process.Restriction" :> obj}; 258 | { Label="Name"; Value=name :> obj}; 259 | { Label="Continuation"; Value=continuation :> obj}; 260 | ]; 261 | 262 | let (|ProcessRestriction|_|) (data:obj) = 263 | match data with 264 | | :? PiJsonObject as json -> 265 | match GetMemberValue json "Type" with 266 | | "Process.Restriction" -> Some( (GetMemberValue json "Name", GetMemberValue json "Continuation") ) 267 | | _ -> None 268 | | _ -> None 269 | 270 | let CreateProcessComposition (left:PiJsonObject) (right:PiJsonObject) = 271 | [ 272 | { Label="Type"; Value="Process.Composition" :> obj}; 273 | { Label="ProcessLeft"; Value=left :> obj}; 274 | { Label="ProcessRight"; Value=right :> obj}; 275 | ]; 276 | 277 | let (|ProcessComposition|_|) (data:obj) = 278 | match data with 279 | | :? PiJsonObject as json -> 280 | match GetMemberValue json "Type" with 281 | | "Process.Composition" -> Some( (GetMemberValue json "ProcessLeft", GetMemberValue json "ProcessRight") ) 282 | | _ -> None 283 | | _ -> None 284 | 285 | let CreateProcessReplication (proc:PiJsonObject) = 286 | [ 287 | { Label="Type"; Value="Process.Replication" :> obj}; 288 | { Label="Process"; Value=proc :> obj}; 289 | ]; 290 | 291 | let (|ProcessReplication|_|) (data:obj) = 292 | match data with 293 | | :? PiJsonObject as json -> 294 | match GetMemberValue json "Type" with 295 | | "Process.Replication" -> Some(GetMemberValue json "Process" ) 296 | | _ -> None 297 | | _ -> None 298 | 299 | let CreateModule (id:PiIdentifier) (proc:PiJsonObject) = 300 | [ 301 | { Label="Type"; Value="PiModule" :> obj}; 302 | { Label="Id"; Value=id :> obj}; 303 | { Label="Process"; Value=proc :> obj}; 304 | ]; 305 | 306 | let (|PiModule|_|) (data:obj) = 307 | match data with 308 | | :? PiJsonObject as json -> 309 | match GetMemberValue json "Type" with 310 | | "PiModule" -> Some( (GetMemberValue json "Id", GetMemberValue json "Process") ) 311 | | _ -> None 312 | | _ -> None 313 | 314 | let CreateAssembly (id:PiIdentifier) (modules: PiJsonObject list) = 315 | let modulesArray = modules |> List.map (fun m -> m :> obj) |> List.toArray 316 | [ 317 | { Label="Type"; Value="PiAssembly" :> obj}; 318 | { Label="Id"; Value=id :> obj}; 319 | { Label="Modules"; Value=modulesArray :> obj}; 320 | ]; 321 | 322 | let (|PiAssembly|_|) (data:obj) = 323 | match data with 324 | | :? PiJsonObject as json -> 325 | match GetMemberValue json "Type" with 326 | | "PiAssembly" -> Some( (GetMemberValue json "Id", GetMemberValue json "Modules") ) 327 | | _ -> None 328 | | _ -> None 329 | 330 | let (|AssemblyEntryProcess|_|) (json:PiJsonObject) = 331 | match json with 332 | | PiAssembly (idAsm, modules) -> 333 | modules |> 334 | Array.tryPick 335 | ( function 336 | | PiModule (idMod, proc) when idMod = "" -> 337 | Some(proc) 338 | | _ -> None 339 | ) 340 | | _ -> None 341 | 342 | type PiContext private (start:PiJsonObject, pl:PiJsonObject list) = 343 | let mutable proc = start 344 | let mutable (parents:PiJsonObject list) = pl 345 | 346 | let tryFindModule (modId:PiIdentifier) (inAsmOpt:PiIdentifier option) (assemblies:PiJsonObject seq) = 347 | assemblies |> 348 | Seq.rev |> 349 | Seq.tryPick (fun asm -> 350 | let asmId = GetMemberValue asm "Id" 351 | let idMatch = 352 | match inAsmOpt with 353 | | Some(inAsm) -> 354 | inAsm = asmId 355 | | None -> 356 | true 357 | if idMatch then 358 | let modules = GetMemberValue asm "Modules" 359 | modules |> 360 | Seq.tryPick (fun m -> 361 | match m with 362 | | PiModule(id, proc) when modId = id -> 363 | Some(proc) 364 | | _ -> None 365 | ) 366 | else 367 | None 368 | ) 369 | 370 | let rec tryFindExport (bindingId:PiIdentifier) (json:PiJsonObject) (assemblies:PiJsonObject seq) = 371 | match json with 372 | | PiModule (id, proc) -> 373 | tryFindExport bindingId proc assemblies 374 | | ProcessBinding (id, proc, continuation) -> 375 | if id = bindingId then 376 | Some(proc) 377 | else 378 | tryFindExport bindingId continuation assemblies 379 | | ProcessModuleRef (modId, inAsmOpt, _) -> 380 | match tryFindModule modId inAsmOpt assemblies with 381 | | Some(m) -> tryFindExport bindingId m assemblies 382 | | None -> failwith "unable to find module" 383 | | _ -> None 384 | 385 | let rec tryFindBinding (id:PiIdentifier) (l:PiJsonObject list) (assemblies:PiJsonObject seq) = 386 | match l with 387 | | [] -> None 388 | | h :: t -> 389 | match h with 390 | | ProcessBinding (bindingId, proc, _) when bindingId = id -> 391 | Some(proc) 392 | | ProcessModuleRef (modId, inAsmOpt, _) -> 393 | // look for an export 394 | match tryFindModule modId inAsmOpt assemblies with 395 | | Some(m) -> tryFindExport id m assemblies 396 | | None -> failwith "unable to find module" 397 | | _ -> 398 | tryFindBinding id t assemblies 399 | 400 | new(start:PiJsonObject) = PiContext(start, []) 401 | 402 | member this.CurrentProcess with get() = proc 403 | 404 | member this.Parent 405 | with get() = 406 | match parents with 407 | | [] -> None 408 | | h :: _ -> Some(h) 409 | 410 | member this.SplitComposition(left:PiJsonObject, right:PiJsonObject) = 411 | this.NextProcess(left) 412 | let contextRight = PiContext(right, parents) 413 | (this, contextRight) 414 | 415 | member this.TryFindBinding(id:PiIdentifier, assemblies:PiJsonObject seq) = 416 | tryFindBinding id parents assemblies 417 | 418 | member this.TryFindModule(modId:PiIdentifier, inAsmOpt:PiIdentifier option, assemblies:PiJsonObject seq) = 419 | tryFindModule modId inAsmOpt assemblies 420 | 421 | member this.NextChild(continuation:PiJsonObject) = 422 | parents <- proc :: parents 423 | proc <- continuation 424 | 425 | member this.NextProcess(continuation:PiJsonObject) = 426 | proc <- continuation 427 | 428 | member this.AsJson() : PiJsonObject = 429 | let parentsArray = parents |> List.map (fun m -> m :> obj) |> List.toArray 430 | [ 431 | { Label="Type"; Value="PiContext" :> obj}; 432 | { Label="Proc"; Value=proc :> obj}; 433 | { Label="Parents"; Value=parentsArray :> obj}; 434 | ]; 435 | 436 | static member FromJson(json:PiJsonObject) = 437 | match TryGetMemberValue json "Type" with 438 | | Some("PiContext") -> 439 | let proc = 440 | match TryGetMemberValue json "Proc" with 441 | | Some(p) -> p 442 | | None -> failwith "bad" 443 | let parents = 444 | match TryGetMemberValue json "Parents" with 445 | | Some(p) -> p |> Array.toList |> List.map (fun x -> x :?> PiJsonObject) 446 | | None -> failwith "bad" 447 | PiContext(proc, parents) 448 | | _ -> failwith "bad" 449 | 450 | type GuardedContext = 451 | { 452 | CurrentContext : PiContext; 453 | Prefix : PiJsonObject; 454 | Continuation : PiJsonObject; 455 | } with 456 | member this.AsJson() : PiJsonObject = 457 | [ 458 | { Label="Type"; Value="GuardedContext" :> obj}; 459 | { Label="CurrentContext"; Value=this.CurrentContext.AsJson() :> obj}; 460 | { Label="Prefix"; Value=this.Prefix :> obj}; 461 | { Label="Continuation"; Value=this.Continuation :> obj}; 462 | ]; 463 | 464 | static member FromJson(json:PiJsonObject) = 465 | match TryGetMemberValue json "Type" with 466 | | Some("GuardedContext") -> 467 | let context = 468 | match TryGetMemberValue json "CurrentContext" with 469 | | Some(c) -> PiContext.FromJson(c) 470 | | None -> failwith "bad" 471 | let prefix = 472 | match TryGetMemberValue json "Prefix" with 473 | | Some(p) -> p 474 | | None -> failwith "bad" 475 | let continuation = 476 | match TryGetMemberValue json "Continuation" with 477 | | Some(c) -> c 478 | | None -> failwith "bad" 479 | { CurrentContext=context; Prefix=prefix; Continuation=continuation; } 480 | | _ -> failwith "bad" 481 | 482 | type TransitionContext = 483 | | ChannelMatch of Out : GuardedContext * 484 | Inp : GuardedContext 485 | | Unobservable of Guard : GuardedContext 486 | | NoTransition 487 | with 488 | member this.AsJson() : PiJsonObject = 489 | match this with 490 | | TransitionContext.ChannelMatch(outGuard, inpGuard) -> 491 | [ 492 | { Label="Type"; Value="TransitionContext.ChannelMatch" :> obj}; 493 | { Label="Out"; Value=outGuard.AsJson() :> obj }; 494 | { Label="Inp"; Value=inpGuard.AsJson() :> obj }; 495 | ]; 496 | | TransitionContext.Unobservable(guard) -> 497 | [ 498 | { Label="Type"; Value="TransitionContext.Unobservable" :> obj}; 499 | { Label="Guard"; Value=guard.AsJson() :> obj }; 500 | ]; 501 | | TransitionContext.NoTransition -> 502 | [ 503 | { Label="Type"; Value="TransitionContext.NoTransition" :> obj}; 504 | ]; 505 | 506 | static member FromJson(json:PiJsonObject) = 507 | match TryGetMemberValue json "Type" with 508 | | Some("TransitionContext.ChannelMatch") -> 509 | let outGuard = 510 | match TryGetMemberValue json "Out" with 511 | | Some(g) -> GuardedContext.FromJson(g) 512 | | None -> failwith "bad" 513 | let inpGuard = 514 | match TryGetMemberValue json "Inp" with 515 | | Some(g) -> GuardedContext.FromJson(g) 516 | | None -> failwith "bad" 517 | TransitionContext.ChannelMatch(outGuard, inpGuard) 518 | | Some("TransitionContext.Unobservable") -> 519 | let guard = 520 | match TryGetMemberValue json "Guard" with 521 | | Some(g) -> GuardedContext.FromJson(g) 522 | | None -> failwith "bad" 523 | TransitionContext.Unobservable(guard) 524 | | Some("TransitionContext.NoTransition") -> 525 | TransitionContext.NoTransition 526 | | _ -> failwith "bad" 527 | 528 | type PiCodeWriter (tw:TextWriter) = 529 | let mutable count = 0 530 | 531 | let elide () = 532 | tw.Write("...") 533 | count <- count + 3 534 | 535 | member this.NextColumn(elideAt:int) = 536 | for i = count to elideAt+3 do 537 | tw.Write(" ") 538 | 539 | member this.Write(s:string, elideAt:int) = 540 | if count < elideAt then 541 | let sout = s.Substring(0, Math.Min(s.Length, elideAt - count)) 542 | tw.Write(sout) 543 | count <- count + sout.Length 544 | if count = elideAt then 545 | elide() 546 | 547 | member this.WriteName(name, elideAt) = 548 | match name with 549 | | PiName(id, _, _) -> this.Write(id, elideAt) 550 | | _ -> () 551 | 552 | member this.WriteParams (names:PiJsonArray, elideAt) = 553 | match names.Length with 554 | | 0 -> () 555 | | length -> 556 | for i = 0 to length - 2 do 557 | this.WriteName(names.[i], elideAt) 558 | this.Write(",", elideAt) 559 | this.WriteName(names.[length-1], elideAt) 560 | 561 | member this.WritePrefix(data:obj, elideAt:int) = 562 | match data with 563 | | PrefixUnobservable -> 564 | this.Write("TAU", elideAt) 565 | | PrefixOutput(channel, outNames) -> 566 | this.WriteName(channel, elideAt) 567 | this.Write("<", elideAt) 568 | this.WriteParams(outNames, elideAt) 569 | this.Write(">", elideAt) 570 | | PrefixInput(channel, inpNames) -> 571 | this.WriteName(channel, elideAt) 572 | this.Write("(", elideAt) 573 | this.WriteParams(inpNames, elideAt) 574 | this.Write(")", elideAt) 575 | | PrefixMatch(pl, pr, pfx) -> 576 | this.Write("[", elideAt) 577 | this.Write("]", elideAt) 578 | this.WriteParams(pl, elideAt) 579 | this.WriteParams(pr, elideAt) 580 | this.WritePrefix(pfx, elideAt) 581 | | _ -> failwith "bad" 582 | 583 | member this.WriteSummation (data:obj, elideAt:int) = 584 | match data with 585 | | SummationInaction -> 586 | this.Write(";", elideAt) 587 | | SummationPrefix(pfx, continuation) -> 588 | this.WritePrefix(pfx, elideAt) 589 | 590 | let inaction = 591 | match continuation with 592 | | ProcessSummation(s) -> 593 | match s with 594 | | SummationInaction -> true 595 | | _ -> false 596 | | _ -> false 597 | 598 | if inaction 599 | then 600 | this.Write(";", elideAt) 601 | else 602 | this.Write(" ", elideAt) 603 | this.WriteProcess(continuation, elideAt) 604 | | SummationSum(sums) -> 605 | elide() 606 | | _ -> failwith "bad" 607 | 608 | member this.WriteProcess (data:obj, elideAt:int) = 609 | match data with 610 | | ProcessSummation(s) -> 611 | this.WriteSummation(s, elideAt) 612 | | ProcessRestriction(n, continuation) -> 613 | this.Write("new (", elideAt) 614 | this.WriteName(n, elideAt) 615 | this.Write(") ", elideAt) 616 | this.WriteProcess(continuation, elideAt) 617 | | ProcessComposition(pl, pr) -> 618 | this.WriteProcess(pl, elideAt) 619 | this.Write(" | ", elideAt) 620 | this.WriteProcess(pr, elideAt) 621 | | ProcessReplication(p) -> 622 | this.Write("!(", elideAt) 623 | this.WriteProcess(p, elideAt) 624 | this.Write(")", elideAt) 625 | | _ -> 626 | () 627 | 628 | member this.Reset() = 629 | count <- 0 630 | 631 | type PiJsonWriter (tw:TextWriter, depthOpt:int option) = 632 | let mutable depth = 0 633 | 634 | let IncDepth() = depth <- depth + 1 635 | let DecDepth() = depth <- depth - 1 636 | 637 | new (tw:TextWriter) = PiJsonWriter(tw, None) 638 | 639 | member this.WriteNull() = 640 | tw.Write("null") 641 | 642 | member this.WriteBool(value:bool) = 643 | tw.Write(if value then "true" else "false") 644 | 645 | member this.WriteInt(value:int) = 646 | tw.Write(value) 647 | 648 | member this.WriteFloat(value:float) = 649 | tw.Write(value) 650 | 651 | member this.WriteString(s:string) = 652 | // todo: better json encoding of string 653 | tw.Write("\"") 654 | tw.Write(s.Replace("\"", "\\\"")) 655 | tw.Write("\"") 656 | 657 | member this.Write(json:PiJsonObject) = 658 | match depthOpt with 659 | | Some(maxdepth) when maxdepth <= depth -> 660 | tw.Write("{ ... }") 661 | | _ -> 662 | IncDepth() 663 | tw.Write("{") 664 | let length = json.Length 665 | json |> 666 | List.iteri (fun i m -> 667 | this.Write(m) 668 | if i < length - 1 then 669 | tw.Write(",") 670 | ) 671 | tw.Write("}") 672 | DecDepth() 673 | 674 | member this.Write({Label=label; Value=value;}:PiJsonPair) = 675 | this.WriteString(label) 676 | tw.Write(":") 677 | this.Write(value) 678 | 679 | member this.Write(json:PiJsonArray) = 680 | match depthOpt with 681 | | Some(maxdepth) when maxdepth <= depth -> 682 | tw.Write("[ ... ]") 683 | | _ -> 684 | IncDepth() 685 | tw.Write("[") 686 | match json.Length with 687 | | 0 -> () 688 | | length -> 689 | for i = 0 to length - 2 do 690 | this.Write(json.[i]) 691 | tw.Write(",") 692 | this.Write(json.[length-1]) 693 | tw.Write("]") 694 | DecDepth() 695 | 696 | member this.Write(context:PiContext) = 697 | let json = context.AsJson() 698 | this.Write(json) 699 | 700 | member this.Write(guard:GuardedContext) = 701 | let json = guard.AsJson() 702 | this.Write(json) 703 | 704 | member this.Write(txc:TransitionContext) = 705 | let json = txc.AsJson() 706 | this.Write(json) 707 | 708 | member this.Write(data:obj) = 709 | match data with 710 | | null -> this.WriteNull() 711 | | :? string as json -> this.WriteString(json) 712 | | :? int as json -> this.WriteInt(json) 713 | | :? float as json -> this.WriteFloat(json) 714 | | :? bool as json -> this.WriteBool(json) 715 | | :? PiJsonObject as json -> this.Write(json) 716 | | :? PiJsonArray as json -> this.Write(json) 717 | | :? PiContext as context -> this.Write(context) 718 | | :? GuardedContext as guard -> this.Write(guard) 719 | | :? TransitionContext as txc -> this.Write(txc) 720 | | _ -> failwith "unexpected json data type" 721 | 722 | 723 | type PiFSharpWriter (tw:TextWriter, depthOpt:int option) = 724 | let mutable depth = 0 725 | 726 | let IncDepth() = depth <- depth + 1 727 | let DecDepth() = depth <- depth - 1 728 | 729 | new (tw:TextWriter) = PiFSharpWriter(tw, None) 730 | 731 | member this.WriteNull() = 732 | tw.Write("null") 733 | 734 | member this.WriteBool(value:bool) = 735 | tw.Write(if value then "true" else "false") 736 | 737 | member this.WriteInt(value:int) = 738 | tw.Write(value) 739 | 740 | member this.WriteFloat(value:float) = 741 | tw.Write(value) 742 | 743 | member this.WriteString(s:string) = 744 | // todo: better json encoding of string 745 | tw.Write("\"") 746 | tw.Write(s.Replace("\"", "\\\"")) 747 | tw.Write("\"") 748 | 749 | member this.Write(json:PiJsonObject) = 750 | match depthOpt with 751 | | Some(maxdepth) when maxdepth <= depth -> 752 | tw.Write("[]") 753 | | _ -> 754 | IncDepth() 755 | tw.Write("[") 756 | let length = json.Length 757 | json |> 758 | List.iter (fun m -> 759 | this.Write(m) 760 | tw.Write(";") 761 | ) 762 | tw.Write("]") 763 | DecDepth() 764 | 765 | member this.Write({Label=label; Value=value;}:PiJsonPair) = 766 | tw.Write("{Label=") 767 | this.WriteString(label) 768 | tw.Write(";Value=") 769 | this.Write(value) 770 | tw.Write(";}") 771 | 772 | member this.Write(json:PiJsonArray) = 773 | match depthOpt with 774 | | Some(maxdepth) when maxdepth <= depth -> 775 | tw.Write("[||]") 776 | | _ -> 777 | IncDepth() 778 | tw.Write("[|") 779 | match json.Length with 780 | | 0 -> () 781 | | length -> 782 | for i = 0 to length - 2 do 783 | this.Write(json.[i]) 784 | tw.Write(" :> obj;") 785 | this.Write(json.[length-1]) 786 | tw.Write(":>obj") 787 | tw.Write("|]") 788 | DecDepth() 789 | 790 | member this.Write(context:PiContext) = 791 | let json = context.AsJson() 792 | this.Write(json) 793 | 794 | member this.Write(guard:GuardedContext) = 795 | let json = guard.AsJson() 796 | this.Write(json) 797 | 798 | member this.Write(txc:TransitionContext) = 799 | let json = txc.AsJson() 800 | this.Write(json) 801 | 802 | member this.Write(data:obj) = 803 | match data with 804 | | null -> this.WriteNull() 805 | | :? string as json -> this.WriteString(json) 806 | | :? int as json -> this.WriteInt(json) 807 | | :? float as json -> this.WriteFloat(json) 808 | | :? bool as json -> this.WriteBool(json) 809 | | :? PiJsonObject as json -> this.Write(json) 810 | | :? PiJsonArray as json -> this.Write(json) 811 | | :? PiContext as context -> this.Write(context) 812 | | :? GuardedContext as guard -> this.Write(guard) 813 | | :? TransitionContext as txc -> this.Write(txc) 814 | | _ -> failwith "unexpected json data type" 815 | 816 | type PiJsonCloner() = 817 | member this.Clone(json:PiJsonObject) : PiJsonObject = 818 | json |> List.map (fun m -> this.Clone(m)) 819 | 820 | member this.Clone({Label=label; Value=value;}:PiJsonPair) = 821 | {Label=label; Value=this.Clone(value);} 822 | 823 | member this.Clone(json:PiJsonArray) : PiJsonArray = 824 | json |> Array.map (fun e -> this.Clone(e)) 825 | 826 | member this.Clone(data:obj) = 827 | match data with 828 | | null -> null 829 | | :? string 830 | | :? int 831 | | :? float -> data 832 | | :? PiJsonObject as json -> this.Clone(json) :> obj 833 | | :? PiJsonArray as json -> this.Clone(json) :> obj 834 | | _ -> failwith "unexpected json data type" 835 | 836 | let WriteJson (tw:TextWriter) (json:obj) = 837 | let ptw = PiJsonWriter(tw) 838 | ptw.Write(json) 839 | 840 | let WriteJsonToString (json:obj) = 841 | use sw = new StringWriter() 842 | let ptw = PiJsonWriter(sw) 843 | ptw.Write(json) 844 | sw.Flush() 845 | sw.ToString() 846 | 847 | let WriteJsonToFSharp (json:obj) = 848 | use sw = new StringWriter() 849 | let ptw = PiFSharpWriter(sw) 850 | ptw.Write(json) 851 | sw.Flush() 852 | sw.ToString() 853 | 854 | let WriteJsonWithMaxDepth (tw:TextWriter) (json:obj) (maxdepth:int) = 855 | let ptw = PiJsonWriter(tw, Some(maxdepth)) 856 | ptw.Write(json) 857 | 858 | let CloneJson (json:PiJsonObject) = 859 | let jsc = PiJsonCloner() 860 | jsc.Clone(json) 861 | 862 | -------------------------------------------------------------------------------- /JsonPiInterpreter/PiLexerInternal.fsl: -------------------------------------------------------------------------------- 1 | { 2 | module internal PiLexerInternal 3 | 4 | open System 5 | open System.Text 6 | 7 | // Opens methods related to fslex.exe 8 | open Microsoft.FSharp.Text.Lexing 9 | 10 | let lexeme = LexBuffer<_>.LexemeString 11 | 12 | let newline (lexbuf: LexBuffer<_>) = 13 | lexbuf.StartPos <- lexbuf.StartPos.NextLine 14 | } 15 | 16 | // Regular expressions 17 | let whitespace = [' ' '\t' ] 18 | let newline = ('\n' | '\r' '\n') 19 | let idstart = [ 'a'-'z' 'A'-'Z' '_' ] 20 | let id = idstart ( idstart | ['0'-'9'])* 21 | let hex_digit = ['0'-'9' 'A'-'F' 'a'-'f'] 22 | let json_bool = ("true" | "false") 23 | let json_null = "null" 24 | let json_char = ("\\\"" | "\\\\" | "\\/" | "\\b" | "\\f" | "\\n" | "\\r" | "\\t" | ('\\' 'u' hex_digit hex_digit hex_digit hex_digit) | [^'"' '\\']) 25 | let json_string = '"' json_char* '"' 26 | let json_digit19 = ['1'-'9'] 27 | let json_digit = ['0'-'9'] 28 | let json_int = '-'? json_digit19 json_digit* 29 | let json_frac = '.' json_digit+ 30 | let json_e = ['e' 'E'] 31 | let json_plusminus = ['+' '-'] 32 | let json_exp = json_e json_plusminus? json_digit+ 33 | let json_float = json_int (json_frac | json_exp | (json_frac json_exp)) 34 | 35 | rule pi = parse 36 | // -------------------------- 37 | | "new" { PiParserInternal.NEW } 38 | | "let" { PiParserInternal.LET } 39 | | "module" { PiParserInternal.MODULE } 40 | | "using" { PiParserInternal.USING } 41 | | "choose" { PiParserInternal.CHOOSE } 42 | | "when" { PiParserInternal.WHEN } 43 | | "then" { PiParserInternal.THEN } 44 | | "default" { PiParserInternal.DEFAULT } 45 | | "end" { PiParserInternal.END } 46 | | "continue" { PiParserInternal.CONTINUE } 47 | | "in" { PiParserInternal.IN } 48 | | "$" { PiParserInternal.SYM_DOLLAR } 49 | | "(" { PiParserInternal.SYM_LPAREN } 50 | | ")" { PiParserInternal.SYM_RPAREN } 51 | | "=" { PiParserInternal.SYM_EQUALS } 52 | | "!" { PiParserInternal.SYM_BANG } 53 | | "<" { PiParserInternal.SYM_LANGLE } 54 | | ">" { PiParserInternal.SYM_RANGLE } 55 | | ":" { PiParserInternal.SYM_COLON } 56 | | ";" { PiParserInternal.SYM_SEMICOLON } 57 | | "|" { PiParserInternal.SYM_BAR} 58 | | "," { PiParserInternal.SYM_COMMA } 59 | | "." { PiParserInternal.SYM_PERIOD } 60 | | "[" { PiParserInternal.SYM_LBRACKET } 61 | | "]" { PiParserInternal.SYM_RBRACKET } 62 | | "{" { PiParserInternal.SYM_LCURLY } 63 | | "}" { PiParserInternal.SYM_RCURLY } 64 | | json_string { PiParserInternal.JSON_STRING(let s = lexeme lexbuf in (s.Substring(1, s.Length-2))) } 65 | | json_int { PiParserInternal.JSON_INT(lexeme lexbuf) } 66 | | json_float { PiParserInternal.JSON_FLOAT(lexeme lexbuf) } 67 | | json_bool { PiParserInternal.JSON_BOOL(lexeme lexbuf) } 68 | | json_null { PiParserInternal.JSON_NULL(lexeme lexbuf) } 69 | | id { PiParserInternal.ID(lexeme lexbuf) } 70 | // -------------------------- 71 | | "//" [ ^ '\n']* { pi lexbuf } 72 | | "(*" [ ^ ')'] { piComment 0 lexbuf } 73 | | whitespace+ { pi lexbuf } 74 | | newline { newline lexbuf; pi lexbuf } 75 | // -------------------------- 76 | | _ { failwith ("ParseError " + LexBuffer<_>.LexemeString lexbuf) } 77 | | eof { PiParserInternal.EOF } 78 | and piComment c = parse 79 | | "(*" [ ^ ')'] { piComment (c+1) lexbuf } 80 | | "*)" { if c = 0 then pi lexbuf else piComment (c-1) lexbuf } 81 | | _ { piComment c lexbuf } 82 | | eof { PiParserInternal.EOF } 83 | -------------------------------------------------------------------------------- /JsonPiInterpreter/PiParser.fs: -------------------------------------------------------------------------------- 1 | module JsonPi.PiParser 2 | 3 | open Microsoft.FSharp.Text.Lexing 4 | 5 | let ParseFromString text = 6 | let lexbuf = LexBuffer.FromString text 7 | let result = PiParserInternal.start PiLexerInternal.pi lexbuf 8 | result 9 | 10 | let ParseFromFile (fileName:string) = 11 | let fi = System.IO.FileInfo(fileName) 12 | use textReader = new System.IO.StreamReader(fileName) 13 | let lexbuf = LexBuffer.FromTextReader textReader 14 | let result = PiParserInternal.start PiLexerInternal.pi lexbuf 15 | //result.Id <- fi.Name 16 | result 17 | 18 | -------------------------------------------------------------------------------- /JsonPiInterpreter/PiParserInternal.fsy: -------------------------------------------------------------------------------- 1 | %{ 2 | open System 3 | open JsonPi.Data 4 | 5 | %} 6 | 7 | // The start token becomes a parser function in the compiled code: 8 | %start start 9 | 10 | // Regular tokens 11 | %token NEW LET MODULE USING CHOOSE WHEN THEN DEFAULT END 12 | CONTINUE 13 | IN 14 | SYM_DOLLAR 15 | SYM_LPAREN SYM_RPAREN 16 | SYM_EQUALS 17 | SYM_BANG 18 | SYM_BAR 19 | SYM_COMMA 20 | SYM_PERIOD 21 | SYM_LANGLE 22 | SYM_RANGLE 23 | SYM_LBRACKET 24 | SYM_RBRACKET 25 | SYM_LCURLY 26 | SYM_RCURLY 27 | SYM_SEMICOLON 28 | SYM_COLON 29 | %token ID 30 | %token JSON_BOOL 31 | %token JSON_NULL 32 | %token JSON_STRING 33 | %token JSON_INT 34 | %token JSON_FLOAT 35 | %token EOF 36 | 37 | %left SYM_BAR 38 | %right SYM_BANG SYM_LPAREN SYM_DOLLAR 39 | 40 | // This is the type of the data produced by a successful reduction of the 'start' 41 | // symbol: 42 | %type < PiJsonObject > start 43 | 44 | %% 45 | 46 | start: Assembly EOF { $1 } 47 | 48 | Assembly: 49 | | Modules { CreateAssembly "" $1 } 50 | 51 | Modules: 52 | | Module { [ $1 ] } 53 | | Modules Module { $2 :: $1 } 54 | 55 | Module: 56 | | Process { CreateModule "" $1 } 57 | | MODULE DottedId Process { CreateModule $2 $3 } 58 | 59 | Process: 60 | | ModuleRef { $1 } 61 | 62 | ModuleRef: 63 | | ProcessDefinition { $1 } 64 | | USING DottedId ModuleInAssembly ModuleRef { CreateProcessModuleRef $2 $3 $4 } 65 | 66 | ModuleInAssembly: 67 | | { None } 68 | | IN DottedId { Some($2) } 69 | 70 | ProcessDefinition: 71 | | ProcessReplication { $1 } 72 | | LET DottedId SYM_EQUALS Process Process { CreateProcessBinding $2 $4 $5 } 73 | 74 | ProcessReplication: 75 | | ProcessRestriction { $1 } 76 | | SYM_BANG Process { CreateProcessReplication $2 } 77 | 78 | ProcessRestriction: 79 | | ProcessComposition { $1 } 80 | | NEW RestrictionName RestrictionType RestrictionInitialization Process { CreateProcessRestriction (CreateName $2 $3 $4) $5 } 81 | 82 | RestrictionName: 83 | | SYM_LPAREN DottedId { $2 } 84 | 85 | RestrictionType: 86 | | SYM_RPAREN { None } 87 | | SYM_COLON DottedId SYM_RPAREN { Some($2) } 88 | 89 | RestrictionInitialization: 90 | | { None } 91 | | SYM_EQUALS JsonValue { Some($2 :> obj) } 92 | 93 | ProcessComposition: 94 | | ProcessReference { $1 } 95 | | ProcessComposition SYM_BAR ProcessComposition { CreateProcessComposition $1 $3 } 96 | 97 | ProcessReference: 98 | | ProcessExtensionContinue { $1 } 99 | | SYM_DOLLAR DottedId { CreateProcessBindingRef $2 } 100 | 101 | ProcessExtensionContinue: 102 | | ProcessSummation { $1 } 103 | | CONTINUE { CreateProcessBindingRef "continue" } 104 | 105 | ProcessSummation: 106 | | Summation { CreateProcessSummation $1 } 107 | | SYM_LPAREN Process SYM_RPAREN { $2 } 108 | 109 | Summation: 110 | | SummationSum { $1 } 111 | 112 | SummationSum: 113 | | SummationPrefix { $1 } 114 | | CHOOSE SummationChoiceList ChooseDefault END { CreateSummationSum ($2 @ $3) } 115 | 116 | SummationChoiceList: 117 | | SummationChoice { [ $1 ] } 118 | | SummationChoice SummationChoiceList { $1 :: $2 } 119 | 120 | SummationChoice: 121 | | WHEN Prefix THEN Process { CreateSummationPrefix $2 $4 } 122 | 123 | ChooseDefault: 124 | | { [] } 125 | | DEFAULT Process { [ (CreateSummationPrefix (CreatePrefixUnobservable()) $2) ] } 126 | 127 | SummationPrefix: 128 | | SummationInaction { $1 } 129 | | Prefix ProcessSummation { CreateSummationPrefix $1 $2 } 130 | 131 | SummationInaction: 132 | | SYM_SEMICOLON { CreateSummationInaction() } 133 | 134 | Prefix: 135 | | PrefixOutput { $1 } 136 | | PrefixInput { $1 } 137 | | PrefixMatch { $1 } 138 | 139 | PrefixOutput: 140 | | DottedId SYM_LANGLE ParamList SYM_RANGLE { CreatePrefixOutput (CreateName $1 None None) (List.rev $3) } 141 | 142 | PrefixInput: 143 | | DottedId SYM_LPAREN TypedParamList SYM_RPAREN { CreatePrefixInput (CreateName $1 None None) (List.rev $3) } 144 | 145 | PrefixMatch: 146 | | SYM_LBRACKET ParamList SYM_EQUALS ParamList SYM_RBRACKET Prefix { CreatePrefixMatch (List.rev $2) (List.rev $4) $6 } 147 | 148 | ParamList: 149 | | Param { [ $1 ] } 150 | | ParamList SYM_COMMA Param { $3 :: $1 } 151 | 152 | TypedParamList: 153 | | TypedParam { [ $1 ] } 154 | | TypedParamList SYM_COMMA TypedParam { $3 :: $1 } 155 | 156 | Param: 157 | | DottedId { CreateName (String.Intern($1)) None None} 158 | 159 | TypedParam: 160 | | DottedId SYM_COLON DottedId { CreateName (String.Intern($1)) (Some($3)) None } 161 | | DottedId { CreateName (String.Intern($1)) None None } 162 | 163 | DottedId: 164 | | ID { $1 } 165 | | DottedId SYM_PERIOD ID { $1 + "." + $3 } 166 | 167 | JsonValue: 168 | | JsonString { $1 :> obj } 169 | | JsonNumber { $1 :> obj } 170 | | JsonObject { $1 :> obj } 171 | | JsonArray { $1 :> obj } 172 | | JsonBool { $1 :> obj } 173 | | JsonNull { $1 :> obj } 174 | 175 | JsonString: 176 | | JSON_STRING { $1 } 177 | 178 | JsonNumber: 179 | | JSON_INT { int($1) :> obj } 180 | | JSON_FLOAT { float($1) :> obj } 181 | 182 | JsonObject: 183 | | SYM_LCURLY JsonMembers SYM_RCURLY { $2; } 184 | 185 | JsonMembers: 186 | | JsonPair { [ $1 ] } 187 | | JsonPair SYM_COMMA JsonMembers { $1 :: $3 } 188 | 189 | JsonPair: 190 | | JSON_STRING SYM_COLON JsonValue { { Label = $1; Value = $3; } } 191 | 192 | JsonArray: 193 | | SYM_LBRACKET JsonElements SYM_RBRACKET { Array.ofList $2 } 194 | 195 | JsonElements: 196 | | JsonValue { [ $1 ] } 197 | | JsonValue SYM_COMMA JsonElements { $1 :: $3 } 198 | 199 | JsonBool: 200 | | JSON_BOOL { bool.Parse($1) } 201 | 202 | JsonNull: 203 | | JSON_NULL { null } 204 | 205 | -------------------------------------------------------------------------------- /JsonPiInterpreter/PiProcessor.fs: -------------------------------------------------------------------------------- 1 | namespace JsonPi 2 | 3 | open System 4 | open System.Collections.Generic 5 | 6 | open JsonPi.Data 7 | open JsonPi.PiRuntime 8 | 9 | 10 | type PiProcessor (resolver:PiExtensionResolver option) = 11 | let mutable restrictedNames = Map.empty 12 | let mutable extensions = Map.empty 13 | let pitrace = PiObservable() 14 | let assemblies = ResizeArray() 15 | let ws = Stack() 16 | let pns = PiNamespace() 17 | 18 | let rec GetNextRestrictedId (id:PiIdentifier) = 19 | let num = 20 | match restrictedNames.ContainsKey(id) with 21 | | false -> 22 | restrictedNames <- Map.add id 1 restrictedNames 23 | 1 24 | | true -> 25 | let n = restrictedNames.[id] + 1 26 | restrictedNames <- Map.remove id restrictedNames 27 | restrictedNames <- Map.add id n restrictedNames 28 | n 29 | 30 | match id.IndexOf("`") with 31 | | -1 -> String.Intern(sprintf "%s`%d" id num) 32 | | index -> 33 | String.Intern(sprintf "%s`%d" (id.Substring(0, index)) num) 34 | 35 | let AddAssembly asm = 36 | if not(Seq.exists ((=) asm) (assemblies)) then 37 | assemblies.Add asm 38 | 39 | let PushProcess (context:PiContext) = 40 | pitrace.Next(PiTraceEvent.PushProcess(context.CurrentProcess)) 41 | ws.Push(context) 42 | 43 | let rec MatchSummationPrefix (guard:GuardedContext) = 44 | match guard.Prefix with 45 | | PrefixOutput (channel, outNames) -> 46 | match pns.TrySend(channel, guard) with 47 | | None -> 48 | pitrace.Next(PiTraceEvent.PutPrefix(guard.Prefix, guard.Continuation)) 49 | TransitionContext.NoTransition 50 | | Some(matchedInput) -> 51 | pitrace.Next(PiTraceEvent.GetPrefix(matchedInput.Prefix, matchedInput.Continuation)) 52 | TransitionContext.ChannelMatch(guard, matchedInput) 53 | | PrefixInput (channel, inNames) -> 54 | match pns.TryReceive(channel, guard) with 55 | | None -> 56 | pitrace.Next(PiTraceEvent.PutPrefix(guard.Prefix, guard.Continuation)) 57 | TransitionContext.NoTransition 58 | | Some(matchedOutput) -> 59 | pitrace.Next(PiTraceEvent.GetPrefix(matchedOutput.Prefix, matchedOutput.Continuation)) 60 | TransitionContext.ChannelMatch(matchedOutput, guard) 61 | | PrefixMatch (paramsLeft, paramsRight, matchPfx) -> 62 | let isMatch = 63 | (paramsLeft.Length = paramsRight.Length) && 64 | (Array.forall2 65 | (fun np1 np2 -> 66 | match (np1, np2) with 67 | | (PiName(id1, _, _), PiName(id2, _, _)) -> id1 = id2 68 | | _ -> false 69 | ) 70 | paramsLeft paramsRight) 71 | 72 | if isMatch then 73 | let matchGuard = 74 | { 75 | CurrentContext = guard.CurrentContext; 76 | Prefix = matchPfx; 77 | Continuation = guard.Continuation 78 | } 79 | MatchSummationPrefix matchGuard 80 | else 81 | TransitionContext.NoTransition 82 | | PrefixUnobservable -> 83 | TransitionContext.Unobservable(guard) 84 | | _ -> failwith "bad" 85 | 86 | let rec RunProcessSummation (context:PiContext) (ls:PiJsonArray) index : TransitionContext = 87 | if index < ls.Length then 88 | let whenSummation = ls.[index] 89 | match whenSummation with 90 | | SummationPrefix (whenPfx, whenNext) -> 91 | let guard = 92 | { 93 | CurrentContext = context; 94 | Prefix = whenPfx; 95 | Continuation = whenNext 96 | } 97 | match MatchSummationPrefix guard with 98 | | TransitionContext.NoTransition -> 99 | RunProcessSummation context ls (index+1) 100 | | _ as tc -> tc 101 | | _ -> failwith "Unexpected summation type in sum." 102 | else 103 | TransitionContext.NoTransition 104 | 105 | let rec RunProcess (context:PiContext) : TransitionContext = 106 | pitrace.Next(PiTraceEvent.RunProcess(context.CurrentProcess)) 107 | 108 | match context.CurrentProcess with 109 | | ProcessSummation summation -> 110 | match summation with 111 | | SummationInaction -> 112 | TransitionContext.NoTransition 113 | | SummationPrefix (pfx, continuation) -> 114 | let guard = 115 | { 116 | CurrentContext = context; 117 | Prefix = pfx; 118 | Continuation = continuation; 119 | } 120 | MatchSummationPrefix guard 121 | | SummationSum (ls) -> 122 | RunProcessSummation context ls 0 123 | | _ -> failwith "bad" 124 | | ProcessComposition (left, right) -> 125 | let (contextLeft, contextRight) = context.SplitComposition(left, right) 126 | PushProcess contextLeft 127 | PushProcess contextRight 128 | TransitionContext.NoTransition 129 | | ProcessBinding (id, proc, continuation) -> 130 | context.NextChild(continuation) 131 | PushProcess context 132 | TransitionContext.NoTransition 133 | | ProcessBindingRef id -> 134 | match context.TryFindBinding(id, assemblies) with 135 | | Some(bindProc) -> 136 | let bindClone = CloneJson bindProc 137 | context.NextProcess(bindClone) 138 | PushProcess context 139 | TransitionContext.NoTransition 140 | | None -> 141 | failwith "Unable to resolve process reference." 142 | | ProcessModuleRef (id, inAsm, continuation) -> 143 | match context.TryFindModule(id, inAsm, assemblies) with 144 | | Some(pimod) -> 145 | let modProcClone = CloneJson pimod 146 | let newComp = CreateProcessComposition continuation modProcClone 147 | context.NextChild(newComp) 148 | PushProcess context 149 | TransitionContext.NoTransition 150 | | None -> 151 | failwith "unable to find module" 152 | | ProcessRestriction (name, continuation) -> 153 | let id = GetMemberValue name "Id" 154 | let restrictedId = GetNextRestrictedId id 155 | SetMemberValue name "Id" restrictedId 156 | 157 | let nameType = TryGetMemberValue name "NameType" 158 | let data = TryGetMemberValue name "Data" 159 | 160 | match (nameType, resolver) with 161 | | (Some(nt), Some(r)) -> 162 | match r nt data with 163 | | Some(ext) -> 164 | if Map.containsKey restrictedId extensions then 165 | extensions <- Map.remove restrictedId extensions 166 | 167 | extensions <- Map.add restrictedId ext extensions 168 | | None -> () 169 | | _ -> () 170 | 171 | let findName = CreateName id None None 172 | let restrictedName = CreateName restrictedId (TryGetMemberValue name "NameType") (TryGetMemberValue name "Data") 173 | Substitute continuation [| restrictedName :> obj |] [| findName :> obj |] 174 | context.NextChild(continuation) 175 | PushProcess context 176 | TransitionContext.NoTransition 177 | | ProcessReplication repProc -> 178 | let repProcClone = CloneJson repProc 179 | context.NextChild(repProcClone) 180 | PushProcess context 181 | TransitionContext.NoTransition 182 | | _ -> failwith "bad" 183 | 184 | let TransitionOut (context:PiContext) (channel:PiJsonObject) (outNames:PiJsonArray) (continuation:PiJsonObject) = 185 | pitrace.Next(PiTraceEvent.TransitionOut(channel, outNames, continuation)) 186 | 187 | match channel with 188 | | PiName (id, nameTypeOpt, _) -> 189 | match nameTypeOpt with 190 | | Some(nt) -> 191 | match Map.tryFind id extensions with 192 | | Some(ext) -> 193 | let result = ext.OnOutput channel outNames 194 | match result with 195 | | Some(extProcess) -> 196 | context.NextProcess(extcontinue extProcess continuation) 197 | | None -> 198 | context.NextProcess(continuation) 199 | | None -> 200 | context.NextProcess(continuation) 201 | | None -> 202 | context.NextProcess(continuation) 203 | | _ -> failwith "bad" 204 | 205 | let TransitionInp (context:PiContext) (channel:PiJsonObject) (outNames:PiJsonArray) (inpNames:PiJsonArray) (continuation:PiJsonObject) = 206 | pitrace.Next(PiTraceEvent.TransitionInp(channel, outNames, inpNames, continuation)) 207 | 208 | match channel with 209 | | PiName (id, nameTypeOpt, _) -> 210 | match nameTypeOpt with 211 | | Some(nt) -> 212 | match Map.tryFind id extensions with 213 | | Some(ext) -> 214 | let result = ext.OnInput channel outNames inpNames 215 | match result with 216 | | Some(extProcess) -> 217 | context.NextProcess(extcontinue extProcess continuation) 218 | | None -> 219 | context.NextProcess(continuation) 220 | | None -> 221 | context.NextProcess(continuation) 222 | | None -> 223 | context.NextProcess(continuation) 224 | | _ -> failwith "bad" 225 | 226 | Substitute (context.CurrentProcess) outNames inpNames 227 | 228 | let TransitionTau (context:PiContext) (continuation:PiJsonObject) = 229 | pitrace.Next(PiTraceEvent.TransitionTau) 230 | 231 | context.NextProcess(continuation) 232 | 233 | let TransitionSum (guard:GuardedContext) (summation:PiJsonObject) (whenPfx:PiJsonObject) = 234 | pitrace.Next(PiTraceEvent.TransitionSum(summation, whenPfx)) 235 | 236 | match summation with 237 | | SummationSum ls -> 238 | for i = 0 to ls.Length - 1 do 239 | match ls.[i] with 240 | | SummationPrefix (sumPfx, _) when sumPfx <> whenPfx -> 241 | let channel = GetPrefixChannel sumPfx 242 | pitrace.Next(PiTraceEvent.RemoveSummation(summation)) 243 | pns.RemoveSummation(channel, guard.CurrentContext) 244 | | _ -> () 245 | | _ -> failwith "Unexpected summation type." 246 | 247 | let TransitionRep (guard:GuardedContext) (repProc:PiJsonObject) = 248 | let {CurrentContext = context; Continuation=continuation; } = guard 249 | 250 | match context.CurrentProcess with 251 | | ProcessSummation(SummationInaction) -> 252 | pitrace.Next(PiTraceEvent.TransitionRep("Inaction")) 253 | let repProcClone = CloneJson repProc 254 | context.NextProcess(repProcClone) 255 | | _ -> 256 | pitrace.Next(PiTraceEvent.TransitionRep("Continuation")) 257 | let left = CloneJson repProc 258 | let right = context.CurrentProcess 259 | let comp = CreateProcessComposition left right 260 | context.NextProcess(comp) 261 | 262 | let (|TxSum|_|) (guard:GuardedContext) = 263 | let {CurrentContext = context; Prefix=whenPfx; Continuation=continuation; } = guard 264 | 265 | match context.CurrentProcess with 266 | | ProcessSummation summation -> 267 | match summation with 268 | | SummationSum _ -> 269 | let fSum = fun () -> 270 | TransitionSum guard summation whenPfx 271 | Some(fSum) 272 | | _ -> None 273 | | _ -> None 274 | 275 | let (|TxRep|_|) (guard:GuardedContext) = 276 | let {CurrentContext = context; Continuation=continuation; } = guard 277 | match context.Parent with 278 | | Some(parent) -> 279 | match parent with 280 | | ProcessReplication(repProc) -> 281 | let fRep = fun () -> 282 | TransitionRep guard repProc 283 | Some(fRep) 284 | | _ -> 285 | None 286 | | _ -> 287 | None 288 | 289 | let (|TxOut|_|) (outGuard:GuardedContext) = 290 | let {CurrentContext = outContext; Prefix=pfxOut; Continuation=continuation; } = outGuard 291 | 292 | match pfxOut with 293 | | PrefixOutput (channel, outNames) -> 294 | let fSum = 295 | match outGuard with 296 | | TxSum f -> f 297 | | _ -> function () -> () 298 | 299 | let fRep = 300 | match outGuard with 301 | | TxRep f -> f 302 | | _ -> function () -> () 303 | 304 | let fOut = fun () -> 305 | fSum() 306 | TransitionOut outContext channel outNames continuation 307 | fRep() 308 | 309 | Some(fOut) 310 | | _ -> None 311 | 312 | let (|TxInp|_|) (outGuard:GuardedContext, inpGuard:GuardedContext) = 313 | let {CurrentContext = outContext; Prefix=pfxOut; Continuation=outContinuation; } = outGuard 314 | let {CurrentContext = inpContext; Prefix=pfxInp; Continuation=inpContinuation; } = inpGuard 315 | 316 | match pfxOut with 317 | | PrefixOutput (_, outNames) -> 318 | match pfxInp with 319 | | PrefixInput (channel, inpNames) -> 320 | let fSum = 321 | match inpGuard with 322 | | TxSum f -> f 323 | | _ -> function () -> () 324 | 325 | let fRep = 326 | match inpGuard with 327 | | TxRep f -> f 328 | | _ -> function () -> () 329 | 330 | let fInp = fun () -> 331 | fSum() 332 | TransitionInp inpContext channel outNames inpNames inpContinuation 333 | fRep() 334 | 335 | Some(fInp) 336 | | _ -> 337 | None 338 | | _ -> 339 | None 340 | 341 | let (|TxTau|_|) (guard:GuardedContext) = 342 | let {CurrentContext = context; Prefix=pfx; Continuation=continuation; } = guard 343 | 344 | match pfx with 345 | | PrefixUnobservable -> 346 | let fSum = 347 | match guard with 348 | | TxSum f -> f 349 | | _ -> function () -> () 350 | 351 | let fRep = 352 | match guard with 353 | | TxRep f -> f 354 | | _ -> function () -> () 355 | 356 | let fTau = fun () -> 357 | fSum() 358 | TransitionTau context continuation 359 | fRep() 360 | 361 | Some(fTau) 362 | | _ -> 363 | None 364 | 365 | let (|TxComm|_|) (outGuard:GuardedContext, inpGuard:GuardedContext) = 366 | match ( outGuard, (outGuard, inpGuard)) with 367 | | (TxOut fOut, TxInp fInp) -> 368 | let fComm = fun () -> 369 | let pOut = fOut() 370 | let pInp = fInp() 371 | PushProcess (outGuard.CurrentContext) 372 | PushProcess (inpGuard.CurrentContext) 373 | Some(fComm) 374 | | _ -> 375 | None 376 | 377 | let TransitionProcess (tc:TransitionContext) = 378 | match tc with 379 | | TransitionContext.NoTransition -> () 380 | | TransitionContext.ChannelMatch(outGuard, inpGuard) -> 381 | match (outGuard, inpGuard) with 382 | | TxComm f -> f() 383 | | _ -> failwith "Unexpexted transition context." 384 | | TransitionContext.Unobservable(guard) -> 385 | match guard with 386 | | TxTau f -> 387 | f() 388 | PushProcess (guard.CurrentContext) 389 | | _ -> failwith "Unexpexted transition context." 390 | 391 | new() = PiProcessor(None) 392 | 393 | member internal this.RunStack () = 394 | match ws.Count with 395 | | 0 -> 396 | pitrace.Completed() 397 | | _ -> 398 | let next = ws.Pop() 399 | let tcl = RunProcess next 400 | TransitionProcess tcl 401 | this.RunStack() 402 | 403 | member this.RunProgram(program:PiJsonObject) = 404 | AddAssembly program 405 | 406 | match program with 407 | | AssemblyEntryProcess pstart -> 408 | let context = PiContext(pstart) 409 | PushProcess context 410 | | _ -> failwith "bad" 411 | 412 | this.RunStack() 413 | 414 | member this.RunString(pitext:string) = 415 | let program = PiParser.ParseFromString pitext 416 | this.RunProgram(program) 417 | 418 | member this.RunFile(filename:string) = 419 | let program = PiParser.ParseFromFile filename 420 | this.RunProgram(program) 421 | 422 | member this.ListPending (f:(GuardedContext -> unit)) = 423 | pns.ListPending(f) 424 | 425 | member this.AsObservable() = pitrace.AsObservable -------------------------------------------------------------------------------- /JsonPiInterpreter/PiRuntime.fs: -------------------------------------------------------------------------------- 1 | module JsonPi.PiRuntime 2 | 3 | open System 4 | open System.Collections.Generic 5 | 6 | open JsonPi.Data 7 | 8 | type PiNamespace() = 9 | let pendingInputs = Dictionary() 10 | let pendingOutputs = Dictionary() 11 | 12 | let TryGetList (dict:Dictionary) id = 13 | match dict.ContainsKey(id) with 14 | | false -> None 15 | | true -> 16 | Some(dict.[id]) 17 | 18 | let WhereNotContext (context:PiContext) = 19 | List.where (fun {CurrentContext=c;} -> 20 | c <> context 21 | ) 22 | 23 | member this.ListPending (f:(GuardedContext -> unit)) = 24 | pendingOutputs.Values |> 25 | Seq.iter (fun v -> v |> List.iter f) 26 | 27 | pendingInputs.Values |> 28 | Seq.iter (fun v -> v |> List.iter f) 29 | 30 | member this.TrySend(channel:PiJsonObject, guard:GuardedContext) = 31 | match channel with 32 | | PiName (id, nameTypeOpt, _) -> 33 | match TryGetList pendingInputs id with 34 | | Some(l) -> 35 | match l with 36 | | h :: [] -> 37 | pendingInputs.Remove(id) |> ignore 38 | Some(h) 39 | | h :: t -> 40 | pendingInputs.[id] <- t 41 | Some(h) 42 | | [] -> failwith "unexpected" 43 | | None -> 44 | match TryGetList pendingOutputs id with 45 | | Some(l) -> 46 | pendingOutputs.[id] <- guard :: l 47 | | None -> 48 | pendingOutputs.Add(id, [guard]) 49 | None 50 | | _ -> failwith "bad" 51 | 52 | member this.TryReceive(channel:PiJsonObject, guard:GuardedContext) = 53 | match channel with 54 | | PiName (id, nameTypeOpt, _) -> 55 | match TryGetList pendingOutputs id with 56 | | Some(l) -> 57 | match l with 58 | | h :: [] -> 59 | pendingOutputs.Remove(id) |> ignore 60 | Some(h) 61 | | h :: t -> 62 | pendingOutputs.[id] <- t 63 | Some(h) 64 | | [] -> failwith "unexpected" 65 | | None -> 66 | match TryGetList pendingInputs id with 67 | | Some(l) -> 68 | pendingInputs.[id] <- guard :: l 69 | | None -> 70 | pendingInputs.Add(id, [guard]) 71 | None 72 | | _ -> failwith "bad" 73 | 74 | member this.RemoveSummation (channel:PiJsonObject, context:PiContext) = 75 | let id = GetMemberValue channel "Id" 76 | 77 | match TryGetList pendingOutputs id with 78 | | Some(l) -> 79 | match WhereNotContext context l with 80 | | [] -> pendingOutputs.Remove(id) |> ignore 81 | | outl -> pendingOutputs.[id] <- outl 82 | | None -> 83 | () 84 | 85 | match TryGetList pendingInputs id with 86 | | Some(l) -> 87 | match WhereNotContext context l with 88 | | [] -> pendingInputs.Remove(id) |> ignore 89 | | outl -> pendingInputs.[id] <- outl 90 | | None -> 91 | () 92 | 93 | let rec internal exts (s:PiJsonObject) (continuation:PiJsonObject) = 94 | match s with 95 | | SummationInaction -> s 96 | | SummationPrefix (pfx, p1) -> 97 | CreateSummationPrefix pfx (extp p1 continuation) 98 | | SummationSum(ls) -> 99 | let sumlist = ls |> Seq.map (fun s1 -> exts (s1 :?> PiJsonObject) continuation) |> List.ofSeq 100 | CreateSummationSum sumlist 101 | | _ -> failwith "bad" 102 | 103 | and internal extp (p:PiJsonObject) (continuation:PiJsonObject) = 104 | match p with 105 | | ProcessSummation s -> 106 | CreateProcessSummation (exts s continuation) 107 | | ProcessComposition (p1, p2) -> 108 | CreateProcessComposition (extp p1 continuation) (extp p2 continuation) 109 | | ProcessReplication p1 -> 110 | CreateProcessReplication (extp p1 continuation) 111 | | ProcessRestriction (n, rp) -> 112 | CreateProcessRestriction n (extp rp continuation) 113 | | ProcessBinding (id, p1, p2) -> 114 | CreateProcessBinding id (extp p1 continuation) (extp p2 continuation) 115 | | ProcessBindingRef id -> 116 | if id = "continue" then 117 | continuation 118 | else 119 | p 120 | | ProcessModuleRef (id, inIdOpt, p1) -> 121 | CreateProcessModuleRef id inIdOpt (extp p1 continuation) 122 | | _ -> failwith "bad" 123 | 124 | and internal extcontinue (p:PiJsonObject) (continuation:PiJsonObject) = 125 | extp p continuation 126 | 127 | 128 | let internal subparams (pa:PiJsonArray) (rn:obj) (fn:obj) = 129 | let fnid = 130 | match fn with 131 | | PiName(id, _, _) -> id 132 | | _ -> failwith "bad" 133 | 134 | seq { 135 | for i = 0 to pa.Length - 1 do 136 | match pa.[i] with 137 | | PiName (nid, _, _) when nid = fnid -> 138 | match rn with 139 | | :? PiJsonArray as rna -> 140 | yield! rna 141 | | PiName(_,_,_) -> 142 | yield rn 143 | | _ -> failwith "bad" 144 | | _ as xn -> 145 | yield xn 146 | } |> Array.ofSeq 147 | 148 | 149 | let rec internal subpfx (pfx:PiJsonObject) (rn:obj) (fn:obj) = 150 | match pfx with 151 | | PrefixInput (c, x) 152 | | PrefixOutput(c, x) -> 153 | match (c, fn) with 154 | | (PiName (id, _, _), PiName(fnid, _, _)) -> 155 | if id = fnid then 156 | SetMemberValue pfx "Channel" rn 157 | 158 | let newParams = subparams x rn fn 159 | SetMemberValue pfx "Params" newParams 160 | 161 | | _ -> failwith "bad" 162 | 163 | | PrefixMatch (paramsLeft, paramsRight, p1) -> 164 | let newParamsLeft = subparams paramsLeft rn fn 165 | let newParamsRight = subparams paramsRight rn fn 166 | 167 | SetMemberValue pfx "ParamsLeft" (newParamsLeft :> obj) 168 | SetMemberValue pfx "ParamsRight" (newParamsRight :> obj) 169 | 170 | subpfx p1 rn fn 171 | 172 | | PrefixUnobservable -> () 173 | | _ -> failwith "bad" 174 | 175 | let rec subs s rn fn = 176 | match s with 177 | | SummationInaction -> () 178 | | SummationPrefix (pfx, p1) -> 179 | subpfx pfx rn fn 180 | subp p1 rn fn 181 | | SummationSum(ls) -> 182 | ls |> Array.iter (fun s1 -> subs s1 rn fn) 183 | | _ -> failwith "bad" 184 | 185 | and subp p (rn:obj) (fn:obj) = 186 | match p with 187 | | ProcessSummation s -> 188 | subs s rn fn 189 | | ProcessComposition (p1, p2) -> 190 | subp p1 rn fn 191 | subp p2 rn fn 192 | | ProcessReplication p1 -> 193 | subp p1 rn fn 194 | | ProcessRestriction (n, rp) -> 195 | match (n, fn) with 196 | | (PiName (id, _, _), PiName(fnid, _, _)) -> 197 | if id <> fnid then 198 | subp rp rn fn 199 | | _ -> failwith "bad" 200 | | ProcessBinding (id, p1, p2) -> 201 | subp p1 rn fn 202 | subp p2 rn fn 203 | | ProcessBindingRef id -> () 204 | | ProcessModuleRef (id, inIdOpt, p1) -> 205 | subp p1 rn fn 206 | | _ -> failwith "bad" 207 | 208 | let rec internal Substitute (p:PiJsonObject) (r:PiJsonArray) (f:PiJsonArray) = 209 | for i = 0 to f.Length - 1 do 210 | if r.Length > f.Length && i = f.Length - 1 then 211 | let ra = Array.sub r i (r.Length - i) 212 | subp p ra (f.[i]) 213 | else 214 | if i < r.Length then 215 | subp p (r.[i]) (f.[i]) 216 | 217 | -------------------------------------------------------------------------------- /JsonPiInterpreter/PiTrace.fs: -------------------------------------------------------------------------------- 1 | namespace JsonPi 2 | 3 | open System 4 | open System.Diagnostics 5 | 6 | open JsonPi 7 | open JsonPi.Data 8 | 9 | type PiTraceEvent = 10 | | PushProcess of Process:PiJsonObject 11 | | RunProcess of Process:PiJsonObject 12 | | PutPrefix of Prefix:PiJsonObject * 13 | Continuation:PiJsonObject 14 | | GetPrefix of Prefix:PiJsonObject * 15 | Continuation:PiJsonObject 16 | | TransitionOut of Channel:PiJsonObject * 17 | OutNames:PiJsonArray * 18 | Continuation:PiJsonObject 19 | | TransitionInp of Channel:PiJsonObject * 20 | OutNames:PiJsonArray * 21 | InpNames:PiJsonArray * 22 | Continuation:PiJsonObject 23 | | TransitionSum of Summation:PiJsonObject * 24 | WhenPfx:PiJsonObject 25 | | TransitionTau 26 | | TransitionRep of string 27 | | RemoveSummation of Summation:PiJsonObject 28 | 29 | type PiObservable<'T>() = 30 | let thisLock = new obj() 31 | let mutable finished = false 32 | let mutable key = 0 33 | let mutable subscriptions = Map.empty : Map> 34 | 35 | let protect f = 36 | let mutable ok = false 37 | try 38 | f() 39 | ok <- true 40 | finally 41 | Debug.Assert(ok, "IObserver method threw an exception.") 42 | 43 | let next(obs) = 44 | subscriptions |> Seq.iter (fun (KeyValue(_, value)) -> 45 | protect (fun () -> value.OnNext(obs))) 46 | 47 | let completed() = 48 | subscriptions |> Seq.iter (fun (KeyValue(_, value)) -> 49 | protect (fun () -> value.OnCompleted())) 50 | 51 | let error(err) = 52 | subscriptions |> Seq.iter (fun (KeyValue(_, value)) -> 53 | protect (fun () -> value.OnError(err))) 54 | 55 | let obs = 56 | { new IObservable<'T> with 57 | member this.Subscribe(obs) = 58 | let key1 = 59 | lock thisLock (fun () -> 60 | let key1 = key 61 | key <- key + 1 62 | subscriptions <- subscriptions.Add(key1, obs) 63 | key1) 64 | { new IDisposable with 65 | member this.Dispose() = 66 | lock thisLock (fun () -> 67 | subscriptions <- subscriptions.Remove(key1)) } } 68 | 69 | member this.Next(obs) = 70 | Debug.Assert(not finished, "IObserver is already finished") 71 | next obs 72 | 73 | member this.Completed() = 74 | Debug.Assert(not finished, "IObserver is already finished") 75 | finished <- true 76 | completed() 77 | finished <- false 78 | 79 | member this.Error(err) = 80 | Debug.Assert(not finished, "IObserver is already finished") 81 | finished <- true 82 | error err 83 | 84 | member this.AsObservable = obs 85 | -------------------------------------------------------------------------------- /JsonPiREPL/JsonPiREPL.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | Exe 5 | netcoreapp2.0 6 | win10-x64;osx.10.11-x64;ubuntu.16.04-x64 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /JsonPiREPL/PiRepl.fs: -------------------------------------------------------------------------------- 1 | module PiRepl 2 | 3 | open System 4 | open System.Text 5 | open JsonPi 6 | open JsonPi.Data 7 | open System.IO 8 | 9 | let mutable internal step = false 10 | let mutable internal quit = false 11 | let mutable internal multiline = false 12 | let internal picalc = new StringBuilder() 13 | 14 | let internal PrintTrace (ev:PiTraceEvent) = 15 | use sw = new StringWriter() 16 | let pcw = PiCodeWriter(sw) 17 | 18 | sw.Write(" ") 19 | match ev with 20 | | PiTraceEvent.PushProcess(p) -> 21 | () 22 | | PiTraceEvent.RunProcess(p) -> 23 | () 24 | | PiTraceEvent.PutPrefix(pfx, continuation) -> 25 | sw.Write("Put ") 26 | pcw.WritePrefix(pfx, 20) 27 | pcw.NextColumn(20) 28 | sw.Write(" (") 29 | pcw.WriteProcess(continuation, 20) 30 | sw.Write(")") 31 | | PiTraceEvent.GetPrefix(pfx, continuation) -> 32 | sw.Write("Get ") 33 | pcw.WritePrefix(pfx, 20) 34 | pcw.NextColumn(20) 35 | sw.Write(" (") 36 | pcw.WriteProcess(continuation, 20) 37 | sw.Write(")") 38 | | PiTraceEvent.TransitionOut(channel, outNames, continuation) -> 39 | sw.Write("TxOut ") 40 | pcw.WriteName(channel, 20) 41 | pcw.Write("<", 20) 42 | pcw.WriteParams(outNames, 20) 43 | pcw.Write(">", 20) 44 | pcw.NextColumn(20) 45 | sw.Write(" (") 46 | pcw.WriteProcess(continuation, 20) 47 | sw.Write(")") 48 | | PiTraceEvent.TransitionInp(channel, outNames, inpNames, continuation) -> 49 | sw.Write("TxInp ") 50 | pcw.WriteName(channel, 20) 51 | pcw.Write("(", 20) 52 | pcw.WriteParams(outNames, 20) 53 | pcw.Write("/", 20) 54 | pcw.WriteParams(inpNames, 20) 55 | pcw.Write(")", 20) 56 | pcw.NextColumn(20) 57 | sw.Write(" (") 58 | pcw.WriteProcess(continuation, 20) 59 | sw.Write(")") 60 | | _ -> 61 | () 62 | 63 | sw.Flush() 64 | let ps = sw.ToString() 65 | if ps.Trim().Length > 0 then 66 | Console.WriteLine(ps) 67 | 68 | if step 69 | then Console.ReadKey(true) |> ignore 70 | 71 | let mutable internal processor = PiProcessor() 72 | let mutable internal subscription = processor.AsObservable() |> Observable.subscribe PrintTrace 73 | 74 | let Quit () = 75 | quit <- true 76 | 77 | let StepMode () = 78 | step <- true 79 | 80 | let RunMode () = 81 | step <- false 82 | 83 | let ToggleMultiline () = 84 | picalc.Clear() |> ignore 85 | multiline <- not(multiline) 86 | 87 | let CommandUnknown (cmd:string) = 88 | Console.WriteLine("Unknown command '{0}'", cmd) 89 | 90 | let Reset () = 91 | subscription.Dispose() 92 | 93 | processor <- PiProcessor() 94 | subscription <- processor.AsObservable() |> Observable.subscribe PrintTrace 95 | 96 | let ListPending () = 97 | let WritePending (guard:GuardedContext) = 98 | use sw = new StringWriter() 99 | let pcw = PiCodeWriter(sw) 100 | sw.Write(" ") 101 | pcw.WritePrefix(guard.Prefix, 30) 102 | pcw.NextColumn(30) 103 | pcw.Write("(", 30) 104 | pcw.WriteProcess(guard.Continuation, 40) 105 | pcw.Write(")", 40) 106 | sw.Flush() 107 | Console.WriteLine(sw.ToString()) 108 | 109 | Console.WriteLine(" Prefix Continuation"); 110 | Console.WriteLine(" ------ ------------"); 111 | processor.ListPending(WritePending) 112 | 113 | let ExecutePi (pi:string) = 114 | try 115 | let program = PiParser.ParseFromString(pi) 116 | processor.RunProgram(program) 117 | with 118 | | exp -> Console.WriteLine("Exception: {0}", exp.Message) 119 | 120 | let Help () = 121 | let msg = """JsonPi REPL Help 122 | Enter REPL Command or JsonPi statements. Commands start with a colon (':'). 123 | 124 | :h or :help Display this help message. 125 | :q or :quit Exit from the JsonPi REPL program. 126 | :r or :run Enter into run mode. Execution runs continuously without stopping between steps. 127 | :s or :step Enter into step mode. Execution will wait for a key press between steps. 128 | :m or :multi Toggles multiline mode. When in multiline mode enter 'go' to start execution. 129 | :l or :list Display the list of channels with pending receive or send continuations. 130 | :reset Reset the processor, clearing the list of pending recieve or send continuations. 131 | 132 | JsonPi Basic Syntax 133 | c Send name(s) on channel c. 134 | c(n1 [, n2...]) Receive name(s) on channel c. 135 | | Separates concurrent processes. ('|' vertical bar character) 136 | ; Terminates processes. (';' semicolon character) 137 | !P Replicate process P. 138 | new (n [':' t]) [ '=' JSON] Creates new name with optional type and optional JSON initialization data. 139 | 140 | See https://github.com/glenbraun/JsonPi readme for more detailed help. 141 | """ 142 | Console.WriteLine(msg) 143 | 144 | let rec Run() = 145 | let prompt = 146 | match (multiline, step) with 147 | | (false, false) -> "Run> " 148 | | (false, true) -> "Step> " 149 | | (true, false) -> "Run>> " 150 | | (true, true) -> "Step >> " 151 | 152 | Console.Write(prompt) 153 | 154 | let line = Console.ReadLine().Trim() 155 | 156 | if (line.StartsWith(":")) 157 | then 158 | match line with 159 | | ":q" | ":quit" | ":exit" -> Quit() 160 | | ":h" | ":help" -> Help(); Run() 161 | | ":l" | ":list" -> ListPending(); Run() 162 | | ":s" | ":step" -> StepMode(); Run() 163 | | ":r" | ":run" -> RunMode(); Run() 164 | | ":m" | ":multi" -> ToggleMultiline(); Run() 165 | | ":reset" -> Reset(); Run() 166 | | _ -> CommandUnknown(line); Run() 167 | else 168 | if multiline 169 | then 170 | if line = "go" 171 | then 172 | ExecutePi(picalc.ToString()) 173 | picalc.Clear() |> ignore 174 | else 175 | picalc.Append(line + Environment.NewLine) |> ignore 176 | else 177 | picalc.Clear() |> ignore 178 | ExecutePi(line) 179 | Run() 180 | -------------------------------------------------------------------------------- /JsonPiREPL/PiReplParser.fs: -------------------------------------------------------------------------------- 1 | // Implementation file for parser generated by fsyacc 2 | module internal PiReplParser 3 | #nowarn "64";; // turn off warnings that type variables used in production annotations are instantiated to concrete type 4 | open Microsoft.FSharp.Text.Lexing 5 | open Microsoft.FSharp.Text.Parsing.ParseHelpers 6 | # 1 "PiReplParser.fsy" 7 | 8 | open System 9 | open PiRepl 10 | 11 | 12 | # 12 "PiReplParser.fs" 13 | // This type is the type of tokens accepted by the parser 14 | type token = 15 | | COMMAND_UNKNOWN of (string) 16 | | PI of (string) 17 | | COMMAND_QUIT 18 | | COMMAND_HELP 19 | | COMMAND_RUN 20 | | COMMAND_STEP 21 | | COMMAND_MULTI 22 | | COMMAND_LIST 23 | | COMMAND_RESET 24 | | END_OF_LINE 25 | | EOF 26 | // This type is used to give symbolic names to token indexes, useful for error messages 27 | type tokenId = 28 | | TOKEN_COMMAND_UNKNOWN 29 | | TOKEN_PI 30 | | TOKEN_COMMAND_QUIT 31 | | TOKEN_COMMAND_HELP 32 | | TOKEN_COMMAND_RUN 33 | | TOKEN_COMMAND_STEP 34 | | TOKEN_COMMAND_MULTI 35 | | TOKEN_COMMAND_LIST 36 | | TOKEN_COMMAND_RESET 37 | | TOKEN_END_OF_LINE 38 | | TOKEN_EOF 39 | | TOKEN_end_of_input 40 | | TOKEN_error 41 | // This type is used to give symbolic names to token indexes, useful for error messages 42 | type nonTerminalId = 43 | | NONTERM__startstart 44 | | NONTERM_start 45 | | NONTERM_ReplLines 46 | | NONTERM_ReplLine 47 | | NONTERM_PiStatement 48 | | NONTERM_ReplCommand 49 | 50 | // This function maps tokens to integer indexes 51 | let tagOfToken (t:token) = 52 | match t with 53 | | COMMAND_UNKNOWN _ -> 0 54 | | PI _ -> 1 55 | | COMMAND_QUIT -> 2 56 | | COMMAND_HELP -> 3 57 | | COMMAND_RUN -> 4 58 | | COMMAND_STEP -> 5 59 | | COMMAND_MULTI -> 6 60 | | COMMAND_LIST -> 7 61 | | COMMAND_RESET -> 8 62 | | END_OF_LINE -> 9 63 | | EOF -> 10 64 | 65 | // This function maps integer indexes to symbolic token ids 66 | let tokenTagToTokenId (tokenIdx:int) = 67 | match tokenIdx with 68 | | 0 -> TOKEN_COMMAND_UNKNOWN 69 | | 1 -> TOKEN_PI 70 | | 2 -> TOKEN_COMMAND_QUIT 71 | | 3 -> TOKEN_COMMAND_HELP 72 | | 4 -> TOKEN_COMMAND_RUN 73 | | 5 -> TOKEN_COMMAND_STEP 74 | | 6 -> TOKEN_COMMAND_MULTI 75 | | 7 -> TOKEN_COMMAND_LIST 76 | | 8 -> TOKEN_COMMAND_RESET 77 | | 9 -> TOKEN_END_OF_LINE 78 | | 10 -> TOKEN_EOF 79 | | 13 -> TOKEN_end_of_input 80 | | 11 -> TOKEN_error 81 | | _ -> failwith "tokenTagToTokenId: bad token" 82 | 83 | /// This function maps production indexes returned in syntax errors to strings representing the non terminal that would be produced by that production 84 | let prodIdxToNonTerminal (prodIdx:int) = 85 | match prodIdx with 86 | | 0 -> NONTERM__startstart 87 | | 1 -> NONTERM_start 88 | | 2 -> NONTERM_ReplLines 89 | | 3 -> NONTERM_ReplLines 90 | | 4 -> NONTERM_ReplLine 91 | | 5 -> NONTERM_ReplLine 92 | | 6 -> NONTERM_ReplLine 93 | | 7 -> NONTERM_PiStatement 94 | | 8 -> NONTERM_ReplCommand 95 | | 9 -> NONTERM_ReplCommand 96 | | 10 -> NONTERM_ReplCommand 97 | | 11 -> NONTERM_ReplCommand 98 | | 12 -> NONTERM_ReplCommand 99 | | 13 -> NONTERM_ReplCommand 100 | | 14 -> NONTERM_ReplCommand 101 | | 15 -> NONTERM_ReplCommand 102 | | _ -> failwith "prodIdxToNonTerminal: bad production index" 103 | 104 | let _fsyacc_endOfInputTag = 13 105 | let _fsyacc_tagOfErrorTerminal = 11 106 | 107 | // This function gets the name of a token as a string 108 | let token_to_string (t:token) = 109 | match t with 110 | | COMMAND_UNKNOWN _ -> "COMMAND_UNKNOWN" 111 | | PI _ -> "PI" 112 | | COMMAND_QUIT -> "COMMAND_QUIT" 113 | | COMMAND_HELP -> "COMMAND_HELP" 114 | | COMMAND_RUN -> "COMMAND_RUN" 115 | | COMMAND_STEP -> "COMMAND_STEP" 116 | | COMMAND_MULTI -> "COMMAND_MULTI" 117 | | COMMAND_LIST -> "COMMAND_LIST" 118 | | COMMAND_RESET -> "COMMAND_RESET" 119 | | END_OF_LINE -> "END_OF_LINE" 120 | | EOF -> "EOF" 121 | 122 | // This function gets the data carried by a token as an object 123 | let _fsyacc_dataOfToken (t:token) = 124 | match t with 125 | | COMMAND_UNKNOWN _fsyacc_x -> Microsoft.FSharp.Core.Operators.box _fsyacc_x 126 | | PI _fsyacc_x -> Microsoft.FSharp.Core.Operators.box _fsyacc_x 127 | | COMMAND_QUIT -> (null : System.Object) 128 | | COMMAND_HELP -> (null : System.Object) 129 | | COMMAND_RUN -> (null : System.Object) 130 | | COMMAND_STEP -> (null : System.Object) 131 | | COMMAND_MULTI -> (null : System.Object) 132 | | COMMAND_LIST -> (null : System.Object) 133 | | COMMAND_RESET -> (null : System.Object) 134 | | END_OF_LINE -> (null : System.Object) 135 | | EOF -> (null : System.Object) 136 | let _fsyacc_gotos = [| 0us; 65535us; 1us; 65535us; 0us; 1us; 1us; 65535us; 0us; 2us; 2us; 65535us; 0us; 3us; 2us; 4us; 2us; 65535us; 0us; 5us; 2us; 5us; 2us; 65535us; 0us; 7us; 2us; 7us; |] 137 | let _fsyacc_sparseGotoTableRowOffsets = [|0us; 1us; 3us; 5us; 8us; 11us; |] 138 | let _fsyacc_stateToProdIdxsTableElements = [| 1us; 0us; 1us; 0us; 2us; 1us; 3us; 1us; 2us; 1us; 3us; 1us; 4us; 1us; 4us; 1us; 5us; 1us; 5us; 1us; 6us; 1us; 7us; 1us; 8us; 1us; 9us; 1us; 10us; 1us; 11us; 1us; 12us; 1us; 13us; 1us; 14us; 1us; 15us; |] 139 | let _fsyacc_stateToProdIdxsTableRowOffsets = [|0us; 2us; 4us; 7us; 9us; 11us; 13us; 15us; 17us; 19us; 21us; 23us; 25us; 27us; 29us; 31us; 33us; 35us; 37us; |] 140 | let _fsyacc_action_rows = 19 141 | let _fsyacc_actionTableElements = [|10us; 32768us; 0us; 18us; 1us; 10us; 2us; 11us; 3us; 12us; 4us; 14us; 5us; 15us; 6us; 13us; 7us; 16us; 8us; 17us; 9us; 9us; 0us; 49152us; 10us; 16385us; 0us; 18us; 1us; 10us; 2us; 11us; 3us; 12us; 4us; 14us; 5us; 15us; 6us; 13us; 7us; 16us; 8us; 17us; 9us; 9us; 0us; 16386us; 0us; 16387us; 1us; 32768us; 9us; 6us; 0us; 16388us; 1us; 32768us; 9us; 8us; 0us; 16389us; 0us; 16390us; 0us; 16391us; 0us; 16392us; 0us; 16393us; 0us; 16394us; 0us; 16395us; 0us; 16396us; 0us; 16397us; 0us; 16398us; 0us; 16399us; |] 142 | let _fsyacc_actionTableRowOffsets = [|0us; 11us; 12us; 23us; 24us; 25us; 27us; 28us; 30us; 31us; 32us; 33us; 34us; 35us; 36us; 37us; 38us; 39us; 40us; |] 143 | let _fsyacc_reductionSymbolCounts = [|1us; 1us; 1us; 2us; 2us; 2us; 1us; 1us; 1us; 1us; 1us; 1us; 1us; 1us; 1us; 1us; |] 144 | let _fsyacc_productionToNonTerminalTable = [|0us; 1us; 2us; 2us; 3us; 3us; 3us; 4us; 5us; 5us; 5us; 5us; 5us; 5us; 5us; 5us; |] 145 | let _fsyacc_immediateActions = [|65535us; 49152us; 65535us; 16386us; 16387us; 65535us; 16388us; 65535us; 16389us; 16390us; 16391us; 16392us; 16393us; 16394us; 16395us; 16396us; 16397us; 16398us; 16399us; |] 146 | let _fsyacc_reductions () = [| 147 | # 147 "PiReplParser.fs" 148 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 149 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : obj option )) in 150 | Microsoft.FSharp.Core.Operators.box 151 | ( 152 | ( 153 | raise (Microsoft.FSharp.Text.Parsing.Accept(Microsoft.FSharp.Core.Operators.box _1)) 154 | ) 155 | : '_startstart)); 156 | # 156 "PiReplParser.fs" 157 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 158 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : 'ReplLines)) in 159 | Microsoft.FSharp.Core.Operators.box 160 | ( 161 | ( 162 | # 27 "PiReplParser.fsy" 163 | None 164 | ) 165 | # 27 "PiReplParser.fsy" 166 | : obj option )); 167 | # 167 "PiReplParser.fs" 168 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 169 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : 'ReplLine)) in 170 | Microsoft.FSharp.Core.Operators.box 171 | ( 172 | ( 173 | # 30 "PiReplParser.fsy" 174 | None 175 | ) 176 | # 30 "PiReplParser.fsy" 177 | : 'ReplLines)); 178 | # 178 "PiReplParser.fs" 179 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 180 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : 'ReplLines)) in 181 | let _2 = (let data = parseState.GetInput(2) in (Microsoft.FSharp.Core.Operators.unbox data : 'ReplLine)) in 182 | Microsoft.FSharp.Core.Operators.box 183 | ( 184 | ( 185 | # 31 "PiReplParser.fsy" 186 | None 187 | ) 188 | # 31 "PiReplParser.fsy" 189 | : 'ReplLines)); 190 | # 190 "PiReplParser.fs" 191 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 192 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : 'PiStatement)) in 193 | Microsoft.FSharp.Core.Operators.box 194 | ( 195 | ( 196 | # 34 "PiReplParser.fsy" 197 | None 198 | ) 199 | # 34 "PiReplParser.fsy" 200 | : 'ReplLine)); 201 | # 201 "PiReplParser.fs" 202 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 203 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : 'ReplCommand)) in 204 | Microsoft.FSharp.Core.Operators.box 205 | ( 206 | ( 207 | # 35 "PiReplParser.fsy" 208 | None 209 | ) 210 | # 35 "PiReplParser.fsy" 211 | : 'ReplLine)); 212 | # 212 "PiReplParser.fs" 213 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 214 | Microsoft.FSharp.Core.Operators.box 215 | ( 216 | ( 217 | # 36 "PiReplParser.fsy" 218 | None 219 | ) 220 | # 36 "PiReplParser.fsy" 221 | : 'ReplLine)); 222 | # 222 "PiReplParser.fs" 223 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 224 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : string)) in 225 | Microsoft.FSharp.Core.Operators.box 226 | ( 227 | ( 228 | # 39 "PiReplParser.fsy" 229 | PiRepl.ExecutePi(_1); None 230 | ) 231 | # 39 "PiReplParser.fsy" 232 | : 'PiStatement)); 233 | # 233 "PiReplParser.fs" 234 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 235 | Microsoft.FSharp.Core.Operators.box 236 | ( 237 | ( 238 | # 42 "PiReplParser.fsy" 239 | PiRepl.Quit(); None 240 | ) 241 | # 42 "PiReplParser.fsy" 242 | : 'ReplCommand)); 243 | # 243 "PiReplParser.fs" 244 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 245 | Microsoft.FSharp.Core.Operators.box 246 | ( 247 | ( 248 | # 43 "PiReplParser.fsy" 249 | PiRepl.Help(); None 250 | ) 251 | # 43 "PiReplParser.fsy" 252 | : 'ReplCommand)); 253 | # 253 "PiReplParser.fs" 254 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 255 | Microsoft.FSharp.Core.Operators.box 256 | ( 257 | ( 258 | # 44 "PiReplParser.fsy" 259 | PiRepl.ToggleMultiline(); None 260 | ) 261 | # 44 "PiReplParser.fsy" 262 | : 'ReplCommand)); 263 | # 263 "PiReplParser.fs" 264 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 265 | Microsoft.FSharp.Core.Operators.box 266 | ( 267 | ( 268 | # 45 "PiReplParser.fsy" 269 | PiRepl.RunMode(); None 270 | ) 271 | # 45 "PiReplParser.fsy" 272 | : 'ReplCommand)); 273 | # 273 "PiReplParser.fs" 274 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 275 | Microsoft.FSharp.Core.Operators.box 276 | ( 277 | ( 278 | # 46 "PiReplParser.fsy" 279 | PiRepl.StepMode(); None 280 | ) 281 | # 46 "PiReplParser.fsy" 282 | : 'ReplCommand)); 283 | # 283 "PiReplParser.fs" 284 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 285 | Microsoft.FSharp.Core.Operators.box 286 | ( 287 | ( 288 | # 47 "PiReplParser.fsy" 289 | PiRepl.ListPending(); None 290 | ) 291 | # 47 "PiReplParser.fsy" 292 | : 'ReplCommand)); 293 | # 293 "PiReplParser.fs" 294 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 295 | Microsoft.FSharp.Core.Operators.box 296 | ( 297 | ( 298 | # 48 "PiReplParser.fsy" 299 | PiRepl.Reset(); None 300 | ) 301 | # 48 "PiReplParser.fsy" 302 | : 'ReplCommand)); 303 | # 303 "PiReplParser.fs" 304 | (fun (parseState : Microsoft.FSharp.Text.Parsing.IParseState) -> 305 | let _1 = (let data = parseState.GetInput(1) in (Microsoft.FSharp.Core.Operators.unbox data : string)) in 306 | Microsoft.FSharp.Core.Operators.box 307 | ( 308 | ( 309 | # 49 "PiReplParser.fsy" 310 | PiRepl.CommandUnknown(_1); None 311 | ) 312 | # 49 "PiReplParser.fsy" 313 | : 'ReplCommand)); 314 | |] 315 | # 315 "PiReplParser.fs" 316 | let tables () : Microsoft.FSharp.Text.Parsing.Tables<_> = 317 | { reductions= _fsyacc_reductions (); 318 | endOfInputTag = _fsyacc_endOfInputTag; 319 | tagOfToken = tagOfToken; 320 | dataOfToken = _fsyacc_dataOfToken; 321 | actionTableElements = _fsyacc_actionTableElements; 322 | actionTableRowOffsets = _fsyacc_actionTableRowOffsets; 323 | stateToProdIdxsTableElements = _fsyacc_stateToProdIdxsTableElements; 324 | stateToProdIdxsTableRowOffsets = _fsyacc_stateToProdIdxsTableRowOffsets; 325 | reductionSymbolCounts = _fsyacc_reductionSymbolCounts; 326 | immediateActions = _fsyacc_immediateActions; 327 | gotos = _fsyacc_gotos; 328 | sparseGotoTableRowOffsets = _fsyacc_sparseGotoTableRowOffsets; 329 | tagOfErrorTerminal = _fsyacc_tagOfErrorTerminal; 330 | parseError = (fun (ctxt:Microsoft.FSharp.Text.Parsing.ParseErrorContext<_>) -> 331 | match parse_error_rich with 332 | | Some f -> f ctxt 333 | | None -> parse_error ctxt.Message); 334 | numTerminals = 14; 335 | productionToNonTerminalTable = _fsyacc_productionToNonTerminalTable } 336 | let engine lexer lexbuf startState = (tables ()).Interpret(lexer, lexbuf, startState) 337 | let start lexer lexbuf : obj option = 338 | Microsoft.FSharp.Core.Operators.unbox ((tables ()).Interpret(lexer, lexbuf, 0)) 339 | -------------------------------------------------------------------------------- /JsonPiREPL/PiReplParser.fsi: -------------------------------------------------------------------------------- 1 | // Signature file for parser generated by fsyacc 2 | module internal PiReplParser 3 | type token = 4 | | COMMAND_UNKNOWN of (string) 5 | | PI of (string) 6 | | COMMAND_QUIT 7 | | COMMAND_HELP 8 | | COMMAND_RUN 9 | | COMMAND_STEP 10 | | COMMAND_MULTI 11 | | COMMAND_LIST 12 | | COMMAND_RESET 13 | | END_OF_LINE 14 | | EOF 15 | type tokenId = 16 | | TOKEN_COMMAND_UNKNOWN 17 | | TOKEN_PI 18 | | TOKEN_COMMAND_QUIT 19 | | TOKEN_COMMAND_HELP 20 | | TOKEN_COMMAND_RUN 21 | | TOKEN_COMMAND_STEP 22 | | TOKEN_COMMAND_MULTI 23 | | TOKEN_COMMAND_LIST 24 | | TOKEN_COMMAND_RESET 25 | | TOKEN_END_OF_LINE 26 | | TOKEN_EOF 27 | | TOKEN_end_of_input 28 | | TOKEN_error 29 | type nonTerminalId = 30 | | NONTERM__startstart 31 | | NONTERM_start 32 | | NONTERM_ReplLines 33 | | NONTERM_ReplLine 34 | | NONTERM_PiStatement 35 | | NONTERM_ReplCommand 36 | /// This function maps tokens to integer indexes 37 | val tagOfToken: token -> int 38 | 39 | /// This function maps integer indexes to symbolic token ids 40 | val tokenTagToTokenId: int -> tokenId 41 | 42 | /// This function maps production indexes returned in syntax errors to strings representing the non terminal that would be produced by that production 43 | val prodIdxToNonTerminal: int -> nonTerminalId 44 | 45 | /// This function gets the name of a token as a string 46 | val token_to_string: token -> string 47 | val start : (Microsoft.FSharp.Text.Lexing.LexBuffer<'cty> -> token) -> Microsoft.FSharp.Text.Lexing.LexBuffer<'cty> -> ( obj option ) 48 | -------------------------------------------------------------------------------- /JsonPiREPL/Program.fs: -------------------------------------------------------------------------------- 1 | module JsonPiRepl 2 | 3 | open System 4 | open PiRepl 5 | 6 | [] 7 | let main argv = 8 | Run() 9 | 0 // return an integer exit code 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 glenbraun 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # JsonPi 2 | A Pi Calculus interpreter. 3 | 4 | ## Purpose 5 | To aid in learning the pi calculus and experiment with the pi calculus model of computation. To learn about the pi calculus see https://en.wikipedia.org/wiki/Π-calculus. 6 | 7 | 8 | ## Description 9 | JsonPi is designed to interpret programs based on the pi calculus as described in chapter one of the book: "The pi-calculus: a Theory of Mobile Processes" by Davide Sangiorgi and David Walker. 10 | The interpreter is currently implemented in F# but designed to be easily ported to other languages. JsonPi programs are represented in JSON so are meant to be easily executed on any platform which supports an interpreter. 11 | 12 | ## Primary features 13 | * Designed to run pi calculus programs as defined in the book "The pi-calculus: a Theory of Mobile Processes" 14 | * Represents names as any arbitrary JSON 15 | * Modularity for building reusable libraries of pi calculus components 16 | * Extensibility to the backing language of the interpreter (right now F#) 17 | 18 | ## Example 19 | ``` 20 | world; | world(message); 21 | ``` 22 | 23 | Above is an example of the most basic and fundamental capability of the pi calculus and JsonPi, the comm rule. 24 | * The identifier 'world' is a pi calculus name which, in this case, is being used as a channel of communication used by two processes, one sending and one receiving 25 | * The identifier 'hello' is a pi calculus name which is used here as data being sent over the channel 'world' 26 | * The identifier 'message' is also a pi calculus name used as a handle to whatever data is being received over the channel 'world' 27 | * The construct channel\ is read "Send name on channel" 28 | * The construct channel(name) is read "Receive name on channel" 29 | * The semi-colon ';', is the inactive process which terminates a process 30 | * The vertical bar '|', separates two processes running in parallel. (JsonPi is single threaded but more on that later.) 31 | 32 | The constructs of send and receive ('channel\' and 'channel(name)') are called prefixes which can be strung together into a series of consecutive steps. 33 | For any process, execution is halted on a prefix until a matching send or receive operation is pending on another process. 34 | So, in the example above, a matching send and receive operation is present on the channel 'world' and so execution will progress one more step after the send and receive operations. 35 | In this case, the next step for both processes is the inactive process ';', which completes execution. 36 | 37 | ## Elements of the JsonPi Language 38 | The full JsonPi grammar is defined in the lex/yacc files in the source code at [PiLexerInternal.fsl](https://github.com/glenbraun/JsonPi/blob/JsonPi/JsonPiInterpreter/PiLexerInternal.fsl) and [PiParserInternal.fsy](https://github.com/glenbraun/JsonPi/blob/JsonPi/JsonPiInterpreter/PiParserInternal.fsy). 39 | 40 | ### Send on a channel 41 | #### Syntax 42 | channel '\<' name [ ',' name] '>' 43 | #### Example 44 | ``` 45 | x; 46 | ``` 47 | #### Description 48 | The names 'a', 'b' and 'c' are being sent on the channel 'x'. 49 | Execution will block for this process until another process is attempting to receive on channel 'x'. 50 | All other processes are free to execute. 51 | 52 | ### Receive on a channel 53 | #### Syntax 54 | channel '(' name [ ',' name] ')' 55 | #### Example 56 | ``` 57 | x(f,g,h); 58 | ``` 59 | #### Description. 60 | The names 'f', 'g' and 'h' are used as placeholders for data to be received over the channel 'x'. 61 | Execution will block for this process until another process is attempting to send on channel 'x'. 62 | All other processes are free to execute. 63 | 64 | ### Compose processes 65 | #### Syntax 66 | P '|' Q 67 | #### Example 68 | ``` 69 | x; | x(f,g,h); 70 | ``` 71 | #### Description 72 | Compose processes using a vertical bar '|'. 73 | In the example, the left process is sending on the channel 'x' and the other is receiving on the channel 'x'. 74 | The three names of 'a', 'b' and 'c' will be sent over channel 'x' and then both processes with become inactive. 75 | JsonPi is single threaded but, conceptually, the sending process on the left and the receiving process on the right should be thought of as running at the same time. 76 | The ending ';' is important and required in both the left and right process because prefixes must be followed by a process. 77 | In this case the inactive process. 78 | 79 | ### Create a new name 80 | #### Syntax 81 | 'new' '(' name [ ':' name-type ] ')' [ '=' JSON-Data ] 82 | ### Examples 83 | ``` 84 | new (x) 85 | 86 | new (x:MyNameType) 87 | 88 | new (x) = { "City" : "Seattle" } 89 | 90 | new (x:MyNameType) = { "City" : "Seattle" } 91 | ``` 92 | #### Description 93 | The 'new' syntax is used to create a restricted name. 94 | Names in JsonPi do not have to be restricted, you can use any name you like. 95 | However, restricting a name ensures that the name is not one that has been used before, even though it might share an identifier. 96 | For example: 97 | 98 | ``` 99 | x; | new (x) x(f); 100 | ``` 101 | 102 | will remained blocked with the send operation on the channel identified by 'x' and the receive operation identified by the new channel identified by 'x' as happening on separate channels. 103 | 104 | Restricted names can be sent outside the scope of 'new'. For example: 105 | 106 | ``` 107 | new (a) x; | x(f) ( f; | f(c); ) 108 | ``` 109 | 110 | Here, the new name 'a' is being sent over the channel 'x' and then used as a channel over which the name 'b' is being sent. 111 | This demonstrates how restricted names can be extruded across processes. 112 | 113 | Restricted names are also the way to indicate to JsonPi that the name has an optional type and an optional JSON data object. 114 | The name-type is used to map to an extensibility capability provided by the backing language of the interpreter (more below). 115 | The JSON-Data object is carried as additional data for the name and is available to extension code implemented in the backing language. Any arbitrary JSON data is acceptable. 116 | 117 | ### Repeated processes 118 | #### Syntax 119 | '!' P 120 | #### Example 121 | ``` 122 | !(x(f);) 123 | ``` 124 | #### Description 125 | The execution of processes moves from prefix to prefix until reaching the inactive process which completes the execution. 126 | To keep a process active the replication systax is used. After each successful step in the process defined under a replication a new process is started from the beginning. 127 | For example: 128 | 129 | ``` 130 | x; | x y(c); | ( !(x(d) y;) ) 131 | ``` 132 | 133 | defines three processes. 134 | The first, from the left, will attempt to send 'a' on 'x' and then become inactive. 135 | The second will attempt to send 'b' on 'x' and then receive 'c' on 'y'. 136 | The third process uses replication to continuously receive on 'x' and then send what it receives on 'y'. 137 | 138 | When the replication executes the first receive on 'x', it will compose two processes, one which continues the remainder of the first execution, that is, sending 'd' on 'y', and the other to begin the replication process from the start by attempting to receive 'd' on 'x' again. 139 | In this example, of the three processes, the first two will run to completion but the replication process will retain one process awaiting a receive on 'x'. 140 | 141 | ### Conditional execution 142 | #### Syntax 143 | '[' name '=' name ']' Prefix 144 | #### Examples 145 | ``` 146 | x(a) [a=b]y; | x; 147 | 148 | x(a) y(c) [a=b][c=d]z(f); | x y z; 149 | ``` 150 | #### Description 151 | The match syntax defines a conditional guard on a prefix. The conditoinin the match must be met before its send or receive operation is attempted. 152 | In the first example, the name 'b' is sent over the channel 'x' and received as 'a'. 153 | Once 'a' is received as 'b', subsequent values of 'a' are substituted with 'b' which produces the match expression of [b=b] which is true. 154 | This then allows the attempt to send 'c' on 'y'. 155 | 156 | The second example demonstrates that multiple match expressions can be used before a send or receive prefix. 157 | 158 | ### Branching 159 | #### Syntax 160 | 'choose' 'when' Prefix 'then' Process [...] [ 'default' Process ] 'end' 161 | #### Example 162 | ``` 163 | choose 164 | when x(a) then ; 165 | when y(b) then z; 166 | when [c=d]x then y(f); 167 | default z(g); 168 | end 169 | ``` 170 | #### Description 171 | The 'choose' syntax is used to define a pi calculus sum expression. The prefix of each 'when' clause is evaluated in order from first to last. 172 | If the prefix does not block then it will proceed to the process of the 'then' clause and the other 'when' clauses and an optional 'default' will be abandoned. 173 | The optional default process is executed if all of the 'when' clause prefixes are blocked. 174 | 175 | ### Process Binding 176 | #### Syntax 177 | 'let' Identifier '=' Process 178 | #### Examples 179 | ``` 180 | let P = x; 181 | let Q = x(b); 182 | ``` 183 | #### Description 184 | Process bindings give an identifier to a process for the sake of code organization and reuse. 185 | 186 | ### Process Reference 187 | #### Syntax 188 | '$' Identifier 189 | #### Examples 190 | ``` 191 | $P | $Q 192 | 193 | x $P | x(b) $Q 194 | ``` 195 | #### Description 196 | Processes defined with a previous process binding can be used with a process reference. A process reference can be used anywhere a process could also be used. 197 | 198 | ### Module Definition 199 | #### Syntax 200 | 'module' Identifier 201 | #### Example 202 | ``` 203 | module MyModule 204 | ``` 205 | #### Description 206 | Modules provide a way to group related code together. All pi calculus code following a 'module' definition is combined within that module. 207 | Modules can define process bindings which can be used by other programs which reference the defining module. 208 | 209 | ### Module Reference 210 | #### Syntax 211 | 'using' Identifier 212 | #### Example 213 | ``` 214 | using MyModule 215 | ``` 216 | #### Description 217 | Referencing a module makes all of the top-level process bindings of the defining module available to the program. 218 | Modules also have a base process which executes in parallel with the process which references the module. 219 | 220 | ## Extensibility 221 | JsonPi provides a mechanism to execute code written in the language of the interpreter (currently only F#). 222 | This allows for JsonPi programs to use the features of the backing language. 223 | While F# is the only backing language today, other backing languages like JavaScript could provide an interpreter with the ability to call scripts from a pi calculus program. 224 | There are three events when external code can be called: 225 | * On the creation of a new name 226 | * During a send operation 227 | * During a receive operation 228 | When the external code is executed it can optionally return a pi calculus process which will executed after the external code. 229 | The name type of the channel is used as a map to the external functionality. 230 | For an example of the extensibility mechanism, see the basic tests in the Test project. 231 | 232 | ## Threading 233 | Even though pi calculus is meant for modeling concurrent processes, the JsonPi interpreter executes sequentially. 234 | This was done intentionally to simplify the implementation and to provide a repeatable execution to aid in understanding and learning the pi calculus. 235 | Some thought has been given to a future enhancement of making the PiNamespace type threadsafe and alowing it to be shared across PiProcessor instances which would provide for multiple threads of execution. 236 | 237 | ## Running the REPL 238 | JsonPi runs on .Net Core so it should run on other platforms than Windows. I've confirmed this on Ubuntu 16.04. 239 | 240 | ### Steps for building manually (pseudo code below) 241 | 1. Install .Net Core using Step 1 of instructions from https://www.microsoft.com/net/learn/get-started/linux/rhel 242 | 2. Clone or copy this repo 243 | 3. ```cd ./JsonPiREPL``` 244 | 4. Run ```dotnet build -c Release -r ubuntu.16.04-x64```. (or, ```dotnet publish -c Release -r ubuntu.16.04-x64``` for self-contained application) 245 | 246 | Note: Other platforms for the -r switch can be found at https://docs.microsoft.com/en-us/dotnet/core/rid-catalog 247 | 5. ```cd ./bin/Release/netcoreapp2.0/ubuntu.16.04-x64```. 248 | 249 | Note: You'll see a different folder than ```ubuntu.16.04-x64``` based on the value of the -r switch in step 4. 250 | 6. Run ```./JsonPiREPL``` 251 | 252 | You should see "Run>". Type :h for help, :q to quit. 253 | 254 | ## Known Issues 255 | 1. No friendly parser errors. Any error in parsing results in an exception thrown with very little indication of what the issue is. 256 | Sorry, I know this can be maddening. When in doubt, add parenthesis around processes, and don't forget the termination process (;) at the end of processes. 257 | The Tests folder has many examples which all parse and run, starting with these can help get the right syntax. 258 | 259 | 2. Let bindings don't work in the REPL. They probably do work in multiline mode but not across executions. 260 | 261 | 3. Commands don't work between steps in step mode. You can't run a few steps then enter :l, for example. 262 | You have to wait for the execution to complete. 263 | -------------------------------------------------------------------------------- /Tests/AssemblyInfo.fs: -------------------------------------------------------------------------------- 1 | namespace Tests.AssemblyInfo 2 | 3 | open System.Reflection 4 | open System.Runtime.CompilerServices 5 | open System.Runtime.InteropServices 6 | 7 | // General Information about an assembly is controlled through the following 8 | // set of attributes. Change these attribute values to modify the information 9 | // associated with an assembly. 10 | [] 11 | [] 12 | [] 13 | [] 14 | [] 15 | [] 16 | [] 17 | [] 18 | 19 | // Setting ComVisible to false makes the types in this assembly not visible 20 | // to COM components. If you need to access a type in this assembly from 21 | // COM, set the ComVisible attribute to true on that type. 22 | [] 23 | 24 | // The following GUID is for the ID of the typelib if this project is exposed to COM 25 | [] 26 | 27 | // Version information for an assembly consists of the following four values: 28 | // 29 | // Major Version 30 | // Minor Version 31 | // Build Number 32 | // Revision 33 | // 34 | // You can specify all the values or you can default the Build and Revision Numbers 35 | // by using the '*' as shown below: 36 | // [] 37 | [] 38 | [] 39 | 40 | do 41 | () -------------------------------------------------------------------------------- /Tests/PiTest.fs: -------------------------------------------------------------------------------- 1 | module PiTest 2 | 3 | open System 4 | open System.IO 5 | 6 | open JsonPi 7 | open JsonPi.Data 8 | open JsonPi.PiRuntime 9 | 10 | type PiTestCase = 11 | | AsString of Name : string * 12 | Code : string 13 | | AsStringWithExtensions of Name : string * 14 | Code : string * 15 | Resolver : PiExtensionResolver 16 | | AsFile of Name : string * 17 | Path : string 18 | | AsFileWithExtensions of Name : string * 19 | Path : string * 20 | Resolver : PiExtensionResolver 21 | 22 | type PiTestResult = 23 | | Unknown 24 | | Passed 25 | | Failed of string 26 | 27 | type ITextExpected = 28 | abstract member GetExpected : string -> PiTraceEvent list 29 | 30 | type PiTestModule (path:string, cases:PiTestCase list) = 31 | 32 | let PrintPiEvent (sw:TextWriter) (ev:PiTraceEvent) = 33 | let fsw = PiFSharpWriter(sw) 34 | 35 | match ev with 36 | | PiTraceEvent.PushProcess(p) -> 37 | sw.Write(" PiTraceEvent.PushProcess([]") 38 | //fsw.Write(p) 39 | sw.WriteLine(")") 40 | | PiTraceEvent.RunProcess(p) -> 41 | sw.Write(" PiTraceEvent.RunProcess([]") 42 | //fsw.Write(p) 43 | sw.WriteLine(")") 44 | | PiTraceEvent.PutPrefix(pfx, continuation) -> 45 | sw.Write(" PiTraceEvent.PutPrefix(") 46 | fsw.Write(pfx) 47 | sw.Write(",[]") 48 | //fsw.Write(continuation) 49 | sw.WriteLine(")") 50 | | PiTraceEvent.GetPrefix(pfx, continuation) -> 51 | sw.Write(" PiTraceEvent.GetPrefix(") 52 | fsw.Write(pfx) 53 | sw.Write(",[]") 54 | //fsw.Write(continuation) 55 | sw.WriteLine(")") 56 | | PiTraceEvent.TransitionOut(channel, outNames, _) -> 57 | sw.Write(" PiTraceEvent.TransitionOut(") 58 | fsw.Write(channel) 59 | sw.Write(",") 60 | fsw.Write(outNames) 61 | sw.WriteLine(", [])") 62 | | PiTraceEvent.TransitionInp(channel, outNames, inpNames, _) -> 63 | sw.Write(" PiTraceEvent.TransitionInp(") 64 | fsw.Write(channel) 65 | sw.Write(",") 66 | fsw.Write(outNames) 67 | sw.Write(",") 68 | fsw.Write(inpNames) 69 | sw.WriteLine(", [])") 70 | | PiTraceEvent.TransitionSum(summation, whenPfx) -> 71 | sw.Write(" PiTraceEvent.TransitionSum(") 72 | fsw.Write(summation) 73 | sw.Write(",") 74 | fsw.Write(whenPfx) 75 | sw.WriteLine(")") 76 | | PiTraceEvent.TransitionTau -> 77 | sw.WriteLine(" PiTraceEvent.TransitionTau") 78 | | PiTraceEvent.TransitionRep(s) -> 79 | sw.Write(" PiTraceEvent.TransitionRep(") 80 | fsw.Write(s) 81 | sw.WriteLine(")") 82 | | PiTraceEvent.RemoveSummation(summation) -> 83 | sw.Write(" PiTraceEvent.RemoveSummation(") 84 | fsw.Write(summation) 85 | sw.WriteLine(")") 86 | 87 | let GenerateTestCase (sw:StreamWriter) (test:PiTestCase) = 88 | let pp = 89 | match test with 90 | | PiTestCase.AsFile(_) 91 | | PiTestCase.AsString(_) -> 92 | PiProcessor() 93 | | PiTestCase.AsFileWithExtensions(_, _, resolver) 94 | | PiTestCase.AsStringWithExtensions(_, _, resolver) -> 95 | PiProcessor(Some(resolver)) 96 | 97 | use subscription = pp.AsObservable() |> Observable.subscribe (PrintPiEvent sw) 98 | 99 | match test with 100 | | PiTestCase.AsString(name, code) 101 | | PiTestCase.AsStringWithExtensions(name, code, _) -> 102 | Printf.fprintfn sw " let %s_Observations = [" name 103 | 104 | pp.RunString(code) 105 | 106 | Printf.fprintfn sw " ]" 107 | Printf.fprintfn sw "" 108 | | PiTestCase.AsFile(name, file) 109 | | PiTestCase.AsFileWithExtensions(name, file, _) -> 110 | Printf.fprintfn sw " let %s_Observations = [" name 111 | 112 | pp.RunFile(file) 113 | 114 | Printf.fprintfn sw " ]" 115 | Printf.fprintfn sw "" 116 | 117 | 118 | let GenerateTestMatch (sw:StreamWriter) (test:PiTestCase) = 119 | match test with 120 | | PiTestCase.AsString(name, _) 121 | | PiTestCase.AsStringWithExtensions(name, _, _) -> 122 | Printf.fprintfn sw " | \"%s\" -> %s_Observations" name name 123 | | _ -> () 124 | 125 | let getTag (a:'a) = 126 | let (uc,_) = Microsoft.FSharp.Reflection.FSharpValue.GetUnionFields(a, typeof<'a>) 127 | uc.Name 128 | 129 | let CompareEvents (ev:PiTraceEvent) (exp:PiTraceEvent) = 130 | use sw1 = new StringWriter() 131 | PrintPiEvent sw1 ev 132 | sw1.Flush() 133 | 134 | use sw2 = new StringWriter() 135 | PrintPiEvent sw2 exp 136 | sw2.Flush() 137 | 138 | let same = ((sw1.ToString()) = (sw2.ToString())) 139 | if same 140 | then 0 141 | else -1 142 | 143 | let RunTestCase (ex:ITextExpected) (test:PiTestCase) = 144 | let name = 145 | match test with 146 | | PiTestCase.AsString (n, _) -> n 147 | | PiTestCase.AsStringWithExtensions(n, _, _) -> n 148 | | PiTestCase.AsFile (n, _) -> n 149 | | PiTestCase.AsFileWithExtensions(n, _, _) -> n 150 | 151 | let expected = ex.GetExpected(name) 152 | 153 | let mutable result = PiTestResult.Unknown 154 | let mutable events : PiTraceEvent list = [] 155 | 156 | let addevent () (ev:PiTraceEvent) = 157 | events <- ev :: events 158 | 159 | let resolver = 160 | match test with 161 | | PiTestCase.AsStringWithExtensions(_, _, r) 162 | | PiTestCase.AsFileWithExtensions(_, _, r) -> Some(r) 163 | | _ -> None 164 | 165 | let pp = PiProcessor(resolver) 166 | let subscription = 167 | pp.AsObservable() 168 | |> Observable.scan addevent () 169 | |> Observable.subscribe (fun () -> ()) 170 | 171 | match test with 172 | | PiTestCase.AsString(n, code) 173 | | PiTestCase.AsStringWithExtensions(n, code, _) -> 174 | pp.RunString(code) 175 | | _ -> failwith "unexpected" 176 | 177 | events <- List.rev events 178 | let comp = 179 | List.compareWith CompareEvents expected events 180 | 181 | match comp with 182 | | 0 -> 183 | PiTestResult.Passed 184 | | _ -> 185 | PiTestResult.Failed(name) 186 | 187 | member this.Generate() = 188 | use modfile = File.CreateText(path) 189 | Printf.fprintfn modfile "namespace Generated_%s" (Path.GetFileNameWithoutExtension(path)) 190 | Printf.fprintfn modfile "" 191 | Printf.fprintfn modfile "open System" 192 | Printf.fprintfn modfile "" 193 | Printf.fprintfn modfile "open JsonPi" 194 | Printf.fprintfn modfile "open JsonPi.Data" 195 | Printf.fprintfn modfile "open JsonPi.PiRuntime" 196 | Printf.fprintfn modfile "" 197 | Printf.fprintfn modfile "open PiTest" 198 | Printf.fprintfn modfile "" 199 | 200 | Printf.fprintfn modfile "type %s () =" (Path.GetFileNameWithoutExtension(path)) 201 | 202 | cases |> 203 | List.iter (GenerateTestCase modfile) 204 | 205 | Printf.fprintfn modfile " interface ITextExpected with" 206 | Printf.fprintfn modfile " member this.GetExpected(name:string) =" 207 | Printf.fprintfn modfile " match name with" 208 | 209 | cases |> 210 | List.iter (GenerateTestMatch modfile) 211 | 212 | Printf.fprintfn modfile " | _ -> failwith \"unexpected\"" 213 | 214 | member this.RunOne(name:string, ex:ITextExpected) = 215 | let test = 216 | cases |> List.find 217 | (function 218 | | PiTestCase.AsString(n, _) 219 | | PiTestCase.AsStringWithExtensions(n, _, _) 220 | | PiTestCase.AsFile(n, _) 221 | | PiTestCase.AsFileWithExtensions(n, _, _) when n = name -> true 222 | | _ -> false 223 | ) 224 | 225 | RunTestCase ex test 226 | 227 | member this.RunAll(ex:ITextExpected) = 228 | let failedCases = 229 | cases 230 | |> List.choose 231 | (fun test -> 232 | match RunTestCase ex test with 233 | | PiTestResult.Passed -> None 234 | | r -> Some(r) 235 | ) 236 | 237 | match failedCases.Length with 238 | | 0 -> PiTestResult.Passed 239 | | _ -> failedCases.Item(0) 240 | -------------------------------------------------------------------------------- /Tests/Program.fs: -------------------------------------------------------------------------------- 1 | open System 2 | 3 | open JsonPi 4 | open JsonPi.Data 5 | open PiTest 6 | 7 | open Generated_BasicTests 8 | 9 | type MyExtension () = 10 | interface IPiExtension with 11 | member this.OnOutput (channel:PiJsonObject) (outNames:PiJsonArray) : PiJsonObject option = 12 | printfn "Output extension" 13 | match channel with 14 | | PiName (id, _, _) when id = "ex`2" -> 15 | let program = PiParser.ParseFromString "b(g) (continue)" 16 | match program with 17 | | AssemblyEntryProcess p -> 18 | Some (p) 19 | | _ -> failwith "bad" 20 | | _ -> None 21 | 22 | member this.OnInput (channel:PiJsonObject) (outNames:PiJsonArray) (inpNames:PiJsonArray) : PiJsonObject option = 23 | printfn "Input extension" 24 | match channel with 25 | | PiName (id, _, _) when id = "ex`2" -> 26 | let program = PiParser.ParseFromString "b (continue)" 27 | match program with 28 | | AssemblyEntryProcess p -> 29 | Some (p) 30 | | _ -> failwith "bad" 31 | | _ -> None 32 | 33 | 34 | let resolver : PiExtensionResolver = 35 | fun (nameType:PiIdentifier) (data:obj option) -> 36 | match nameType with 37 | | "MyExtension" -> Some((new MyExtension()) :> IPiExtension) 38 | | _ -> None 39 | 40 | [] 41 | let main argv = 42 | let pp = PiProcessor(Some(resolver)) 43 | pp.RunString("new (ex) new (ex:MyExtension) ex(x) (* b *) c(h);|ex (* b(g) *) c;") 44 | 45 | let basictests = [ 46 | PiTestCase.AsString("TestInaction", ";"); 47 | PiTestCase.AsString("TestComposeInaction", ";|;"); 48 | PiTestCase.AsString("TestSimpleComm", "a; | a(y);"); 49 | PiTestCase.AsString("TestSimpleCommMultiParam2to2", "x; | x(f,g) y; | y(m,n);"); 50 | PiTestCase.AsString("TestSimpleCommMultiParam2To1", "x; | x(f) y; | y(m,n);"); 51 | PiTestCase.AsString("TestSimpleCommMultiParam3To2", "x; | x(f,g) y; | y(m,n);"); 52 | PiTestCase.AsString("TestSimpleCommMultiParam1To2", "x; | x(f,g) y; | y(m,n);"); 53 | PiTestCase.AsString("TestSimpleCommMultiParam2To3", "x; | x(f,g,h) y; | y(m,n,o);"); 54 | PiTestCase.AsString("TestMultiComm", "(x(z) z; | x y;) | y(v) v(u);"); 55 | PiTestCase.AsString("TestSummationComposition", "a b c d; | a(y) b(y) c(y) d(y);") 56 | PiTestCase.AsString("TestCommWithSimpleMatch", "c(x);|[b=b]c;"); 57 | PiTestCase.AsString("TestCommWithMatch", "x(z) [z=y]a(b);|x;|a;"); 58 | PiTestCase.AsString("TestCommWithMatchMultipleParams", "x y(c); | x(f) [f=a,b]y;") 59 | PiTestCase.AsString("TestLeftSumOut", "(choose when b then ; when a then ; end) | a(y);"); 60 | PiTestCase.AsString("TestRightSumOut", "a(y); | (choose when b then ; when a then ; end)"); 61 | PiTestCase.AsString("TestLeftSumInp", "(choose when b(x) then ; when a(x) then ; end) | a;"); 62 | PiTestCase.AsString("TestRightSumInp", "a; | (choose when b(x) then ; when a(x) then ; end)"); 63 | PiTestCase.AsString("TestSumMatchSum", "(choose when c then ; when a(y) then ; end) | (choose when b then ; when a then ; end)"); 64 | PiTestCase.AsString("TestLeftDefaultSumOut", "choose when a then ; default b; end | b(z);"); 65 | PiTestCase.AsString("TestRightDefaultSumOut", "b(z); | choose when a then ; default b; end"); 66 | PiTestCase.AsString("TestLeftDefaultSumInp", "choose when a(x) then ; default b(y); end | b;"); 67 | PiTestCase.AsString("TestRightDefaultSumInp", "b; | choose when a(x) then ; default b(y); end"); 68 | PiTestCase.AsString("TestDefaultSumMatchDefaultSum", "choose when a then ; default b; end | choose when a then ; default b(y); end"); 69 | PiTestCase.AsString("TestBindingAndRef", "let P = a; $P | a(y);"); 70 | PiTestCase.AsString("TestModuleAndRef", "module A a; using A a(y);"); 71 | PiTestCase.AsString("TestModuleRefAndBindingRef", "module A let P = a; ; using A $P | a(y);"); 72 | PiTestCase.AsString("TestModuleRefAndBindingRef2", "module A let P1 = a; let P2 = a; ; using A $P2 | a(y);"); 73 | PiTestCase.AsString("TestSimpleRestriction", "new (a) new (a) a(x);|a;"); 74 | PiTestCase.AsString("TestRestrictionWithSubstitute", "x; | x(f) (new (f) new (f) y;) | y(b);") 75 | PiTestCase.AsStringWithExtensions("TestSimpleRestrictionWithExtension", "new (a) new (a:MyExtension) a(x);|a;", resolver); 76 | PiTestCase.AsStringWithExtensions("TestSimpleRestrictionWithExtensionAndJson", "new (a:MyExtension) = [true, 5, -12, 1.2093, -93.5, 1.8001e7, -391.8001e-7, {\"TestLabel\":\"TestValue\"}] a; | a(y);", resolver); 77 | PiTestCase.AsStringWithExtensions("TestSimpleRestrictionWithExtensionReturn", "new (ex) new (ex:MyExtension) ex(x) (* b *) c(h);|ex (* b(g) *) c;", resolver); 78 | PiTestCase.AsString("TestSimpleReplication", "(!(x(y);)) | (x x x;)"); 79 | PiTestCase.AsString("TestReplication", "(!(x y(b);)) | (x(c) y x(e);)"); 80 | 81 | // Milner examples, https://pdfs.semanticscholar.org/5d25/0a3a14f68abb1ae0111d35b8220b4472b277.pdf 82 | PiTestCase.AsString("Milner_Page_6_Section_2_2", "x; | x(u) u; | x;"); 83 | PiTestCase.AsString("Milner_Page_7_1", "(new (x) ( x; | x(u) u;)) | x;"); 84 | // Same as Section 2.2 but has a replication. 85 | PiTestCase.AsString("Milner_Page_7_2", "x; | (!(x(u) u;)) | x;"); 86 | PiTestCase.AsString("Milner_Page_10_Section_3_1", "x(y,z); | x; | x;"); 87 | ] 88 | 89 | let basicmod = PiTestModule("..\..\\..\\BasicTests.fs", basictests) 90 | 91 | let generate = false 92 | 93 | if generate then 94 | basicmod.Generate() 95 | else 96 | let bb = BasicTests() 97 | //let r = basicmod.RunOne("TestSimpleCommMultiParam2to2", bb) 98 | let r = basicmod.RunAll(bb) 99 | if r <> PiTestResult.Passed then 100 | failwith "test failed" 101 | 102 | 0 // return an integer exit code 103 | -------------------------------------------------------------------------------- /Tests/Tests.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | Exe 5 | netcoreapp2.0 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | --------------------------------------------------------------------------------