├── .gitattributes ├── .gitignore ├── Assignment1 ├── Arith.fs ├── Assignment1.fsproj ├── Readme.md ├── SExp.fs └── Tok.fs ├── Assignment2 ├── Assignment2.fsproj ├── Compiler.fs ├── Expr.fs └── Readme.md ├── Assignment3 ├── Assignment3.fsproj ├── Compiler.fs ├── Expr.fs ├── Parser.fs └── Readme.md ├── Assignment4 ├── Assignment4.fsproj ├── Compiler.fs ├── Expr.fs ├── Parser.fs └── Readme.md ├── Assignment5 ├── Assignment5.fsproj ├── Compiler.fs ├── Decl.fs ├── Expr.fs ├── Parser.fs └── Readme.md ├── Assignment6 ├── Assignment6.fsproj ├── Compiler.fs ├── Decl.fs ├── Expression.fs ├── Identifier.fs ├── Parser.fs ├── Program.fs ├── Readme.md ├── Scheme.fs ├── SchemeEnvironment.fs ├── Substitution.fs ├── Type.fs ├── TypeCheck.fs ├── TypeEnvironment.fs └── TypeInfer.fs ├── CompilerDesign.sln ├── Core ├── App.runtimeconfig.json ├── CompilationUnit.fs ├── Compiler.fs ├── Core.fsproj ├── Env.fs └── Result.fs ├── Readme.md └── UnitTests ├── Assignment1 ├── ArithTests.fs ├── SExpTests.fs └── TokTests.fs ├── Assignment2 └── AdderTests.fs ├── Assignment3 ├── BoaTests.fs └── FuzzTests.fs ├── Assignment4 ├── CobraTests.fs └── FuzzTests.fs ├── Assignment5 ├── DiamondbackTests.fs └── FuzzTests.fs ├── Assignment6 ├── FuzzTests.fs └── TaipanTests.fs ├── Program.fs ├── UnitTests.fsproj └── Utility.fs /.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 | ## Get latest from https://github.com/github/gitignore/blob/master/VisualStudio.gitignore 5 | 6 | # User-specific files 7 | *.rsuser 8 | *.suo 9 | *.user 10 | *.userosscache 11 | *.sln.docstates 12 | 13 | # User-specific files (MonoDevelop/Xamarin Studio) 14 | *.userprefs 15 | 16 | # Mono auto generated files 17 | mono_crash.* 18 | 19 | # Build results 20 | [Dd]ebug/ 21 | [Dd]ebugPublic/ 22 | [Rr]elease/ 23 | [Rr]eleases/ 24 | x64/ 25 | x86/ 26 | [Ww][Ii][Nn]32/ 27 | [Aa][Rr][Mm]/ 28 | [Aa][Rr][Mm]64/ 29 | bld/ 30 | [Bb]in/ 31 | [Oo]bj/ 32 | [Oo]ut/ 33 | [Ll]og/ 34 | [Ll]ogs/ 35 | 36 | # Visual Studio 2015/2017 cache/options directory 37 | .vs/ 38 | # Uncomment if you have tasks that create the project's static files in wwwroot 39 | #wwwroot/ 40 | 41 | # Visual Studio 2017 auto generated files 42 | Generated\ Files/ 43 | 44 | # MSTest test Results 45 | [Tt]est[Rr]esult*/ 46 | [Bb]uild[Ll]og.* 47 | 48 | # NUnit 49 | *.VisualState.xml 50 | TestResult.xml 51 | nunit-*.xml 52 | 53 | # Build Results of an ATL Project 54 | [Dd]ebugPS/ 55 | [Rr]eleasePS/ 56 | dlldata.c 57 | 58 | # Benchmark Results 59 | BenchmarkDotNet.Artifacts/ 60 | 61 | # .NET Core 62 | project.lock.json 63 | project.fragment.lock.json 64 | artifacts/ 65 | 66 | # ASP.NET Scaffolding 67 | ScaffoldingReadMe.txt 68 | 69 | # StyleCop 70 | StyleCopReport.xml 71 | 72 | # Files built by Visual Studio 73 | *_i.c 74 | *_p.c 75 | *_h.h 76 | *.ilk 77 | *.meta 78 | *.obj 79 | *.iobj 80 | *.pch 81 | *.pdb 82 | *.ipdb 83 | *.pgc 84 | *.pgd 85 | *.rsp 86 | *.sbr 87 | *.tlb 88 | *.tli 89 | *.tlh 90 | *.tmp 91 | *.tmp_proj 92 | *_wpftmp.csproj 93 | *.log 94 | *.vspscc 95 | *.vssscc 96 | .builds 97 | *.pidb 98 | *.svclog 99 | *.scc 100 | 101 | # Chutzpah Test files 102 | _Chutzpah* 103 | 104 | # Visual C++ cache files 105 | ipch/ 106 | *.aps 107 | *.ncb 108 | *.opendb 109 | *.opensdf 110 | *.sdf 111 | *.cachefile 112 | *.VC.db 113 | *.VC.VC.opendb 114 | 115 | # Visual Studio profiler 116 | *.psess 117 | *.vsp 118 | *.vspx 119 | *.sap 120 | 121 | # Visual Studio Trace Files 122 | *.e2e 123 | 124 | # TFS 2012 Local Workspace 125 | $tf/ 126 | 127 | # Guidance Automation Toolkit 128 | *.gpState 129 | 130 | # ReSharper is a .NET coding add-in 131 | _ReSharper*/ 132 | *.[Rr]e[Ss]harper 133 | *.DotSettings.user 134 | 135 | # TeamCity is a build add-in 136 | _TeamCity* 137 | 138 | # DotCover is a Code Coverage Tool 139 | *.dotCover 140 | 141 | # AxoCover is a Code Coverage Tool 142 | .axoCover/* 143 | !.axoCover/settings.json 144 | 145 | # Coverlet is a free, cross platform Code Coverage Tool 146 | coverage*.json 147 | coverage*.xml 148 | coverage*.info 149 | 150 | # Visual Studio code coverage results 151 | *.coverage 152 | *.coveragexml 153 | 154 | # NCrunch 155 | _NCrunch_* 156 | .*crunch*.local.xml 157 | nCrunchTemp_* 158 | 159 | # MightyMoose 160 | *.mm.* 161 | AutoTest.Net/ 162 | 163 | # Web workbench (sass) 164 | .sass-cache/ 165 | 166 | # Installshield output folder 167 | [Ee]xpress/ 168 | 169 | # DocProject is a documentation generator add-in 170 | DocProject/buildhelp/ 171 | DocProject/Help/*.HxT 172 | DocProject/Help/*.HxC 173 | DocProject/Help/*.hhc 174 | DocProject/Help/*.hhk 175 | DocProject/Help/*.hhp 176 | DocProject/Help/Html2 177 | DocProject/Help/html 178 | 179 | # Click-Once directory 180 | publish/ 181 | 182 | # Publish Web Output 183 | *.[Pp]ublish.xml 184 | *.azurePubxml 185 | # Note: Comment the next line if you want to checkin your web deploy settings, 186 | # but database connection strings (with potential passwords) will be unencrypted 187 | *.pubxml 188 | *.publishproj 189 | 190 | # Microsoft Azure Web App publish settings. Comment the next line if you want to 191 | # checkin your Azure Web App publish settings, but sensitive information contained 192 | # in these scripts will be unencrypted 193 | PublishScripts/ 194 | 195 | # NuGet Packages 196 | *.nupkg 197 | # NuGet Symbol Packages 198 | *.snupkg 199 | # The packages folder can be ignored because of Package Restore 200 | **/[Pp]ackages/* 201 | # except build/, which is used as an MSBuild target. 202 | !**/[Pp]ackages/build/ 203 | # Uncomment if necessary however generally it will be regenerated when needed 204 | #!**/[Pp]ackages/repositories.config 205 | # NuGet v3's project.json files produces more ignorable files 206 | *.nuget.props 207 | *.nuget.targets 208 | 209 | # Microsoft Azure Build Output 210 | csx/ 211 | *.build.csdef 212 | 213 | # Microsoft Azure Emulator 214 | ecf/ 215 | rcf/ 216 | 217 | # Windows Store app package directories and files 218 | AppPackages/ 219 | BundleArtifacts/ 220 | Package.StoreAssociation.xml 221 | _pkginfo.txt 222 | *.appx 223 | *.appxbundle 224 | *.appxupload 225 | 226 | # Visual Studio cache files 227 | # files ending in .cache can be ignored 228 | *.[Cc]ache 229 | # but keep track of directories ending in .cache 230 | !?*.[Cc]ache/ 231 | 232 | # Others 233 | ClientBin/ 234 | ~$* 235 | *~ 236 | *.dbmdl 237 | *.dbproj.schemaview 238 | *.jfm 239 | *.pfx 240 | *.publishsettings 241 | orleans.codegen.cs 242 | 243 | # Including strong name files can present a security risk 244 | # (https://github.com/github/gitignore/pull/2483#issue-259490424) 245 | #*.snk 246 | 247 | # Since there are multiple workflows, uncomment next line to ignore bower_components 248 | # (https://github.com/github/gitignore/pull/1529#issuecomment-104372622) 249 | #bower_components/ 250 | 251 | # RIA/Silverlight projects 252 | Generated_Code/ 253 | 254 | # Backup & report files from converting an old project file 255 | # to a newer Visual Studio version. Backup files are not needed, 256 | # because we have git ;-) 257 | _UpgradeReport_Files/ 258 | Backup*/ 259 | UpgradeLog*.XML 260 | UpgradeLog*.htm 261 | ServiceFabricBackup/ 262 | *.rptproj.bak 263 | 264 | # SQL Server files 265 | *.mdf 266 | *.ldf 267 | *.ndf 268 | 269 | # Business Intelligence projects 270 | *.rdl.data 271 | *.bim.layout 272 | *.bim_*.settings 273 | *.rptproj.rsuser 274 | *- [Bb]ackup.rdl 275 | *- [Bb]ackup ([0-9]).rdl 276 | *- [Bb]ackup ([0-9][0-9]).rdl 277 | 278 | # Microsoft Fakes 279 | FakesAssemblies/ 280 | 281 | # GhostDoc plugin setting file 282 | *.GhostDoc.xml 283 | 284 | # Node.js Tools for Visual Studio 285 | .ntvs_analysis.dat 286 | node_modules/ 287 | 288 | # Visual Studio 6 build log 289 | *.plg 290 | 291 | # Visual Studio 6 workspace options file 292 | *.opt 293 | 294 | # Visual Studio 6 auto-generated workspace file (contains which files were open etc.) 295 | *.vbw 296 | 297 | # Visual Studio LightSwitch build output 298 | **/*.HTMLClient/GeneratedArtifacts 299 | **/*.DesktopClient/GeneratedArtifacts 300 | **/*.DesktopClient/ModelManifest.xml 301 | **/*.Server/GeneratedArtifacts 302 | **/*.Server/ModelManifest.xml 303 | _Pvt_Extensions 304 | 305 | # Paket dependency manager 306 | .paket/paket.exe 307 | paket-files/ 308 | 309 | # FAKE - F# Make 310 | .fake/ 311 | 312 | # CodeRush personal settings 313 | .cr/personal 314 | 315 | # Python Tools for Visual Studio (PTVS) 316 | __pycache__/ 317 | *.pyc 318 | 319 | # Cake - Uncomment if you are using it 320 | # tools/** 321 | # !tools/packages.config 322 | 323 | # Tabs Studio 324 | *.tss 325 | 326 | # Telerik's JustMock configuration file 327 | *.jmconfig 328 | 329 | # BizTalk build output 330 | *.btp.cs 331 | *.btm.cs 332 | *.odx.cs 333 | *.xsd.cs 334 | 335 | # OpenCover UI analysis results 336 | OpenCover/ 337 | 338 | # Azure Stream Analytics local run output 339 | ASALocalRun/ 340 | 341 | # MSBuild Binary and Structured Log 342 | *.binlog 343 | 344 | # NVidia Nsight GPU debugger configuration file 345 | *.nvuser 346 | 347 | # MFractors (Xamarin productivity tool) working folder 348 | .mfractor/ 349 | 350 | # Local History for Visual Studio 351 | .localhistory/ 352 | 353 | # BeatPulse healthcheck temp database 354 | healthchecksdb 355 | 356 | # Backup folder for Package Reference Convert tool in Visual Studio 2017 357 | MigrationBackup/ 358 | 359 | # Ionide (cross platform F# VS Code tools) working folder 360 | .ionide/ 361 | 362 | # Fody - auto-generated XML schema 363 | FodyWeavers.xsd -------------------------------------------------------------------------------- /Assignment1/Arith.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment1 2 | 3 | type env = Map 4 | 5 | /// Question 1. 6 | module Env = 7 | 8 | let empty : env = Map.empty 9 | 10 | let get (env : env) name = 11 | Map.tryFind name env 12 | 13 | let contains (env : env) name = 14 | Map.containsKey name env 15 | 16 | let add (env : env) name value = 17 | Map.add name value env 18 | 19 | type arith = 20 | | Plus of arith * arith 21 | | Times of arith * arith 22 | | Variable of string 23 | | Num of int 24 | 25 | /// Question 1. 26 | module Arith = 27 | 28 | let rec evaluate arith env = 29 | match arith with 30 | | Plus (x, y) -> 31 | (evaluate x env) + (evaluate y env) 32 | | Times (x, y) -> 33 | (evaluate x env) * (evaluate y env) 34 | | Variable name -> 35 | match Env.get env name with 36 | | Some value -> value 37 | | None -> failwith $"No such variable: '{name}" 38 | | Num n -> n 39 | 40 | let rec pretty arith env = 41 | match arith with 42 | | Plus (x, y) -> 43 | $"({pretty x env} + {pretty y env})" 44 | | Times (x, y) -> 45 | $"({pretty x env} * {pretty y env})" 46 | | Variable name -> name 47 | | Num n -> string n 48 | -------------------------------------------------------------------------------- /Assignment1/Assignment1.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net8.0 5 | true 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /Assignment1/Readme.md: -------------------------------------------------------------------------------- 1 | [Assignment 1: OCaml warmup, part 2: trees](https://course.ccs.neu.edu/cs4410sp21/hw_warmup2_assignment.html) 2 | -------------------------------------------------------------------------------- /Assignment1/SExp.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment1 2 | 3 | open CompilerDesign.Core 4 | 5 | type sexp<'a> = 6 | | Sym of string * 'a 7 | | Int of int * 'a 8 | | Bool of bool * 'a 9 | | Nest of List> * 'a 10 | 11 | module SExp = 12 | 13 | let getPos = function 14 | | Sym (_, pos) -> pos 15 | | Int (_, pos) -> pos 16 | | Bool (_, pos) -> pos 17 | | Nest (_, pos) -> pos 18 | 19 | /// Parses a single expression starting at the given token. 20 | let rec private parse_sexp tok tail = 21 | result { 22 | match tok with 23 | 24 | // parse sub-expressions until the corresponding r-paren 25 | | LPAREN (pos : pos) -> 26 | let! sexps, pos', tail' = parse_nested pos tail 27 | let range = Pos.range pos pos' 28 | return Nest (sexps, range), tail' 29 | 30 | // unexpected r-paren 31 | | RPAREN pos -> 32 | let line, col, _ , _ = pos 33 | return! Error $"Unmatched right paren at line {line}, col {col}" 34 | 35 | | TSym (sym, pos) -> return Sym (sym, pos), tail 36 | | TInt (n, pos) -> return Int (n, pos), tail 37 | | TBool (b, pos) -> return Bool (b, pos), tail 38 | } 39 | 40 | /// Parses nested sub-expressions. 41 | and private parse_nested pos toks = 42 | result { 43 | match toks with 44 | 45 | // no further sub-expressions to parse 46 | | RPAREN (pos' : pos) :: tail -> 47 | return [], pos', tail 48 | 49 | // parse sub-expression starting at the current token 50 | | tok :: tail -> 51 | let! sexp, tail' = parse_sexp tok tail 52 | let! sexps, pos', tail'' = parse_nested pos tail' 53 | return sexp :: sexps, pos', tail'' 54 | 55 | // ran out of tokens 56 | | [] -> 57 | let line, col, _ , _ = pos 58 | return! Error $"Unmatched left paren at line {line}, col {col}" 59 | } 60 | 61 | /// Question 4. 62 | let rec parse_toks toks = 63 | result { 64 | match toks with 65 | | tok :: tail -> 66 | let! sexp, tail' = parse_sexp tok tail 67 | let! sexps = parse_toks tail' 68 | return sexp :: sexps 69 | | [] -> return List.empty 70 | } 71 | 72 | /// Question 5. 73 | let parse = Tok.tokenize >> parse_toks 74 | -------------------------------------------------------------------------------- /Assignment1/Tok.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment1 2 | 3 | open FParsec 4 | 5 | type tok<'a> = 6 | | LPAREN of 'a 7 | | RPAREN of 'a 8 | | TSym of string * 'a 9 | | TInt of int * 'a 10 | | TBool of bool * 'a 11 | 12 | (* startline, startcol, endline, endcol *) 13 | type pos = int * int * int * int // this is really ugly, but we use what we're given 14 | 15 | module Pos = 16 | 17 | let range 18 | ((startline, startcol, _, _) : pos) 19 | ((_, _, endline, endcol) : pos) : pos = 20 | startline, startcol, endline, endcol 21 | 22 | module Tok = 23 | 24 | (* 25 | Use FParsec to tokenize, since we don't have access to the original 26 | OCaml tokenizer. 27 | *) 28 | 29 | let private parsePos p makeToken = 30 | parse { 31 | let! startPos = getPosition 32 | let! value = p 33 | let! endPos = getPosition 34 | let pos : pos = 35 | int startPos.Line - 1, 36 | int startPos.Column - 1, 37 | int endPos.Line - 1, 38 | int endPos.Column - 1 39 | return makeToken (value, pos) 40 | } 41 | 42 | let private parseLparen = 43 | parsePos 44 | (skipChar '(') 45 | (snd >> LPAREN) 46 | 47 | let private parseRparen = 48 | parsePos 49 | (skipChar ')') 50 | (snd >> RPAREN) 51 | 52 | let private parseSym = 53 | let psym = identifier (IdentifierOptions ()) // details not specified in the assignment, so assume something basic 54 | parsePos psym TSym 55 | 56 | let private parseInt = 57 | parsePos pint32 TInt 58 | 59 | let private parseBool = 60 | let pbool = 61 | choice [ 62 | skipStringCI "true" >>% true 63 | skipStringCI "false" >>% false 64 | ] 65 | parsePos pbool TBool 66 | 67 | let private parseTok = 68 | choice [ 69 | parseLparen 70 | parseRparen 71 | parseInt 72 | parseBool 73 | parseSym // last to avoid parsing literals as symbols (e.g. "true") 74 | ] .>> spaces 75 | 76 | let private parseText = 77 | spaces 78 | >>. many parseTok 79 | .>> spaces 80 | .>> eof 81 | 82 | /// Question 3. 83 | let tokenize text = 84 | match runParserOnString parseText () "" text with 85 | | Success (result, _, _) -> result 86 | | Failure (msg, _, _) -> failwith msg 87 | -------------------------------------------------------------------------------- /Assignment2/Assignment2.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net8.0 5 | true 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /Assignment2/Compiler.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment2 2 | 3 | open CompilerDesign.Core 4 | open CompilerDesign.Assignment1 // for S-expression parser 5 | 6 | module Compiler = 7 | 8 | /// Converts an S-expression into an Adder expression. 9 | let rec convert = function 10 | 11 | | Int (n, pos) -> 12 | Ok (Number (n, pos)) 13 | 14 | | Nest ([Sym ("add1", _); sexp], pos) -> 15 | makePrim Add1 sexp pos 16 | 17 | | Nest ([Sym ("sub1", _); sexp], pos) -> 18 | makePrim Sub1 sexp pos 19 | 20 | | Nest ([Sym ("let", _); Nest (sexps, _); sexp], pos) -> 21 | makeLet sexps sexp pos 22 | 23 | | Sym (name, pos) -> 24 | Ok (Id (name, pos)) 25 | 26 | | sexp -> Error $"Invalid S-expression: {sexp}" 27 | 28 | and private makePrim op sexp pos = 29 | result { 30 | let! e = convert sexp 31 | return Prim1 (op, e, pos) 32 | } 33 | 34 | and private makeLet sexps sexp pos = 35 | 36 | let rec makeBindings sexps = 37 | match sexps with 38 | | Nest ([Sym (name, _ : pos); sexp], _) :: tail -> 39 | result { 40 | let! exp = convert sexp 41 | let! bindings = makeBindings tail 42 | return (name, exp) :: bindings 43 | } 44 | | [] -> Ok [] 45 | | sexp :: _ -> Error $"Unexpected binding: {sexp}" 46 | 47 | result { 48 | let! bindings = makeBindings sexps 49 | let! exp = convert sexp 50 | return Let (bindings, exp, pos) 51 | } 52 | 53 | /// Helper function roughly corresponding to function "t" 54 | /// in the assignment. 55 | let compile assemblyName text = 56 | match SExp.parse text with 57 | | Ok [ sexp ] -> 58 | result { 59 | let! e = convert sexp 60 | let! node = Expr.compile e 61 | do! Compiler.compile_prog assemblyName node 62 | } 63 | | Ok sexps -> 64 | Error $"Too many S-expressions: ${sexps}" 65 | | Error msg -> 66 | Error msg 67 | -------------------------------------------------------------------------------- /Assignment2/Expr.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment2 2 | 3 | open Microsoft.CodeAnalysis 4 | open Microsoft.CodeAnalysis.CSharp 5 | open type SyntaxFactory 6 | 7 | open CompilerDesign.Core 8 | 9 | /// Abstract syntax for the Adder language. 10 | type expr<'a> = 11 | | Number of int * 'a 12 | | Prim1 of prim1 * expr<'a> * 'a 13 | | Let of 14 | bindings : List> 15 | * expr<'a> 16 | * 'a 17 | | Id of name : string * 'a 18 | 19 | and prim1 = 20 | | Add1 21 | | Sub1 22 | 23 | /// Functions for converting expressions into Rosyln syntax 24 | /// nodes. (It would be nice to generate a .NET assembly 25 | /// by emitting CIL opcodes instead, but there's currently 26 | /// no reliable way to save such an assembly to a file. 27 | /// See https://github.com/dotnet/runtime/issues/15704.) 28 | module Expr = 29 | 30 | let private numericLiteral (n : int) = 31 | LiteralExpression( 32 | SyntaxKind.NumericLiteralExpression, 33 | Literal(n)) 34 | 35 | let private compileNumber n (env : env) = 36 | let node = 37 | numericLiteral n 38 | :> Syntax.ExpressionSyntax 39 | Ok (node, env) 40 | 41 | let private compileId name env = 42 | Env.tryFind name env 43 | |> Result.map (fun node -> node, env) 44 | 45 | let rec private compileExp exp env : CompilerResult<_> = 46 | match exp with 47 | | Number (n, _) -> compileNumber n env 48 | | Prim1 (op, e, _) -> compilePrim1 op e env 49 | | Let (bindings, e, _) -> compileLet bindings e env 50 | | Id (name, _) -> compileId name env 51 | 52 | and private compilePrim1 op exp env = 53 | let kind = 54 | match op with 55 | | Add1 -> SyntaxKind.AddExpression 56 | | Sub1 -> SyntaxKind.SubtractExpression 57 | result { 58 | let! left, _ = compileExp exp env 59 | let node = 60 | BinaryExpression( 61 | kind, 62 | left, 63 | numericLiteral 1) 64 | return node, env 65 | } 66 | 67 | and private compileLet bindings exp env = 68 | 69 | let rec loop bindings (env : env) = 70 | match bindings with 71 | | (name, exp) :: tail -> 72 | result { 73 | let! node, env' = compileExp exp env 74 | let! env'' = env' |> Env.tryAdd name node 75 | return! loop tail env'' 76 | } 77 | | [] -> Ok env 78 | 79 | result { 80 | let! env' = loop bindings env 81 | return! compileExp exp env' 82 | } 83 | 84 | /// Corresponds roughly to `compile : pos expr -> instruction list` 85 | /// in the assignment. 86 | let compile exp : CompilerResult<_> = 87 | result { 88 | let! node, _ = compileExp exp Env.empty 89 | return node 90 | } 91 | -------------------------------------------------------------------------------- /Assignment2/Readme.md: -------------------------------------------------------------------------------- 1 | [Assignment 2: Adder: A starter language](https://course.ccs.neu.edu/cs4410sp21/hw_adder_assignment.html) 2 | -------------------------------------------------------------------------------- /Assignment3/Assignment3.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net8.0 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /Assignment3/Compiler.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment3 2 | 3 | open Microsoft.CodeAnalysis 4 | open Microsoft.CodeAnalysis.CSharp 5 | open type SyntaxFactory 6 | 7 | open CompilerDesign.Core 8 | 9 | module Compiler = 10 | 11 | let private numericLiteral (n : int) = 12 | LiteralExpression( 13 | SyntaxKind.NumericLiteralExpression, 14 | Literal(n)) 15 | 16 | let private compileNumber num (env : env) = 17 | let node = 18 | numericLiteral num 19 | :> Syntax.ExpressionSyntax 20 | Ok (node, env) 21 | 22 | let private compileIdentifier ident env = 23 | Env.tryFind ident env 24 | |> Result.map (fun node -> node, env) 25 | 26 | let rec private compileExpr expr env : CompilerResult<_> = 27 | match expr with 28 | | LetExpr def -> 29 | compileLet def.Bindings def.Expr env 30 | | Prim1Expr def -> 31 | compilePrim1 def.Operator def.Expr env 32 | | Prim2Expr def -> 33 | compilePrim2 def.Operator def.Left def.Right env 34 | | IfExpr def -> 35 | compileIf def.Condition def.TrueBranch def.FalseBranch env 36 | | NumberExpr def -> 37 | compileNumber def.Number env 38 | | IdentifierExpr def -> 39 | compileIdentifier def.Identifier env 40 | 41 | and private compileLet bindings expr env = 42 | 43 | let folder env (binding : Binding<_>) = 44 | result { 45 | let! node, env' = 46 | compileExpr binding.Expr env 47 | return! env' 48 | |> Env.tryAdd binding.Identifier node 49 | } 50 | 51 | result { 52 | let! env' = Result.List.foldM folder env bindings 53 | return! compileExpr expr env' 54 | } 55 | 56 | and private compilePrim1 op expr env = 57 | let kind = 58 | match op with 59 | | Add1 -> SyntaxKind.AddExpression 60 | | Sub1 -> SyntaxKind.SubtractExpression 61 | result { 62 | let! left, _ = compileExpr expr env 63 | let node = 64 | BinaryExpression( 65 | kind, 66 | left, 67 | numericLiteral 1) 68 | return node, env 69 | } 70 | 71 | and private compilePrim2 op left right env = 72 | let kind = 73 | match op with 74 | | Plus -> SyntaxKind.AddExpression 75 | | Minus -> SyntaxKind.SubtractExpression 76 | | Times -> SyntaxKind.MultiplyExpression 77 | result { 78 | let! leftNode, _ = compileExpr left env 79 | let! rightNode, _ = compileExpr right env 80 | let node = 81 | BinaryExpression( 82 | kind, 83 | leftNode, 84 | rightNode) 85 | return node, env 86 | } 87 | 88 | and private compileIf cond trueBranch falseBranch env = 89 | result { 90 | 91 | let! condNode, _ = compileExpr cond env 92 | let! trueNode, _ = compileExpr trueBranch env 93 | let! falseNode, _ = compileExpr falseBranch env 94 | 95 | let node = 96 | let condNode' = 97 | BinaryExpression( 98 | SyntaxKind.NotEqualsExpression, 99 | condNode, 100 | numericLiteral 0) 101 | ConditionalExpression( 102 | condNode', trueNode, falseNode) 103 | 104 | return node, env 105 | } 106 | 107 | let compile assemblyName text = 108 | result { 109 | let! expr = Parser.parse text 110 | let! node, _ = compileExpr expr Env.empty 111 | do! Compiler.compile_prog assemblyName node 112 | } 113 | -------------------------------------------------------------------------------- /Assignment3/Expr.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment3 2 | 3 | type Prim1 = 4 | | Add1 5 | | Sub1 6 | 7 | type Prim2 = 8 | | Plus 9 | | Minus 10 | | Times 11 | 12 | type Expr<'tag> = 13 | | LetExpr of LetDef<'tag> 14 | | Prim1Expr of Prim1Def<'tag> 15 | | Prim2Expr of Prim2Def<'tag> 16 | | IfExpr of IfDef<'tag> 17 | | NumberExpr of NumberDef<'tag> 18 | | IdentifierExpr of IdentifierDef<'tag> 19 | with 20 | 21 | member expr.Tag' = // F# uses the name "Tag" internally :( 22 | match expr with 23 | | LetExpr x -> x.Tag 24 | | Prim1Expr x -> x.Tag 25 | | Prim2Expr x -> x.Tag 26 | | IfExpr x -> x.Tag 27 | | NumberExpr x -> x.Tag 28 | | IdentifierExpr x -> x.Tag 29 | 30 | and LetDef<'tag> = 31 | { 32 | Bindings : List> 33 | Expr : Expr<'tag> 34 | Tag : 'tag 35 | } 36 | 37 | and Binding<'tag> = 38 | { 39 | Identifier : string 40 | Expr : Expr<'tag> 41 | Tag : 'tag 42 | } 43 | 44 | and Prim1Def<'tag> = 45 | { 46 | Operator : Prim1 47 | Expr : Expr<'tag> 48 | Tag : 'tag 49 | } 50 | 51 | and Prim2Def<'tag> = 52 | { 53 | Operator : Prim2 54 | Left : Expr<'tag> 55 | Right : Expr<'tag> 56 | Tag : 'tag 57 | } 58 | 59 | and IfDef<'tag> = 60 | { 61 | Condition : Expr<'tag> 62 | TrueBranch : Expr<'tag> 63 | FalseBranch : Expr<'tag> 64 | Tag : 'tag 65 | } 66 | 67 | and NumberDef<'tag> = 68 | { 69 | Number : int 70 | Tag : 'tag 71 | } 72 | 73 | and IdentifierDef<'tag> = 74 | { 75 | Identifier : string 76 | Tag : 'tag 77 | } 78 | 79 | module Expr = 80 | 81 | let rec unparse = function 82 | | LetExpr def -> 83 | let bindings = 84 | def.Bindings 85 | |> Seq.map (fun binding -> 86 | $"{binding.Identifier} = {unparse binding.Expr}") 87 | |> String.concat ", " 88 | $"(let {bindings} in {unparse def.Expr})" 89 | | Prim1Expr def -> 90 | let op = (string def.Operator).ToLower() 91 | $"{op}({unparse def.Expr})" 92 | | Prim2Expr def -> 93 | let op = function 94 | | Plus -> '+' 95 | | Minus -> '-' 96 | | Times -> '*' 97 | $"({unparse def.Left} {op def.Operator} {unparse def.Right})" 98 | | IfExpr def -> 99 | $"(if {unparse def.Condition} : \ 100 | {unparse def.TrueBranch} \ 101 | else: {unparse def.FalseBranch})" 102 | | NumberExpr def -> string def.Number 103 | | IdentifierExpr def -> def.Identifier 104 | -------------------------------------------------------------------------------- /Assignment3/Parser.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment3 2 | 3 | open FParsec 4 | open CompilerDesign.Core 5 | 6 | module Parser = 7 | 8 | let private parseExpr, parseExprRef = 9 | createParserForwardedToRef () 10 | 11 | let private parsePos create parser = 12 | parse { 13 | let! startPos = getPosition 14 | let! value = parser 15 | let! endPos = getPosition 16 | return create value (startPos, endPos) 17 | } 18 | 19 | let private parseNumber : Parser<_, unit> = 20 | pint32 21 | |> parsePos (fun n tag -> 22 | NumberExpr { 23 | Number = n 24 | Tag = tag 25 | }) 26 | 27 | let private parseIdentifierName = 28 | identifier (IdentifierOptions ()) 29 | |> parsePos (fun ident tag -> 30 | (ident, tag)) 31 | 32 | let private parseIdentifier = 33 | parseIdentifierName 34 | |>> (fun (ident, tag) -> 35 | IdentifierExpr { 36 | Identifier = ident 37 | Tag = tag 38 | }) 39 | 40 | let private parseParens = 41 | parse { 42 | do! skipChar '(' >>. spaces 43 | let! expr = parseExpr 44 | do! spaces >>. skipChar ')' 45 | return expr 46 | } 47 | 48 | let private parsePrim1 = 49 | parse { 50 | let! op = 51 | choice [ 52 | skipString "add1" >>% Add1 53 | skipString "sub1" >>% Sub1 54 | ] 55 | do! spaces 56 | let! expr = parseParens 57 | return op, expr 58 | } |> parsePos (fun (op, expr) tag -> 59 | Prim1Expr { 60 | Operator = op 61 | Expr = expr 62 | Tag = tag 63 | }) 64 | 65 | let private parseIf = 66 | parse { 67 | do! skipString "if" >>. spaces 68 | let! cond = parseExpr 69 | do! spaces >>. skipChar ':' >>. spaces 70 | let! trueBranch = parseExpr 71 | do! spaces >>. skipString "else:" >>. spaces 72 | let! falseBranch = parseExpr 73 | return cond, trueBranch, falseBranch 74 | } |> parsePos (fun (cond, trueBranch, falseBranch) tag -> 75 | IfExpr { 76 | Condition = cond 77 | TrueBranch = trueBranch 78 | FalseBranch = falseBranch 79 | Tag = tag 80 | }) 81 | 82 | let private parseBinding = 83 | parse { 84 | let! (ident, tag) = parseIdentifierName 85 | do! spaces >>. skipChar '=' >>. spaces 86 | let! expr = parseExpr 87 | return { 88 | Identifier = ident 89 | Expr = expr 90 | Tag = tag // identifier tag, not for entire binding 91 | } 92 | } 93 | 94 | let private parseBindings = 95 | sepBy1 96 | (parseBinding .>> spaces) 97 | (skipChar ',' .>> spaces) 98 | 99 | let private parseLet = 100 | parse { 101 | do! skipString "let" >>. spaces 102 | let! bindings = parseBindings 103 | do! spaces >>. skipString "in" >>. spaces 104 | let! expr = parseExpr 105 | return bindings, expr 106 | } |> parsePos (fun (bindings, expr) tag -> 107 | LetExpr { 108 | Bindings = bindings 109 | Expr = expr 110 | Tag = tag 111 | }) 112 | 113 | let private parseSimpleExpr = 114 | choice [ 115 | parseNumber 116 | parsePrim1 117 | parseIf 118 | parseLet 119 | parseIdentifier // must come after any parser that looks for keywords 120 | parseParens 121 | ] 122 | 123 | let private parseExprImpl = 124 | let create op left right = 125 | Prim2Expr { 126 | Operator = op 127 | Left = left 128 | Right = right 129 | Tag = fst left.Tag', snd right.Tag' 130 | } 131 | let parseOp = 132 | choice [ 133 | pchar '+' >>% create Plus 134 | pchar '-' >>% create Minus 135 | pchar '*' >>% create Times 136 | ] 137 | chainl1 138 | (parseSimpleExpr .>> spaces) 139 | (parseOp .>> spaces) 140 | 141 | let private parseText = 142 | spaces 143 | >>. parseExpr 144 | .>> spaces 145 | .>> eof 146 | 147 | let parse text = 148 | match runParserOnString parseText () "" text with 149 | | Success (result, _, _) -> Result.Ok result 150 | | Failure (msg, _, _) -> Result.Error msg 151 | 152 | do parseExprRef.Value <- parseExprImpl 153 | -------------------------------------------------------------------------------- /Assignment3/Readme.md: -------------------------------------------------------------------------------- 1 | [Assignment 3: Boa: Adding new operators](https://course.ccs.neu.edu/cs4410sp21/hw_boa_assignment.html) 2 | -------------------------------------------------------------------------------- /Assignment4/Assignment4.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net8.0 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /Assignment4/Compiler.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment4 2 | 3 | open Microsoft.CodeAnalysis 4 | open Microsoft.CodeAnalysis.CSharp 5 | open type SyntaxFactory 6 | 7 | open CompilerDesign.Core 8 | 9 | module private Syntax = 10 | 11 | let numericLiteral (n : int) = 12 | LiteralExpression( 13 | SyntaxKind.NumericLiteralExpression, 14 | Literal(n)) 15 | 16 | let boolLiteral flag = 17 | let kind = 18 | if flag then SyntaxKind.TrueLiteralExpression 19 | else SyntaxKind.FalseLiteralExpression 20 | LiteralExpression(kind) 21 | 22 | let by1 node kind = 23 | BinaryExpression( 24 | kind, 25 | node, 26 | numericLiteral 1) 27 | 28 | let isType node kind = 29 | BinaryExpression( 30 | SyntaxKind.IsExpression, 31 | node, 32 | PredefinedType(Token(kind))) 33 | 34 | let print node = 35 | InvocationExpression(IdentifierName("Print")) 36 | .WithArgumentList( 37 | ArgumentList( 38 | SingletonSeparatedList( 39 | Argument(node)))) 40 | 41 | let not node = 42 | PrefixUnaryExpression( 43 | SyntaxKind.LogicalNotExpression, 44 | node) 45 | 46 | module Compiler = 47 | 48 | let private compileNumber num (env : env) = 49 | let node = 50 | Syntax.numericLiteral num 51 | :> Syntax.ExpressionSyntax 52 | Ok (node, env) 53 | 54 | let private compileBool flag (env : env) = 55 | let node = 56 | Syntax.boolLiteral flag 57 | :> Syntax.ExpressionSyntax 58 | Ok (node, env) 59 | 60 | let private compileIdentifier ident env = 61 | Env.tryFind ident env 62 | |> Result.map (fun node -> node, env) 63 | 64 | let rec private compileExpr expr env : CompilerResult<_> = 65 | match expr with 66 | | LetExpr def -> 67 | compileLet def.Bindings def.Expr env 68 | | Prim1Expr def -> 69 | compilePrim1 def.Operator def.Expr env 70 | | Prim2Expr def -> 71 | compilePrim2 def.Operator def.Left def.Right env 72 | | IfExpr def -> 73 | compileIf def.Condition def.TrueBranch def.FalseBranch env 74 | | NumberExpr def -> 75 | compileNumber def.Number env 76 | | IdentifierExpr def -> 77 | compileIdentifier def.Identifier env 78 | | BoolExpr def -> 79 | compileBool def.Flag env 80 | 81 | and private compileLet bindings expr env = 82 | 83 | let folder env (binding : Binding<_>) = 84 | result { 85 | let! node, env' = 86 | compileExpr binding.Expr env 87 | return! env' 88 | |> Env.tryAdd binding.Identifier node 89 | } 90 | 91 | result { 92 | let! env' = Result.List.foldM folder env bindings 93 | return! compileExpr expr env' 94 | } 95 | 96 | and private compilePrim1 op expr env = 97 | 98 | result { 99 | let! node, _ = compileExpr expr env 100 | 101 | let prim1Node = 102 | match op with 103 | | Add1 -> 104 | Syntax.by1 node SyntaxKind.AddExpression 105 | :> Syntax.ExpressionSyntax 106 | | Sub1 -> 107 | Syntax.by1 node SyntaxKind.SubtractExpression 108 | | Print -> 109 | Syntax.print node 110 | | IsBool -> 111 | Syntax.isType node SyntaxKind.BoolKeyword 112 | | IsNum -> 113 | Syntax.isType node SyntaxKind.IntKeyword 114 | | Not -> 115 | Syntax.not node 116 | return prim1Node, env 117 | } 118 | 119 | and private compilePrim2 op left right env = 120 | let kind = 121 | match op with 122 | | Plus -> SyntaxKind.AddExpression 123 | | Minus -> SyntaxKind.SubtractExpression 124 | | Times -> SyntaxKind.MultiplyExpression 125 | | And -> SyntaxKind.LogicalAndExpression 126 | | Or -> SyntaxKind.LogicalOrExpression 127 | | Greater -> SyntaxKind.GreaterThanExpression 128 | | GreaterEq -> SyntaxKind.GreaterThanOrEqualExpression 129 | | Less -> SyntaxKind.LessThanExpression 130 | | LessEq -> SyntaxKind.LessThanOrEqualExpression 131 | | Eq -> SyntaxKind.EqualsExpression 132 | result { 133 | let! leftNode, _ = compileExpr left env 134 | let! rightNode, _ = compileExpr right env 135 | let node = 136 | BinaryExpression( 137 | kind, 138 | leftNode, 139 | rightNode) 140 | return node, env 141 | } 142 | 143 | and private compileIf cond trueBranch falseBranch env = 144 | result { 145 | 146 | let! condNode, _ = compileExpr cond env 147 | let! trueNode, _ = compileExpr trueBranch env 148 | let! falseNode, _ = compileExpr falseBranch env 149 | 150 | let node = 151 | ConditionalExpression( 152 | condNode, trueNode, falseNode) 153 | 154 | return node, env 155 | } 156 | 157 | let compile assemblyName text = 158 | result { 159 | let! expr = Parser.parse text 160 | let! node, _ = compileExpr expr Env.empty 161 | do! Compiler.compile_prog assemblyName node 162 | } 163 | -------------------------------------------------------------------------------- /Assignment4/Expr.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment4 2 | 3 | type Prim1 = 4 | | Add1 5 | | Sub1 6 | | Print 7 | | IsBool 8 | | IsNum 9 | | Not 10 | 11 | type Prim2 = 12 | | Plus 13 | | Minus 14 | | Times 15 | | And 16 | | Or 17 | | Greater 18 | | GreaterEq 19 | | Less 20 | | LessEq 21 | | Eq 22 | 23 | type Expr<'tag> = 24 | | LetExpr of LetDef<'tag> 25 | | Prim1Expr of Prim1Def<'tag> 26 | | Prim2Expr of Prim2Def<'tag> 27 | | IfExpr of IfDef<'tag> 28 | | NumberExpr of NumberDef<'tag> // numeric literal 29 | | IdentifierExpr of IdentifierDef<'tag> 30 | | BoolExpr of BoolDef<'tag> // Boolean literal 31 | with 32 | 33 | member expr.Tag' = // F# uses the name "Tag" internally :( 34 | match expr with 35 | | LetExpr def -> def.Tag 36 | | Prim1Expr def -> def.Tag 37 | | Prim2Expr def -> def.Tag 38 | | IfExpr def -> def.Tag 39 | | NumberExpr def -> def.Tag 40 | | IdentifierExpr def -> def.Tag 41 | | BoolExpr def -> def.Tag 42 | 43 | and LetDef<'tag> = 44 | { 45 | Bindings : List> 46 | Expr : Expr<'tag> 47 | Tag : 'tag 48 | } 49 | 50 | and Binding<'tag> = 51 | { 52 | Identifier : string 53 | Expr : Expr<'tag> 54 | Tag : 'tag 55 | } 56 | 57 | and Prim1Def<'tag> = 58 | { 59 | Operator : Prim1 60 | Expr : Expr<'tag> 61 | Tag : 'tag 62 | } 63 | 64 | and Prim2Def<'tag> = 65 | { 66 | Operator : Prim2 67 | Left : Expr<'tag> 68 | Right : Expr<'tag> 69 | Tag : 'tag 70 | } 71 | 72 | and IfDef<'tag> = 73 | { 74 | Condition : Expr<'tag> 75 | TrueBranch : Expr<'tag> 76 | FalseBranch : Expr<'tag> 77 | Tag : 'tag 78 | } 79 | 80 | and NumberDef<'tag> = 81 | { 82 | Number : int 83 | Tag : 'tag 84 | } 85 | 86 | and IdentifierDef<'tag> = 87 | { 88 | Identifier : string 89 | Tag : 'tag 90 | } 91 | 92 | and BoolDef<'tag> = 93 | { 94 | Flag : bool 95 | Tag : 'tag 96 | } 97 | 98 | module Expr = 99 | 100 | let rec unparse = function 101 | | LetExpr def -> 102 | let bindings = 103 | def.Bindings 104 | |> Seq.map (fun binding -> 105 | $"{binding.Identifier} = {unparse binding.Expr}") 106 | |> String.concat ", " 107 | $"(let {bindings} in {unparse def.Expr})" 108 | | Prim1Expr def -> 109 | let op = function 110 | | Not -> "!" 111 | | prim1 -> (string prim1).ToLower() 112 | $"{op def.Operator}({unparse def.Expr})" 113 | | Prim2Expr def -> 114 | let op = function 115 | | Plus -> "+" 116 | | Minus -> "-" 117 | | Times -> "*" 118 | | And -> "&&" 119 | | Or -> "||" 120 | | Greater -> ">" 121 | | GreaterEq -> ">=" 122 | | Less -> "<" 123 | | LessEq -> "<=" 124 | | Eq -> "==" 125 | $"({unparse def.Left} {op def.Operator} {unparse def.Right})" 126 | | IfExpr def -> 127 | $"(if {unparse def.Condition} : \ 128 | {unparse def.TrueBranch} \ 129 | else: {unparse def.FalseBranch})" 130 | | NumberExpr def -> string def.Number 131 | | IdentifierExpr def -> def.Identifier 132 | | BoolExpr def -> (string def.Flag).ToLower() 133 | -------------------------------------------------------------------------------- /Assignment4/Parser.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment4 2 | 3 | open FParsec 4 | open CompilerDesign.Core 5 | 6 | module Parser = 7 | 8 | let private parseExpr, parseExprRef = 9 | createParserForwardedToRef () 10 | 11 | let private parsePos create parser = 12 | parse { 13 | let! startPos = getPosition 14 | let! value = parser 15 | let! endPos = getPosition 16 | return create value (startPos, endPos) 17 | } 18 | 19 | let private parseNumber : Parser<_, unit> = 20 | pint32 21 | |> parsePos (fun n tag -> 22 | NumberExpr { 23 | Number = n 24 | Tag = tag 25 | }) 26 | 27 | let private parseIdentifierName = 28 | identifier (IdentifierOptions ()) 29 | |> parsePos (fun ident tag -> 30 | (ident, tag)) 31 | 32 | let private parseIdentifier = 33 | parseIdentifierName 34 | |>> (fun (ident, tag) -> 35 | IdentifierExpr { 36 | Identifier = ident 37 | Tag = tag 38 | }) 39 | 40 | let private choiceF pairs = 41 | pairs 42 | |> Seq.map (fun (str, f) -> 43 | skipString str >>% f) 44 | |> choice 45 | 46 | let private parseBool = 47 | choiceF [ 48 | "true", true 49 | "false", false 50 | ] 51 | |> parsePos (fun flag tag -> 52 | BoolExpr { 53 | Flag = flag 54 | Tag = tag 55 | }) 56 | 57 | let private parseParens = 58 | parse { 59 | do! skipChar '(' >>. spaces 60 | let! expr = parseExpr 61 | do! spaces >>. skipChar ')' 62 | return expr 63 | } 64 | 65 | let private parsePrim1 = 66 | parse { 67 | let! op = 68 | choiceF [ 69 | "add1", Add1 70 | "sub1", Sub1 71 | "print", Print 72 | "isbool", IsBool 73 | "isnum", IsNum 74 | "!", Not 75 | ] 76 | do! spaces 77 | let! expr = parseParens 78 | return op, expr 79 | } |> parsePos (fun (op, expr) tag -> 80 | Prim1Expr { 81 | Operator = op 82 | Expr = expr 83 | Tag = tag 84 | }) 85 | 86 | let private parseIf = 87 | parse { 88 | do! skipString "if" >>. spaces 89 | let! cond = parseExpr 90 | do! spaces >>. skipChar ':' >>. spaces 91 | let! trueBranch = parseExpr 92 | do! spaces >>. skipString "else:" >>. spaces 93 | let! falseBranch = parseExpr 94 | return cond, trueBranch, falseBranch 95 | } |> parsePos (fun (cond, trueBranch, falseBranch) tag -> 96 | IfExpr { 97 | Condition = cond 98 | TrueBranch = trueBranch 99 | FalseBranch = falseBranch 100 | Tag = tag 101 | }) 102 | 103 | let private parseBinding = 104 | parse { 105 | let! (ident, tag) = parseIdentifierName 106 | do! spaces >>. skipChar '=' >>. spaces 107 | let! expr = parseExpr 108 | return { 109 | Identifier = ident 110 | Expr = expr 111 | Tag = tag // identifier tag, not for entire binding 112 | } 113 | } 114 | 115 | let private parseBindings = 116 | sepBy1 117 | (parseBinding .>> spaces) 118 | (skipChar ',' .>> spaces) 119 | 120 | let private parseLet = 121 | parse { 122 | do! skipString "let" >>. spaces 123 | let! bindings = parseBindings 124 | do! spaces >>. skipString "in" >>. spaces 125 | let! expr = parseExpr 126 | return bindings, expr 127 | } |> parsePos (fun (bindings, expr) tag -> 128 | LetExpr { 129 | Bindings = bindings 130 | Expr = expr 131 | Tag = tag 132 | }) 133 | 134 | let private parseSimpleExpr = 135 | choice [ 136 | parseNumber 137 | parseBool 138 | parsePrim1 139 | parseIf 140 | parseLet 141 | parseIdentifier // must come after any parser that looks for keywords 142 | parseParens 143 | ] 144 | 145 | let private parseExprImpl = 146 | let create op left right = 147 | Prim2Expr { 148 | Operator = op 149 | Left = left 150 | Right = right 151 | Tag = fst left.Tag', snd right.Tag' 152 | } 153 | let parseOp = 154 | choiceF [ 155 | "+", create Plus 156 | "-", create Minus 157 | "*", create Times 158 | "&&", create And 159 | "||", create Or 160 | ">=", create GreaterEq // must come before ">" 161 | ">", create Greater 162 | "<=", create LessEq // must come before "<" 163 | "<", create Less 164 | "==", create Eq 165 | ] 166 | chainl1 167 | (parseSimpleExpr .>> spaces) 168 | (parseOp .>> spaces) 169 | 170 | let private parseText = 171 | spaces 172 | >>. parseExpr 173 | .>> spaces 174 | .>> eof 175 | 176 | let parse text = 177 | match runParserOnString parseText () "" text with 178 | | Success (result, _, _) -> Result.Ok result 179 | | Failure (msg, _, _) -> Result.Error msg 180 | 181 | do parseExprRef.Value <- parseExprImpl 182 | -------------------------------------------------------------------------------- /Assignment4/Readme.md: -------------------------------------------------------------------------------- 1 | [Assignment 4: Cobra: Multiple types of values](https://course.ccs.neu.edu/cs4410sp21/hw_cobra_assignment.html) 2 | -------------------------------------------------------------------------------- /Assignment5/Assignment5.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net8.0 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /Assignment5/Compiler.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment5 2 | 3 | open Microsoft.CodeAnalysis 4 | open Microsoft.CodeAnalysis.CSharp 5 | open type SyntaxFactory 6 | 7 | open CompilerDesign.Core 8 | 9 | module private Syntax = 10 | 11 | let numericLiteral (n : int) = 12 | LiteralExpression( 13 | SyntaxKind.NumericLiteralExpression, 14 | Literal(n)) 15 | 16 | let boolLiteral flag = 17 | let kind = 18 | if flag then SyntaxKind.TrueLiteralExpression 19 | else SyntaxKind.FalseLiteralExpression 20 | LiteralExpression(kind) 21 | 22 | let by1 node kind = 23 | BinaryExpression( 24 | kind, 25 | node, 26 | numericLiteral 1) 27 | 28 | let isType node kind = 29 | BinaryExpression( 30 | SyntaxKind.IsExpression, 31 | node, 32 | PredefinedType(Token(kind))) 33 | 34 | let print node = 35 | InvocationExpression(IdentifierName("Print")) 36 | .WithArgumentList( 37 | ArgumentList( 38 | SingletonSeparatedList( 39 | Argument(node)))) 40 | 41 | let not node = 42 | PrefixUnaryExpression( 43 | SyntaxKind.LogicalNotExpression, 44 | node) 45 | 46 | type private ArityEnvironment = Map 47 | 48 | module ArityEnvironment = 49 | 50 | let empty : ArityEnvironment = 51 | Map.empty 52 | 53 | let tryAdd name arity (aenv : ArityEnvironment) = 54 | if Map.containsKey name aenv then 55 | Error $"Function already exists: {name}" 56 | else 57 | let env : ArityEnvironment = Map.add name arity aenv 58 | Ok env 59 | 60 | let tryFind name (aenv : ArityEnvironment) = 61 | match Map.tryFind name aenv with 62 | | Some arity -> Ok arity 63 | | None -> Error $"Function not found: {name}" 64 | 65 | module Compiler = 66 | 67 | module private rec Expr = 68 | 69 | let compile env aenv = function 70 | | LetExpr def -> compileLet env aenv def 71 | | Prim1Expr def -> compilePrim1 env aenv def 72 | | Prim2Expr def -> compilePrim2 env aenv def 73 | | IfExpr def -> compileIf env aenv def 74 | | NumberExpr def -> compileNumber env def 75 | | IdentifierExpr def -> compileIdentifier env def 76 | | BoolExpr def -> compileBool env def 77 | | ApplicationExpr def -> compileApplication env aenv def 78 | 79 | let private compileNumber (env : env) (def : NumberDef<_>) = 80 | let node = 81 | Syntax.numericLiteral def.Number 82 | :> Syntax.ExpressionSyntax 83 | Ok (node, env) 84 | 85 | let private compileBool (env : env) (def : BoolDef<_>) = 86 | let node = 87 | Syntax.boolLiteral def.Flag 88 | :> Syntax.ExpressionSyntax 89 | Ok (node, env) 90 | 91 | let private compileIdentifier env (def : IdentifierDef<_>) = 92 | Env.tryFind def.Name env 93 | |> Result.map (fun node -> node, env) 94 | 95 | let private compileLet env aenv (def : LetDef<_>) = 96 | result { 97 | let! env' = 98 | (env, def.Bindings) 99 | ||> Result.List.foldM (fun acc binding -> 100 | result { 101 | let! node, acc' = 102 | compile acc aenv binding.Expr 103 | return! acc' 104 | |> Env.tryAdd 105 | binding.Identifier.Name 106 | node 107 | }) 108 | return! compile env' aenv def.Expr 109 | } 110 | 111 | let private compilePrim1 env aenv (def : Prim1Def<_>) = 112 | result { 113 | let! node, _ = compile env aenv def.Expr 114 | 115 | let prim1Node = 116 | match def.Operator with 117 | | Add1 -> 118 | Syntax.by1 node SyntaxKind.AddExpression 119 | :> Syntax.ExpressionSyntax 120 | | Sub1 -> 121 | Syntax.by1 node SyntaxKind.SubtractExpression 122 | | Print -> 123 | Syntax.print node 124 | | IsBool -> 125 | Syntax.isType node SyntaxKind.BoolKeyword 126 | | IsNum -> 127 | Syntax.isType node SyntaxKind.IntKeyword 128 | | Not -> 129 | Syntax.not node 130 | return prim1Node, env 131 | } 132 | 133 | let private compilePrim2 env aenv (def : Prim2Def<_>) = 134 | let kind = 135 | match def.Operator with 136 | | Plus -> SyntaxKind.AddExpression 137 | | Minus -> SyntaxKind.SubtractExpression 138 | | Times -> SyntaxKind.MultiplyExpression 139 | | And -> SyntaxKind.LogicalAndExpression 140 | | Or -> SyntaxKind.LogicalOrExpression 141 | | Greater -> SyntaxKind.GreaterThanExpression 142 | | GreaterEq -> SyntaxKind.GreaterThanOrEqualExpression 143 | | Less -> SyntaxKind.LessThanExpression 144 | | LessEq -> SyntaxKind.LessThanOrEqualExpression 145 | | Eq -> SyntaxKind.EqualsExpression 146 | result { 147 | let! leftNode, _ = compile env aenv def.Left 148 | let! rightNode, _ = compile env aenv def.Right 149 | let node = 150 | BinaryExpression( 151 | kind, 152 | leftNode, 153 | rightNode) 154 | return node, env 155 | } 156 | 157 | let private compileIf env aenv (def : IfDef<_>) = 158 | result { 159 | 160 | let! condNode, _ = compile env aenv def.Condition 161 | let! trueNode, _ = compile env aenv def.TrueBranch 162 | let! falseNode, _ = compile env aenv def.FalseBranch 163 | 164 | let node = 165 | ConditionalExpression( 166 | condNode, trueNode, falseNode) 167 | 168 | return node, env 169 | } 170 | 171 | let private compileApplication env aenv (def : ApplicationDef<_>) = 172 | result { 173 | 174 | let! arity = 175 | ArityEnvironment.tryFind def.Identifier.Name aenv 176 | if arity <> def.Arguments.Length then 177 | return! Error $"Arity mismatch: \ 178 | expected {arity}, \ 179 | actual {def.Arguments.Length}" 180 | 181 | let! argsNode = 182 | def.Arguments 183 | |> Result.List.traverse (fun expr -> 184 | compile env aenv expr 185 | |> Result.map (fst >> Argument)) 186 | |> Result.map SeparatedList 187 | 188 | let node = 189 | InvocationExpression( 190 | IdentifierName(def.Identifier.Name)) 191 | .WithArgumentList(ArgumentList(argsNode)) 192 | 193 | return node, env 194 | } 195 | 196 | module private Decl = 197 | 198 | let compile aenv decl = 199 | result { 200 | 201 | let! env = 202 | (Env.empty, decl.Parameters) 203 | ||> Result.List.foldM (fun acc parm -> 204 | result { 205 | let node = IdentifierName(parm.Name) 206 | return! acc 207 | |> Env.tryAdd parm.Name node 208 | }) 209 | 210 | let parmNodes = 211 | decl.Parameters 212 | |> List.map (fun parm -> 213 | Parameter(Identifier(parm.Name)) 214 | .WithType( 215 | PredefinedType( 216 | Token(SyntaxKind.IntKeyword)))) // ugh 217 | 218 | let! aenv' = 219 | ArityEnvironment.tryAdd 220 | decl.Identifier.Name 221 | decl.Parameters.Length 222 | aenv 223 | let! bodyNode, _ = Expr.compile env aenv' decl.Body 224 | 225 | let declNode = 226 | MethodDeclaration( 227 | returnType = 228 | PredefinedType( 229 | Token(SyntaxKind.IntKeyword)), 230 | identifier = decl.Identifier.Name) 231 | .AddModifiers( 232 | Token(SyntaxKind.StaticKeyword)) 233 | .WithParameterList( 234 | ParameterList(SeparatedList(parmNodes))) 235 | .WithBody( 236 | Block(ReturnStatement(bodyNode))) 237 | 238 | return declNode, aenv' 239 | } 240 | 241 | module private Program = 242 | 243 | let compile program = 244 | result { 245 | let! declNodes, aenv = 246 | ((List.empty, ArityEnvironment.empty), program.Declarations) 247 | ||> Result.List.foldM (fun (declNodes, aenv) decl -> 248 | result { 249 | let! declNode, aenv' = Decl.compile aenv decl 250 | return declNode :: declNodes, aenv' 251 | }) 252 | let! mainNode, _ = 253 | Expr.compile Env.empty aenv program.Main 254 | return mainNode, List.rev declNodes 255 | } 256 | 257 | let compile assemblyName text = 258 | result { 259 | let! program = Parser.parse text 260 | let! mainNode, methodNodes = Program.compile program 261 | let memberNodes = 262 | methodNodes 263 | |> Seq.cast 264 | |> Seq.toArray 265 | do! 266 | Compiler.compileWithMembers 267 | assemblyName 268 | mainNode 269 | memberNodes 270 | } 271 | -------------------------------------------------------------------------------- /Assignment5/Decl.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment5 2 | 3 | type Decl<'tag> = 4 | { 5 | /// Name of function begin declared. 6 | Identifier : IdentifierDef<'tag> 7 | Parameters : List> 8 | Body : Expr<'tag> 9 | } 10 | 11 | module Decl = 12 | 13 | let unparse decl = 14 | let ident = decl.Identifier.Name 15 | let parms = 16 | decl.Parameters 17 | |> Seq.map (fun ident -> ident.Name) 18 | |> String.concat ", " 19 | let body = Expr.unparse decl.Body 20 | $"def {ident}({parms}):\n{body}" 21 | 22 | type Program<'tag> = 23 | { 24 | Declarations : List> 25 | Main : Expr<'tag> 26 | } 27 | 28 | module Program = 29 | 30 | let unparse program = 31 | let decls = 32 | program.Declarations 33 | |> List.map Decl.unparse 34 | |> String.concat "\n" 35 | let main = Expr.unparse program.Main 36 | $"{decls}\n{main}" 37 | -------------------------------------------------------------------------------- /Assignment5/Expr.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment5 2 | 3 | type Prim1 = 4 | | Add1 5 | | Sub1 6 | | Print 7 | | IsBool 8 | | IsNum 9 | | Not 10 | 11 | type Prim2 = 12 | | Plus 13 | | Minus 14 | | Times 15 | | And 16 | | Or 17 | | Greater 18 | | GreaterEq 19 | | Less 20 | | LessEq 21 | | Eq 22 | 23 | type IdentifierDef<'tag> = 24 | { 25 | Name : string 26 | Tag : 'tag 27 | } 28 | 29 | type NumberDef<'tag> = 30 | { 31 | Number : int 32 | Tag : 'tag 33 | } 34 | 35 | type BoolDef<'tag> = 36 | { 37 | Flag : bool 38 | Tag : 'tag 39 | } 40 | 41 | type Expr<'tag> = 42 | | LetExpr of LetDef<'tag> 43 | | Prim1Expr of Prim1Def<'tag> 44 | | Prim2Expr of Prim2Def<'tag> 45 | | IfExpr of IfDef<'tag> 46 | | NumberExpr of NumberDef<'tag> // numeric literal 47 | | IdentifierExpr of IdentifierDef<'tag> 48 | | BoolExpr of BoolDef<'tag> // Boolean literal 49 | | ApplicationExpr of ApplicationDef<'tag> 50 | with 51 | 52 | member expr.Tag' = // F# uses the name "Tag" internally :( 53 | match expr with 54 | | LetExpr def -> def.Tag 55 | | Prim1Expr def -> def.Tag 56 | | Prim2Expr def -> def.Tag 57 | | IfExpr def -> def.Tag 58 | | NumberExpr def -> def.Tag 59 | | IdentifierExpr def -> def.Tag 60 | | BoolExpr def -> def.Tag 61 | | ApplicationExpr def -> def.Tag 62 | 63 | and LetDef<'tag> = 64 | { 65 | Bindings : List> 66 | Expr : Expr<'tag> 67 | Tag : 'tag 68 | } 69 | 70 | and Binding<'tag> = 71 | { 72 | Identifier : IdentifierDef<'tag> 73 | Expr : Expr<'tag> 74 | } 75 | 76 | and Prim1Def<'tag> = 77 | { 78 | Operator : Prim1 79 | Expr : Expr<'tag> 80 | Tag : 'tag 81 | } 82 | 83 | and Prim2Def<'tag> = 84 | { 85 | Operator : Prim2 86 | Left : Expr<'tag> 87 | Right : Expr<'tag> 88 | Tag : 'tag 89 | } 90 | 91 | and IfDef<'tag> = 92 | { 93 | Condition : Expr<'tag> 94 | TrueBranch : Expr<'tag> 95 | FalseBranch : Expr<'tag> 96 | Tag : 'tag 97 | } 98 | 99 | and ApplicationDef<'tag> = 100 | { 101 | /// Name of function being called. 102 | Identifier : IdentifierDef<'tag> 103 | Arguments : List> 104 | Tag : 'tag 105 | } 106 | 107 | module Expr = 108 | 109 | let rec unparse = function 110 | | LetExpr def -> 111 | let bindings = 112 | def.Bindings 113 | |> Seq.map (fun binding -> 114 | $"{binding.Identifier.Name} = {unparse binding.Expr}") 115 | |> String.concat ", " 116 | $"(let {bindings} in {unparse def.Expr})" 117 | | Prim1Expr def -> 118 | let op = function 119 | | Not -> "!" 120 | | prim1 -> (string prim1).ToLower() 121 | $"{op def.Operator}({unparse def.Expr})" 122 | | Prim2Expr def -> 123 | let op = function 124 | | Plus -> "+" 125 | | Minus -> "-" 126 | | Times -> "*" 127 | | And -> "&&" 128 | | Or -> "||" 129 | | Greater -> ">" 130 | | GreaterEq -> ">=" 131 | | Less -> "<" 132 | | LessEq -> "<=" 133 | | Eq -> "==" 134 | $"({unparse def.Left} {op def.Operator} {unparse def.Right})" 135 | | IfExpr def -> 136 | $"(if {unparse def.Condition} : \ 137 | {unparse def.TrueBranch} \ 138 | else: {unparse def.FalseBranch})" 139 | | NumberExpr def -> 140 | if def.Number < 0 then 141 | $"({def.Number})" // use parens to avoid ambiguity 142 | else 143 | $"{def.Number}" 144 | | IdentifierExpr def -> def.Name 145 | | BoolExpr def -> (string def.Flag).ToLower() 146 | | ApplicationExpr def -> 147 | let args = 148 | def.Arguments 149 | |> Seq.map unparse 150 | |> String.concat ", " 151 | $"{def.Identifier.Name}({args})" 152 | -------------------------------------------------------------------------------- /Assignment5/Parser.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment5 2 | 3 | open System 4 | open FParsec 5 | open CompilerDesign.Core 6 | 7 | module Parser = 8 | 9 | let private skipComment = 10 | skipChar '#' 11 | >>. skipManyTill 12 | anyChar 13 | (skipNewline <|> eof) 14 | 15 | let private spaces = 16 | skipMany ( 17 | skipSatisfy Char.IsWhiteSpace 18 | <|> skipComment) 19 | 20 | let private parsePos create parser = 21 | parse { 22 | let! startPos = getPosition 23 | let! value = parser 24 | let! endPos = getPosition 25 | return create value (startPos, endPos) 26 | } 27 | 28 | let private parseIdentifierDef = 29 | identifier (IdentifierOptions ()) 30 | |> parsePos (fun name tag -> 31 | { 32 | Name = name 33 | Tag = tag 34 | }) 35 | 36 | let private choiceF pairs = 37 | pairs 38 | |> Seq.map (fun (str, f) -> 39 | skipString str >>% f) 40 | |> choice 41 | 42 | let private parseParens parser = 43 | parse { 44 | do! skipChar '(' >>. spaces 45 | let! value = parser 46 | do! spaces >>. skipChar ')' 47 | return value 48 | } 49 | 50 | module private Expr = 51 | 52 | let private parseExpr, parseExprRef = 53 | createParserForwardedToRef () 54 | 55 | let private parseNumber : Parser<_, unit> = 56 | pint32 57 | |> parsePos (fun n tag -> 58 | NumberExpr { 59 | Number = n 60 | Tag = tag 61 | }) 62 | 63 | let private parseIdentifier = 64 | parseIdentifierDef 65 | |>> IdentifierExpr 66 | 67 | let private parseBool = 68 | choiceF [ 69 | "true", true 70 | "false", false 71 | ] 72 | |> parsePos (fun flag tag -> 73 | BoolExpr { 74 | Flag = flag 75 | Tag = tag 76 | }) 77 | 78 | let private parsePrim1 = 79 | parse { 80 | let! op = 81 | choiceF [ 82 | "add1", Add1 83 | "sub1", Sub1 84 | "print", Print 85 | "isbool", IsBool 86 | "isnum", IsNum 87 | "!", Not 88 | ] 89 | do! spaces 90 | let! expr = parseParens parseExpr 91 | return op, expr 92 | } |> parsePos (fun (op, expr) tag -> 93 | Prim1Expr { 94 | Operator = op 95 | Expr = expr 96 | Tag = tag 97 | }) 98 | 99 | let private parseIf = 100 | parse { 101 | do! skipString "if" >>. spaces 102 | let! cond = parseExpr 103 | do! spaces >>. skipChar ':' >>. spaces 104 | let! trueBranch = parseExpr 105 | do! spaces >>. skipString "else:" >>. spaces 106 | let! falseBranch = parseExpr 107 | return cond, trueBranch, falseBranch 108 | } |> parsePos (fun (cond, trueBranch, falseBranch) tag -> 109 | IfExpr { 110 | Condition = cond 111 | TrueBranch = trueBranch 112 | FalseBranch = falseBranch 113 | Tag = tag 114 | }) 115 | 116 | let private parseBinding = 117 | parse { 118 | let! ident = parseIdentifierDef 119 | do! spaces >>. skipChar '=' >>. spaces 120 | let! expr = parseExpr 121 | return { 122 | Identifier = ident 123 | Expr = expr 124 | } 125 | } 126 | 127 | let private parseBindings = 128 | sepBy1 129 | (parseBinding .>> spaces) 130 | (skipChar ',' .>> spaces) 131 | 132 | let private parseLet = 133 | parse { 134 | do! skipString "let" >>. spaces 135 | let! bindings = parseBindings 136 | do! spaces >>. skipString "in" >>. spaces 137 | let! expr = parseExpr 138 | return bindings, expr 139 | } |> parsePos (fun (bindings, expr) tag -> 140 | LetExpr { 141 | Bindings = bindings 142 | Expr = expr 143 | Tag = tag 144 | }) 145 | 146 | let private parseArguments = 147 | sepBy 148 | (parseExpr .>> spaces) 149 | (skipChar ',' >>. spaces) 150 | 151 | let private parseApplication = 152 | parse { 153 | let! ident = parseIdentifierDef 154 | // no spaces allowed here! 155 | let! args = parseParens parseArguments 156 | return ident, args 157 | } 158 | |> parsePos (fun (ident, args) tag -> 159 | ApplicationExpr { 160 | Identifier = ident 161 | Arguments = args 162 | Tag = tag 163 | }) 164 | |> attempt // rollback if needed 165 | 166 | let private parseSimpleExpr = 167 | choice [ 168 | parseNumber 169 | parseBool 170 | parsePrim1 171 | parseIf 172 | parseLet 173 | parseApplication 174 | parseIdentifier // must come after other parsers 175 | parseParens parseExpr 176 | ] 177 | 178 | let private parseExprImpl = 179 | let create op left right = 180 | Prim2Expr { 181 | Operator = op 182 | Left = left 183 | Right = right 184 | Tag = fst left.Tag', snd right.Tag' 185 | } 186 | let parseOp = 187 | choiceF [ 188 | "+", create Plus 189 | "-", create Minus 190 | "*", create Times 191 | "&&", create And 192 | "||", create Or 193 | ">=", create GreaterEq // must come before ">" 194 | ">", create Greater 195 | "<=", create LessEq // must come before "<" 196 | "<", create Less 197 | "==", create Eq 198 | ] 199 | chainl1 200 | (parseSimpleExpr .>> spaces) 201 | (parseOp .>> spaces) 202 | 203 | let parse = parseExpr 204 | 205 | do parseExprRef.Value <- parseExprImpl 206 | 207 | module private Decl = 208 | 209 | let private parseParameters = 210 | sepBy 211 | (parseIdentifierDef .>> spaces) 212 | (skipChar ',' >>. spaces) 213 | 214 | let parse = 215 | parse { 216 | do! skipString "def" >>. spaces 217 | let! ident = parseIdentifierDef 218 | do! spaces 219 | let! parms = parseParens parseParameters 220 | do! spaces >>. skipChar ':' >>. spaces 221 | let! body = Expr.parse 222 | return { 223 | Identifier = ident 224 | Parameters = parms 225 | Body = body 226 | } 227 | } 228 | 229 | module private Program = 230 | 231 | let parse = 232 | parse { 233 | do! spaces 234 | let! decls = 235 | many (Decl.parse .>> spaces) 236 | let! main = Expr.parse .>> spaces 237 | do! eof 238 | return { 239 | Declarations = decls 240 | Main = main 241 | } 242 | } 243 | 244 | let parse text = 245 | match runParserOnString Program.parse () "" text with 246 | | Success (result, _, _) -> Result.Ok result 247 | | Failure (msg, _, _) -> Result.Error msg 248 | -------------------------------------------------------------------------------- /Assignment5/Readme.md: -------------------------------------------------------------------------------- 1 | [Assignment 5: Diamondback: Defining functions](https://course.ccs.neu.edu/cs4410sp21/hw_diamondback_assignment.html) 2 | 3 | Relevant lectures: 4 | 5 | * [Lecture 7: Defining functions](https://course.ccs.neu.edu/cs4410sp21/lec_function-defs_notes.html) 6 | -------------------------------------------------------------------------------- /Assignment6/Assignment6.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net8.0 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /Assignment6/Compiler.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open Microsoft.CodeAnalysis 4 | open Microsoft.CodeAnalysis.CSharp 5 | open type SyntaxFactory 6 | 7 | open CompilerDesign.Core 8 | 9 | module private Syntax = 10 | 11 | let numericLiteral (n : int) = 12 | LiteralExpression( 13 | SyntaxKind.NumericLiteralExpression, 14 | Literal(n)) 15 | 16 | let boolLiteral flag = 17 | let kind = 18 | if flag then SyntaxKind.TrueLiteralExpression 19 | else SyntaxKind.FalseLiteralExpression 20 | LiteralExpression(kind) 21 | 22 | let by1 node kind = 23 | BinaryExpression( 24 | kind, 25 | node, 26 | numericLiteral 1) 27 | 28 | let isType node kind = 29 | BinaryExpression( 30 | SyntaxKind.IsExpression, 31 | node, 32 | PredefinedType(Token(kind))) 33 | 34 | let print node = 35 | InvocationExpression(IdentifierName("Print")) 36 | .WithArgumentList( 37 | ArgumentList( 38 | SingletonSeparatedList( 39 | Argument(node)))) 40 | 41 | let not node = 42 | PrefixUnaryExpression( 43 | SyntaxKind.LogicalNotExpression, 44 | node) 45 | 46 | module Compiler = 47 | 48 | module private rec Expression = 49 | 50 | let compile env = function 51 | | LetExpr def -> (compileLet env def : CompilerResult<_>) 52 | | Prim1Expr def -> compilePrim1 env def 53 | | Prim2Expr def -> compilePrim2 env def 54 | | IfExpr def -> compileIf env def 55 | | NumberExpr def -> compileNumber env def 56 | | IdentifierExpr def -> compileIdentifier env def 57 | | BoolExpr def -> compileBool env def 58 | | ApplicationExpr def -> compileApplication env def 59 | | AnnotationExpr def -> compile env def.Expr 60 | 61 | let private compileNumber (env : env) (def : NumberDef<_>) = 62 | let node = 63 | Syntax.numericLiteral def.Number 64 | :> Syntax.ExpressionSyntax 65 | Ok (node, env) 66 | 67 | let private compileBool (env : env) (def : BoolDef<_>) = 68 | let node = 69 | Syntax.boolLiteral def.Flag 70 | :> Syntax.ExpressionSyntax 71 | Ok (node, env) 72 | 73 | let private compileIdentifier env (def : IdentifierDef<_>) = 74 | Env.tryFind def.Name env 75 | |> Result.map (fun node -> node, env) 76 | 77 | let private compileLet env (def : LetDef<_>) = 78 | result { 79 | let! env' = 80 | (env, def.Bindings) 81 | ||> Result.List.foldM (fun acc binding -> 82 | result { 83 | let! node, acc' = 84 | compile acc binding.Expr 85 | return! acc' 86 | |> Env.tryAdd 87 | binding.Identifier.Name 88 | node 89 | }) 90 | return! compile env' def.Expr 91 | } 92 | 93 | let private compilePrim1 env (def : Prim1Def<_>) = 94 | result { 95 | let! node, _ = compile env def.Expr 96 | let prim1Node = 97 | match def.Operator with 98 | | Add1 -> 99 | Syntax.by1 node SyntaxKind.AddExpression 100 | :> Syntax.ExpressionSyntax 101 | | Sub1 -> 102 | Syntax.by1 node SyntaxKind.SubtractExpression 103 | | Print -> 104 | Syntax.print node 105 | | IsBool -> 106 | Syntax.isType node SyntaxKind.BoolKeyword 107 | | IsNum -> 108 | Syntax.isType node SyntaxKind.IntKeyword 109 | | Not -> 110 | Syntax.not node 111 | return prim1Node, env 112 | } 113 | 114 | let private compilePrim2 env (def: Prim2Def<_>) = 115 | let kind = 116 | match def.Operator with 117 | | Plus -> SyntaxKind.AddExpression 118 | | Minus -> SyntaxKind.SubtractExpression 119 | | Times -> SyntaxKind.MultiplyExpression 120 | | And -> SyntaxKind.LogicalAndExpression 121 | | Or -> SyntaxKind.LogicalOrExpression 122 | | Greater -> SyntaxKind.GreaterThanExpression 123 | | GreaterEq -> SyntaxKind.GreaterThanOrEqualExpression 124 | | Less -> SyntaxKind.LessThanExpression 125 | | LessEq -> SyntaxKind.LessThanOrEqualExpression 126 | | Eq -> SyntaxKind.EqualsExpression 127 | result { 128 | let! leftNode, _ = compile env def.Left 129 | let! rightNode, _ = compile env def.Right 130 | let node = 131 | BinaryExpression( 132 | kind, 133 | leftNode, 134 | rightNode) 135 | return node, env 136 | } 137 | 138 | let private compileIf env (def : IfDef<_>) = 139 | result { 140 | 141 | let! condNode, _ = compile env def.Condition 142 | let! trueNode, _ = compile env def.TrueBranch 143 | let! falseNode, _ = compile env def.FalseBranch 144 | 145 | let node = 146 | ConditionalExpression( 147 | condNode, trueNode, falseNode) 148 | 149 | return node, env 150 | } 151 | 152 | let private compileApplication env (def : ApplicationDef<_>) = 153 | result { 154 | 155 | let! argsNode = 156 | def.Arguments 157 | |> Result.List.traverse (fun expr -> 158 | compile env expr 159 | |> Result.map (fst >> Argument)) 160 | |> Result.map SeparatedList 161 | 162 | let node = 163 | InvocationExpression( 164 | IdentifierName(def.Identifier.Name)) 165 | .WithArgumentList(ArgumentList(argsNode)) 166 | 167 | return node, env 168 | } 169 | 170 | type Syntax.MethodDeclarationSyntax with 171 | member node.MaybeWithTypeParameterList( 172 | typeParameterList : Syntax.TypeParameterListSyntax) = 173 | if typeParameterList.Parameters.Count > 0 then 174 | node.WithTypeParameterList(typeParameterList) 175 | else node 176 | 177 | module private Decl = 178 | 179 | let private predefinedTypeMap = 180 | Map [ 181 | Type.int, SyntaxKind.IntKeyword 182 | Type.bool, SyntaxKind.BoolKeyword 183 | ] 184 | 185 | let private compileType typ = 186 | result { 187 | do! TypeCheck.Type.checkMissing typ 188 | match typ with 189 | | TypeConstant _ -> 190 | let kind = predefinedTypeMap[typ] 191 | return (PredefinedType(Token(kind)) : Syntax.TypeSyntax) 192 | | TypeVariable def -> 193 | return IdentifierName(def.Name) 194 | | _ -> return! Error "Unexpected type" 195 | } 196 | 197 | let private compileParameter parm typ = 198 | result { 199 | let! typeNode = compileType typ 200 | return Parameter( 201 | Identifier(parm.Name)) 202 | .WithType(typeNode) 203 | } 204 | 205 | let compile decl = 206 | result { 207 | 208 | let! typedParms, outputType = Decl.getSignature decl 209 | let! returnType = compileType outputType 210 | let typeParmNodes = 211 | decl.Scheme.TypeVariableIdents 212 | |> Seq.map (fun tvIdent -> 213 | TypeParameter( 214 | Identifier(tvIdent.Name))) 215 | let! env = 216 | (Env.empty, typedParms) 217 | ||> Result.List.foldM (fun acc (parm, _) -> 218 | result { 219 | let node = IdentifierName(parm.Name) 220 | return! acc 221 | |> Env.tryAdd parm.Name node 222 | }) 223 | let! parmNodes = 224 | typedParms 225 | |> Result.List.traverse (fun (parm, typ) -> 226 | compileParameter parm typ) 227 | let! bodyNode, _ = Expression.compile env decl.Body 228 | 229 | return MethodDeclaration( 230 | returnType = returnType, 231 | identifier = decl.Identifier.Name) 232 | .AddModifiers( 233 | Token(SyntaxKind.StaticKeyword)) 234 | .MaybeWithTypeParameterList( 235 | TypeParameterList(SeparatedList(typeParmNodes))) 236 | .WithParameterList( 237 | ParameterList(SeparatedList(parmNodes))) 238 | .WithBody( 239 | Block(ReturnStatement(bodyNode))) 240 | } 241 | 242 | module private DeclGroup = 243 | 244 | let compile group = 245 | group.Decls 246 | |> Result.List.traverse Decl.compile 247 | 248 | module private Program = 249 | 250 | let compile program = 251 | result { 252 | let! declNodes = 253 | program.DeclGroups 254 | |> Result.List.traverse DeclGroup.compile 255 | |> Result.map (Seq.concat >> Seq.toArray) 256 | let! mainNode, _ = 257 | Expression.compile Env.empty program.Main 258 | return mainNode, declNodes 259 | } 260 | 261 | let compile assemblyName text = 262 | result { 263 | let! program = Parser.parse text 264 | let! program' = TypeInfer.annotate program 265 | do! TypeCheck.validate program' 266 | let! mainNode, methodNodes = 267 | Program.compile program' 268 | let memberNodes = 269 | methodNodes 270 | |> Array.map (fun node -> 271 | node :> Syntax.MemberDeclarationSyntax) 272 | do! 273 | Compiler.compileWithMembers 274 | assemblyName 275 | mainNode 276 | memberNodes 277 | } 278 | -------------------------------------------------------------------------------- /Assignment6/Decl.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open CompilerDesign.Core 4 | 5 | /// Function declaration. 6 | /// E.g. "def f(x): x + x". 7 | type Decl<'tag> = 8 | { 9 | /// Name of function begin declared. E.g. "f". 10 | Identifier : IdentifierDef<'tag> 11 | 12 | /// Function parameters. E.g. "(x)". 13 | Parameters : List> 14 | 15 | /// Generalized function signature. 16 | Scheme : Scheme<'tag> 17 | 18 | /// Function body. E.g. "x + x". 19 | Body : Expression<'tag> 20 | } 21 | 22 | module Decl = 23 | 24 | let untag decl = 25 | { 26 | Identifier = 27 | IdentifierDef.create decl.Identifier.Name 28 | Parameters = 29 | decl.Parameters 30 | |> List.map IdentifierDef.untag 31 | Scheme = Scheme.untag decl.Scheme 32 | Body = Expression.untag decl.Body 33 | } 34 | 35 | let getSignature decl = 36 | match decl.Scheme.Type with 37 | | TypeArrow arrowDef -> 38 | let typedParms = List.zip decl.Parameters arrowDef.InputTypes 39 | Ok (typedParms, arrowDef.OutputType) 40 | | _ -> Error "Invalid decl scheme" 41 | 42 | let unparse decl = 43 | let ident = decl.Identifier.Name 44 | let tvIdents = decl.Scheme.UnparseTypeVariableIdents() 45 | let typedParms, outputType = 46 | getSignature decl |> Result.get 47 | let parms = 48 | typedParms 49 | |> Seq.map (fun (ident, typ) -> 50 | match typ with 51 | | TypeBlank _ -> ident.Name 52 | | _ -> $"{ident.Name} : {Type.unparse typ}") 53 | |> String.concat ", " 54 | let sOutputType = 55 | match outputType with 56 | | TypeBlank _ -> "" 57 | | _ -> $" -> {Type.unparse outputType}" 58 | let body = Expression.unparse decl.Body 59 | $"def {ident}{tvIdents}({parms}){sOutputType}:\n {body}\n\n" 60 | 61 | /// A group of mutually-recursive functions. 62 | type DeclGroup<'tag> = 63 | { 64 | Decls : List> 65 | } 66 | 67 | module DeclGroup = 68 | 69 | let untag group = 70 | { 71 | Decls = 72 | List.map Decl.untag group.Decls 73 | } 74 | 75 | let unparse group = 76 | group.Decls 77 | |> List.map Decl.unparse 78 | |> String.concat "and " 79 | -------------------------------------------------------------------------------- /Assignment6/Expression.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | /// Primitive unary operators. 4 | type Prim1 = 5 | | Add1 6 | | Sub1 7 | | Print 8 | | IsBool 9 | | IsNum 10 | | Not 11 | 12 | module Prim1 = 13 | 14 | let unparse = function 15 | | Not -> "!" 16 | | prim1 -> (string prim1).ToLower() 17 | 18 | /// Primitive binary operators. 19 | type Prim2 = 20 | | Plus 21 | | Minus 22 | | Times 23 | | And 24 | | Or 25 | | Greater 26 | | GreaterEq 27 | | Less 28 | | LessEq 29 | | Eq 30 | 31 | module Prim2 = 32 | 33 | let unparse = function 34 | | Plus -> "+" 35 | | Minus -> "-" 36 | | Times -> "*" 37 | | And -> "&&" 38 | | Or -> "||" 39 | | Greater -> ">" 40 | | GreaterEq -> ">=" 41 | | Less -> "<" 42 | | LessEq -> "<=" 43 | | Eq -> "==" 44 | 45 | /// Numeric literal. 46 | type NumberDef<'tag> = 47 | { 48 | Number : int 49 | Tag : 'tag 50 | } 51 | 52 | /// Boolean literal. 53 | type BoolDef<'tag> = 54 | { 55 | Flag : bool 56 | Tag : 'tag 57 | } 58 | 59 | /// An expression that evaluates to a value. 60 | type Expression<'tag> = 61 | 62 | /// E.g. "let x = 0 in 2 * x". 63 | | LetExpr of LetDef<'tag> 64 | 65 | /// E.g. "add1(0)". 66 | | Prim1Expr of Prim1Def<'tag> 67 | 68 | /// E.g. "1 + 2". 69 | | Prim2Expr of Prim2Def<'tag> 70 | 71 | /// E.g. "if flag: 1 else: 2". 72 | | IfExpr of IfDef<'tag> 73 | 74 | /// Numeric literal. E.g. "1". 75 | | NumberExpr of NumberDef<'tag> 76 | 77 | /// Value identifier. E.g. "x". 78 | | IdentifierExpr of IdentifierDef<'tag> 79 | 80 | /// Boolean literal. E.g. "true". 81 | | BoolExpr of BoolDef<'tag> 82 | 83 | /// Function application. E.g. "f(3)". 84 | | ApplicationExpr of ApplicationDef<'tag> 85 | 86 | /// Type annotation. E.g. "(x : Int)". 87 | | AnnotationExpr of AnnotationDef<'tag> 88 | 89 | with 90 | member expr.Tag' = // F# uses the name "Tag" internally :( 91 | match expr with 92 | | LetExpr def -> def.Tag 93 | | Prim1Expr def -> def.Tag 94 | | Prim2Expr def -> def.Tag 95 | | IfExpr def -> def.Tag 96 | | NumberExpr def -> def.Tag 97 | | IdentifierExpr def -> def.Tag 98 | | BoolExpr def -> def.Tag 99 | | ApplicationExpr def -> def.Tag 100 | | AnnotationExpr def -> def.Tag 101 | 102 | and LetDef<'tag> = 103 | { 104 | Bindings : List> 105 | Expr : Expression<'tag> 106 | Tag : 'tag 107 | } 108 | 109 | and Binding<'tag> = 110 | { 111 | Identifier : IdentifierDef<'tag> 112 | Type : Type<'tag> 113 | Expr : Expression<'tag> 114 | } 115 | 116 | and Prim1Def<'tag> = 117 | { 118 | Operator : Prim1 119 | TypeArguments : List> 120 | Expr : Expression<'tag> 121 | Tag : 'tag 122 | } 123 | 124 | and Prim2Def<'tag> = 125 | { 126 | Operator : Prim2 127 | TypeArguments : List> 128 | Left : Expression<'tag> 129 | Right : Expression<'tag> 130 | Tag : 'tag 131 | } 132 | 133 | and IfDef<'tag> = 134 | { 135 | Condition : Expression<'tag> 136 | TrueBranch : Expression<'tag> 137 | FalseBranch : Expression<'tag> 138 | Tag : 'tag 139 | } 140 | 141 | and ApplicationDef<'tag> = 142 | { 143 | /// Name of function being called. 144 | Identifier : IdentifierDef<'tag> 145 | TypeArguments : List> 146 | Arguments : List> 147 | Tag : 'tag 148 | } 149 | 150 | and AnnotationDef<'tag> = 151 | { 152 | Expr : Expression<'tag> 153 | Type: Type<'tag> 154 | Tag : 'tag 155 | } 156 | 157 | module Expression = 158 | 159 | let rec untag = function 160 | | LetExpr def-> 161 | LetExpr { 162 | Bindings = 163 | def.Bindings 164 | |> List.map (fun binding -> 165 | { 166 | Identifier = IdentifierDef.untag binding.Identifier 167 | Type = Type.untag binding.Type 168 | Expr = untag binding.Expr 169 | }) 170 | Expr = untag def.Expr 171 | Tag = () 172 | } 173 | | Prim1Expr def -> 174 | Prim1Expr { 175 | Operator = def.Operator 176 | TypeArguments = 177 | def.TypeArguments 178 | |> List.map Type.untag 179 | Expr = untag def.Expr 180 | Tag = () 181 | } 182 | | Prim2Expr def -> 183 | Prim2Expr { 184 | Operator = def.Operator 185 | TypeArguments = 186 | def.TypeArguments 187 | |> List.map Type.untag 188 | Left = untag def.Left 189 | Right = untag def.Right 190 | Tag = () 191 | } 192 | | IfExpr def -> 193 | IfExpr { 194 | Condition = untag def.Condition 195 | TrueBranch = untag def.TrueBranch 196 | FalseBranch = untag def.FalseBranch 197 | Tag = () 198 | } 199 | | NumberExpr def -> 200 | NumberExpr { 201 | Number = def.Number 202 | Tag = () 203 | } 204 | | IdentifierExpr def -> 205 | IdentifierExpr ( 206 | IdentifierDef.create def.Name) 207 | | BoolExpr def -> 208 | BoolExpr { 209 | Flag = def.Flag 210 | Tag = () 211 | } 212 | | ApplicationExpr def -> 213 | ApplicationExpr { 214 | Identifier = IdentifierDef.untag def.Identifier 215 | TypeArguments = 216 | def.TypeArguments 217 | |> List.map Type.untag 218 | Arguments = 219 | def.Arguments |> List.map untag 220 | Tag = () 221 | } 222 | | AnnotationExpr def -> 223 | AnnotationExpr { 224 | Expr = untag def.Expr 225 | Type = Type.untag def.Type 226 | Tag = () 227 | } 228 | 229 | module private rec Unparse = 230 | 231 | let private unparseTypeArgs typeArgs = 232 | if typeArgs |> List.isEmpty then "" 233 | else 234 | let str = 235 | typeArgs 236 | |> List.map Type.unparse 237 | |> String.concat ", " 238 | $"<{str}>" 239 | 240 | let private unparseBinding (binding : Binding<_>) = 241 | let ident = binding.Identifier.Name 242 | let expr = unparseExpr binding.Expr 243 | let typ = 244 | match binding.Type with 245 | | TypeBlank _ -> "" 246 | | t -> $" : {Type.unparse t}" 247 | $"{ident}{typ} = {expr}" 248 | 249 | let unparseExpr = function 250 | | LetExpr def -> 251 | let bindings = 252 | def.Bindings 253 | |> Seq.map unparseBinding 254 | |> String.concat ", " 255 | $"(let {bindings} in {unparseExpr def.Expr})" 256 | | Prim1Expr def -> 257 | let op = Prim1.unparse def.Operator 258 | let typeArgs = unparseTypeArgs def.TypeArguments 259 | let expr = unparseExpr def.Expr 260 | $"{op}{typeArgs}({expr})" 261 | | Prim2Expr def -> 262 | let left = unparseExpr def.Left 263 | let op = Prim2.unparse def.Operator 264 | let typeArgs = unparseTypeArgs def.TypeArguments 265 | let right = unparseExpr def.Right 266 | $"({left} {op}{typeArgs} {right})" 267 | | IfExpr def -> 268 | $"(if {unparseExpr def.Condition} : \ 269 | {unparseExpr def.TrueBranch} \ 270 | else: {unparseExpr def.FalseBranch})" 271 | | NumberExpr def -> 272 | if def.Number < 0 then 273 | $"({def.Number})" // use parens to avoid ambiguity 274 | else 275 | $"{def.Number}" 276 | | IdentifierExpr def -> def.Name 277 | | BoolExpr def -> (string def.Flag).ToLower() 278 | | ApplicationExpr def -> 279 | let args = 280 | def.Arguments 281 | |> Seq.map unparseExpr 282 | |> String.concat ", " 283 | $"{def.Identifier.Name}{unparseTypeArgs def.TypeArguments}({args})" 284 | | AnnotationExpr def -> 285 | $"({unparseExpr def.Expr} : {Type.unparse def.Type})" 286 | 287 | let unparse = Unparse.unparseExpr 288 | -------------------------------------------------------------------------------- /Assignment6/Identifier.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | /// An identifier, such as the name of a value or function. 4 | type IdentifierDef<'tag> = 5 | { 6 | Name : string 7 | Tag : 'tag 8 | } 9 | 10 | module IdentifierDef = 11 | 12 | let create name = 13 | { 14 | Name = name 15 | Tag = () 16 | } 17 | 18 | let untag ident = 19 | create ident.Name 20 | -------------------------------------------------------------------------------- /Assignment6/Parser.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open System 4 | open FParsec 5 | open CompilerDesign.Core 6 | 7 | module Parser = 8 | 9 | #if DEBUG 10 | let () (p: Parser<_,_>) label : Parser<_,_> = 11 | fun stream -> 12 | printfn "%A: Entering %s" stream.Position label 13 | let reply = p stream 14 | let safeResult = string reply.Result 15 | printfn "%A: Leaving %s (%A): %A" stream.Position label reply.Status safeResult 16 | reply 17 | #endif 18 | 19 | let private skipComment = 20 | skipChar '#' 21 | >>. skipManyTill 22 | anyChar 23 | (skipNewline <|> eof) 24 | 25 | let private spaces = 26 | skipMany ( 27 | skipSatisfy Char.IsWhiteSpace 28 | <|> skipComment) 29 | 30 | let private parsePos create parser = 31 | parse { 32 | let! startPos = getPosition 33 | let! value = parser 34 | let! endPos = getPosition 35 | return create value (startPos, endPos) 36 | } 37 | 38 | let private parseIdentifierDef = 39 | identifier (IdentifierOptions ()) 40 | |> parsePos (fun name tag -> 41 | { 42 | Name = name 43 | Tag = tag 44 | }) 45 | 46 | let private choiceF pairs = 47 | pairs 48 | |> Seq.map (fun (str, f) -> 49 | skipString str >>% f) 50 | |> choice 51 | 52 | let private parseBrackets cOpen cClose parser : Parser<_, _> = 53 | parse { 54 | do! skipChar cOpen >>. spaces 55 | let! value = parser 56 | do! spaces >>. skipChar cClose 57 | return value 58 | } 59 | 60 | let private parseParens parser = 61 | parseBrackets '(' ')' parser 62 | 63 | let private parseAngles parser = 64 | parseBrackets '<' '>' parser 65 | 66 | let private parseCsv parser = 67 | sepBy 68 | (parser .>> spaces) 69 | (skipChar ',' .>> spaces) 70 | 71 | let private parseCsv1 parser = 72 | sepBy1 73 | (parser .>> spaces) 74 | (skipChar ',' .>> spaces) 75 | 76 | module private Type = 77 | 78 | let private parseType, private parseTypeRef = 79 | createParserForwardedToRef () 80 | 81 | /// Allow "_" to indicate a blank type. This isn't specified in 82 | /// the assignment, but is useful for inputs like (x : _). 83 | let private parseBlank = 84 | skipChar '_' 85 | |> parsePos (fun () tag -> 86 | TypeBlank tag) 87 | 88 | let private parseConstant = 89 | parseIdentifierDef |>> TypeConstant 90 | 91 | let parseVariableIdentifier = 92 | skipChar '\'' 93 | >>. parseIdentifierDef // don't include apostrophe 94 | 95 | let private parseVariable = 96 | parseVariableIdentifier 97 | |>> TypeVariable 98 | 99 | let private parseArrow = 100 | parse { 101 | let! inputs = parseCsv1 parseType 102 | do! spaces >>. skipString "->" >>. spaces 103 | let! output = parseType 104 | return inputs, output 105 | } 106 | |> parseParens 107 | |> parsePos (fun (inputs, output) tag -> 108 | TypeArrow { 109 | InputTypes = inputs 110 | OutputType = output 111 | Tag = tag 112 | }) 113 | |> attempt 114 | 115 | let private parseTypeImpl = 116 | choice [ 117 | parseBlank 118 | parseArrow // must come before simpler types 119 | parseConstant 120 | parseVariable 121 | ] 122 | 123 | let parseOrBlank parser = 124 | let skipBlank = 125 | getPosition 126 | .>>. getPosition 127 | |>> TypeBlank 128 | parser <|> skipBlank 129 | 130 | let parseTypeDecl = 131 | skipChar ':' 132 | >>. spaces 133 | >>. parseType 134 | |> parseOrBlank 135 | 136 | let parse = parseType 137 | 138 | do parseTypeRef.Value <- parseTypeImpl 139 | 140 | module private Expression = 141 | 142 | let private parseExpr, private parseExprRef = 143 | createParserForwardedToRef () 144 | 145 | let private parseNumber : Parser<_, unit> = 146 | pint32 147 | |> parsePos (fun n tag -> 148 | NumberExpr { 149 | Number = n 150 | Tag = tag 151 | }) 152 | 153 | let private parseIdentifier = 154 | parseIdentifierDef 155 | |>> IdentifierExpr 156 | 157 | let private parseBool = 158 | choiceF [ 159 | "true", true 160 | "false", false 161 | ] 162 | |> parsePos (fun flag tag -> 163 | BoolExpr { 164 | Flag = flag 165 | Tag = tag 166 | }) 167 | 168 | let private parseTypeArgs = 169 | parseCsv1 Type.parse 170 | |> parseAngles 171 | |> opt 172 | |>> Option.defaultValue List.empty 173 | 174 | let private parsePrim1 = 175 | parse { 176 | let! op = 177 | choiceF [ 178 | "add1", Add1 179 | "sub1", Sub1 180 | "print", Print 181 | "isbool", IsBool 182 | "isnum", IsNum 183 | "!", Not 184 | ] 185 | do! spaces 186 | let! typeArgs = parseTypeArgs 187 | do! spaces 188 | let! expr = parseParens parseExpr 189 | return op, typeArgs, expr 190 | } |> parsePos (fun (op, typeArgs, expr) tag -> 191 | Prim1Expr { 192 | Operator = op 193 | TypeArguments = typeArgs 194 | Expr = expr 195 | Tag = tag 196 | }) 197 | 198 | let private parseIf = 199 | parse { 200 | do! skipString "if" >>. spaces 201 | let! cond = parseExpr 202 | do! spaces >>. skipChar ':' >>. spaces 203 | let! trueBranch = parseExpr 204 | do! spaces >>. skipString "else:" >>. spaces 205 | let! falseBranch = parseExpr 206 | return cond, trueBranch, falseBranch 207 | } |> parsePos (fun (cond, trueBranch, falseBranch) tag -> 208 | IfExpr { 209 | Condition = cond 210 | TrueBranch = trueBranch 211 | FalseBranch = falseBranch 212 | Tag = tag 213 | }) 214 | 215 | let private parseBinding = 216 | parse { 217 | let! ident = parseIdentifierDef 218 | do! spaces 219 | let! typ = Type.parseTypeDecl 220 | do! spaces >>. skipChar '=' >>. spaces 221 | let! expr = parseExpr 222 | return { 223 | Identifier = ident 224 | Type = typ 225 | Expr = expr 226 | } 227 | } 228 | 229 | let private parseBindings = 230 | parseCsv1 parseBinding 231 | 232 | let private parseLet = 233 | parse { 234 | do! skipString "let" >>. spaces 235 | let! bindings = parseBindings 236 | do! spaces >>. skipString "in" >>. spaces 237 | let! expr = parseExpr 238 | return bindings, expr 239 | } |> parsePos (fun (bindings, expr) tag -> 240 | LetExpr { 241 | Bindings = bindings 242 | Expr = expr 243 | Tag = tag 244 | }) 245 | 246 | let private parseArguments = 247 | parseCsv parseExpr 248 | 249 | let private parseApplication = 250 | parse { 251 | let! ident = parseIdentifierDef 252 | // no spaces allowed here! 253 | let! typeArgs = parseTypeArgs 254 | // no spaces allowed here! 255 | let! args = parseParens parseArguments 256 | return ident, typeArgs, args 257 | } 258 | |> parsePos (fun (ident, typeArgs, args) tag -> 259 | ApplicationExpr { 260 | Identifier = ident 261 | TypeArguments = typeArgs 262 | Arguments = args 263 | Tag = tag 264 | }) 265 | |> attempt // rollback if needed 266 | 267 | let private parseParenExpr = 268 | parseExpr 269 | |> parseParens 270 | |> attempt // rollback if needed 271 | 272 | /// Allow any expression to be annotated. This syntax 273 | /// is a little different from what the assignment 274 | /// specifies, but is simpler and more powerful. 275 | let private parseAnnotation = 276 | parse { 277 | let! expr = parseExpr 278 | do! spaces >>. skipChar ':' >>. spaces 279 | let! typ = Type.parse 280 | return expr, typ 281 | } 282 | |> parseParens 283 | |> parsePos (fun (expr, typ) tag -> 284 | AnnotationExpr { 285 | Expr = expr 286 | Type = typ 287 | Tag = tag 288 | }) 289 | 290 | let private parseSimpleExpr = 291 | choice [ 292 | parseNumber 293 | parseBool 294 | parsePrim1 295 | parseIf 296 | parseLet 297 | parseApplication 298 | parseIdentifier // must come after other parsers 299 | parseParenExpr 300 | parseAnnotation 301 | ] 302 | 303 | let private parseExprImpl = 304 | 305 | let create (str, prim2) : Parser -> Expression<_> -> Expression<_>, _> = 306 | skipString str 307 | >>. spaces 308 | >>. parseTypeArgs 309 | |>> (fun typeArgs left right -> 310 | Prim2Expr { 311 | Operator = prim2 312 | TypeArguments = typeArgs 313 | Left = left 314 | Right = right 315 | Tag = fst left.Tag', snd right.Tag' 316 | }) 317 | 318 | let parseOp : Parser -> Expression<_> -> Expression<_>, _> = 319 | [ 320 | "+", Plus 321 | "-", Minus 322 | "*", Times 323 | "&&", And 324 | "||", Or 325 | ">=", GreaterEq // must come before ">" 326 | ">", Greater 327 | "<=", LessEq // must come before "<" 328 | "<", Less 329 | "==", Eq 330 | ] 331 | |> List.map create 332 | |> choice 333 | 334 | chainl1 335 | (parseSimpleExpr .>> spaces) 336 | (parseOp .>> spaces) 337 | 338 | let parse = parseExpr 339 | 340 | do parseExprRef.Value <- parseExprImpl 341 | 342 | module private Decl = 343 | 344 | let parseTypeVariableIdentifiers = 345 | parseCsv1 Type.parseVariableIdentifier 346 | |> parseAngles 347 | |> opt 348 | |>> Option.defaultValue List.empty 349 | 350 | let private parseParameter = 351 | parse { 352 | let! ident = parseIdentifierDef 353 | do! spaces 354 | let! typ = Type.parseTypeDecl 355 | return ident, typ 356 | } 357 | 358 | let private parseParameters = 359 | parseCsv parseParameter 360 | |> parseParens 361 | |> parsePos (fun pairs tag -> 362 | pairs, tag) 363 | 364 | let private parseOutputType = 365 | skipString "->" 366 | >>. spaces 367 | >>. Type.parse 368 | |> Type.parseOrBlank 369 | 370 | (* 371 | def whatever(anything): 372 | print(anything) 373 | 374 | def whatever<'a>(anything : 'a) -> 'a: 375 | print<'a>(anything) 376 | *) 377 | let parse = 378 | parse { 379 | 380 | do! skipString "def" >>. spaces 381 | let! ident = parseIdentifierDef 382 | do! spaces 383 | let! tvIdents = parseTypeVariableIdentifiers 384 | do! spaces 385 | let! parmPairs, parmsTag = parseParameters 386 | do! spaces 387 | let! outType = parseOutputType 388 | do! skipChar ':' >>. spaces 389 | let! body = Expression.parse 390 | 391 | let parms, parmTypes = List.unzip parmPairs 392 | 393 | return { 394 | Identifier = ident 395 | Parameters = parms 396 | Scheme = 397 | { 398 | TypeVariableIdents = tvIdents 399 | Type = 400 | TypeArrow { 401 | InputTypes = parmTypes 402 | OutputType = outType 403 | Tag = parmsTag 404 | } 405 | Tag = parmsTag 406 | } 407 | Body = body 408 | } 409 | } 410 | 411 | module private DeclGroup = 412 | 413 | let parse = 414 | parse { 415 | let! decls = 416 | sepBy1 417 | Decl.parse 418 | (spaces 419 | .>> skipString "and" 420 | >>. spaces) 421 | return { Decls = decls } 422 | } 423 | 424 | module private Program = 425 | 426 | let parse = 427 | parse { 428 | do! spaces 429 | let! groups = 430 | many (DeclGroup.parse .>> spaces) 431 | let! main = Expression.parse .>> spaces 432 | return { 433 | DeclGroups = groups 434 | Main = main 435 | } 436 | } 437 | 438 | /// Runs the given parser on the given text. 439 | let run parser text = 440 | let parser' = parser .>> eof 441 | match runParserOnString parser' () "" text with 442 | | Success (result, _, _) -> Result.Ok result 443 | | Failure (msg, _, _) -> Result.Error msg 444 | 445 | let parse text = 446 | run Program.parse text 447 | 448 | module Scheme = 449 | 450 | let private parseScheme = 451 | Decl.parseTypeVariableIdentifiers 452 | .>>. Type.parse 453 | |> parsePos (fun (tvIdents, typ) tag -> 454 | { 455 | TypeVariableIdents = tvIdents 456 | Type = typ 457 | Tag = tag 458 | }) 459 | 460 | /// E.g. <'a>('a, 'a -> Bool) 461 | let parse text = 462 | run parseScheme text 463 | -------------------------------------------------------------------------------- /Assignment6/Program.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | /// A program computes a single value via its "main" expression. 4 | type Program<'tag> = 5 | { 6 | DeclGroups : List> 7 | Main : Expression<'tag> 8 | } 9 | 10 | module Program = 11 | 12 | let untag program = 13 | { 14 | DeclGroups = 15 | program.DeclGroups 16 | |> List.map DeclGroup.untag 17 | Main = Expression.untag program.Main 18 | } 19 | 20 | let unparse program = 21 | let declGroups = 22 | program.DeclGroups 23 | |> List.map DeclGroup.unparse 24 | |> String.concat "" 25 | let main = Expression.unparse program.Main 26 | $"{declGroups}{main}" 27 | -------------------------------------------------------------------------------- /Assignment6/Readme.md: -------------------------------------------------------------------------------- 1 | [Assignment 6: Taipan: Checking and inferring types](https://course.ccs.neu.edu/cs4410sp21/hw_taipan_assignment.html) 2 | 3 | Relevant lectures and other material: 4 | 5 | * [Lecture 11: Type Checking](https://course.ccs.neu.edu/cs4410sp21/lec_type-checking_notes.html) 6 | * [Lecture 12: Type Inference](https://course.ccs.neu.edu/cs4410sp21/lec_type-inference_notes.html) 7 | * [Write You a Haskell](https://web.archive.org/web/20211218201109/http://dev.stephendiehl.com/fun/WYAH.pdf) - Internet Archive version, since the original website seems to be permanently offline. 8 | 9 | This is a **big** step up from Assignment 5. Type inference is quite difficult to get right, and the course materials have some gaps. Here are a few of the major issues I ran into: 10 | 11 | * The [type checking rules](https://course.ccs.neu.edu/cs4410sp21/lec_type-checking_notes.html#%28part._.Functions_and_function_calls%29) don't handle calls to polymorphic functions. For this, I had to use unification, as described in the type inference lecture. 12 | 13 | * The type inference "[occurs check](https://course.ccs.neu.edu/cs4410sp21/lec_type-inference_notes.html#%28part._.Unification%29)" should *not* prohibit unification of a type variable with itself. In other words, `'A` unifies with `'A`, even though "the variable we're trying to constrain appears within its constraint". 14 | 15 | * It doesn't make any sense to [instantiate a function's type scheme when inferring its type](https://course.ccs.neu.edu/cs4410sp21/lec_type-inference_notes.html#%28part._.Inference_and_.Generalization%29). Instead, I had to invent a different "`preinstantiate`" function at this step. Scheme instantiation happens later, when applying the function. 16 | 17 | * The comment in the following example is incorrect: 18 | 19 | ``` 20 | def ab_bool(a, b): # should have scheme Forall 'A, 'B, ('A, 'B -> Bool) 21 | isnum(f(a)) && f(b) 22 | ``` 23 | 24 | The correct scheme is `Forall 'A, ('A, Bool -> Bool)`, because parameter `b` must be a `Bool`. This wasn't a major mistake, but it confused me for a while. -------------------------------------------------------------------------------- /Assignment6/Scheme.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | /// Generalized type signature of a function. 4 | /// E.g. isnum has scheme: <'a>('a -> Bool) 5 | [] 6 | type Scheme<'tag> = 7 | { 8 | /// E.g. <'a, 'b>. 9 | TypeVariableIdents : List> 10 | 11 | /// E.g. ('a, 'b -> Bool). 12 | Type : Type<'tag> 13 | 14 | Tag : 'tag 15 | } 16 | 17 | with 18 | member scheme.UnparseTypeVariableIdents() = 19 | if scheme.TypeVariableIdents.IsEmpty then "" 20 | else 21 | scheme.TypeVariableIdents 22 | |> Seq.map (fun ident -> $"'{ident.Name}") 23 | |> String.concat ", " 24 | |> sprintf "<%s>" 25 | 26 | member scheme.Unparse() = 27 | let typeVars = scheme.UnparseTypeVariableIdents() 28 | $"{typeVars}{Type.unparse scheme.Type}" 29 | 30 | module Scheme = 31 | 32 | let untag scheme = 33 | { 34 | TypeVariableIdents = 35 | scheme.TypeVariableIdents 36 | |> List.map IdentifierDef.untag 37 | Type = Type.untag scheme.Type 38 | Tag = () 39 | } 40 | 41 | let unparse (scheme : Scheme<_>) = 42 | scheme.Unparse() 43 | -------------------------------------------------------------------------------- /Assignment6/SchemeEnvironment.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open CompilerDesign.Core 4 | open Substitution 5 | 6 | /// Maps primitive operations and declared function to their schemes. 7 | /// E.g. isbool : <'a>('a -> Bool) 8 | /// E.g. myIdentityFunction : <'a>('a -> 'a) 9 | type private SchemeEnvironment = 10 | Map> 11 | 12 | module SchemeEnvironment = 13 | 14 | let apply (subst : Substitution<_>) (env : SchemeEnvironment) = 15 | (env, subst) 16 | ||> List.fold (fun acc (fromIdent, toType) -> 17 | Map.map (fun _ typ -> 18 | Scheme.substitute fromIdent toType typ) acc) 19 | 20 | let initial : SchemeEnvironment = 21 | 22 | let prim1s = 23 | [ 24 | Add1, "(Int -> Int)" 25 | Sub1, "(Int -> Int)" 26 | Print, "<'a>('a -> 'a)" 27 | IsBool, "<'a>('a -> Bool)" 28 | IsNum, "<'a>('a -> Bool)" 29 | Not, "(Bool -> Bool)" 30 | ] |> List.map (fun (op, text) -> 31 | Prim1.unparse op, text) 32 | 33 | let prim2s = 34 | [ 35 | Plus, "(Int, Int -> Int)" 36 | Minus, "(Int, Int -> Int)" 37 | Times, "(Int, Int -> Int)" 38 | And, "(Bool, Bool -> Bool)" 39 | Or, "(Bool, Bool -> Bool)" 40 | Greater, "(Int, Int -> Bool)" 41 | GreaterEq, "(Int, Int -> Bool)" 42 | Less, "(Int, Int -> Bool)" 43 | LessEq, "(Int, Int -> Bool)" 44 | Eq, "<'a>('a, 'a -> Bool)" 45 | ] |> List.map (fun (op, text) -> 46 | Prim2.unparse op, text) 47 | 48 | prim1s @ prim2s 49 | |> Result.List.traverse (fun (name, text) -> 50 | result { 51 | let! scheme = Parser.Scheme.parse text 52 | return name, Scheme.untag scheme 53 | }) 54 | |> Result.get 55 | |> Map 56 | 57 | let tryAdd name scheme (env : SchemeEnvironment) = 58 | if Map.containsKey name env then 59 | Error $"Duplicate scheme name: {name}" 60 | else 61 | let env : SchemeEnvironment = Map.add name scheme env 62 | Ok env 63 | 64 | let private tryFind name (env : SchemeEnvironment) = 65 | env 66 | |> Map.tryFind name 67 | |> Option.map Result.Ok 68 | |> Option.defaultWith (fun () -> 69 | Result.Error $"Name not found: {name}") 70 | 71 | let tryFindIdent ident = 72 | tryFind ident.Name 73 | 74 | let tryFindPrim1 prim1 = 75 | tryFind (Prim1.unparse prim1) 76 | 77 | let tryFindPrim2 prim2 = 78 | tryFind (Prim2.unparse prim2) 79 | -------------------------------------------------------------------------------- /Assignment6/Substitution.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open CompilerDesign.Core 4 | 5 | /// Type variable substitution. 6 | /// E.g. ['x = Int; 'y = Bool -> Int; 'z = 'x]. 7 | type Substitution<'tag> = 8 | List * Type<'tag>> 9 | 10 | module Substitution = 11 | 12 | module Type = 13 | 14 | let substitute fromIdent toType inType = 15 | 16 | let rec loop = function 17 | | TypeVariable ident as tv -> 18 | if ident = fromIdent then toType 19 | else tv 20 | | TypeArrow def -> 21 | TypeArrow { 22 | InputTypes = List.map loop def.InputTypes 23 | OutputType = loop def.OutputType 24 | Tag = def.Tag 25 | } 26 | | typ -> typ 27 | 28 | loop inType 29 | 30 | let apply (subst : Substitution<_>) typ = 31 | (typ, subst) 32 | ||> List.fold (fun acc (fromIdent, toType) -> 33 | substitute fromIdent toType acc) 34 | 35 | let empty : Substitution<_> = List.empty 36 | 37 | let apply (subst : Substitution<_>) (inSubst : Substitution<_>) = 38 | (inSubst, subst) 39 | ||> List.fold (fun acc (fromIdent, toType) -> 40 | List.map (fun (ident, typ) -> 41 | let typ' = Type.substitute fromIdent toType typ 42 | ident, typ') acc) 43 | 44 | let compose (subst1 : Substitution<_>) subst2 : Substitution<_> = 45 | subst1 @ apply subst1 subst2 46 | 47 | let private occurs ident typ = 48 | typ 49 | |> Type.freeTypeVars 50 | |> Set.contains ident 51 | 52 | /// Finds a substitution that unifies the given types. 53 | let unify type1 type2 = 54 | 55 | let err type1 type2 = 56 | Error $"Could not unify {Type.unparse type1} \ 57 | and {Type.unparse type2}" 58 | 59 | let rec loop type1 type2 = 60 | result { 61 | match type1, type2 with 62 | 63 | | TypeBlank (), _ 64 | | _, TypeBlank () -> 65 | return! err type1 type2 66 | 67 | | TypeConstant ident1, TypeConstant ident2 68 | when ident1 = ident2 -> 69 | return empty 70 | 71 | | TypeVariable ident1, TypeVariable ident2 // avoid occurs check 72 | when ident1 = ident2 -> 73 | return empty 74 | 75 | | TypeVariable ident, _ 76 | when type2 |> occurs ident |> not -> 77 | return [ ident, type2 ] 78 | 79 | | _, TypeVariable ident 80 | when type1 |> occurs ident |> not -> 81 | return [ ident, type1 ] 82 | 83 | | TypeArrow def1, TypeArrow def2 84 | when def1.InputTypes.Length = def2.InputTypes.Length -> 85 | let pairs = 86 | let types1 = def1.InputTypes @ [def1.OutputType] 87 | let types2 = def2.InputTypes @ [def2.OutputType] 88 | List.zip types1 types2 89 | return! (empty, pairs) 90 | ||> Result.List.foldM (fun subst (t1, t2) -> 91 | result { 92 | let! subst' = 93 | loop 94 | (Type.apply subst t1) 95 | (Type.apply subst t2) 96 | return compose subst subst' 97 | }) 98 | 99 | | _ -> 100 | return! err type1 type2 101 | } 102 | 103 | loop 104 | (Type.untag type1) 105 | (Type.untag type2) 106 | 107 | module Scheme = 108 | 109 | let substitute fromIdent toType scheme = 110 | if List.contains fromIdent scheme.TypeVariableIdents then 111 | scheme 112 | else { 113 | scheme with 114 | Type = 115 | Type.substitute 116 | fromIdent 117 | toType 118 | scheme.Type 119 | } 120 | 121 | let apply (subst : Substitution<_>) scheme = 122 | (scheme, subst) 123 | ||> List.fold (fun acc (fromIdent, toType) -> 124 | substitute fromIdent toType acc) 125 | 126 | let rec freeTypeVars scheme = 127 | Set.difference 128 | (Type.freeTypeVars scheme.Type) 129 | (set scheme.TypeVariableIdents) 130 | 131 | module TypeEnvironment = 132 | 133 | let apply (subst : Substitution<_>) (env : TypeEnvironment) = 134 | (env, subst) 135 | ||> List.fold (fun acc (fromIdent, toType) -> 136 | Map.map (fun _ typ -> 137 | Type.substitute fromIdent toType typ) acc) 138 | 139 | module Expression = 140 | 141 | let rec apply (subst : Substitution<_>) = function 142 | | LetExpr def -> applyLet subst def 143 | | Prim1Expr def -> applyPrim1 subst def 144 | | Prim2Expr def -> applyPrim2 subst def 145 | | IfExpr def -> applyIf subst def 146 | | ApplicationExpr def -> applyApplication subst def 147 | | AnnotationExpr def -> applyAnnotation subst def 148 | | expr -> expr 149 | 150 | and private applyBinding subst (binding : Binding<_>) = 151 | { binding with 152 | Type = Type.apply subst binding.Type } 153 | 154 | and private applyLet subst def = 155 | let bindings = 156 | def.Bindings 157 | |> List.map (applyBinding subst) 158 | LetExpr { 159 | def with 160 | Bindings = bindings 161 | Expr = apply subst def.Expr } 162 | 163 | and private applyPrim1 subst def = 164 | let typeArgs = 165 | def.TypeArguments 166 | |> List.map (Type.apply subst) 167 | Prim1Expr { 168 | def with 169 | TypeArguments = typeArgs 170 | Expr = apply subst def.Expr } 171 | 172 | and private applyPrim2 subst def = 173 | let typeArgs = 174 | def.TypeArguments 175 | |> List.map (Type.apply subst) 176 | Prim2Expr { 177 | def with 178 | TypeArguments = typeArgs 179 | Left = apply subst def.Left 180 | Right = apply subst def.Right 181 | } 182 | 183 | and private applyIf subst def = 184 | IfExpr { 185 | def with 186 | Condition = apply subst def.Condition 187 | TrueBranch = apply subst def.TrueBranch 188 | FalseBranch = apply subst def.FalseBranch 189 | } 190 | 191 | and private applyApplication subst def = 192 | let typeArgs = 193 | def.TypeArguments 194 | |> List.map (Type.apply subst) 195 | let args = 196 | def.Arguments 197 | |> List.map (apply subst) 198 | ApplicationExpr { 199 | def with 200 | TypeArguments = typeArgs 201 | Arguments = args 202 | } 203 | 204 | and private applyAnnotation subst def = 205 | AnnotationExpr { 206 | def with 207 | Expr = apply subst def.Expr 208 | Type = Type.apply subst def.Type 209 | } 210 | -------------------------------------------------------------------------------- /Assignment6/Type.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | /// The type of a value or function. 4 | [] 5 | type Type<'tag> = 6 | 7 | /// No type specified. Will be inferred later. 8 | | TypeBlank of 'tag 9 | 10 | /// Type constant. E.g. "Int", "Bool". 11 | | TypeConstant of IdentifierDef<'tag> 12 | 13 | /// Type variable. E.g. "'a". 14 | | TypeVariable of IdentifierDef<'tag> 15 | 16 | /// Function type. E.g. "('a, Bool) -> Int". 17 | | TypeArrow of TypeArrowDef<'tag> 18 | 19 | with 20 | 21 | member typ.Unparse() = 22 | match typ with 23 | | TypeBlank _ -> "_" 24 | | TypeConstant def -> def.Name 25 | | TypeVariable def -> $"'{def.Name}" // apostrophe is implicit 26 | | TypeArrow def -> 27 | let inputs = 28 | if def.InputTypes.IsEmpty then 29 | "Unit" // no other way to represent a function with no inputs 30 | else 31 | def.InputTypes 32 | |> Seq.map (fun t -> t.Unparse()) 33 | |> String.concat ", " 34 | $"({inputs} -> {def.OutputType.Unparse()})" 35 | 36 | /// Function type. E.g. "('a, Bool) -> Int". 37 | and TypeArrowDef<'tag> = 38 | { 39 | InputTypes : List> 40 | OutputType : Type<'tag> 41 | Tag : 'tag 42 | } 43 | 44 | module Type = 45 | 46 | let rec untag = function 47 | | TypeBlank _ -> TypeBlank () 48 | | TypeConstant def -> TypeConstant (IdentifierDef.untag def) 49 | | TypeVariable def -> TypeVariable (IdentifierDef.untag def) 50 | | TypeArrow def -> 51 | TypeArrow { 52 | InputTypes = 53 | def.InputTypes |> List.map untag 54 | OutputType = untag def.OutputType 55 | Tag = () 56 | } 57 | 58 | let unparse (typ : Type<_>) = 59 | typ.Unparse() 60 | 61 | let rec freeTypeVars = function 62 | | TypeVariable ident -> Set.singleton ident 63 | | TypeArrow def -> 64 | List.fold (fun ftvs typ -> 65 | Set.union (freeTypeVars typ) ftvs) 66 | (freeTypeVars def.OutputType) 67 | def.InputTypes 68 | | _ -> Set.empty 69 | 70 | let int = TypeConstant (IdentifierDef.create "Int") 71 | let bool = TypeConstant (IdentifierDef.create "Bool") 72 | -------------------------------------------------------------------------------- /Assignment6/TypeCheck.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open CompilerDesign.Core 4 | 5 | module TypeCheck = 6 | 7 | module Type = 8 | 9 | let checkMissing typ = 10 | if typ = TypeBlank () then 11 | Error "Missing type" 12 | else Ok () 13 | 14 | let mismatch expected actual = 15 | Error 16 | $"Expected: {Type.unparse expected}, \ 17 | Actual: {Type.unparse actual}" 18 | 19 | module private rec Expression = 20 | 21 | let typeOf env expr = 22 | result { 23 | let! typ = 24 | match expr with 25 | | NumberExpr _ -> Ok Type.int 26 | | BoolExpr _ -> Ok Type.bool 27 | | LetExpr def -> typeOfLet env def 28 | | Prim1Expr def -> typeOfPrim1 env def 29 | | Prim2Expr def -> typeOfPrim2 env def 30 | | IfExpr def -> typeOfIf env def 31 | | IdentifierExpr def -> TypeEnvironment.tryFind def env 32 | | ApplicationExpr def -> typeOfApplication env def 33 | | AnnotationExpr def -> typeOfAnnotation env def 34 | do! Type.checkMissing typ 35 | return typ 36 | } 37 | 38 | let private typeOfLet env def = 39 | result { 40 | let! env' = 41 | (env, def.Bindings) 42 | ||> Result.List.foldM (fun acc binding -> 43 | result { 44 | do! Type.checkMissing binding.Type 45 | let! typeExpr = typeOf acc binding.Expr 46 | if binding.Type = typeExpr then 47 | return! TypeEnvironment.tryAdd 48 | binding.Identifier 49 | typeExpr 50 | acc 51 | else 52 | return! Type.mismatch binding.Type typeExpr 53 | }) 54 | return! typeOf env' def.Expr 55 | } 56 | 57 | let private typeOfPrim1 env def = 58 | result { 59 | let! actual = typeOf env def.Expr 60 | 61 | let check expected = 62 | result { 63 | if actual = expected then 64 | return actual 65 | else 66 | return! Type.mismatch expected actual 67 | } 68 | 69 | match def.Operator with 70 | | Add1 | Sub1 -> return! check Type.int 71 | | Not -> return! check Type.bool 72 | | IsBool | IsNum -> return Type.bool 73 | | Print -> return actual 74 | } 75 | 76 | let private typeOfPrim2 env def = 77 | result { 78 | let! typeLeft = typeOf env def.Left 79 | let! typeRight = typeOf env def.Right 80 | 81 | let check expected final = 82 | result { 83 | match typeLeft = expected, typeRight = expected with 84 | | true, true -> return final 85 | | false, _ -> return! Type.mismatch expected typeLeft 86 | | _, false -> return! Type.mismatch expected typeRight 87 | } 88 | 89 | match def.Operator with 90 | | Plus | Minus | Times -> return! check Type.int Type.int 91 | | And | Or -> return! check Type.bool Type.bool 92 | | Greater | GreaterEq 93 | | Less | LessEq -> return! check Type.int Type.bool 94 | | Eq -> 95 | if typeLeft = typeRight then 96 | return Type.bool 97 | else 98 | return! Type.mismatch typeLeft typeRight 99 | } 100 | 101 | let private typeOfIf env def = 102 | result { 103 | let! typeCond = typeOf env def.Condition 104 | let! typeTrue = typeOf env def.TrueBranch 105 | let! typeFalse = typeOf env def.FalseBranch 106 | 107 | if typeCond = Type.bool then 108 | if typeTrue = typeFalse then 109 | return typeTrue 110 | else 111 | return! Type.mismatch typeTrue typeFalse 112 | else 113 | return! Type.mismatch Type.bool typeCond 114 | } 115 | 116 | let private typeOfApplication env def = 117 | result { 118 | let! typeArrowDef = 119 | TypeEnvironment.tryFindFunc def.Identifier env 120 | if typeArrowDef.InputTypes.Length = def.Arguments.Length then 121 | let expected = TypeArrow typeArrowDef 122 | let! argTypes = 123 | def.Arguments 124 | |> Result.List.traverse (typeOf env) 125 | let actual = 126 | TypeArrow { 127 | InputTypes = argTypes 128 | OutputType = typeArrowDef.OutputType 129 | Tag = () 130 | } 131 | let! subst = 132 | Substitution.unify expected actual // needed to type check application of a polymorphic function 133 | return Substitution.Type.apply 134 | subst 135 | typeArrowDef.OutputType 136 | else 137 | return! Error $"Arity mismatch: \ 138 | expected {typeArrowDef.InputTypes.Length}, \ 139 | actual {def.Arguments.Length}" 140 | } 141 | 142 | let private typeOfAnnotation env def = 143 | result { 144 | do! Type.checkMissing def.Type 145 | let! typeExpr = typeOf env def.Expr 146 | if typeExpr = def.Type then 147 | return typeExpr 148 | else 149 | return! Type.mismatch def.Type typeExpr 150 | } 151 | 152 | module private Decl = 153 | 154 | let typeCheck env decl = 155 | result { 156 | let! typedParms, outputType = Decl.getSignature decl 157 | let! env' = 158 | (env, typedParms) 159 | ||> Result.List.foldM (fun acc (ident, typ) -> 160 | acc |> TypeEnvironment.tryAdd ident typ) 161 | let! bodyType = Expression.typeOf env' decl.Body 162 | 163 | if bodyType <> outputType then 164 | return! Type.mismatch outputType bodyType 165 | } 166 | 167 | module private DeclGroup = 168 | 169 | let typeCheck env group = 170 | result { 171 | let! env' = 172 | (env, group.Decls) 173 | ||> Result.List.foldM (fun env decl -> 174 | TypeEnvironment.tryAdd 175 | decl.Identifier 176 | decl.Scheme.Type 177 | env) 178 | for decl in group.Decls do 179 | do! Decl.typeCheck env' decl 180 | return env' 181 | } 182 | 183 | /// Answers the type returned by the main expression of the 184 | /// given function. 185 | let typeOf program = 186 | result { 187 | let program' = Program.untag program 188 | let! env = 189 | (TypeEnvironment.empty, program'.DeclGroups) 190 | ||> Result.List.foldM DeclGroup.typeCheck 191 | return! Expression.typeOf env program'.Main 192 | } 193 | 194 | /// Type-checks the given program. 195 | let validate program = 196 | result { 197 | let! _type = typeOf program 198 | return () 199 | } 200 | -------------------------------------------------------------------------------- /Assignment6/TypeEnvironment.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | /// Maps a value or function identifier to its type. 4 | /// E.g. x : Int 5 | /// E.g. f : Int -> Bool 6 | type TypeEnvironment = Map, Type> 7 | 8 | module TypeEnvironment = 9 | 10 | let empty : TypeEnvironment = Map.empty 11 | 12 | let tryAdd ident typ (env : TypeEnvironment) = 13 | if Map.containsKey ident env then 14 | Error $"Duplicate identifier: {ident.Name}" 15 | else 16 | let env : TypeEnvironment = Map.add ident typ env 17 | Ok env 18 | 19 | let tryFind ident (env : TypeEnvironment) = 20 | match Map.tryFind ident env with 21 | | Some typ -> Ok typ 22 | | None -> Error $"Unbound identifier: {ident.Name}" 23 | 24 | let tryFindFunc ident env = 25 | match tryFind ident env with 26 | | Ok (TypeArrow def) -> Ok def 27 | | Ok _ -> Error $"Not a function: {ident.Name}" 28 | | Error err -> Error err 29 | 30 | let freeTypeVars (env : TypeEnvironment) = 31 | env 32 | |> Map.values 33 | |> Seq.map Type.freeTypeVars 34 | |> Set.unionMany 35 | -------------------------------------------------------------------------------- /CompilerDesign.sln: -------------------------------------------------------------------------------- 1 |  2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 17 4 | VisualStudioVersion = 17.3.32929.385 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{96B42E0B-078E-4FC9-BD3C-9485D2D78711}" 7 | ProjectSection(SolutionItems) = preProject 8 | Readme.md = Readme.md 9 | EndProjectSection 10 | EndProject 11 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Assignment1", "Assignment1\Assignment1.fsproj", "{BFC1D80B-4116-48CB-91AF-A2BE4A70D7C4}" 12 | EndProject 13 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Assignment2", "Assignment2\Assignment2.fsproj", "{8CF0AD89-F58E-4B3D-916D-BF113DDD98B4}" 14 | EndProject 15 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "UnitTests", "UnitTests\UnitTests.fsproj", "{C4F05FC1-E80F-48CE-AA64-2C7002DB570F}" 16 | EndProject 17 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Assignment3", "Assignment3\Assignment3.fsproj", "{B3F42990-CF60-4F88-8C43-312C329F8EB4}" 18 | EndProject 19 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Core", "Core\Core.fsproj", "{9500A25B-F738-4CE7-96BB-C70C23C70EFD}" 20 | EndProject 21 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Assignment4", "Assignment4\Assignment4.fsproj", "{39BD6766-BB91-478D-957E-D45EB308F5AF}" 22 | EndProject 23 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Assignment5", "Assignment5\Assignment5.fsproj", "{9A7EA85E-6AC3-47F0-8BF6-6BA439567593}" 24 | EndProject 25 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Assignment6", "Assignment6\Assignment6.fsproj", "{E26E6D60-4416-4BAA-B0FF-9201BD561D95}" 26 | EndProject 27 | Global 28 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 29 | Debug|Any CPU = Debug|Any CPU 30 | Release|Any CPU = Release|Any CPU 31 | EndGlobalSection 32 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 33 | {BFC1D80B-4116-48CB-91AF-A2BE4A70D7C4}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 34 | {BFC1D80B-4116-48CB-91AF-A2BE4A70D7C4}.Debug|Any CPU.Build.0 = Debug|Any CPU 35 | {BFC1D80B-4116-48CB-91AF-A2BE4A70D7C4}.Release|Any CPU.ActiveCfg = Release|Any CPU 36 | {BFC1D80B-4116-48CB-91AF-A2BE4A70D7C4}.Release|Any CPU.Build.0 = Release|Any CPU 37 | {8CF0AD89-F58E-4B3D-916D-BF113DDD98B4}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 38 | {8CF0AD89-F58E-4B3D-916D-BF113DDD98B4}.Debug|Any CPU.Build.0 = Debug|Any CPU 39 | {8CF0AD89-F58E-4B3D-916D-BF113DDD98B4}.Release|Any CPU.ActiveCfg = Release|Any CPU 40 | {8CF0AD89-F58E-4B3D-916D-BF113DDD98B4}.Release|Any CPU.Build.0 = Release|Any CPU 41 | {C4F05FC1-E80F-48CE-AA64-2C7002DB570F}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 42 | {C4F05FC1-E80F-48CE-AA64-2C7002DB570F}.Debug|Any CPU.Build.0 = Debug|Any CPU 43 | {C4F05FC1-E80F-48CE-AA64-2C7002DB570F}.Release|Any CPU.ActiveCfg = Release|Any CPU 44 | {C4F05FC1-E80F-48CE-AA64-2C7002DB570F}.Release|Any CPU.Build.0 = Release|Any CPU 45 | {B3F42990-CF60-4F88-8C43-312C329F8EB4}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 46 | {B3F42990-CF60-4F88-8C43-312C329F8EB4}.Debug|Any CPU.Build.0 = Debug|Any CPU 47 | {B3F42990-CF60-4F88-8C43-312C329F8EB4}.Release|Any CPU.ActiveCfg = Release|Any CPU 48 | {B3F42990-CF60-4F88-8C43-312C329F8EB4}.Release|Any CPU.Build.0 = Release|Any CPU 49 | {9500A25B-F738-4CE7-96BB-C70C23C70EFD}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 50 | {9500A25B-F738-4CE7-96BB-C70C23C70EFD}.Debug|Any CPU.Build.0 = Debug|Any CPU 51 | {9500A25B-F738-4CE7-96BB-C70C23C70EFD}.Release|Any CPU.ActiveCfg = Release|Any CPU 52 | {9500A25B-F738-4CE7-96BB-C70C23C70EFD}.Release|Any CPU.Build.0 = Release|Any CPU 53 | {39BD6766-BB91-478D-957E-D45EB308F5AF}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 54 | {39BD6766-BB91-478D-957E-D45EB308F5AF}.Debug|Any CPU.Build.0 = Debug|Any CPU 55 | {39BD6766-BB91-478D-957E-D45EB308F5AF}.Release|Any CPU.ActiveCfg = Release|Any CPU 56 | {39BD6766-BB91-478D-957E-D45EB308F5AF}.Release|Any CPU.Build.0 = Release|Any CPU 57 | {9A7EA85E-6AC3-47F0-8BF6-6BA439567593}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 58 | {9A7EA85E-6AC3-47F0-8BF6-6BA439567593}.Debug|Any CPU.Build.0 = Debug|Any CPU 59 | {9A7EA85E-6AC3-47F0-8BF6-6BA439567593}.Release|Any CPU.ActiveCfg = Release|Any CPU 60 | {9A7EA85E-6AC3-47F0-8BF6-6BA439567593}.Release|Any CPU.Build.0 = Release|Any CPU 61 | {E26E6D60-4416-4BAA-B0FF-9201BD561D95}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 62 | {E26E6D60-4416-4BAA-B0FF-9201BD561D95}.Debug|Any CPU.Build.0 = Debug|Any CPU 63 | {E26E6D60-4416-4BAA-B0FF-9201BD561D95}.Release|Any CPU.ActiveCfg = Release|Any CPU 64 | {E26E6D60-4416-4BAA-B0FF-9201BD561D95}.Release|Any CPU.Build.0 = Release|Any CPU 65 | EndGlobalSection 66 | GlobalSection(SolutionProperties) = preSolution 67 | HideSolutionNode = FALSE 68 | EndGlobalSection 69 | GlobalSection(ExtensibilityGlobals) = postSolution 70 | SolutionGuid = {3469E2F1-FE2A-4D2A-91D8-4A6093A7453A} 71 | EndGlobalSection 72 | EndGlobal 73 | -------------------------------------------------------------------------------- /Core/App.runtimeconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "runtimeOptions": { 3 | "tfm": "net8.0", 4 | "framework": { 5 | "name": "Microsoft.NETCore.App", 6 | "version": "8.0.0" 7 | } 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /Core/CompilationUnit.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Core 2 | 3 | open Microsoft.CodeAnalysis.CSharp 4 | open type SyntaxFactory 5 | 6 | module private CompilationUnit = 7 | 8 | (* 9 | static T Print(T t) 10 | { 11 | System.Console.WriteLine(node); 12 | return t; 13 | } 14 | *) 15 | let private printMethod = 16 | MethodDeclaration( 17 | returnType = IdentifierName("T"), 18 | identifier = Identifier("Print")) 19 | .WithModifiers( 20 | TokenList( 21 | Token(SyntaxKind.StaticKeyword))) 22 | .WithTypeParameterList( 23 | TypeParameterList( 24 | SingletonSeparatedList( 25 | TypeParameter( 26 | Identifier("T"))))) 27 | .WithParameterList( 28 | ParameterList( 29 | SingletonSeparatedList( 30 | Parameter( 31 | Identifier("t")) 32 | .WithType( 33 | IdentifierName("T"))))) 34 | .WithBody( 35 | Block( 36 | ExpressionStatement( 37 | InvocationExpression( 38 | MemberAccessExpression( 39 | SyntaxKind.SimpleMemberAccessExpression, 40 | MemberAccessExpression( 41 | SyntaxKind.SimpleMemberAccessExpression, 42 | IdentifierName("System"), 43 | IdentifierName("Console")), 44 | IdentifierName("WriteLine"))) 45 | .WithArgumentList( 46 | ArgumentList( 47 | SingletonSeparatedList( 48 | Argument( 49 | IdentifierName("t")))))), 50 | ReturnStatement( 51 | IdentifierName("t")))) 52 | 53 | (* 54 | static void Main() 55 | { 56 | System.Console.Write($node); 57 | } 58 | *) 59 | /// our_code_starts_here 60 | let private mainMethod node = 61 | MethodDeclaration( 62 | returnType = 63 | PredefinedType( 64 | Token(SyntaxKind.VoidKeyword)), 65 | identifier = "Main") 66 | .AddModifiers( 67 | Token(SyntaxKind.StaticKeyword)) 68 | .WithBody( 69 | Block( 70 | ExpressionStatement( 71 | InvocationExpression( 72 | MemberAccessExpression( 73 | SyntaxKind.SimpleMemberAccessExpression, 74 | MemberAccessExpression( 75 | SyntaxKind.SimpleMemberAccessExpression, 76 | IdentifierName("System"), 77 | IdentifierName("Console")), 78 | IdentifierName("Write"))) 79 | .WithArgumentList( 80 | ArgumentList( 81 | SingletonSeparatedList( 82 | Argument(node))))))) 83 | 84 | let create assemblyName memberNodes mainNode = 85 | let classNode = 86 | ClassDeclaration($"{assemblyName}Type") 87 | .AddModifiers( 88 | Token(SyntaxKind.StaticKeyword)) 89 | .AddMembers(memberNodes) 90 | .AddMembers( 91 | printMethod, 92 | mainMethod mainNode) 93 | let namespaceNode = 94 | NamespaceDeclaration( 95 | IdentifierName(assemblyName : string)) 96 | .AddMembers(classNode) 97 | let compilationUnit = 98 | CompilationUnit().AddMembers(namespaceNode) 99 | let mainTypeName = 100 | $"{namespaceNode.Name}.{classNode.Identifier}" 101 | compilationUnit, mainTypeName 102 | -------------------------------------------------------------------------------- /Core/Compiler.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Core 2 | 3 | open System.IO 4 | open System.Reflection 5 | 6 | open Microsoft.CodeAnalysis 7 | open Microsoft.CodeAnalysis.CSharp 8 | 9 | open Basic.Reference.Assemblies 10 | 11 | module Compiler = 12 | 13 | let compileWithMembers assemblyName mainNode memberNodes = 14 | 15 | let emitResult = 16 | 17 | let compilationUnit, mainTypeName = 18 | CompilationUnit.create assemblyName memberNodes mainNode 19 | #if DEBUG 20 | printfn "%A" <| compilationUnit.NormalizeWhitespace() 21 | #endif 22 | let compilation = 23 | let options = 24 | CSharpCompilationOptions(OutputKind.ConsoleApplication) 25 | .WithMainTypeName(mainTypeName) 26 | CSharpCompilation 27 | .Create(assemblyName) 28 | .WithReferences( 29 | Net80.References.SystemRuntime, 30 | Net80.References.SystemConsole) 31 | .AddSyntaxTrees(compilationUnit.SyntaxTree) 32 | .WithOptions(options) 33 | compilation.Emit($"{assemblyName}.dll") 34 | 35 | result { 36 | if emitResult.Success then 37 | let sourcePath = 38 | Path.Combine( 39 | Path.GetDirectoryName( 40 | Assembly.GetExecutingAssembly().Location), 41 | "App.runtimeconfig.json") 42 | File.Copy( 43 | sourcePath, 44 | $"{assemblyName}.runtimeconfig.json", 45 | overwrite = true) 46 | else 47 | return! emitResult.Diagnostics 48 | |> Seq.map string 49 | |> CompilerResult.ofErrors 50 | } 51 | 52 | /// Helper function corresponding to compile_prog in Lecture 3. 53 | /// https://course.ccs.neu.edu/cs4410sp21/lec_let-and-stack_notes.html 54 | let compile_prog assemblyName mainNode = 55 | compileWithMembers assemblyName mainNode Array.empty 56 | -------------------------------------------------------------------------------- /Core/Core.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net8.0 5 | true 6 | 7 | 8 | 9 | 10 | PreserveNewest 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /Core/Env.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Core 2 | 3 | open Microsoft.CodeAnalysis.CSharp 4 | 5 | /// Variable environment. 6 | type env = Map 7 | 8 | module Env = 9 | 10 | let empty : env = 11 | Map.empty 12 | 13 | let tryAdd name node (env : env) = 14 | if Map.containsKey name env then 15 | Error $"Variable already exists: {name}" 16 | else 17 | let env : env = Map.add name node env 18 | Ok env 19 | 20 | let tryFind name (env : env) = 21 | match Map.tryFind name env with 22 | | Some node -> Ok node 23 | | None -> Error $"Unbound identifier: {name}" 24 | -------------------------------------------------------------------------------- /Core/Result.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Core 2 | 3 | open System 4 | 5 | type ResultBuilder() = 6 | member _.Return(x) = Ok x 7 | member _.ReturnFrom(res : Result<_, _>) = res 8 | member _.Bind(res, f) = Result.bind f res 9 | member _.Zero() = Ok () 10 | member _.Combine(res, f) = Result.bind f res 11 | member _.Delay(f : unit -> Result<_, _>) = f 12 | member _.Run(f : unit -> Result<_, _>) = f () 13 | 14 | member this.While(guard, body) = 15 | if not (guard()) 16 | then this.Zero() 17 | else this.Bind(body (), fun () -> 18 | this.While(guard, body)) 19 | 20 | member this.TryWith(body, handler) = 21 | try this.ReturnFrom(body ()) 22 | with e -> handler e 23 | 24 | member this.TryFinally(body, compensation) = 25 | try this.ReturnFrom(body ()) 26 | finally compensation() 27 | 28 | member this.Using(disposable : #IDisposable, body) = 29 | let body' = fun () -> body disposable 30 | this.TryFinally(body', fun () -> 31 | match disposable with 32 | | null -> () 33 | | disp -> disp.Dispose()) 34 | 35 | member this.For(sequence : seq<_>, body) = 36 | this.Using( 37 | sequence.GetEnumerator(), 38 | fun enum -> 39 | this.While(enum.MoveNext, 40 | this.Delay(fun () -> body enum.Current))) 41 | 42 | [] 43 | module ResultBuilder = 44 | 45 | /// Monadic result builder. 46 | let result = ResultBuilder() 47 | 48 | module Result = 49 | 50 | let get = function 51 | | Ok x -> x 52 | | Error err -> failwith (string err) 53 | 54 | module List = 55 | 56 | // https://stackoverflow.com/a/53029378/344223 57 | let traverse f items = 58 | let folder head tail = 59 | result { 60 | let! h = f head 61 | let! t = tail 62 | return h :: t 63 | } 64 | let empty = result { return List.empty } 65 | List.foldBack folder items empty 66 | 67 | let sequence items = 68 | traverse id items 69 | 70 | // https://hoogle.haskell.org/?hoogle=foldM 71 | let foldM f state items = 72 | 73 | let rec loop state = function 74 | | item :: tail -> 75 | result { 76 | let! state' = f state item 77 | return! loop state' tail 78 | } 79 | | [] -> Ok state 80 | 81 | loop state items 82 | 83 | /// Standard return type for compiler results. (This is 84 | /// preferable to throwing exceptions.) 85 | type CompilerResult<'a> = Result<'a, string> 86 | 87 | [] 88 | module CompilerResult = 89 | 90 | let ofErrors msgs = 91 | msgs 92 | |> String.concat "\n" 93 | |> Error 94 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | ## Northeastern University [CS 4410/6410: Compiler Design](https://course.ccs.neu.edu/cs4410sp21/) 2 | 3 | Assignments are implemented in F#, and the compiler targets .NET (rather than x64 assembly). This allows me to skip over the back-end details that aren't relevant to .NET/Roslyn. 4 | 5 | I've linked to the 2021 version of the course, because it includes the [type inference assignment](https://course.ccs.neu.edu/cs4410sp21/hw_taipan_assignment.html), which is my end goal. (This assignment was skipped in the 2022 version of the course, for some reason.) 6 | -------------------------------------------------------------------------------- /UnitTests/Assignment1/ArithTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment1 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open CompilerDesign.UnitTesting 5 | 6 | /// Question 2. 7 | [] 8 | type ArithTests() = 9 | 10 | [] 11 | member _.``3 * (4 + 5)``() = 12 | let arith = Times(Num 3, Plus(Num 4, Num 5)) 13 | Assert.AreEqual( 14 | "(3 * (4 + 5))", 15 | Arith.pretty arith Env.empty) 16 | Assert.AreEqual( 17 | 27, 18 | Arith.evaluate arith Env.empty) 19 | 20 | [] 21 | member _.``(3 * 4) + 5``() = 22 | let arith = Plus(Times(Num 3, Num 4), Num 5) 23 | Assert.AreEqual( 24 | "((3 * 4) + 5)", 25 | Arith.pretty arith Env.empty) 26 | Assert.AreEqual( 27 | 17, 28 | Arith.evaluate arith Env.empty) 29 | 30 | [] 31 | member _.``x + 1``() = 32 | let env = Env.add Env.empty "x" 2 33 | let arith = Plus(Variable "x", Num 1) 34 | Assert.AreEqual( 35 | "(x + 1)", 36 | Arith.pretty arith env) 37 | Assert.AreEqual( 38 | 3, 39 | Arith.evaluate arith env) 40 | 41 | [] 42 | member _.``Invalid``() = 43 | let env = Env.empty // x is not defined 44 | let arith = Plus(Variable "x", Num 1) 45 | Assert.AreEqual( 46 | "(x + 1)", 47 | Arith.pretty arith env) 48 | Assert.ThrowsException(fun () -> 49 | Arith.evaluate arith env) 50 | |> ignore 51 | -------------------------------------------------------------------------------- /UnitTests/Assignment1/SExpTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment1 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open CompilerDesign.UnitTesting 5 | 6 | /// Question 6. 7 | [] 8 | type SExpTests() = 9 | 10 | [] 11 | member _.``(a b)``() = 12 | let expected = 13 | Ok [ 14 | Nest ( 15 | [ 16 | Sym ("a", (0, 1, 0, 2)) 17 | Sym ("b", (0, 3, 0, 4)) 18 | ], 19 | (0, 0, 0, 5)) 20 | ] 21 | let actual = SExp.parse "(a b)" 22 | Assert.AreEqual(expected, actual) 23 | 24 | [] 25 | member _.``(a (b true) 3)``() = 26 | let expected = 27 | Ok [ 28 | Nest ( 29 | [ 30 | Sym ("a", (0, 1, 0, 2)) 31 | Nest ( 32 | [ 33 | Sym ("b", (0, 4, 0, 5)) 34 | Bool (true, (0, 6, 0, 10)) 35 | ], 36 | (0, 3, 0, 11)) 37 | Int (3, (0, 12, 0, 13)) 38 | ], 39 | (0, 0, 0, 14)) 40 | ] 41 | let actual = SExp.parse "(a (b true) 3)" 42 | Assert.AreEqual(expected, actual) 43 | 44 | [] 45 | member _.``(a``() = 46 | let expected = Error "Unmatched left paren at line 0, col 0" 47 | let actual = SExp.parse "(a" 48 | Assert.AreEqual(expected, actual) 49 | 50 | [] 51 | member _.``(a (b c``() = 52 | let expected = Error "Unmatched left paren at line 0, col 3" 53 | let actual = SExp.parse "(a (b c" 54 | Assert.AreEqual(expected, actual) 55 | 56 | [] 57 | member _.``()``() = 58 | let expected = 59 | Ok [ 60 | Nest ( 61 | List.empty, 62 | (0, 0, 0, 2)) 63 | ] 64 | let actual = SExp.parse "()" 65 | Assert.AreEqual(expected, actual) 66 | -------------------------------------------------------------------------------- /UnitTests/Assignment1/TokTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment1 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open CompilerDesign.UnitTesting 5 | 6 | [] 7 | type TokTests() = 8 | 9 | [] 10 | member _.``(a b)``() = 11 | let expected = 12 | [ 13 | LPAREN (0, 0, 0, 1) 14 | TSym ("a", (0, 1, 0, 2)) 15 | TSym ("b", (0, 3, 0, 4)) 16 | RPAREN (0, 4, 0, 5) 17 | ] 18 | let actual = Tok.tokenize "(a b)" 19 | Assert.AreEqual(expected, actual) 20 | -------------------------------------------------------------------------------- /UnitTests/Assignment2/AdderTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment2 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | 5 | open CompilerDesign.Core 6 | open CompilerDesign.UnitTesting 7 | 8 | [] 9 | type AdderTests() = 10 | 11 | let run text = 12 | let assemblyName = "Adder" 13 | result { 14 | do! Compiler.compile assemblyName text 15 | return! Process.run assemblyName 16 | } 17 | 18 | [] 19 | member _.``5``() = 20 | Assert.AreEqual(Ok "5", run "5") 21 | 22 | [] 23 | member _.``(sub1 (add1 (sub1 5)))``() = 24 | Assert.AreEqual( 25 | Ok "4", 26 | run "(sub1 (add1 (sub1 5)))") 27 | 28 | [] 29 | member _.``(let ((x 5)) (add1 x))``() = 30 | let text = 31 | """ 32 | (let ((x 5)) 33 | (add1 x)) 34 | """ 35 | Assert.AreEqual(Ok "6", run text) 36 | 37 | [] 38 | member _.``(let ((x 5) (y (sub1 x))) (sub1 y))``() = 39 | let text = 40 | """ 41 | (let ((x 5) 42 | (y (sub1 x))) 43 | (sub1 y)) 44 | """ 45 | Assert.AreEqual(Ok "3", run text) 46 | 47 | [] 48 | member _.DuplicateBinding() = 49 | let text = 50 | """ 51 | (let ((x 5) 52 | (x (sub1 x))) 53 | (sub1 x)) 54 | """ 55 | Assert.AreEqual( 56 | Error "Variable already exists: x", 57 | run text) 58 | 59 | [] 60 | member _.UnboundIdentifier() = 61 | let text = 62 | """ 63 | (let ((x 5)) 64 | (add1 y)) 65 | """ 66 | Assert.AreEqual( 67 | Error "Unbound identifier: y", 68 | run text) 69 | -------------------------------------------------------------------------------- /UnitTests/Assignment3/BoaTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment3 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | 5 | open CompilerDesign.Core 6 | open CompilerDesign.UnitTesting 7 | 8 | [] 9 | type BoaTests() = 10 | 11 | let run text = 12 | let assemblyName = "Boa" 13 | result { 14 | do! Compiler.compile assemblyName text 15 | return! Process.run assemblyName 16 | } 17 | 18 | [] 19 | member _.SumOfSquares() = 20 | let text = 21 | """ 22 | let a = 3, b = 4 in 23 | let asq = a * a, bsq = b * b in 24 | if a : asq + bsq 25 | else: add1(a) 26 | """ 27 | Assert.AreEqual(Ok "25", run text) 28 | -------------------------------------------------------------------------------- /UnitTests/Assignment3/FuzzTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment3 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open FsCheck 5 | 6 | module Generator = 7 | 8 | let from<'t> = Arb.from<'t>.Generator // is there a better way to get this? 9 | 10 | type Identifier = 11 | Ident of string 12 | with 13 | member this.Get = 14 | let (Ident str) = this 15 | str 16 | 17 | module Identifier = 18 | 19 | let arb = 20 | Gen.elements ['a' .. 'z'] 21 | |> Gen.map string 22 | |> Arb.fromGen 23 | 24 | module LetDef = 25 | 26 | let arb = 27 | gen { 28 | let! bindings = 29 | Generator.from> 30 | let! expr = 31 | Generator.from> 32 | return { 33 | Bindings = Seq.toList bindings.Get 34 | Expr = expr 35 | Tag = () 36 | } 37 | } |> Arb.fromGen 38 | 39 | module NumberDef = 40 | 41 | let arb = 42 | Generator.from 43 | |> Gen.map (fun n -> 44 | { 45 | Number = n 46 | Tag = () 47 | }) 48 | |> Arb.fromGen 49 | 50 | module IdentifierDef = 51 | 52 | let arb = 53 | Generator.from 54 | |> Gen.map (fun ident -> 55 | { 56 | Identifier = ident.Get 57 | Tag = () 58 | }) 59 | |> Arb.fromGen 60 | 61 | type Arbitraries = 62 | static member LetDef() = LetDef.arb 63 | static member NumberDef() = NumberDef.arb 64 | static member IdentifierDef() = IdentifierDef.arb 65 | static member Identifier() = Identifier.arb 66 | 67 | [] 68 | type FuzzTests() = 69 | 70 | let rec untag = function 71 | | LetExpr def -> 72 | LetExpr { 73 | Bindings = 74 | def.Bindings 75 | |> List.map (fun binding -> 76 | { 77 | Identifier = binding.Identifier 78 | Expr = untag binding.Expr 79 | Tag = () 80 | }) 81 | Expr = untag def.Expr 82 | Tag = () 83 | } 84 | | Prim1Expr def -> 85 | Prim1Expr { 86 | Operator = def.Operator 87 | Expr = untag def.Expr 88 | Tag = () 89 | } 90 | | Prim2Expr def -> 91 | Prim2Expr { 92 | Operator = def.Operator 93 | Left = untag def.Left 94 | Right = untag def.Right 95 | Tag = () 96 | } 97 | | IfExpr def -> 98 | IfExpr { 99 | Condition = untag def.Condition 100 | TrueBranch = untag def.TrueBranch 101 | FalseBranch = untag def.FalseBranch 102 | Tag = () 103 | } 104 | | NumberExpr def -> 105 | NumberExpr { 106 | Number = def.Number 107 | Tag = () 108 | } 109 | | IdentifierExpr def -> 110 | IdentifierExpr { 111 | Identifier = def.Identifier 112 | Tag = () 113 | } 114 | 115 | let config = 116 | { Config.QuickThrowOnFailure with 117 | Arbitrary = [ typeof ] 118 | MaxTest = 1000 119 | Replay = Some (Random.StdGen (0, 0)) } 120 | 121 | [] 122 | member _.ParseUnparseIsOriginal() = 123 | 124 | let parseUnparseIsOriginal expr = 125 | let unparsed = Expr.unparse expr 126 | let reparsed = 127 | Parser.parse unparsed 128 | |> Result.map untag 129 | reparsed = Ok expr |@ unparsed 130 | 131 | Check.One(config, parseUnparseIsOriginal) 132 | -------------------------------------------------------------------------------- /UnitTests/Assignment4/CobraTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment4 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | 5 | open CompilerDesign.Core 6 | open CompilerDesign.UnitTesting 7 | 8 | [] 9 | type CobraTests() = 10 | 11 | let run text = 12 | let assemblyName = "Cobra" 13 | result { 14 | do! Compiler.compile assemblyName text 15 | return! Process.run assemblyName 16 | } 17 | 18 | [] 19 | member _.SumOfSquares() = 20 | let text = 21 | """ 22 | let a = 3, b = 4 in 23 | let asq = a * a, bsq = b * b in 24 | if a < b : asq + bsq 25 | else: add1(a) 26 | """ 27 | Assert.AreEqual(Ok "25", run text) 28 | 29 | [] 30 | member _.Print() = 31 | let text = 32 | """ 33 | let x = 1 in 34 | let y = print(x + 1) in 35 | print(y + 2) 36 | """ 37 | Assert.AreEqual(Ok "2\n4\n4", run text) 38 | 39 | [] 40 | member _.IfPrint() = 41 | let text = 42 | """ 43 | if true : print(100) else: print(99) 44 | """ 45 | Assert.AreEqual(Ok "100\n100", run text) 46 | 47 | [] 48 | member _.WontRun() = 49 | let text = 50 | """ 51 | if true > 0 : print(100) else: print(false) 52 | """ 53 | match run text with 54 | | Error msg -> 55 | Assert.IsTrue( 56 | msg.Contains( 57 | "Operator '>' cannot be applied to operands of type 'bool' and 'int'")) 58 | | _ -> Assert.Fail() 59 | -------------------------------------------------------------------------------- /UnitTests/Assignment4/FuzzTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment4 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open FsCheck 5 | 6 | module Generator = 7 | 8 | let from<'t> = Arb.from<'t>.Generator // is there a better way to get this? 9 | 10 | type Identifier = 11 | Ident of string 12 | with 13 | member this.Get = 14 | let (Ident str) = this 15 | str 16 | 17 | module Identifier = 18 | 19 | let arb = 20 | Gen.elements ['a' .. 'z'] 21 | |> Gen.map string 22 | |> Arb.fromGen 23 | 24 | module LetDef = 25 | 26 | let arb = 27 | gen { 28 | let! bindings = 29 | Generator.from> 30 | let! expr = 31 | Generator.from> 32 | return { 33 | Bindings = Seq.toList bindings.Get 34 | Expr = expr 35 | Tag = () 36 | } 37 | } |> Arb.fromGen 38 | 39 | module NumberDef = 40 | 41 | let arb = 42 | Generator.from 43 | |> Gen.map (fun n -> 44 | { 45 | Number = n 46 | Tag = () 47 | }) 48 | |> Arb.fromGen 49 | 50 | module IdentifierDef = 51 | 52 | let arb = 53 | Generator.from 54 | |> Gen.map (fun ident -> 55 | { 56 | Identifier = ident.Get 57 | Tag = () 58 | }) 59 | |> Arb.fromGen 60 | 61 | type Arbitraries = 62 | static member LetDef() = LetDef.arb 63 | static member NumberDef() = NumberDef.arb 64 | static member IdentifierDef() = IdentifierDef.arb 65 | static member Identifier() = Identifier.arb 66 | 67 | [] 68 | type FuzzTests() = 69 | 70 | let rec untag = function 71 | | LetExpr def -> 72 | LetExpr { 73 | Bindings = 74 | def.Bindings 75 | |> List.map (fun binding -> 76 | { 77 | Identifier = binding.Identifier 78 | Expr = untag binding.Expr 79 | Tag = () 80 | }) 81 | Expr = untag def.Expr 82 | Tag = () 83 | } 84 | | Prim1Expr def -> 85 | Prim1Expr { 86 | Operator = def.Operator 87 | Expr = untag def.Expr 88 | Tag = () 89 | } 90 | | Prim2Expr def -> 91 | Prim2Expr { 92 | Operator = def.Operator 93 | Left = untag def.Left 94 | Right = untag def.Right 95 | Tag = () 96 | } 97 | | IfExpr def -> 98 | IfExpr { 99 | Condition = untag def.Condition 100 | TrueBranch = untag def.TrueBranch 101 | FalseBranch = untag def.FalseBranch 102 | Tag = () 103 | } 104 | | NumberExpr def -> 105 | NumberExpr { 106 | Number = def.Number 107 | Tag = () 108 | } 109 | | IdentifierExpr def -> 110 | IdentifierExpr { 111 | Identifier = def.Identifier 112 | Tag = () 113 | } 114 | | BoolExpr def -> 115 | BoolExpr { 116 | Flag = def.Flag 117 | Tag = () 118 | } 119 | 120 | let config = 121 | { Config.QuickThrowOnFailure with 122 | Arbitrary = [ typeof ] 123 | MaxTest = 1000 124 | Replay = Some (Random.StdGen (0, 0)) } 125 | 126 | [] 127 | member _.ParseUnparseIsOriginal() = 128 | 129 | let parseUnparseIsOriginal expr = 130 | let unparsed = Expr.unparse expr 131 | let reparsed = 132 | Parser.parse unparsed 133 | |> Result.map untag 134 | reparsed = Ok expr |@ unparsed 135 | 136 | Check.One(config, parseUnparseIsOriginal) 137 | -------------------------------------------------------------------------------- /UnitTests/Assignment5/DiamondbackTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment5 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | 5 | open CompilerDesign.Core 6 | open CompilerDesign.UnitTesting 7 | 8 | [] 9 | type DiamondbackTests() = 10 | 11 | let run text = 12 | let assemblyName = "Diamondback" 13 | result { 14 | do! Compiler.compile assemblyName text 15 | return! Process.run assemblyName 16 | } 17 | 18 | [] 19 | member _.Comment() = 20 | let text = "1 # comment" 21 | Assert.AreEqual(Ok "1", run text) 22 | 23 | [] 24 | member _.Factorial() = 25 | let text = 26 | """ 27 | # recursive factorial function 28 | def factorial(n): 29 | if n <= 0: 1 30 | else: n * factorial(n-1) 31 | 32 | factorial(6) 33 | """ 34 | Assert.AreEqual(Ok "720", run text) 35 | 36 | [] 37 | member _.Arity() = 38 | let text = 39 | """ 40 | def f(x, y): x + y 41 | f(0) 42 | """ 43 | Assert.AreEqual( 44 | Error "Arity mismatch: expected 2, actual 1", 45 | run text) 46 | 47 | [] 48 | member _.UnboundFun() = 49 | let text = "f(0)" 50 | Assert.AreEqual( 51 | Error "Function not found: f", 52 | run text) 53 | 54 | [] 55 | member _.UnboundId() = 56 | let text = "a" 57 | Assert.AreEqual( 58 | Error "Unbound identifier: a", 59 | run text) 60 | 61 | [] 62 | member _.DuplicateIdLet() = 63 | let text = "let x=0, x=true in x" 64 | Assert.AreEqual( 65 | Error "Variable already exists: x", 66 | run text) 67 | 68 | [] 69 | member _.DuplicateIdDecl() = 70 | let text = "def f(x, x): x 0" 71 | Assert.AreEqual( 72 | Error "Variable already exists: x", 73 | run text) 74 | 75 | [] 76 | member _.DuplicateFun() = 77 | let text = 78 | """ 79 | def f(x): 0 80 | def f(x): 1 81 | f(0) 82 | """ 83 | Assert.AreEqual( 84 | Error "Function already exists: f", 85 | run text) 86 | -------------------------------------------------------------------------------- /UnitTests/Assignment5/FuzzTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment5 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open FsCheck 5 | 6 | module Generator = 7 | 8 | let from<'t> = Arb.from<'t>.Generator // is there a better way to get this? 9 | 10 | module IdentifierDef = 11 | 12 | let arb = 13 | Gen.elements ['a' .. 'z'] 14 | |> Gen.map (fun c -> 15 | { 16 | Name = string c 17 | Tag = () 18 | }) 19 | |> Arb.fromGen 20 | 21 | module LetDef = 22 | 23 | let arb = 24 | gen { 25 | let! bindings = 26 | Generator.from> 27 | let! expr = 28 | Generator.from> 29 | return { 30 | Bindings = Seq.toList bindings.Get 31 | Expr = expr 32 | Tag = () 33 | } 34 | } |> Arb.fromGen 35 | 36 | module NumberDef = 37 | 38 | let arb = 39 | Generator.from 40 | |> Gen.map (fun n -> 41 | { 42 | Number = n 43 | Tag = () 44 | }) 45 | |> Arb.fromGen 46 | 47 | type Arbitraries = 48 | static member LetDef() = LetDef.arb 49 | static member NumberDef() = NumberDef.arb 50 | static member IdentifierDef() = IdentifierDef.arb 51 | 52 | [] 53 | type FuzzTests() = 54 | 55 | let untagIdent (ident : IdentifierDef<_>) = 56 | { 57 | Name = ident.Name 58 | Tag = () 59 | } 60 | 61 | let rec untagExpr = function 62 | | LetExpr def-> 63 | LetExpr { 64 | Bindings = 65 | def.Bindings 66 | |> List.map (fun binding -> 67 | { 68 | Identifier = untagIdent binding.Identifier 69 | Expr = untagExpr binding.Expr 70 | }) 71 | Expr = untagExpr def.Expr 72 | Tag = () 73 | } 74 | | Prim1Expr def -> 75 | Prim1Expr { 76 | Operator = def.Operator 77 | Expr = untagExpr def.Expr 78 | Tag = () 79 | } 80 | | Prim2Expr def -> 81 | Prim2Expr { 82 | Operator = def.Operator 83 | Left = untagExpr def.Left 84 | Right = untagExpr def.Right 85 | Tag = () 86 | } 87 | | IfExpr def -> 88 | IfExpr { 89 | Condition = untagExpr def.Condition 90 | TrueBranch = untagExpr def.TrueBranch 91 | FalseBranch = untagExpr def.FalseBranch 92 | Tag = () 93 | } 94 | | NumberExpr def -> 95 | NumberExpr { 96 | Number = def.Number 97 | Tag = () 98 | } 99 | | IdentifierExpr def -> 100 | IdentifierExpr { 101 | Name = def.Name 102 | Tag = () 103 | } 104 | | BoolExpr def -> 105 | BoolExpr { 106 | Flag = def.Flag 107 | Tag = () 108 | } 109 | | ApplicationExpr def -> 110 | ApplicationExpr { 111 | Identifier = untagIdent def.Identifier 112 | Arguments = List.map untagExpr def.Arguments 113 | Tag = () 114 | } 115 | 116 | let untagDecl (decl : Decl<_>) = 117 | { 118 | Identifier = 119 | { 120 | Name = decl.Identifier.Name 121 | Tag = () 122 | } 123 | Parameters = 124 | decl.Parameters 125 | |> List.map untagIdent 126 | Body = untagExpr decl.Body 127 | } 128 | 129 | let untagProgram program = 130 | { 131 | Declarations = 132 | program.Declarations 133 | |> List.map untagDecl 134 | Main = untagExpr program.Main 135 | } 136 | 137 | let config = 138 | { Config.QuickThrowOnFailure with 139 | Arbitrary = [ typeof ] 140 | MaxTest = 1000 141 | Replay = Some (Random.StdGen (0, 0)) } 142 | 143 | [] 144 | member _.ParseUnparseIsOriginal() = 145 | 146 | let parseUnparseIsOriginal program = 147 | let unparsed = Program.unparse program 148 | let reparsed = 149 | Parser.parse unparsed 150 | |> Result.map untagProgram 151 | let msg = sprintf "Text: %s\nResult: %A" unparsed reparsed 152 | reparsed = Ok program |@ msg 153 | 154 | Check.One(config, parseUnparseIsOriginal) 155 | -------------------------------------------------------------------------------- /UnitTests/Assignment6/FuzzTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open FsCheck 5 | 6 | module Generator = 7 | 8 | let from<'t> = Arb.from<'t>.Generator // is there a better way to get this? 9 | 10 | module IdentifierDef = 11 | 12 | let arb = 13 | Gen.elements ['a' .. 'z'] // limit to single character names for simplicity 14 | |> Gen.map (string >> IdentifierDef.create) 15 | |> Arb.fromGen 16 | 17 | module LetDef = 18 | 19 | let arb = 20 | gen { 21 | let! bindings = 22 | Generator.from> // ensure there is at least one binding 23 | let! expr = 24 | Generator.from> 25 | return { 26 | Bindings = Seq.toList bindings.Get 27 | Expr = expr 28 | Tag = () 29 | } 30 | } |> Arb.fromGen 31 | 32 | module TypeArrowDef = 33 | 34 | let arb = 35 | gen { 36 | let! inputs = 37 | Generator.from> // ensure there is at least one input type 38 | let! output = 39 | Generator.from> 40 | return { 41 | InputTypes = Seq.toList inputs.Get 42 | OutputType = output 43 | Tag = () 44 | } 45 | } |> Arb.fromGen 46 | 47 | module Type = 48 | 49 | let arb = 50 | gen { 51 | match! Gen.choose (1, 4) with 52 | | 1 -> return TypeBlank () 53 | | 2 -> 54 | return! Gen.elements [ // choose from actual type constants 55 | Type.int 56 | Type.bool 57 | ] 58 | | 3 -> 59 | let! ident = Generator.from> 60 | return TypeVariable ident 61 | | 4 -> 62 | let! def = Generator.from> 63 | return TypeArrow def 64 | | _ -> return failwith "Unexpected" 65 | } |> Arb.fromGen 66 | 67 | module Decl = 68 | 69 | let arb = 70 | gen { 71 | let! ident = Generator.from> 72 | let! parmPairs = 73 | Generator.from * Type<_>>> // ensure # of parameters = # of input types 74 | let parms, parmTypes = List.unzip parmPairs 75 | let! tvIdents = Generator.from>> 76 | let! outType = 77 | Generator.from> 78 | let! body = Generator.from> 79 | 80 | return { 81 | Identifier = ident 82 | Parameters = parms 83 | Scheme = 84 | { 85 | TypeVariableIdents = tvIdents 86 | Type = 87 | TypeArrow { 88 | InputTypes = parmTypes 89 | OutputType = outType 90 | Tag = () 91 | } 92 | Tag = () 93 | } 94 | Body = body 95 | } 96 | } |> Arb.fromGen 97 | 98 | module DeclGroup = 99 | 100 | let arb = 101 | gen { 102 | let! decls = 103 | Generator.from>> // ensure at least one decl per group 104 | return { Decls = Seq.toList decls.Get } 105 | } |> Arb.fromGen 106 | 107 | type WellFormed = WellFormed of Program 108 | 109 | module WellFormed = 110 | 111 | let arb = 112 | gen { 113 | let! program = 114 | Generator.from> 115 | |> Gen.where (fun prog -> 116 | TypeInfer.typeOf prog 117 | |> Result.isOk) 118 | return WellFormed program 119 | } |> Arb.fromGen 120 | 121 | type Arbitraries = 122 | static member LetDef() = LetDef.arb 123 | static member IdentifierDef() = IdentifierDef.arb 124 | static member TypeArrowDef() = TypeArrowDef.arb 125 | static member Type() = Type.arb 126 | static member Decl() = Decl.arb 127 | static member DeclGroup() = DeclGroup.arb 128 | static member WellFormed() = WellFormed.arb 129 | 130 | [] 131 | module Untype = 132 | 133 | module Expression = 134 | 135 | let rec untype = function 136 | | LetExpr def-> 137 | LetExpr { 138 | def with 139 | Bindings = 140 | def.Bindings 141 | |> List.map (fun binding -> 142 | { 143 | binding with 144 | Type = TypeBlank () 145 | Expr = untype binding.Expr 146 | }) 147 | Expr = untype def.Expr 148 | } 149 | | Prim1Expr def -> 150 | Prim1Expr { 151 | def with 152 | TypeArguments = [] 153 | Expr = untype def.Expr 154 | } 155 | | Prim2Expr def -> 156 | Prim2Expr { 157 | def with 158 | TypeArguments = [] 159 | Left = untype def.Left 160 | Right = untype def.Right 161 | } 162 | | IfExpr def -> 163 | IfExpr { 164 | def with 165 | Condition = untype def.Condition 166 | TrueBranch = untype def.TrueBranch 167 | FalseBranch = untype def.FalseBranch 168 | } 169 | | ApplicationExpr def -> 170 | ApplicationExpr { 171 | def with 172 | Identifier = IdentifierDef.untag def.Identifier 173 | TypeArguments = [] 174 | Arguments = 175 | def.Arguments |> List.map untype 176 | } 177 | | AnnotationExpr def -> 178 | untype def.Expr 179 | | expr -> expr 180 | 181 | module Scheme = 182 | 183 | let untype (scheme : Scheme<_>) = 184 | match scheme.Type with 185 | | TypeArrow def -> 186 | { 187 | scheme with 188 | TypeVariableIdents = [] 189 | Type = 190 | TypeArrow { 191 | InputTypes = 192 | def.InputTypes 193 | |> List.map (fun _ -> TypeBlank ()) 194 | OutputType = TypeBlank () 195 | Tag = () 196 | } 197 | } 198 | | _ -> failwith "Unexpected" 199 | 200 | module Decl = 201 | 202 | let untype decl = 203 | { 204 | decl with 205 | Scheme = Scheme.untype decl.Scheme 206 | Body = Expression.untype decl.Body 207 | } 208 | 209 | module DeclGroup = 210 | 211 | let untype group = 212 | { 213 | Decls = 214 | List.map Decl.untype group.Decls 215 | } 216 | 217 | module Program = 218 | 219 | let untype program = 220 | { 221 | program with 222 | DeclGroups = 223 | List.map DeclGroup.untype program.DeclGroups 224 | Main = 225 | Expression.untype program.Main 226 | } 227 | 228 | [] 229 | type FuzzTests() = 230 | 231 | let config = 232 | { Config.QuickThrowOnFailure with 233 | Arbitrary = [ typeof ] 234 | MaxTest = 1000 235 | Replay = Some (Random.StdGen (0, 0)) } 236 | 237 | let toString (subst : Substitution<_>) = 238 | subst 239 | |> Seq.map (fun (ident, typ) -> 240 | $"'{ident.Name} : {Type.unparse typ}") 241 | |> String.concat "\n" 242 | 243 | let unify (typ1 : Type) (typ2 : Type) = 244 | match Substitution.unify typ1 typ2 with 245 | | Ok subst -> 246 | let nDistinct = 247 | subst 248 | |> Seq.distinctBy fst 249 | |> Seq.length 250 | if nDistinct = Seq.length subst then 251 | let typ1' = Substitution.Type.apply subst typ1 252 | let typ2' = Substitution.Type.apply subst typ2 253 | let msg = 254 | sprintf "\nType 1: %s\nType 2: %s\nSubstitution:\n%s" 255 | (Type.unparse typ1) 256 | (Type.unparse typ2) 257 | (toString subst) 258 | typ1' = typ2' |@ msg 259 | else 260 | false |@ toString subst 261 | | _ -> true |@ "" 262 | 263 | [] 264 | member _.ParseUnparseIsOriginal() = 265 | 266 | let parseUnparseIsOriginal program = 267 | let unparsed = Program.unparse program 268 | let reparsed = 269 | Parser.parse unparsed 270 | |> Result.map Program.untag 271 | let msg = sprintf "Text: %s\nResult: %A" unparsed reparsed 272 | reparsed = Ok program |@ msg 273 | 274 | Check.One(config, parseUnparseIsOriginal) 275 | 276 | [] 277 | member _.UnifyTypes() = 278 | let config = { config with MaxTest = 10000 } 279 | Check.One(config, unify) 280 | 281 | [] 282 | member _.UnifyTypeArrows() = 283 | 284 | let unifyArrows arrow1 arrow2 = 285 | unify (TypeArrow arrow1) (TypeArrow arrow2) 286 | 287 | let config = { config with MaxTest = 100000 } 288 | Check.One(config, unifyArrows) 289 | 290 | [] 291 | member _.InferType() = 292 | 293 | let annotate (WellFormed program) = 294 | match TypeInfer.annotate program with 295 | | Ok annotated -> 296 | Program.untype program = Program.untype annotated 297 | |@ Program.unparse program 298 | | Error msg -> true |@ msg 299 | 300 | Check.One(config, annotate) 301 | -------------------------------------------------------------------------------- /UnitTests/Assignment6/TaipanTests.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.Assignment6 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | 5 | open CompilerDesign.Core 6 | open CompilerDesign.UnitTesting 7 | 8 | [] 9 | type TaipanTests() = 10 | 11 | let run text = 12 | let assemblyName = "Taipan" 13 | result { 14 | do! Compiler.compile assemblyName text 15 | return! Process.run assemblyName 16 | } 17 | 18 | [] 19 | member _.Example1() = 20 | let text = 21 | """ 22 | def f(x): 23 | x + 6 24 | 25 | f(38) 26 | """ 27 | Assert.AreEqual(Ok "44", run text) 28 | 29 | [] 30 | member _.Example2() = 31 | let text = 32 | """ 33 | def f(x, y): 34 | isnum(print(x)) && isbool(y) 35 | 36 | def g(z): 37 | f(z, 5) 38 | 39 | g(7) 40 | """ 41 | Assert.AreEqual(Ok "7\nFalse", run text) 42 | 43 | [] 44 | member _.Factorial() = 45 | let text = 46 | """ 47 | # recursive factorial function 48 | def factorial(n): 49 | if n <= 0: 1 50 | else: n * factorial(n-1) 51 | 52 | factorial(6) 53 | """ 54 | Assert.AreEqual(Ok "720", run text) 55 | 56 | [] 57 | member _.MutualRecursion() = 58 | 59 | let text = 60 | """ 61 | def f(x): # should have scheme Forall 'X, ('X -> 'X) 62 | print(x) 63 | 64 | def ab_bool(a, b): # should have scheme Forall 'A, ('A, Bool -> Bool) 65 | isnum(f(a)) && f(b) 66 | 67 | ab_bool(3, true) && ab_bool(true, false) 68 | """ 69 | Assert.AreEqual(Ok "3\nTrue\nTrue\nFalse", run text) 70 | 71 | let text = 72 | """ 73 | def f(x): 74 | print(x) 75 | 76 | and def ab_bool(a, b): 77 | isnum(f(a)) && f(b) # ??? 78 | 79 | ab_bool(3, true) && ab_bool(true, false) 80 | """ 81 | Assert.IsTrue(run text |> Result.isError) 82 | 83 | let text = 84 | """ 85 | # out of order 86 | def ab_bool(a, b): 87 | isnum(f(a)) && f(b) 88 | 89 | def f(x): 90 | print(x) 91 | 92 | ab_bool(3, true) && ab_bool(true, false) 93 | """ 94 | Assert.AreEqual(Error "Name not found: f", run text) 95 | 96 | let text = 97 | """ 98 | def even(n): 99 | !(odd(n)) 100 | 101 | and def odd(n): 102 | if n == 0: false 103 | else: if n == 1: true 104 | else: 105 | even(n - 1) 106 | 107 | odd(5) 108 | """ 109 | Assert.AreEqual(Ok "True", run text) 110 | 111 | [] 112 | member _.Annotation() = 113 | let text = 114 | """ 115 | def whatever(x): 116 | let y : Int = x + 5 in # type-annotations on let-bindings do not need parens 117 | (x : Int) + y # type-annotated variables must be surrounded by parens 118 | 119 | # parameters to function definitions do not need parens 120 | def plus(x : Int, y : Int) -> Int: x + y 121 | 122 | plus(whatever(2), 3) 123 | """ 124 | Assert.AreEqual(Ok "12", run text) 125 | 126 | [] 127 | member _.BoolMainResult() = 128 | let text = 129 | """ 130 | def whatever<'a>(anything : 'a) -> 'a: 131 | print<'a>(anything) 132 | 133 | (3 == print(whatever(5)) : Bool) 134 | """ 135 | Assert.AreEqual(Ok "5\n5\nFalse", run text) 136 | 137 | [] 138 | member _.TypeCheck() = 139 | 140 | let pairs = 141 | [ 142 | "add1(0)", Ok Type.int 143 | "add1(true)", Error "Expected: Int, Actual: Bool" 144 | "3 + 4", Ok Type.int 145 | "3 + a", Error "Unbound identifier: a" 146 | "if 1 == 2: 3 + 4 else: 5 + 6", Ok Type.int 147 | "if 1 >= 2: 3 + 4 else: 5 + 6", Ok Type.int 148 | "if 1 + 2: 3 + 4 else: 5 + 6", Error "Expected: Bool, Actual: Int" 149 | "if true == false: true else: !(true)", Ok Type.bool 150 | "if true >= false: true else: !(true)", Error "Expected: Int, Actual: Bool" 151 | "(add1(0) : Int)", Ok Type.int 152 | "def plus(x : Int, y : Int) -> Int: x + y plus(3, 4)", Ok Type.int 153 | "def plus(x : Int, y : Int) -> Int: x + y plus(true, 4)", Error "Could not unify Int and Bool" 154 | "def plus(x : Bool, y : Int) -> Int: x + y plus(true, 4)", Error "Expected: Int, Actual: Bool" 155 | "def plus(x, y): x + y plus(3, 4)", Error "Missing type" 156 | "let x : Int = 1, y : Int = x + 2 in (x + y : Int)", Ok Type.int 157 | "def f(x : Int, y : Int) -> Int: x + y f(0)", Error "Arity mismatch: expected 2, actual 1" 158 | "f(0)", Error "Unbound identifier: f" 159 | "let x : Int = 0, x : Bool = true in x", Error "Duplicate identifier: x" 160 | "def f(x : Int, x : Int) -> Int: x 0", Error "Duplicate identifier: x" 161 | 162 | """ 163 | def f(x : Int) -> Int: 0 164 | def f(x : Int) -> Int: 1 165 | f(0) 166 | """, Error "Duplicate identifier: f" 167 | 168 | """ 169 | def a() -> Int: b() 170 | and def b() -> Int: a() 171 | a() 172 | """, Ok Type.int 173 | 174 | """ 175 | def id<'t>(x : 't) -> 't: x 176 | id(0) 177 | """, Ok Type.int 178 | ] 179 | 180 | for text, expected in pairs do 181 | let parsed = Parser.parse text 182 | match parsed with 183 | | Ok program -> 184 | let actual = TypeCheck.typeOf program 185 | Assert.AreEqual(expected, actual, text) 186 | | Error msg -> 187 | Assert.Fail($"{text}\n{msg}") 188 | 189 | [] 190 | member _.Unify() = 191 | 192 | let parseType text = 193 | Parser.Scheme.parse text 194 | |> Result.get 195 | |> (fun scheme -> 196 | Assert.IsTrue(scheme.TypeVariableIdents.IsEmpty) 197 | scheme.Type) 198 | 199 | let tuples = 200 | [ 201 | // unify 'X -> Int and Bool -> 'Y under the substitution ['X = Bool, 'Y = Int] 202 | "('X -> Int)", 203 | "(Bool -> 'Y)", 204 | Ok [ 205 | IdentifierDef.create "X", Type.bool 206 | IdentifierDef.create "Y", Type.int 207 | ] 208 | // no substitution that can unify Int -> 'X with Bool -> 'Y 209 | "(Int -> 'X)", 210 | "(Bool -> 'Y)", 211 | Error "Could not unify Int and Bool" 212 | 213 | // cannot unify 'A with 'A -> 'B, because we would get the absurd substitution ['A = 'A -> 'B] 214 | "'A", 215 | "('A -> 'B)", 216 | Error "Could not unify 'A and ('A -> 'B)" 217 | 218 | "('A -> 'A)", 219 | "(Int -> Bool)", 220 | Error "Could not unify Int and Bool" 221 | 222 | "('A -> 'A)", 223 | "(Int -> 'B)", 224 | Ok [ 225 | IdentifierDef.create "A", Type.int 226 | IdentifierDef.create "B", Type.int 227 | ] 228 | 229 | "'x", 230 | "'x", 231 | Ok [] 232 | 233 | "('x -> 'x)", 234 | "('y -> 'x)", 235 | Ok [ IdentifierDef.create "x", TypeVariable (IdentifierDef.create "y") ] 236 | ] 237 | for (text1, text2, expected) in tuples do 238 | let actual = 239 | let typ1 = parseType text1 240 | let typ2 = parseType text2 241 | Substitution.unify typ1 typ2 242 | Assert.AreEqual(expected, actual) 243 | 244 | [] 245 | member _.TypeInfer() = 246 | 247 | let pairs = 248 | [ 249 | "let x = 1, y = x + 2 in x + y", Ok Type.int 250 | "let x = 0, x = true in x", Error "Duplicate identifier: x" 251 | "add1(false)", Error "Could not unify Int and Bool" 252 | "(0 : 'a)", Ok Type.int 253 | "(0 : _)", Ok Type.int 254 | "(false : Int)", Error "Could not unify Bool and Int" 255 | ] 256 | 257 | for text, expected in pairs do 258 | let parsed = Parser.parse text 259 | match parsed with 260 | | Ok program -> 261 | let actual = TypeInfer.typeOf program 262 | Assert.AreEqual(expected, actual, text) 263 | | Error msg -> 264 | Assert.Fail($"{text}\n{msg}") 265 | 266 | [] 267 | member _.Polymorphic() = 268 | 269 | let text = 270 | """ 271 | def identity(x): x 272 | 273 | identity(true) 274 | """ 275 | Assert.AreEqual(Ok "True", run text) 276 | 277 | let text = 278 | """ 279 | def id(x): x 280 | 281 | let f = id(true) in id(3) 282 | """ 283 | Assert.AreEqual(Ok "3", run text) 284 | -------------------------------------------------------------------------------- /UnitTests/Program.fs: -------------------------------------------------------------------------------- 1 | open CompilerDesign.Assignment6 2 | 3 | open CompilerDesign.Core 4 | open CompilerDesign.UnitTesting 5 | 6 | let text = 7 | """ 8 | def even(n): 9 | !(odd(n)) 10 | 11 | and def odd(n): 12 | if n == 0: false 13 | else: if n == 1: true 14 | else: 15 | even(n - 1) 16 | 17 | odd(5) 18 | """ 19 | 20 | result { 21 | let! program = Parser.parse text 22 | 23 | let! program' = TypeInfer.annotate program 24 | printfn "Inferred:\n%s" <| Program.unparse program' 25 | 26 | printfn "\nCompiled:" 27 | let assemblyName = "Taipan" 28 | do! Compiler.compile assemblyName text 29 | return! Process.run assemblyName 30 | } |> printfn "\n%A" 31 | -------------------------------------------------------------------------------- /UnitTests/UnitTests.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | net8.0 5 | 6 | false 7 | false 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | all 34 | runtime; build; native; contentfiles; analyzers; buildtransitive 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /UnitTests/Utility.fs: -------------------------------------------------------------------------------- 1 | namespace CompilerDesign.UnitTesting 2 | 3 | open Microsoft.VisualStudio.TestTools.UnitTesting 4 | open CompilerDesign.Core 5 | 6 | type Assert private () = 7 | 8 | // Improves error message for F# types (e.g. discriminated unions). 9 | static member AreEqual<'t when 't : equality>(expected : 't, actual : 't) = 10 | if actual <> expected then 11 | sprintf "\nExpected: %A.\nActual: %A" expected actual 12 | |> Assert.Fail 13 | 14 | // Improves error message for F# types (e.g. discriminated unions). 15 | static member AreEqual<'t when 't : equality>(expected : 't, actual : 't, msg) = 16 | if actual <> expected then 17 | sprintf "%s\nExpected: %A.\nActual: %A" msg expected actual 18 | |> Assert.Fail 19 | 20 | // Accepts any F# action. 21 | static member ThrowsException(action) = 22 | Microsoft.VisualStudio.TestTools.UnitTesting 23 | .Assert.ThrowsException( 24 | fun () -> ignore (action ())) 25 | 26 | module Process = 27 | 28 | open System.Diagnostics 29 | 30 | let run assemblyName = 31 | try 32 | result { 33 | let psi = 34 | ProcessStartInfo( 35 | FileName = "dotnet", 36 | Arguments = $"{assemblyName}.dll", 37 | RedirectStandardOutput = true) 38 | use proc = new Process(StartInfo = psi) 39 | proc.Start() |> ignore 40 | return proc.StandardOutput 41 | .ReadToEnd() 42 | .Replace("\r", "") 43 | } 44 | with exn -> Error exn.Message 45 | --------------------------------------------------------------------------------