├── .github └── workflows │ ├── codeql-analysis.yml │ └── dotnet.yml ├── .gitignore ├── .gitpod.Dockerfile ├── .gitpod.yml ├── Boba.Compiler ├── Boba.Compiler.fsproj ├── Condenser.fs ├── CoreGen.fs ├── Documentation.fs ├── Elaboration.fs ├── GoOutputGen.fs ├── KindInference.fs ├── Lexer.fs ├── Lexer.fsl ├── MochiGen.fs ├── Parser.fs ├── Parser.fsi ├── Parser.fsy ├── Primitives.fs ├── Program.fs ├── Renamer.fs ├── Shell.fs ├── Syntax.fs ├── TestGenerator.fs ├── TypeInference.fs ├── UnitDependencies.fs └── UnitImport.fs ├── Boba.Core.Test ├── AbelianTests.fs ├── Boba.Core.Test.fsproj ├── BooleanTests.fs ├── CHRTests.fs ├── DotSeqTests.fs ├── KindTests.fs ├── LinearTests.fs ├── Program.fs ├── QuineMcCluskeyTest.fs ├── SubstitutionTests.fs └── UnificationTests.fs ├── Boba.Core ├── Abelian.fs ├── Boba.Core.fsproj ├── Boolean.fs ├── CHR.fs ├── Common.fs ├── DotSeq.fs ├── Environment.fs ├── Fresh.fs ├── Kinds.fs ├── Linear.fs ├── Substitution.fs ├── Syntax.fs ├── TypeBuilder.fs ├── Types.fs └── Unification.fs ├── LICENSE ├── Mochi.Core ├── Instructions.fs ├── Mochi.Core.fsproj └── Permissions.fs ├── README.md ├── boba.sln ├── go.mod ├── runtime ├── bytecode.go ├── fiber.go ├── machine.go ├── numeric.go └── value.go └── test ├── caesar-cipher.boba ├── correct-main ├── closure-capture-order.boba ├── datatype.boba ├── else-expr.boba ├── go-native-wrap.boba ├── handle-closure.boba ├── handle-escape.boba ├── handle-multiret.boba ├── if-expr.boba ├── lists.boba ├── nested-handlers.boba ├── overload.boba ├── permissions.boba ├── records.boba ├── state-handler.boba ├── tags.boba ├── test-example.boba ├── tiny-test.boba ├── tuples.boba ├── type-assert.boba ├── variants.boba └── while-expr.boba ├── correct-test ├── ackermann.boba ├── classes.boba ├── dot-overload.boba ├── export.boba ├── functor.boba ├── fundeps.boba ├── hailstone.boba ├── handle-context.boba ├── handler-order.boba ├── import-reexport.boba ├── import.boba ├── iterators.boba ├── let-order.boba ├── multiple-fundeps.boba ├── multiple-resume.boba ├── numbers.boba ├── nurseries.boba ├── pattern-synonyms.boba ├── patterns.boba ├── prims.boba ├── pseudorandom.boba ├── ranges.boba ├── rec-overload.boba ├── recdata.boba ├── semigroupoid.boba ├── show.boba ├── test-multi-result.boba └── type-synonym.boba ├── run-tests.fsx ├── typeable.boba ├── wrong ├── ambiguous.boba ├── for-comp-incomplete.boba ├── for-effect-incomplete.boba ├── for-fold-incomplete.boba ├── instance-consume-extra.boba ├── instance-extra-effect.boba ├── instance-produce-extra.boba ├── instance-touch-extra.boba └── nursery-no-escape.boba └── zip-iterators.boba /.github/workflows/codeql-analysis.yml: -------------------------------------------------------------------------------- 1 | # For most projects, this workflow file will not need changing; you simply need 2 | # to commit it to your repository. 3 | # 4 | # You may wish to alter this file to override the set of languages analyzed, 5 | # or to provide custom queries or build logic. 6 | # 7 | # ******** NOTE ******** 8 | # We have attempted to detect the languages in your repository. Please check 9 | # the `language` matrix defined below to confirm you have the correct set of 10 | # supported CodeQL languages. 11 | # 12 | name: "CodeQL" 13 | 14 | on: 15 | push: 16 | branches: [ "master" ] 17 | pull_request: 18 | # The branches below must be a subset of the branches above 19 | branches: [ "master" ] 20 | schedule: 21 | - cron: '33 6 * * 1' 22 | 23 | jobs: 24 | analyze: 25 | name: Analyze 26 | runs-on: ubuntu-latest 27 | permissions: 28 | actions: read 29 | contents: read 30 | security-events: write 31 | 32 | strategy: 33 | fail-fast: false 34 | matrix: 35 | language: [ 'go' ] 36 | # CodeQL supports [ 'cpp', 'csharp', 'go', 'java', 'javascript', 'python', 'ruby' ] 37 | # Learn more about CodeQL language support at https://aka.ms/codeql-docs/language-support 38 | 39 | steps: 40 | - name: Checkout repository 41 | uses: actions/checkout@v3 42 | 43 | # Initializes the CodeQL tools for scanning. 44 | - name: Initialize CodeQL 45 | uses: github/codeql-action/init@v2 46 | with: 47 | languages: ${{ matrix.language }} 48 | # If you wish to specify custom queries, you can do so here or in a config file. 49 | # By default, queries listed here will override any specified in a config file. 50 | # Prefix the list here with "+" to use these queries and those in the config file. 51 | 52 | # Details on CodeQL's query packs refer to : https://docs.github.com/en/code-security/code-scanning/automatically-scanning-your-code-for-vulnerabilities-and-errors/configuring-code-scanning#using-queries-in-ql-packs 53 | # queries: security-extended,security-and-quality 54 | 55 | 56 | # Autobuild attempts to build any compiled languages (C/C++, C#, or Java). 57 | # If this step fails, then you should remove it and run the build manually (see below) 58 | - name: Autobuild 59 | uses: github/codeql-action/autobuild@v2 60 | 61 | # ℹ️ Command-line programs to run using the OS shell. 62 | # 📚 See https://docs.github.com/en/actions/using-workflows/workflow-syntax-for-github-actions#jobsjob_idstepsrun 63 | 64 | # If the Autobuild fails above, remove it and uncomment the following three lines. 65 | # modify them (or add more) to build your code if your project, please refer to the EXAMPLE below for guidance. 66 | 67 | # - run: | 68 | # echo "Run, Build Application using script" 69 | # ./location_of_script_within_repo/buildscript.sh 70 | 71 | - name: Perform CodeQL Analysis 72 | uses: github/codeql-action/analyze@v2 73 | -------------------------------------------------------------------------------- /.github/workflows/dotnet.yml: -------------------------------------------------------------------------------- 1 | name: .NET 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | jobs: 10 | build: 11 | 12 | runs-on: ubuntu-latest 13 | 14 | steps: 15 | - uses: actions/checkout@v3 16 | - name: Setup .NET 17 | uses: actions/setup-dotnet@v2 18 | with: 19 | dotnet-version: 6.0.x 20 | - name: Restore dependencies 21 | run: dotnet restore 22 | - name: Build 23 | run: dotnet build --no-restore 24 | - name: Test 25 | run: dotnet test --no-build --verbosity normal 26 | - name: Integration Test 27 | run: dotnet fsi ./test/run-tests.fsx 28 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | *.*~ 3 | project.lock.json 4 | .DS_Store 5 | *.pyc 6 | nupkg/ 7 | 8 | # Visual Studio Code 9 | .vscode 10 | .ionide/* 11 | 12 | # Visual Studio 2019 13 | .vs/* 14 | 15 | # User-specific files 16 | *.suo 17 | *.user 18 | *.userosscache 19 | *.sln.docstates 20 | 21 | # Build results 22 | [Dd]ebug/ 23 | [Dd]ebugPublic/ 24 | [Rr]elease/ 25 | [Rr]eleases/ 26 | [Tt]estResults/ 27 | x64/ 28 | x86/ 29 | build/ 30 | bld/ 31 | [Bb]in/ 32 | [Oo]bj/ 33 | [Oo]ut/ 34 | msbuild.log 35 | msbuild.err 36 | msbuild.wrn 37 | 38 | .fake 39 | .ionide 40 | 41 | # Boba repo custom 42 | output/* 43 | main.go 44 | docs.md 45 | natUnit*.go 46 | boba.exe -------------------------------------------------------------------------------- /.gitpod.Dockerfile: -------------------------------------------------------------------------------- 1 | FROM gitpod/workspace-full-vnc 2 | 3 | USER root 4 | 5 | #.NET installed via .gitpod.yml task until the following issue is fixed: https://github.com/gitpod-io/gitpod/issues/5090 6 | ENV DOTNET_VERSION=6.0 7 | ENV DOTNET_ROOT=/workspace/.dotnet 8 | ENV PATH=$PATH:$DOTNET_ROOT 9 | 10 | RUN apt-get -yq update \ 11 | && apt-get install -y check -------------------------------------------------------------------------------- /.gitpod.yml: -------------------------------------------------------------------------------- 1 | image: 2 | file: .gitpod.Dockerfile 3 | 4 | tasks: 5 | # Mitigation for https://github.com/gitpod-io/gitpod/issues/6460 6 | - name: Postinstall .NET 6.0 and dev certificates 7 | init: | 8 | mkdir -p $DOTNET_ROOT && curl -fsSL https://dot.net/v1/dotnet-install.sh | bash /dev/stdin --channel $DOTNET_VERSION --install-dir $DOTNET_ROOT 9 | dotnet dev-certs https 10 | dotnet restore 11 | 12 | vscode: 13 | extensions: 14 | - Ionide.Ionide-fsharp@5.5.9 15 | - muhammad-sammy.csharp 16 | - golang.go -------------------------------------------------------------------------------- /Boba.Compiler/Boba.Compiler.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | Exe 4 | boba 5 | net6.0 6 | fslex.dll 7 | fsyacc.dll 8 | preview 9 | 10 | 11 | 12 | 13 | --module Parser 14 | 15 | 16 | --module Lexer --unicode 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /Boba.Compiler/Condenser.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | module Condenser = 4 | 5 | open Boba.Core.Types 6 | open Boba.Core.TypeBuilder 7 | open Boba.Core 8 | open Boba.Compiler.Syntax 9 | open Boba.Compiler.Renamer 10 | 11 | 12 | 13 | type Handler = { 14 | Name: string; 15 | Inputs: int; 16 | Outputs: int; 17 | } 18 | 19 | type Effect = { 20 | Name: string; 21 | Handlers: List; 22 | } 23 | 24 | type Native = { 25 | UnitName: string; 26 | Imports: List; 27 | Decls: List 28 | } 29 | 30 | type CondensedProgram = { 31 | Main: List; 32 | Definitions: List<(string * List)>; 33 | Constructors: List; 34 | Effects: List; 35 | Natives: List; 36 | } 37 | 38 | let getCtors decls = 39 | [ 40 | for d in decls do 41 | match d with 42 | | DType dt -> yield dt.Constructors 43 | | DRecTypes dts -> yield [for dt in dts -> dt.Constructors] |> List.concat 44 | | _ -> yield [] 45 | ] 46 | |> List.concat 47 | 48 | let rec substPattern subst pat = 49 | match pat with 50 | | PTuple ps -> PTuple (DotSeq.map (substPattern subst) ps) 51 | | PList ps -> PList (DotSeq.map (substPattern subst) ps) 52 | | PVector _ -> failwith "Vector patterns not yet implemented." 53 | | PSlice _ -> failwith "Slice patterns not yet implemented." 54 | | PRecord fs -> PRecord (List.map (fun f -> fst f, substPattern subst (snd f)) fs) 55 | | PConstructor (n, args) -> PConstructor (n, DotSeq.map (substPattern subst) args) 56 | | PRef p -> PRef (substPattern subst p) 57 | | PNamed (n, PWildcard) -> 58 | if Map.containsKey n.Name subst 59 | then subst.[n.Name] 60 | else pat 61 | | _ -> pat 62 | 63 | let rec expandPattern subst pat = 64 | match pat with 65 | | PTuple ps -> PTuple (DotSeq.map (expandPattern subst) ps) 66 | | PList ps -> PList (DotSeq.map (expandPattern subst) ps) 67 | | PVector _ -> failwith "Vector patterns not yet implemented." 68 | | PSlice _ -> failwith "Slice patterns not yet implemented." 69 | | PRecord fs -> PRecord (List.map (fun f -> fst f, expandPattern subst (snd f)) fs) 70 | | PConstructor (n, args) -> 71 | if Map.containsKey n.Name.Name subst 72 | then 73 | let subArgs = DotSeq.map (expandPattern subst) args 74 | let pars, exp = subst.[n.Name.Name] 75 | let gen = substPattern (Map.ofSeq (List.zip (List.rev pars) (DotSeq.toList subArgs))) exp 76 | gen 77 | else pat 78 | | PRef p -> PRef (expandPattern subst p) 79 | | PNamed (n, p) -> PNamed (n, expandPattern subst p) 80 | | _ -> pat 81 | 82 | let rec expandPatternSynonyms subst expr = [for w in expr -> expandPatternSynonymsWord subst w] 83 | and expandPatternSynonymsWord subst word = 84 | match word with 85 | | EStatementBlock ss -> EStatementBlock (expandPatternSynonymsStatements subst ss) 86 | | ENursery (n, ss) -> ENursery (n, expandPatternSynonymsStatements subst ss) 87 | | ECancellable (n, ss) -> ECancellable (n, expandPatternSynonymsStatements subst ss) 88 | | EHandle (rc, ps, hdld, hdlrs, aft) -> 89 | EHandle (rc, ps, 90 | expandPatternSynonymsStatements subst hdld, 91 | List.map (expandPatternSynonymsHandler subst) hdlrs, 92 | expandPatternSynonyms subst aft) 93 | | EInject (effs, ss) -> EInject (effs, expandPatternSynonymsStatements subst ss) 94 | | EMatch (cs, o) -> EMatch (List.map (expandPatternSynonymsMatchClause subst) cs, expandPatternSynonyms subst o) 95 | | EIf (c, t, e) -> EIf (expandPatternSynonyms subst c, expandPatternSynonymsStatements subst t, expandPatternSynonymsStatements subst e) 96 | | EWhile (c, b) -> EWhile (expandPatternSynonyms subst c, expandPatternSynonymsStatements subst b) 97 | | EFunctionLiteral b -> EFunctionLiteral (expandPatternSynonyms subst b) 98 | | ETupleLiteral b -> ETupleLiteral (expandPatternSynonyms subst b) 99 | | EListLiteral b -> EListLiteral (expandPatternSynonyms subst b) 100 | | EVectorLiteral _ -> failwith "Vector literals not yet implemented." 101 | | ESliceLiteral _ -> failwith "Slice literals not yet implemented." 102 | | ERecordLiteral exp -> ERecordLiteral (expandPatternSynonyms subst exp) 103 | | EVariantLiteral (n, v) -> EVariantLiteral (n, expandPatternSynonyms subst v) 104 | | ECase (cs, o) -> ECase (List.map (expandPatternSynonymsCase subst) cs, expandPatternSynonyms subst o) 105 | | EWithPermission (ps, thenSs, elseSs) -> 106 | EWithPermission (ps, expandPatternSynonymsStatements subst thenSs, expandPatternSynonymsStatements subst elseSs) 107 | | EIfPermission (ps, thenSs, elseSs) -> 108 | EIfPermission (ps, expandPatternSynonymsStatements subst thenSs, expandPatternSynonymsStatements subst elseSs) 109 | | EWithState ss -> EWithState (expandPatternSynonymsStatements subst ss) 110 | | _ -> word 111 | and expandPatternSynonymsStatements subst stmts = List.map (expandPatternSynonymsStatement subst) stmts 112 | and expandPatternSynonymsStatement subst stmt = 113 | match stmt with 114 | | SLet m -> SLet (expandPatternSynonymsMatchClause subst m) 115 | | SLocals _ -> failwith "Substitution for local functions not yet implemented." 116 | | SExpression e -> SExpression (expandPatternSynonyms subst e) 117 | and expandPatternSynonymsHandler subst hdlr = 118 | { hdlr with Body = expandPatternSynonyms subst hdlr.Body } 119 | and expandPatternSynonymsMatchClause subst clause = 120 | { clause with Matcher = DotSeq.map (expandPattern subst) clause.Matcher; Body = expandPatternSynonyms subst clause.Body } 121 | and expandPatternSynonymsCase subst case = { case with Body = expandPatternSynonyms subst case.Body } 122 | 123 | let getPatternSyns decls = 124 | [ 125 | for d in decls -> 126 | match d with 127 | | DPattern p -> [p.Name.Name, ([for p in p.Params -> p.Name], p.Expand)] 128 | | _ -> [] 129 | ] 130 | |> List.concat 131 | 132 | let getDefs decls = 133 | [ 134 | for d in decls do 135 | match d with 136 | | DFunc f -> yield [(f.Name.Name, f.Body)] 137 | | DRecFuncs fs -> yield [for f in fs -> (f.Name.Name, f.Body)] 138 | | DTag t -> yield [(t.TermName.Name, [])] 139 | | DOverload o -> yield o.Bodies 140 | | _ -> yield [] 141 | ] 142 | |> List.concat 143 | 144 | let getEffs decls env = 145 | [ 146 | for d in decls do 147 | match d with 148 | | DEffect e -> 149 | yield [{ 150 | Name = e.Name.Name; 151 | Handlers = [ 152 | for h in e.Handlers -> 153 | let (Some entry) = Environment.lookup env h.Name.Name 154 | let _, _, _, (TSeq ins), (TSeq outs) = functionValueTypeComponents (qualTypeHead entry.Type.Body) 155 | { 156 | Name = h.Name.Name; 157 | Inputs = removeSeqPoly ins |> DotSeq.length; 158 | Outputs = removeSeqPoly outs |> DotSeq.length; 159 | }] 160 | }] 161 | | _ -> yield [] 162 | ] 163 | |> List.concat 164 | 165 | let getNative decls (natName: Name) = 166 | [for d in decls do 167 | match d with 168 | | DNative n -> 169 | if n.Name.Name = natName.Name 170 | then yield [n] 171 | else yield [] 172 | | _ -> yield []] |> List.concat 173 | 174 | let getNatives decls (nats: List) = 175 | [ 176 | for n in nats do 177 | yield { 178 | UnitName = n.UnitName; 179 | Imports = n.Imports; 180 | Decls = List.collect (getNative decls) n.Natives } 181 | ] 182 | 183 | let genCondensed (program : RenamedProgram) env = 184 | let ctors = getCtors program.Declarations 185 | let patSyns = Map.ofList (getPatternSyns program.Declarations) 186 | let defs = getDefs program.Declarations 187 | let patReplDefs = [for d in defs -> (fst d, expandPatternSynonyms patSyns (snd d))] 188 | let matchEffs = [ 189 | for inp in 0..15 -> { 190 | Name = $"match{inp}!"; 191 | Handlers = 192 | { Name = $"$default{inp}!"; Inputs = inp; Outputs = 0 } 193 | :: [for i in 0..99 -> { Name = $"$match{i}-{inp}!"; Inputs = inp; Outputs = 0 }] 194 | } 195 | ] 196 | let effs = List.append matchEffs (getEffs program.Declarations env) 197 | let nats = getNatives program.Declarations program.Natives 198 | { Main = expandPatternSynonyms patSyns program.Main; 199 | Definitions = patReplDefs; 200 | Constructors = ctors; 201 | Effects = effs; 202 | Natives = nats } -------------------------------------------------------------------------------- /Boba.Compiler/Documentation.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | module Documentation = 4 | 5 | open System.Collections.Generic 6 | open FSharp.Formatting.Markdown 7 | open FSharp.Formatting 8 | open Syntax 9 | open Boba.Core 10 | 11 | let docsToMarkdown docLines = 12 | let uncommented = [for d in docLines -> d.Line[3..]] 13 | let uncommented = String.concat "\n" uncommented 14 | match (Markdown.Parse uncommented).Paragraphs with 15 | | [] -> [] 16 | | [Paragraph (body, _)] -> body 17 | | other -> failwith $"Unrecognized markdown documentation format {other}" 18 | 19 | let generateTitle title = [ 20 | Heading (1, [Literal(title, None)], None)] 21 | 22 | let fnType (name: string) = 23 | if name[name.Length-1] = '?' 24 | then "test" 25 | else "func" 26 | 27 | let generateFunction simplifier env (fn : Function) = 28 | match Environment.lookup env fn.Name.Name with 29 | | Some sch -> [ 30 | Heading (3, [ 31 | Literal ($"*{fnType fn.Name.Name}* " + fn.Name.Name + " : ", None)], None); 32 | Paragraph ([ 33 | Literal("**Type**: ", None); 34 | InlineCode (Types.prettyType (simplifier sch.Type.Body), None)], None); 35 | Paragraph (docsToMarkdown fn.Docs, None); 36 | HorizontalRule ('-', None)] 37 | | None -> failwith $"Could not find type for {fn.Name.Name} when generating documentation." 38 | 39 | let generateNative simplifier env (fn : Native) = 40 | match Environment.lookup env fn.Name.Name with 41 | | Some sch -> [ 42 | Heading (3, [ 43 | Literal ($"*native* " + fn.Name.Name + " : ", None)], None); 44 | Paragraph ([ 45 | Literal("**Type**: ", None); 46 | InlineCode (Types.prettyType (simplifier sch.Type.Body), None)], None); 47 | Paragraph (docsToMarkdown fn.Docs, None); 48 | HorizontalRule ('-', None)] 49 | | None -> failwith $"Could not find type for native function {fn.Name.Name} when generating documentation." 50 | 51 | let generateKind simplifier env (k : UserKind) = 52 | match Environment.lookupKind env k.Name.Name with 53 | | Some sch -> [ 54 | Heading (3, [ 55 | Literal ($"*kind* " + k.Name.Name + " : ", None); 56 | InlineCode ($"{k.Unify}", None)], None); 57 | Paragraph (docsToMarkdown k.Docs, None); 58 | HorizontalRule ('-', None)] 59 | | None -> failwith $"Could not find entry for kind {k.Name.Name} when generating documentation." 60 | 61 | let generatePattern simplifier env (p : PatternSynonym) = 62 | match Environment.lookupPattern env p.Name.Name with 63 | | Some sch -> [ 64 | Heading (3, [ 65 | Literal ($"*pattern* " + p.Name.Name + " : ", None)], None); 66 | Paragraph ([ 67 | Literal("**Type**: ", None); 68 | InlineCode (Types.prettyType (simplifier sch.Body), None)], None); 69 | Paragraph (docsToMarkdown p.Docs, None); 70 | HorizontalRule ('-', None)] 71 | | None -> failwith $"Could not find type for pattern {p.Name.Name} when generating documentation." 72 | 73 | let generateOverload simplifier env (o : Overload) = 74 | match Environment.lookup env o.Name.Name with 75 | | Some sch -> [ 76 | Heading (3, [ 77 | Literal ($"*overload* " + o.Name.Name + " : ", None)], None); 78 | Paragraph ([ 79 | Literal("**Type**: ", None); 80 | InlineCode (Types.prettyType (simplifier sch.Type.Body), None)], None); 81 | Paragraph (docsToMarkdown o.Docs, None); 82 | HorizontalRule ('-', None)] 83 | | None -> failwith $"Could not find type for pattern {o.Name.Name} when generating documentation." 84 | 85 | let generateDecl shouldOutput simplifier env decl = 86 | if List.exists (fun (n: Name) -> shouldOutput n.Name) (declNames decl) 87 | then 88 | match decl with 89 | | DFunc f -> generateFunction simplifier env f 90 | | DRecFuncs fs -> List.collect (generateFunction simplifier env) fs 91 | | DNative n -> generateNative simplifier env n 92 | | DKind k -> generateKind simplifier env k 93 | | _ -> 94 | printfn $"Warning: documentation for {declNames decl} unimplemented." 95 | [] 96 | else [] 97 | 98 | let generate unitName shouldOutput simplifier env decls = 99 | let ts = generateTitle unitName 100 | let ds = List.collect (generateDecl shouldOutput simplifier env) (List.rev decls) 101 | let doc = MarkdownDocument (List.append ts ds, new Dictionary()) 102 | Markdown.ToMd doc 103 | -------------------------------------------------------------------------------- /Boba.Compiler/KindInference.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | module KindInference = 4 | 5 | open System 6 | open Boba.Core 7 | open Boba.Core.Common 8 | open Boba.Core.Kinds 9 | open Boba.Core.Types 10 | open Boba.Core.Substitution 11 | open Boba.Core.Unification 12 | open Boba.Core.Fresh 13 | open Boba.Core.Environment 14 | 15 | let lookupTypeOrFail fresh env name ctor = 16 | match lookupType env name with 17 | | Some ksch -> 18 | let instK = instantiateKinds fresh ksch 19 | instK, [], ctor name instK 20 | | None -> failwith $"Could not find '{name}' in type environment during kind inference." 21 | 22 | /// Create a fresh kind variable. 23 | let freshKind (fresh : FreshVars) = KVar (fresh.Fresh "k") 24 | 25 | /// Using the given type constructor parameterized by a kind, return the fresh 26 | /// kind variable `k`, a list of generated kind constraints, and the constructor 27 | /// assigned kind `k`. 28 | let freshCtor fresh ctor = 29 | let k = freshKind fresh 30 | k, [], ctor k 31 | 32 | /// Under the given type environment, transform the unkinded input type into 33 | /// a well-kinded type if possible. Returns the resulting kind of the newly 34 | /// annotated type, a list of kind constraints that can be solved to determine 35 | /// the most-general kind, and the annotated type. 36 | let rec kindInfer fresh env sty = 37 | match sty with 38 | | Syntax.STWildcard -> 39 | let k = freshKind fresh 40 | k, [], TWildcard k 41 | | Syntax.STVar n -> lookupTypeOrFail fresh env n.Name typeVar 42 | | Syntax.STDotVar n -> lookupTypeOrFail fresh env n.Name typeDotVar 43 | | Syntax.STCon n -> lookupTypeOrFail fresh env n.Name.Name typeCon 44 | | Syntax.STTrue -> freshCtor fresh TTrue 45 | | Syntax.STFalse -> freshCtor fresh TFalse 46 | | Syntax.STAnd (l, r) -> simpleBinaryCon fresh env l r TAnd 47 | | Syntax.STOr (l, r) -> simpleBinaryCon fresh env l r TOr 48 | | Syntax.STNot n -> simpleUnaryCon fresh env n TNot 49 | | Syntax.STAbelianOne -> freshCtor fresh TAbelianOne 50 | | Syntax.STExponent (b, p) -> simpleUnaryCon fresh env b (fun t -> TExponent (t, Int32.Parse p.Value)) 51 | | Syntax.STMultiply (l, r) -> simpleBinaryCon fresh env l r TMultiply 52 | | Syntax.STFixedConst c -> primFixedKind, [], TFixedConst (Int32.Parse c.Value) 53 | | Syntax.STRowExtend -> 54 | let k = freshKind fresh 55 | karrow k (karrow (KRow k) (KRow k)), [], TRowExtend k 56 | | Syntax.STRowEmpty -> 57 | let k = freshKind fresh 58 | KRow k, [], TEmptyRow k 59 | | Syntax.STSeq ts -> 60 | if DotSeq.length ts = 0 61 | then 62 | let seqKind = freshKind fresh 63 | KSeq seqKind, [], typeSeq DotSeq.SEnd 64 | else 65 | let ks = DotSeq.map (kindInfer fresh env) ts 66 | let seqKind = 67 | DotSeq.at 0 ks 68 | |> Option.defaultWith (fun () -> failwith "No element in type sequence") 69 | |> (fun (k, _, _) -> k) 70 | let cstrs = DotSeq.map (fun (_, cs, _) -> cs) ks |> DotSeq.fold List.append [] 71 | let allSeqKindsEq = DotSeq.map (fun (k, _, _) -> kindEqConstraint seqKind k) ks |> DotSeq.toList 72 | let allCstrs = List.append allSeqKindsEq cstrs 73 | KSeq seqKind, allCstrs, typeSeq (DotSeq.map (fun (_, _, t) -> t) ks) 74 | | Syntax.STApp (l, r) -> 75 | let lk, lcstrs, lt = kindInfer fresh env l 76 | let rk, rcstrs, rt = kindInfer fresh env r 77 | let ret = freshKind fresh 78 | ret, append3 [kindEqConstraint lk (karrow rk ret)] lcstrs rcstrs, typeApp lt rt 79 | and simpleBinaryCon fresh env l r ctor = 80 | let (lk, lcstrs, lt) = kindInfer fresh env l 81 | let (rk, rcstrs, rt) = kindInfer fresh env r 82 | lk, append3 [kindEqConstraint lk rk] lcstrs rcstrs, ctor (lt, rt) 83 | and simpleUnaryCon fresh env b ctor = 84 | let (k, cstrs, t) = kindInfer fresh env b 85 | k, cstrs, ctor t 86 | 87 | // Given an unannotated type, converts it into a type with kind annotations on constructors and variables, 88 | // and places the type variables in the type environment in an extend copy of the original environment. 89 | // Returns the annotated type and the extended environment copy. 90 | let kindAnnotateTypeWithConstraints fresh expectedKind env (ty : Syntax.SType) = 91 | let free = Syntax.stypeFree ty |> Set.filter (fun v -> not (Map.containsKey v env.TypeConstructors)) 92 | let kenv = free |> Set.fold (fun e v -> addTypeCtor e v (kindScheme [] (freshKind fresh))) env 93 | let (inf, constraints, ty) = kindInfer fresh kenv ty 94 | let subst = solveComposeAll fresh ((kindEqConstraint expectedKind inf) :: constraints) 95 | try 96 | let ann = typeSubstExn fresh subst ty 97 | if not (isTypeWellKinded ann) 98 | then 99 | printfn $"Non-well kinded annotated type : {ann}" 100 | assert (isTypeWellKinded ann) 101 | ann, free |> Set.fold (fun e v -> addTypeCtor e v (generalizeKind (kindSubst subst (lookupType kenv v |> Option.defaultWith (fun _ -> failwith "Should exist") |> instantiateKinds fresh)))) env 102 | with 103 | | UnifyKindMismatchException (l, r) -> failwith $"{l} ~ {r} failed to unify." 104 | 105 | // Given an unannotated type, converts it into a type with kind annotations on constructors and variables, 106 | // and places the type variables in the type environment in an extend copy of the original environment. 107 | // Returns the annotated type and the extended environment copy. 108 | let kindAnnotateTypeWith fresh env (ty : Syntax.SType) = 109 | let free = Syntax.stypeFree ty |> Set.filter (fun v -> not (Map.containsKey v env.TypeConstructors)) 110 | let kenv = free |> Set.fold (fun e v -> addTypeCtor e v (kindScheme [] (freshKind fresh))) env 111 | let (inf, constraints, ty) = kindInfer fresh kenv ty 112 | try 113 | let subst = solveComposeAll fresh constraints 114 | let ann = typeSubstExn fresh subst ty 115 | assert (isTypeWellKinded ann) 116 | ann, free |> Set.fold (fun e v -> addTypeCtor e v (generalizeKind (kindSubst subst (lookupType kenv v |> Option.defaultWith (fun _ -> failwith "Should exist") |> instantiateKinds fresh)))) env 117 | with 118 | | UnifyKindMismatchException (l, r) -> failwith $"{l} ~ {r} failed to unify." 119 | 120 | let kindAnnotateType fresh env (ty : Syntax.SType) = 121 | kindAnnotateTypeWith fresh env ty |> fst 122 | 123 | let kindAnnotateConstraint fresh env (cnstr : Syntax.SConstraint) = 124 | match cnstr with 125 | | Syntax.SCPredicate ty -> CHR.CPredicate (kindAnnotateType fresh env ty) 126 | | Syntax.SCEquality (l, r) -> CHR.CEquality (typeEqConstraint (kindAnnotateType fresh env l) (kindAnnotateType fresh env r)) 127 | 128 | let inferConstructorKinds fresh env (ctor: Syntax.Constructor) = 129 | let ctorTypeFree = List.map Syntax.stypeFree (ctor.Result :: ctor.Components) |> Set.unionMany 130 | let kEnv = Set.fold (fun env v -> addTypeCtor env v (kindScheme [] (freshKind fresh))) env ctorTypeFree 131 | let (kinds, constrs, tys) = List.map (kindInfer fresh kEnv) ctor.Components |> List.unzip3 132 | let ctorKind, ctorConstrs, ctorTy = kindInfer fresh kEnv ctor.Result 133 | // every component in a constructor should be of kind Value 134 | let valConstrs = List.map (fun k -> kindEqConstraint k primValueKind) kinds 135 | // the result component must also be of kind data 136 | let dataConstr = kindEqConstraint ctorKind primDataKind 137 | ctorKind, dataConstr :: append3 ctorConstrs valConstrs (List.concat constrs), List.append tys [ctorTy] -------------------------------------------------------------------------------- /Boba.Compiler/Lexer.fsl: -------------------------------------------------------------------------------- 1 | { 2 | open FSharp.Text.Lexing 3 | open System 4 | open Parser 5 | open Boba.Compiler.Syntax 6 | open Boba.Core.Types 7 | 8 | let lexeme lexbuf = LexBuffer<_>.LexemeString lexbuf 9 | } 10 | 11 | let digit = ['0'-'9'] 12 | let whitespace = [' ' '\t' ] 13 | let newline = ('\n' | '\r' '\n') 14 | 15 | 16 | let lower = ['a'-'z'] 17 | let upper = ['A'-'Z'] 18 | 19 | let alpha = (lower|upper) 20 | let alphanum = (alpha|digit) 21 | 22 | rule token = parse 23 | | whitespace { token lexbuf } 24 | | newline { lexbuf.EndPos <- lexbuf.EndPos.NextLine; token lexbuf } 25 | | ";" { SEMICOLON } 26 | | "," { COMMA } 27 | | "^" { CARET } 28 | | ":" { COLON } 29 | | "::" { DOUBLE_COLON } 30 | | "+" { PLUS } 31 | | "-" { MINUS } 32 | | "*" { STAR } 33 | | "." { DOT } 34 | | "..." { ELLIPSIS } 35 | | "=" { EQUALS } 36 | | "@" { REF } 37 | | "_" { UNDERSCORE } 38 | | "|" { BAR } 39 | | "&&" { DOUBLE_AMP } 40 | | "||" { DOUBLE_BAR } 41 | | "(" { L_PAREN } 42 | | ")" { R_PAREN } 43 | | "[" { L_BRACKET } 44 | | "]" { R_BRACKET } 45 | | "{" { L_BRACE } 46 | | "}" { R_BRACE } 47 | | "<-" { L_ARROW } 48 | | "->" { R_ARROW } 49 | | "*-" { L_STAR } 50 | | "-*" { R_STAR } 51 | | "<=" { L_BIND } 52 | | "=>" { R_BIND } 53 | | "(|" { L_BANANA } 54 | | "|)" { R_BANANA } 55 | | "{|" { L_PUMPKIN } 56 | | "|}" { R_PUMPKIN } 57 | | "[|" { L_BOX } 58 | | "|]" { R_BOX } 59 | | "<|" { L_CONE } 60 | | "|>" { R_CONE } 61 | | "-->" { FN_CTOR } 62 | | "===[" { FN_ARROW_BACK } 63 | | "]==>" { FN_ARROW_FRONT } 64 | | "][" { FN_DIVIDE } 65 | | "!" { NOT } 66 | | "import" { IMPORT } 67 | | "as" { AS } 68 | | "from" { FROM } 69 | | "export" { EXPORT } 70 | | "main" { MAIN } 71 | | "about" { ABOUT } 72 | | "type" { TYPE } 73 | | "kind" { KIND } 74 | | "rec" { RECURSIVE } 75 | | "pattern" { PATTERN } 76 | | "func" { FUNCTION } 77 | | "native" { NATIVE } 78 | | "check" { CHECK } 79 | | "overload" { OVERLOAD } 80 | | "instance" { INSTANCE } 81 | | "rule" { RULE } 82 | | "class" { CLASS } 83 | | "effect" { EFFECT } 84 | | "tag" { TAG } 85 | | "synonym" { SYNONYM } 86 | | "test" { TEST } 87 | | "exhaustive" { EXHAUSTIVE } 88 | | "law" { LAW } 89 | | "is-roughly" { IS_ROUGHLY } 90 | | "satisfies" { SATISFIES } 91 | | "violates" { VIOLATES } 92 | | "is" { IS } 93 | | "is-not" { IS_NOT } 94 | | "let" { LET } 95 | | "local" { LOCAL } 96 | | "with-state" { WITH_STATE } 97 | | "permission" { PERMISSION } 98 | | "by" { BY } 99 | | "of" { OF } 100 | | "per" { PER } 101 | | "nursery" { NURSERY } 102 | | "cancellable" { CANCELLABLE } 103 | | "handle" { HANDLE } 104 | | "after" { AFTER } 105 | | "with" { WITH } 106 | | "inject" { INJECT } 107 | | "match" { MATCH } 108 | | "do" { DO } 109 | | "if" { IF } 110 | | "switch" { SWITCH } 111 | | "for" { FOR } 112 | | "in" { IN } 113 | | "when" { WHEN } 114 | | "then" { THEN } 115 | | "else" { ELSE } 116 | | "while" { WHILE } 117 | | "result" { RESULT } 118 | | "case" { CASE } 119 | | "tuple" { TUPLE } 120 | | "list" { LIST } 121 | | "string" { STRING_KEY } 122 | | "vector" { VECTOR } 123 | | "slice" { SLICE } 124 | | "dictionary" { DICTIONARY } 125 | | "True" { TRUE } 126 | | "False" { FALSE } 127 | | "one" { ONE } 128 | | "boolean" { BOOLEAN } 129 | | "abelian" { ABELIAN } 130 | | "syntactic" { SYNTACTIC } 131 | | digit+ '.' digit+ '.' digit+ { VERSION ((lexeme lexbuf).Split '.' |> Array.toList |> List.map (fun s -> { Value = s; Size = U64; Position = lexbuf.StartPos })) } 132 | | digit+"u" { INTEGER ({ Value = (lexeme lexbuf)[0..^1]; Size = UNative; Position = lexbuf.StartPos }) } 133 | | digit+"u8" { INTEGER ({ Value = (lexeme lexbuf)[0..^2]; Size = U8; Position = lexbuf.StartPos }) } 134 | | digit+"u16" { INTEGER ({ Value = (lexeme lexbuf)[0..^3]; Size = U16; Position = lexbuf.StartPos }) } 135 | | digit+"u16" { INTEGER ({ Value = (lexeme lexbuf)[0..^3]; Size = U32; Position = lexbuf.StartPos }) } 136 | | digit+"u16" { INTEGER ({ Value = (lexeme lexbuf)[0..^3]; Size = U64; Position = lexbuf.StartPos }) } 137 | | ['+''-']?digit+"i8" { INTEGER ({ Value = (lexeme lexbuf)[0..^2]; Size = I8; Position = lexbuf.StartPos }) } 138 | | ['+''-']?digit+"i16" { INTEGER ({ Value = (lexeme lexbuf)[0..^3]; Size = I16; Position = lexbuf.StartPos }) } 139 | | ['+''-']?digit+"i32" { INTEGER ({ Value = (lexeme lexbuf)[0..^3]; Size = I32; Position = lexbuf.StartPos }) } 140 | | ['+''-']?digit+"i64" { INTEGER ({ Value = (lexeme lexbuf)[0..^3]; Size = I64; Position = lexbuf.StartPos }) } 141 | | ['+''-']?digit+ { INTEGER ({ Value = lexeme lexbuf; Size = INative; Position = lexbuf.StartPos }) } 142 | | ['+''-']?(digit+ '.'? digit+) { DECIMAL ({ Value = lexeme lexbuf; Size = Single; Position = lexbuf.StartPos }) } 143 | | ['+''-']?(digit+ '.'? digit+)"f64" { DECIMAL ({ Value = (lexeme lexbuf)[0..^3]; Size = Double; Position = lexbuf.StartPos }) } 144 | | '"'[^'"']*'"' { STRING ({ Value = lexeme lexbuf; Position = lexbuf.StartPos }) } 145 | | '\''[^'\'']+'\'' { CHARACTER ({ Value = lexeme lexbuf; Position = lexbuf.StartPos }) } 146 | | '/''/''/'[^'\n''\r']*newline { lexbuf.EndPos <- lexbuf.EndPos.NextLine; DOCUMENTATION_LINE ({ Line = lexeme lexbuf; Position = lexbuf.StartPos }) } 147 | | '/''/'[^'\n''\r']*newline { lexbuf.EndPos <- lexbuf.EndPos.NextLine; token lexbuf } 148 | | lower(alphanum|'-')* { SMALL_NAME ({ Name = lexeme lexbuf; Kind = ISmall; Position = lexbuf.StartPos }) } 149 | | lower(alphanum|'-')*'!' { OPERATOR_NAME ({ Name = lexeme lexbuf; Kind = IOperator; Position = lexbuf.StartPos }) } 150 | | upper(alphanum|'-')* { BIG_NAME ({ Name = lexeme lexbuf; Kind = IBig; Position = lexbuf.StartPos }) } 151 | | lower(alphanum|'-')*'?' { TEST_NAME ({ Name = lexeme lexbuf; Kind = ISmall; Position = lexbuf.StartPos }) } 152 | | upper(alphanum|'-')*'?' { PREDICATE_NAME ({ Name = lexeme lexbuf; Kind = IPredicate; Position = lexbuf.StartPos }) } 153 | | '#'[^'\n''\r']*newline { lexbuf.EndPos <- lexbuf.EndPos.NextLine; NATIVE_CODE_LINE ({ Line = lexeme lexbuf; Position = lexbuf.StartPos }) } 154 | | eof { EOF } -------------------------------------------------------------------------------- /Boba.Compiler/Primitives.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | module Primitives = 4 | 5 | open Boba.Core.Syntax 6 | open Boba.Core.Types 7 | 8 | let primDup = WCallVar "dup" 9 | let primSwap = WCallVar "swap" 10 | let primDrop = WCallVar "drop" 11 | let primClear = WNativeVar "clear" 12 | 13 | let primTrueBool = WNativeVar "true-bool" 14 | let primFalseBool = WNativeVar "false-bool" 15 | let primNotBool = WNativeVar "not-bool" 16 | let primAndBool = WNativeVar "and-bool" 17 | 18 | let primEqI8 = WNativeVar "eq-i8" 19 | let primEqU8 = WNativeVar "eq-u8" 20 | let primEqI16 = WNativeVar "eq-i16" 21 | let primEqU16 = WNativeVar "eq-u16" 22 | let primEqI32 = WNativeVar "eq-i32" 23 | let primEqU32 = WNativeVar "eq-u32" 24 | let primEqI64 = WNativeVar "eq-i64" 25 | let primEqU64 = WNativeVar "eq-u64" 26 | let primGreaterINative = WNativeVar "gt-inative" 27 | let primLessINative = WNativeVar "lt-inative" 28 | let primEqINative = WNativeVar "eq-inative" 29 | let primEqUNative = WNativeVar "eq-unative" 30 | 31 | let primEqSingle = WNativeVar "eq-single" 32 | let primEqDouble = WNativeVar "eq-double" 33 | 34 | let primNilString = WNativeVar "nil-string" 35 | let primSnocString = WNativeVar "snoc-string" 36 | let primHeadString = WNativeVar "head-string" 37 | let primTailString = WNativeVar "tail-string" 38 | let primDecodeRuneInString = WNativeVar "decode-rune-in-string" 39 | let primLengthString = WNativeVar "length-string" 40 | let primEqString = WNativeVar "eq-string" 41 | 42 | let primNilTuple = WNativeVar "nil-tuple" 43 | let primConsTuple = WNativeVar "cons-tuple" 44 | let primHeadTuple = WNativeVar "head-tuple" 45 | let primTailTuple = WNativeVar "tail-tuple" 46 | let primBreakTuple = WNativeVar "break-tuple" 47 | let primLengthTuple = WNativeVar "length-tuple" 48 | 49 | let primNilList = WNativeVar "nil-list" 50 | let primConsList = WNativeVar "cons-list" 51 | let primSnocList = WNativeVar "snoc-list" 52 | let primHeadList = WNativeVar "head-list" 53 | let primTailList = WNativeVar "tail-list" 54 | let primBreakList = WNativeVar "break-list" 55 | let primLengthList = WNativeVar "length-list" 56 | let primIsEmptyList = WCallVar "is-empty-list" 57 | 58 | let primRefGet = WNativeVar "get" 59 | 60 | let primYield = WOperatorVar "yield!" 61 | 62 | let intEqs = 63 | Map.empty 64 | |> Map.add I8 primEqI8 65 | |> Map.add U8 primEqU8 66 | |> Map.add I16 primEqI16 67 | |> Map.add U16 primEqU16 68 | |> Map.add I32 primEqI32 69 | |> Map.add U32 primEqU32 70 | |> Map.add I64 primEqI64 71 | |> Map.add U64 primEqU64 72 | |> Map.add INative primEqINative 73 | |> Map.add UNative primEqUNative 74 | 75 | let floatEqs = 76 | Map.empty 77 | |> Map.add Single primEqSingle 78 | |> Map.add Double primEqDouble -------------------------------------------------------------------------------- /Boba.Compiler/Program.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | 4 | module Main = 5 | 6 | open System 7 | open System.IO 8 | open FSharp.Text.Lexing 9 | open UnitImport 10 | open Syntax 11 | 12 | let infoMain args = 13 | printfn "Usage: boba [command] [command-options] [arguments]" 14 | printfn "" 15 | printfn "Execute a Boba compiler command." 16 | printfn "" 17 | printfn "Commands:" 18 | printfn " build Build a Boba program from a source file with an entry point." 19 | printfn " run Build and run a Boba program from a source file with an entry point." 20 | printfn " test Run user-written tests and laws to verify code behavior." 21 | printfn " publish Publish a new or updated Boba pearl to https://pearls.tech." 22 | printfn " clean Clean build outputs and dependencies of a Boba program." 23 | printfn " docs Generate Markdown documentation from a Boba source file." 24 | printfn " format Apply code style preferences to a Boba source file." 25 | printfn " tree Generate a recursive map of the dependencies of a Boba source file." 26 | printfn "" 27 | printfn "Run 'boba [command] --help' for more information on a command." 28 | 0 29 | 30 | let loadFromMain (shortPath: string) = 31 | let env = Environment.CurrentDirectory 32 | let currDir = Path.GetDirectoryName(shortPath) 33 | if not (String.IsNullOrEmpty currDir) 34 | then Environment.CurrentDirectory <- currDir 35 | let mainModuleFileName = Path.GetFileNameWithoutExtension(shortPath) 36 | let mainModulePath = Syntax.IPLocal { Value = $"\"{mainModuleFileName}\""; Position = Position.Empty } 37 | let program = loadProgram mainModulePath 38 | Environment.CurrentDirectory <- env 39 | printfn $"Loading complete!" 40 | program, mainModulePath 41 | 42 | let loadWithMain mainFn shortPath = 43 | let program, mainModulePath = loadFromMain shortPath 44 | let organized = UnitDependencies.organize program mainModulePath 45 | let withTransformedMain = mainFn organized 46 | let renamed, startNames = Renamer.rename withTransformedMain 47 | printfn $"Renaming complete!" 48 | let expanded, typeEnv = TypeInference.inferProgram renamed 49 | printfn $"Type inference complete!" 50 | expanded, typeEnv, startNames 51 | 52 | let buildMain (args: string array) = 53 | if Seq.exists (fun arg -> arg = "--help" || arg = "-h") args 54 | then 55 | printfn "Usage: boba build [command-options] " 56 | printfn "" 57 | printfn "Build a program using the given Boba source file as program entry point." 58 | printfn "" 59 | printfn "command-options:" 60 | printfn " --help, -h Show this usage message." 61 | printfn " --inspect, -i Build the project with per-instruction VM inspection logging on stdout." 62 | 0 63 | else 64 | 65 | // optionally compile with no debug output trace 66 | let isInspect = Seq.exists (fun arg -> arg = "--inspect" || arg = "-i") args 67 | 68 | let expanded, typeEnv, startNames = loadWithMain TestGenerator.verifyHasMain args.[0] 69 | let condensed = Condenser.genCondensed expanded typeEnv 70 | let core = CoreGen.genCoreProgram condensed 71 | printfn $"Core generation complete!" 72 | let natives, blocks, constants = MochiGen.genProgram core 73 | printfn $"Bytecode generation complete!" 74 | let mainModuleFileName = Path.GetFileNameWithoutExtension(args.[0]) 75 | GoOutputGen.writeAndBuildDebug mainModuleFileName natives blocks constants isInspect 76 | 77 | let runMain (args: string array) = 78 | if Seq.exists (fun arg -> arg = "--help" || arg = "-h") args 79 | then 80 | printfn "Usage: boba run [command-options] " 81 | printfn "" 82 | printfn "Build and run a program using the given Boba source file as program entry point." 83 | printfn "" 84 | printfn "command-options:" 85 | printfn " --help, -h Show this usage message." 86 | printfn " --inspect, -i Build the project with per-instruction VM inspection logging on stdout." 87 | 0 88 | else 89 | 90 | // optionally compile with no debug output trace 91 | let mainModuleFileName = Path.GetFileNameWithoutExtension(args.[0]) 92 | let buildRes = buildMain args 93 | if buildRes = 0 94 | then GoOutputGen.runBuild mainModuleFileName 95 | else buildRes 96 | 97 | let testMain (args: string array) = 98 | if Seq.exists (fun arg -> arg = "--help" || arg = "-h") args 99 | then 100 | printfn "Usage: boba test [command-options] " 101 | printfn "" 102 | printfn "Build and run the tests present in the given Boba file." 103 | printfn "" 104 | printfn "command-options:" 105 | printfn " --help, -h Show this usage message." 106 | 0 107 | else 108 | 109 | let isInspect = false 110 | 111 | let expanded, typeEnv, startNames = loadWithMain TestGenerator.generateTestRunner args.[0] 112 | let condensed = Condenser.genCondensed expanded typeEnv 113 | let core = CoreGen.genCoreProgram condensed 114 | printfn $"Core generation complete!" 115 | let natives, blocks, constants = MochiGen.genProgram core 116 | printfn $"Bytecode generation complete!" 117 | let mainModuleFileName = Path.GetFileNameWithoutExtension(args.[0]) 118 | let buildRes = GoOutputGen.writeAndBuildDebug mainModuleFileName natives blocks constants isInspect 119 | if buildRes = 0 120 | then GoOutputGen.runBuild mainModuleFileName 121 | else buildRes 122 | 123 | let docsMain (args: string array) = 124 | if Seq.exists (fun arg -> arg = "--help" || arg = "-h") args 125 | then 126 | printfn "Usage: boba docs [command-options] " 127 | printfn "" 128 | printfn "Generate documentation for the definitions present in the given Boba file." 129 | printfn "" 130 | printfn "command-options:" 131 | printfn " --help, -h Show this usage message." 132 | 0 133 | else 134 | 135 | let expanded, typeEnv, startNames = loadWithMain TestGenerator.emptyMain args.[0] 136 | let startNameStrings = List.map (fun (n : Syntax.Name) -> n.Name) startNames 137 | let isStartName n = List.contains n startNameStrings 138 | 139 | let fresh = Boba.Core.Fresh.SimpleFresh(0) 140 | let simplifier ty = 141 | if Boba.Core.Types.isQualType ty 142 | then TypeInference.contextReduceExn fresh ty typeEnv.Classes |> snd 143 | else ty 144 | 145 | //if argv.[0] = "types" 146 | //then 147 | // Boba.Core.Environment.printEnv isStartName simplifier typeEnv 148 | // Environment.Exit 0 149 | //if argv.[0] = "types-all" 150 | //then 151 | // Boba.Core.Environment.printEnv (fun _ -> true) simplifier typeEnv 152 | // Environment.Exit 0 153 | //if argv.[0] = "docs" 154 | //then 155 | let docs = Documentation.generate args.[0] isStartName simplifier typeEnv expanded.Declarations 156 | File.WriteAllText ("docs.md", docs) 157 | 0 158 | 159 | let formatMain args = 160 | printfn "Format command is not yet implemented. Check https://github.com/glossopoeia/boba/issues for updates." 161 | 0 162 | 163 | let publishMain args = 164 | printfn "Publish command is not yet implemented. Check https://github.com/glossopoeia/boba/issues for updates." 165 | 0 166 | 167 | let treeMain args = 168 | printfn "Tree command is not yet implemented. Check https://github.com/glossopoeia/boba/issues for updates." 169 | 0 170 | 171 | let cleanMain args = 172 | printfn "Clean command is not yet implemented. Check https://github.com/glossopoeia/boba/issues for updates." 173 | 0 174 | 175 | [] 176 | let main argv = 177 | 178 | if argv.Length < 1 179 | then 180 | printfn "Boba compiler expects a command. Type 'boba info' for a list of commands." 181 | 1 182 | else 183 | let rest = Array.tail argv 184 | match argv.[0] with 185 | | "info" -> infoMain rest 186 | | "build" -> buildMain rest 187 | | "run" -> runMain rest 188 | | "test" -> testMain rest 189 | | "docs" -> docsMain rest 190 | | "publish" -> publishMain rest 191 | | "format" -> formatMain rest 192 | | "tree" -> treeMain rest 193 | | "clean" -> cleanMain rest 194 | | _ -> 195 | printfn $"Unknown command '{argv.[0]}'. Type 'boba info' for a list of commands." 196 | 1 -------------------------------------------------------------------------------- /Boba.Compiler/Shell.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | module Shell = 4 | 5 | open System.Diagnostics 6 | open System.Threading.Tasks 7 | 8 | type CommandResult = { 9 | ExitCode: int; 10 | StandardOutput: string; 11 | StandardError: string 12 | } 13 | 14 | let executeCommand executable args = 15 | async { 16 | let startInfo = ProcessStartInfo() 17 | startInfo.FileName <- executable 18 | for a in args do 19 | startInfo.ArgumentList.Add(a) 20 | startInfo.RedirectStandardOutput <- true 21 | startInfo.RedirectStandardError <- true 22 | startInfo.UseShellExecute <- false 23 | startInfo.CreateNoWindow <- true 24 | use p = new Process() 25 | p.StartInfo <- startInfo 26 | p.Start() |> ignore 27 | 28 | let outTask = Task.WhenAll([| 29 | p.StandardOutput.ReadToEndAsync(); 30 | p.StandardError.ReadToEndAsync() 31 | |]) 32 | 33 | do! p.WaitForExitAsync() |> Async.AwaitTask 34 | let! out = outTask |> Async.AwaitTask 35 | return { 36 | ExitCode = p.ExitCode; 37 | StandardOutput = out.[0]; 38 | StandardError = out.[1] 39 | } 40 | } 41 | 42 | let executeShellCommand command = 43 | executeCommand "/usr/bin/env" [ "-S"; "bash"; "-c"; command ] -------------------------------------------------------------------------------- /Boba.Compiler/TestGenerator.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | // Takes an organized program, and all the tests in the main module, and overwrites the main 4 | // function definition with calls to those tests. 5 | module TestGenerator = 6 | 7 | open Boba.Core 8 | open Boba.Core.Common 9 | open Boba.Core.Types 10 | open FSharp.Text.Lexing 11 | open Syntax 12 | open UnitDependencies 13 | 14 | let isTest decl = 15 | match decl with 16 | | DTest _ -> true 17 | | DLaw _ -> true 18 | | _ -> false 19 | 20 | let genSmallEIdent name = EIdentifier { Qualifier = []; Name = stringToSmallName name } 21 | 22 | let eqIdent = genSmallEIdent "eq" 23 | let boolNotIdent = genSmallEIdent "not-bool" 24 | let clearStringIdent = genSmallEIdent "clear-string" 25 | let gatherIdent = genSmallEIdent "gather" 26 | let spreadIdent = genSmallEIdent "spread" 27 | 28 | let letVar v body = 29 | SLet { 30 | Matcher = DotSeq.ind (PNamed (stringToSmallName v, PWildcard)) DotSeq.SEnd; 31 | Body = body } 32 | 33 | let genMultiEq left right comparison = [ 34 | EStatementBlock [ 35 | letVar "$p" [gatherIdent]; 36 | letVar "$l" (List.append left [gatherIdent]); 37 | letVar "$r" (List.append right [gatherIdent]); 38 | letVar "$c" (List.append [genSmallEIdent "$l"; genSmallEIdent "$r"] comparison); 39 | SExpression [genSmallEIdent "$p"; spreadIdent; genSmallEIdent "$c"]]] 40 | 41 | let testExprToSimpleExpr left right testKind = 42 | match testKind with 43 | | TKSatisfies -> List.append left right 44 | | TKViolates -> append3 left right [boolNotIdent] 45 | | TKIsRoughly -> failwith "is-roughly test generation is not yet implemented." 46 | | TKIs [] -> genMultiEq left right [eqIdent] 47 | | TKIsNot [] -> genMultiEq left right [eqIdent; boolNotIdent] 48 | | TKIs expr -> append3 left right expr 49 | | TKIsNot expr -> append3 left right (List.append expr [boolNotIdent]) 50 | 51 | let lawGeneratorsExprToSimpleExpr generators left right testKind = 52 | let lawAcc = stringToSmallName "law$Res" 53 | let body = testExprToSimpleExpr left right testKind 54 | let assigns = [for (g: LawParam) in generators -> { Name = g.Name; SeqType = FForIterator; Assigned = g.Generator }] 55 | let res = [{ Name = lawAcc; Assigned = [ETrue] }] 56 | [EForFold (res, assigns, [SExpression (List.concat [[genSmallEIdent "law$Res"]; body; [genSmallEIdent "and-bool"]])])] 57 | 58 | let unitTestToFunction (test : Test) = 59 | DFunc { Name = test.Name; Docs = []; Body = testExprToSimpleExpr test.Left test.Right test.Kind } 60 | 61 | let lawTestToFunction (law: Law) = 62 | DFunc { Name = law.Name; Docs = []; Body = lawGeneratorsExprToSimpleExpr law.Params law.Left law.Right law.Kind } 63 | 64 | let testToFunction testDecl = 65 | match testDecl with 66 | | DTest test -> unitTestToFunction test 67 | | DLaw law -> lawTestToFunction law 68 | | _ -> testDecl 69 | 70 | let testToCall test = 71 | match test with 72 | | DTest t -> EIdentifier { Qualifier = []; Name = t.Name; } 73 | | DLaw t -> EIdentifier { Qualifier = []; Name = t.Name; } 74 | | _ -> failwith "Somehow got a non-test in testToCall." 75 | 76 | let testName test = 77 | match test with 78 | | DTest t -> t.Name.Name 79 | | DLaw l -> l.Name.Name 80 | | _ -> "" 81 | 82 | let intToIntegerLiteral (i: int) = 83 | EInteger { Value = i.ToString(); Size = INative; Position = Position.Empty; } 84 | 85 | let stringToStringLiteral (s: string) = 86 | EString { Value = $"\"{s}\""; Position = Position.Empty } 87 | 88 | let checkName = { Name = "test-check!"; Kind = IOperator; Position = Position.Empty; } 89 | let checkIdent = { Qualifier = []; Name = checkName; } 90 | 91 | let generateTestMain tests = 92 | let callTest t = [ 93 | testToCall t; 94 | stringToStringLiteral (testName t); 95 | clearStringIdent; 96 | EIdentifier checkIdent] 97 | 98 | let handled = 99 | List.collect callTest tests 100 | |> List.append [intToIntegerLiteral 0] 101 | |> SExpression 102 | |> List.singleton 103 | 104 | let addPatVar s v = DotSeq.ind (PNamed (stringToSmallName v, PWildcard)) s 105 | 106 | let checkHandler : Boba.Compiler.Syntax.Handler = { 107 | Name = checkIdent; 108 | Body = [ 109 | EStatementBlock [ 110 | SLet { 111 | Matcher = List.fold addPatVar DotSeq.SEnd ["f"; "b"; "i"]; 112 | Body = [] }; 113 | SExpression [ 114 | genSmallEIdent "b"; 115 | genSmallEIdent "i"; 116 | genSmallEIdent "f" 117 | genSmallEIdent "test-check-handler"; 118 | genSmallEIdent "resume"]] 119 | ] 120 | } 121 | 122 | [EHandle (1, [],handled,[checkHandler],([]))] 123 | 124 | let generateTestRunner (program : OrganizedProgram) = 125 | let decls = unitDecls program.Main.Unit 126 | let tests = List.filter isTest decls 127 | let transformed = List.map testToFunction tests 128 | let newDecls = List.append (List.filter (isTest >> not) decls) transformed 129 | let newMain = generateTestMain tests 130 | { program with 131 | Main = { 132 | Path = program.Main.Path; 133 | ExportableNames = []; 134 | Unit = UMain (unitImports program.Main.Unit, newDecls, newMain) } } 135 | 136 | let verifyHasMain (program : OrganizedProgram) = 137 | match program.Main.Unit with 138 | | UMain (is, ds, m) -> { program with Main = { Path = program.Main.Path; ExportableNames = []; Unit = UMain (is, List.map testToFunction ds, m) } } 139 | | _ -> failwith "Cannot run a module with no main function. Maybe specify the 'test' flag, or compile with a different entry point unit." 140 | 141 | let emptyMain (program : OrganizedProgram) = 142 | { program with 143 | Main = { 144 | Path = program.Main.Path; 145 | ExportableNames = []; 146 | Unit = UMain ( 147 | unitImports program.Main.Unit, 148 | List.map testToFunction (unitDecls program.Main.Unit), 149 | [intToIntegerLiteral 0]) 150 | } } -------------------------------------------------------------------------------- /Boba.Compiler/UnitDependencies.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | /// Given a map of modules, the job of the dependency organizer is to arrange them such that 4 | /// we can perform type inference of units as a basic fold, from left to right. This reduces 5 | /// the need for state handling/checking of whether a declaration has been inferred during 6 | /// inference; thanks to dependency organizing, we know that all dependencies of a given 7 | /// declaration have already been checked. 8 | module UnitDependencies = 9 | 10 | open Syntax 11 | 12 | 13 | type PathUnit = { Path: ImportPath; ExportableNames: List; Unit: Unit } 14 | 15 | type OrganizedProgram = { Units: List; Main: PathUnit } 16 | 17 | 18 | 19 | let rec unitDependencies (program : Program) alreadySeen unit = 20 | let nonNativeImports = [for i in unitImports unit do if not i.Native then yield i] 21 | if not nonNativeImports.IsEmpty && List.forall (fun i -> List.contains i alreadySeen) nonNativeImports 22 | then failwith "Cyclical import detected" 23 | else 24 | [for i in nonNativeImports -> 25 | List.append (unitDependencies program (i :: alreadySeen) program.Units.[i.Path]) [i.Path]] 26 | |> List.concat 27 | |> List.distinct 28 | 29 | /// Computes an in-order dependency tree-as-a-list for the whole program. Every unit has its 30 | /// dependencies names preceding it somewhere in the list. 31 | let dependencyList program = unitDependencies program [] program.Main 32 | 33 | /// Finds the first unit in the program with the given path name. 34 | let findUnit (program: OrganizedProgram) (path: ImportPath) = 35 | try 36 | (List.find (fun (unit: PathUnit) -> unit.Path = path) program.Units).Unit 37 | with 38 | _ -> failwith $"Could not find unit {path} in program" 39 | 40 | let unitExportNames unit = 41 | let possibleExportNames = unitExportableNames unit 42 | match unitExports unit with 43 | | IUSubset es -> 44 | let pubNames = namesToStrings es 45 | if Set.isSubset (Set.ofSeq pubNames) (Set.ofSeq possibleExportNames) 46 | then pubNames 47 | else failwith $"Tried to export names that could not be found in declarations." 48 | | IUAll -> possibleExportNames 49 | 50 | /// Give a program with units that were loaded/stored in arbitrary order, compute the dependencies 51 | /// of the program and order the units from least dependent to most. The result is a program with 52 | /// a list of units where each unit is preceded by its dependencies. Circular units are not currently 53 | /// permitted. 54 | let organize (program : Syntax.Program) mainPath = 55 | { 56 | Units = [for d in dependencyList program -> 57 | let exportableNames = unitExportNames program.Units.[d] |> List.ofSeq 58 | { Path = d; ExportableNames = exportableNames; Unit = program.Units.[d] }] 59 | Main = { Path = mainPath; ExportableNames = unitExportNames program.Main |> List.ofSeq; Unit = program.Main } 60 | } -------------------------------------------------------------------------------- /Boba.Compiler/UnitImport.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Compiler 2 | 3 | module UnitImport = 4 | 5 | open System 6 | open System.IO 7 | open System.Net.Http 8 | open FSharp.Text.Lexing 9 | open Syntax 10 | 11 | let remotePathToUrl r = 12 | $"https://raw.github.com/{r.Org.Name}/{r.Project.Name}/{r.Major.Value}.{r.Minor.Value}.{r.Patch.Value}/{r.Unit.Name}.boba" 13 | 14 | let getCachedRemote remotePath = 15 | let r = remotePath 16 | let cacheFolder = Path.Combine ("boba-pearls", $"{r.Org.Name}.{r.Project.Name}.{r.Unit.Name}.{r.Major.Value}.{r.Minor.Value}.{r.Patch.Value}") 17 | let cacheFolderPath = Path.Combine (Path.GetTempPath (), cacheFolder) 18 | Directory.CreateDirectory cacheFolderPath |> ignore 19 | 20 | let cacheFilePath = Path.Combine (cacheFolderPath, $"unit.boba") 21 | if not (File.Exists cacheFilePath) 22 | then 23 | printfn $"Module {IPRemote r} not cached, downloading..." 24 | let url = remotePathToUrl r 25 | try 26 | let content = (new HttpClient()).GetStringAsync(url) |> Async.AwaitTask |> Async.RunSynchronously 27 | try 28 | File.WriteAllText (cacheFilePath, content) 29 | with 30 | ex -> printfn $"Failed to cache {IPRemote r} with {ex}" 31 | content 32 | with 33 | _ -> failwith $"Import {IPRemote r} could not be located at {url}." 34 | else 35 | File.ReadAllText cacheFilePath 36 | 37 | let getModuleText modulePath = 38 | match modulePath with 39 | | IPLocal _ -> File.ReadAllText $"{modulePath}.boba" 40 | | IPRemote name -> getCachedRemote name 41 | 42 | let parseModule modulePath buffer = 43 | try 44 | Parser.unit Lexer.token buffer 45 | with e -> 46 | failwith $"Parse failed in '{modulePath}' at: {buffer.EndPos.Line}, {buffer.EndPos.Column}\n with '{String(buffer.Lexeme)}'" 47 | 48 | let loadModule path = 49 | getModuleText path 50 | |> LexBuffer.FromString 51 | |> parseModule path 52 | 53 | let makeAbsolutePathTo parent path = 54 | match path with 55 | | IPLocal _ -> 56 | match parent with 57 | | IPLocal l -> IPLocal { l with Value = "\"" + $"""{(Path.Combine(Path.GetDirectoryName($"{parent}"), $"{path}"))}""" + "\"" } 58 | | IPRemote r -> IPRemote { r with Unit = { r.Unit with Name = $"{path}" } } 59 | | IPRemote _ -> path 60 | 61 | let injectCoreImport imps = 62 | List.append imps [{ 63 | Native = false 64 | Unaliased = IUAll 65 | Alias = stringToSmallName "" 66 | Path = IPRemote { 67 | Org = stringToSmallName "glossopoeia" 68 | Project = stringToSmallName "boba-core" 69 | Unit = stringToSmallName "core" 70 | Major = intToLiteral "0" 71 | Minor = intToLiteral "0" 72 | Patch = intToLiteral "22" 73 | } }] 74 | 75 | let rec loadDependencies alreadySeen imports loaded = 76 | match imports with 77 | | [] -> loaded 78 | | i :: is -> 79 | if not (List.contains i alreadySeen) 80 | then 81 | let load = loadModule i 82 | let absolutePathImports = 83 | [ 84 | for sub in unitImports load -> 85 | if not sub.Native 86 | then { sub with Path = makeAbsolutePathTo i sub.Path } 87 | else sub 88 | ] 89 | let imports = 90 | match i with 91 | | IPRemote { Org = o; Project = p } when o.Name = "glossopoeia" && p.Name = "boba-core" -> 92 | absolutePathImports 93 | | _ -> injectCoreImport absolutePathImports 94 | let load = unitSetImports load imports 95 | let newImps = [for subI in unitImports load do if not subI.Native then yield subI.Path] 96 | loadDependencies (i :: alreadySeen) (List.append is newImps) (Map.add i load loaded) 97 | else 98 | loadDependencies alreadySeen is loaded 99 | 100 | let loadProgram entryPath = 101 | let start = loadModule entryPath 102 | let absolutePathImports = 103 | [ 104 | for i in unitImports start -> 105 | if not i.Native 106 | then { i with Path = makeAbsolutePathTo entryPath i.Path } 107 | else i 108 | ] 109 | let start = unitSetImports start (injectCoreImport absolutePathImports) 110 | let imports = [for i in unitImports start do if not i.Native then yield i.Path] 111 | let deps = loadDependencies [entryPath] imports Map.empty 112 | { Units = deps; Main = start } -------------------------------------------------------------------------------- /Boba.Core.Test/AbelianTests.fs: -------------------------------------------------------------------------------- 1 | module AbelianTests 2 | 3 | open Xunit 4 | open Boba.Core 5 | 6 | [] 7 | let ``Match succeed: 0 ~> 0`` () = 8 | Assert.StrictEqual( 9 | Some Map.empty, 10 | Abelian.matchEqns (new Fresh.SimpleFresh(0)) (new Abelian.Equation()) (new Abelian.Equation())) 11 | 12 | [] 13 | let ``Match succeed: a ~> b`` () = 14 | Assert.StrictEqual( 15 | Some (Map.empty.Add("a", new Abelian.Equation("b"))), 16 | Abelian.matchEqns 17 | (new Fresh.SimpleFresh(0)) 18 | (new Abelian.Equation("a")) 19 | (new Abelian.Equation("b"))) 20 | 21 | [] 22 | let ``Match succeed: A^2 * B^3 ~> B^3 * A^2`` () = 23 | let constLeft = Map.empty.Add("A", 2).Add("B", 3) 24 | let constRight = Map.empty.Add("B", 3).Add("A", 2) 25 | Assert.StrictEqual( 26 | Some Map.empty, 27 | Abelian.matchEqns (new Fresh.SimpleFresh(0)) (new Abelian.Equation(Map.empty, constLeft)) (new Abelian.Equation(Map.empty, constRight))) 28 | 29 | [] 30 | let ``Match succeed: x^2 * y^1 ~> z^3`` () = 31 | let leftEqn = Map.empty.Add("x", 2).Add("y", 1) 32 | let rightEqn = Map.empty.Add("z", 3) 33 | let matcher = 34 | Abelian.matchEqns 35 | (new Fresh.SimpleFresh(0)) 36 | (new Abelian.Equation(leftEqn, Map.empty)) 37 | (new Abelian.Equation(rightEqn, Map.empty)) 38 | 39 | Assert.StrictEqual( 40 | Some (Map.empty.Add("x", (new Abelian.Equation("a0"))).Add("y", new Abelian.Equation(Map.empty.Add("a0", -2).Add("z", 3), Map.empty))), 41 | matcher) 42 | 43 | [] 44 | let ``Match fail: x^2 ~> x * y`` () = 45 | let leftEqn = Map.empty.Add("x", 2) 46 | let rightEqn = Map.empty.Add("x", 1).Add("y", 1) 47 | Assert.StrictEqual(None, Abelian.matchEqns (new Fresh.SimpleFresh(0)) (new Abelian.Equation(leftEqn, Map.empty)) (new Abelian.Equation(rightEqn, Map.empty))) 48 | 49 | [] 50 | let ``Match succeed: x^64 * y^-41 ~> 1`` () = 51 | let leftEqn = Map.empty.Add("x", 64).Add("y", -41) 52 | let rightEqn = Map.empty.Add("a", 1) 53 | let matcher = 54 | Abelian.matchEqns 55 | (new Fresh.SimpleFresh(0)) 56 | (new Abelian.Equation(leftEqn, Map.empty)) 57 | (new Abelian.Equation(rightEqn, Map.empty)) 58 | 59 | let expected = 60 | Some 61 | (Map.empty 62 | .Add("x", (new Abelian.Equation(Map.empty.Add("a", -16).Add("a6", -41), Map.empty))) 63 | .Add("y", new Abelian.Equation(Map.empty.Add("a", -25).Add("a6", -64), Map.empty))) 64 | 65 | Assert.StrictEqual(expected, matcher) 66 | 67 | [] 68 | let ``Unify succeed: x^2 * y ~ z^3`` () = 69 | let leftEqn = Map.empty.Add("x", 2).Add("y", 1) 70 | let rightEqn = Map.empty.Add("z", 3) 71 | let unifier = 72 | Abelian.unify 73 | (new Fresh.SimpleFresh(0)) 74 | (new Abelian.Equation(leftEqn, Map.empty)) 75 | (new Abelian.Equation(rightEqn, Map.empty)) 76 | let expected = 77 | Some 78 | (Map.empty 79 | .Add("x", (new Abelian.Equation("a0"))) 80 | .Add("y", new Abelian.Equation(Map.empty.Add("a0", -2).Add("a2", 3), Map.empty)) 81 | .Add("z", new Abelian.Equation("a2"))) 82 | Assert.StrictEqual(expected, unifier) 83 | 84 | [] 85 | let ``Unify succeed: a ~ b`` () = 86 | let unifier = 87 | Abelian.unify 88 | (new Fresh.SimpleFresh(0)) 89 | (new Abelian.Equation(Map.empty.Add("a", 1), Map.empty)) 90 | (new Abelian.Equation(Map.empty.Add("b", 1), Map.empty)) 91 | let expected = 92 | Some (Map.empty 93 | .Add("a", new Abelian.Equation("a1")) 94 | .Add("b", new Abelian.Equation("a1"))) 95 | Assert.StrictEqual(expected, unifier) -------------------------------------------------------------------------------- /Boba.Core.Test/Boba.Core.Test.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net6.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 | runtime; build; native; contentfiles; analyzers; buildtransitive 29 | all 30 | 31 | 32 | runtime; build; native; contentfiles; analyzers; buildtransitive 33 | all 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /Boba.Core.Test/BooleanTests.fs: -------------------------------------------------------------------------------- 1 | module BooleanTests 2 | 3 | open Xunit 4 | open Boba.Core.Boolean 5 | 6 | [] 7 | let ``Truth id: a = 0b10`` () = 8 | Assert.StrictEqual(0b10, truthId (BVar "a") ["a"]) 9 | 10 | [] 11 | let ``Truth id: !a = 0b01`` () = 12 | Assert.StrictEqual(0b01, truthId (mkNot (BVar "a")) ["a"]) 13 | 14 | [] 15 | let ``Unify succeed: true ~ true`` () = 16 | Assert.StrictEqual(Some Map.empty, unify BTrue BTrue) 17 | 18 | [] 19 | let ``Unify succeed: false ~ false`` () = 20 | Assert.StrictEqual(Some Map.empty, unify BFalse BFalse) 21 | 22 | [] 23 | let ``Unify fail: true ~ false`` () = 24 | Assert.StrictEqual(None, unify BTrue BFalse) 25 | 26 | [] 27 | let ``Unify fail: a ~ !a`` () = 28 | Assert.StrictEqual(None, unify (BVar "a") (BNot (BVar "a"))) 29 | 30 | [] 31 | let ``Unify succeed: a ∧ b ~ True`` () = 32 | Assert.StrictEqual(Some (Map.empty.Add("a", BTrue).Add("b", BTrue)), unify (BAnd (BVar "a", BVar "b")) BTrue) 33 | 34 | [] 35 | let ``Unify succeed: a ∧ b ~ False`` () = 36 | Assert.StrictEqual(Some (Map.empty.Add("a", BAnd (BVar "a", BNot (BVar "b"))).Add("b", BVar "b")), unify (BAnd (BVar "a", BVar "b")) BFalse) 37 | 38 | [] 39 | let ``Unify succeed: a || b ~ True`` () = 40 | Assert.StrictEqual(Some (Map.empty.Add("a", BOr (BVar "a", BNot (BVar "b"))).Add("b", BVar "b")), unify (BOr (BVar "a", BVar "b")) BTrue) 41 | 42 | [] 43 | let ``Unify succeed: a || b ~ False`` () = 44 | Assert.StrictEqual(Some (Map.empty.Add("a", BFalse).Add("b", BFalse)), unify (BOr (BVar "a", BVar "b")) BFalse) 45 | 46 | [] 47 | let ``Unify succeed: a ~ b ∨ c`` () = 48 | Assert.StrictEqual( 49 | Some (Map.empty.Add("a", BOr (BVar "b", BVar "c")).Add("b", BVar "b").Add("c", BVar "c")), 50 | unify (BVar "a") (BOr (BVar "b", BVar "c"))) 51 | 52 | [] 53 | let ``Unify succeed: c ~ a ∨ b`` () = 54 | Assert.StrictEqual( 55 | Some (Map.empty.Add("c", BOr (BVar "a", BVar "b")).Add("a", BVar "a").Add("b", BVar "b")), 56 | unify (BVar "c") (BOr (BVar "a", BVar "b"))) 57 | 58 | [] 59 | let ``Unify succeed: b ~ a ∨ c`` () = 60 | Assert.StrictEqual( 61 | Some (Map.empty.Add("b", mkOr (BVar "a") (BVar "c")).Add("a", BVar "a").Add("c", BVar "c")), 62 | unify (BVar "b") (mkOr (BVar "a") (BVar "c"))) 63 | 64 | [] 65 | let ``Unify succeed: a ∨ b ~ a ∧ b`` () = 66 | Assert.StrictEqual(Some (Map.empty.Add("a", BVar "b").Add("b", BVar "b")), unify (BAnd (BVar "a", BVar "b")) (BOr (BVar "a", BVar "b"))) 67 | 68 | [] 69 | let ``Match succeed: b ~> b`` () = 70 | Assert.StrictEqual(Some (Map.empty.Add("b", BRigid "b")), unify (BVar "b") (BRigid "b")) 71 | 72 | [] 73 | let ``Match succeed: a ~> b`` () = 74 | Assert.StrictEqual(Some (Map.empty.Add("a", BRigid "b")), unify (BVar "a") (BRigid "b")) 75 | 76 | [] 77 | let ``Match succeed: a ~> b ∧ c`` () = 78 | Assert.StrictEqual(Some (Map.empty.Add("a", BAnd (BRigid "b", BRigid "c"))), unify (BVar "a") (BAnd (BRigid "b", BRigid "c"))) 79 | 80 | [] 81 | let ``Match succeed: b ∧ c ~> a`` () = 82 | let bsub = BOr (BRigid "a", BAnd (BVar "b", BNot (BVar "c"))) 83 | let csub = BOr (BRigid "a", BVar "c") 84 | Assert.StrictEqual(Some (Map.empty.Add("b", bsub).Add("c", csub)), unify (BAnd (BVar "b", BVar "c")) (BRigid "a")) -------------------------------------------------------------------------------- /Boba.Core.Test/CHRTests.fs: -------------------------------------------------------------------------------- 1 | module CHRTests 2 | 3 | open Xunit 4 | open Boba.Core.Fresh 5 | open Boba.Core.DotSeq 6 | open Boba.Core.Kinds 7 | open Boba.Core.Types 8 | open Boba.Core.TypeBuilder 9 | open Boba.Core.Unification 10 | open Boba.Core.CHR 11 | 12 | let intType = typeCon "Int" primValueKind 13 | let floatType = typeCon "Float" primValueKind 14 | let boolType = typeCon "Bool" primValueKind 15 | let listType = typeApp (typeCon "[]" (karrow primValueKind primValueKind)) 16 | let fnType arg ret = typeApp (typeApp (typeCon "->" (karrow primValueKind (karrow primValueKind primValueKind))) arg) ret 17 | 18 | let leqInsRules = [ 19 | // Leq (Int -> Int -> Bool) <==> True 20 | RSimplification ([typeConstraint "Leq" [fnType intType (fnType intType boolType)]], SEnd) 21 | // Leq (Float -> Float -> Bool) <==> True 22 | RSimplification ([typeConstraint "Leq" [fnType floatType (fnType floatType boolType)]], SEnd) 23 | // Ins ([a] -> a -> [a]) <==> Leq (a -> a -> Bool) 24 | RSimplification ( 25 | [typeConstraint "Ins" [fnType (listType (valueVar "a")) (fnType (valueVar "a") (listType (valueVar "a")))]], 26 | (ind (CPredicate (typeConstraint "Leq" [fnType (valueVar "a") (fnType (valueVar "a") boolType)])) SEnd)) 27 | // Leq t ==> t = a -> a -> Bool 28 | RPropagation ([typeConstraint "Leq" [valueVar "t"]], [CEquality (typeEqConstraint (valueVar "t") (fnType (valueVar "a") (fnType (valueVar "a") boolType)))]) 29 | // Ins t ==> t = ce -> e -> ce 30 | RPropagation ([typeConstraint "Ins" [valueVar "t"]], [CEquality (typeEqConstraint (valueVar "t") (fnType (valueVar "ce") (fnType (valueVar "c") (valueVar "ce"))))]) 31 | // Ins ([a] -> b -> [a]) ==> b = a 32 | RPropagation ( 33 | [typeConstraint "Ins" [fnType (listType (valueVar "a")) (fnType (valueVar "b") (listType (valueVar "a")))]], 34 | [CEquality (typeEqConstraint (valueVar "b") (valueVar "a"))]) 35 | ] 36 | 37 | let ordEqRules = [ 38 | // Eq (Int -> Int -> Bool) <==> True 39 | RSimplification ([typeConstraint "Eq" [fnType intType (fnType intType boolType)]], SEnd) 40 | // Eq ([a] -> [a] -> Bool) <==> Eq (a -> a -> Bool) 41 | RSimplification ( 42 | [typeConstraint "Eq" [fnType (listType (valueVar "a")) (fnType (listType (valueVar "a")) boolType)]], 43 | (ind (CPredicate (typeConstraint "Eq" [fnType (valueVar "a") (fnType (valueVar "a") boolType)])) SEnd)) 44 | // Ord ([a] -> [a] -> Bool) <==> True 45 | RSimplification ([typeConstraint "Ord" [fnType (listType (valueVar "a")) (fnType (listType (valueVar "a")) boolType)]], SEnd) 46 | // Ord t ==> Eq t 47 | RPropagation ([typeConstraint "Ord" [valueVar "t"]], [CPredicate (typeConstraint "Eq" [valueVar "t"])]) 48 | ] 49 | 50 | let eqLeqSimplRules = [ 51 | // Eq t, Leq t <==> Ord t 52 | RSimplification ( 53 | [typeConstraint "Eq" [valueVar "t"]; typeConstraint "Leq" [valueVar "t"]], 54 | ind (CPredicate (typeConstraint "Ord" [valueVar "t"])) SEnd) 55 | ] 56 | 57 | [] 58 | let ``Compute 'Ins ([z] -> y -> x)' ~> 'Leq (z -> z -> Bool)'`` () = 59 | let problem = Set.singleton (typeConstraint "Ins" [fnType (listType (valueVar "z")) (fnType (valueVar "y") (valueVar "x"))]) 60 | let result = typeConstraint "Leq" [fnType (valueVar "z") (fnType (valueVar "z") boolType)] 61 | let fresh = new SimpleFresh(0) 62 | let res = solvePredicates fresh true leqInsRules problem 63 | Assert.StrictEqual(1, res.Length) 64 | Assert.True(isTypeMatch fresh result (fst res[0]).MaximumElement) 65 | Assert.True(isTypeMatch fresh (fst res[0]).MaximumElement result) 66 | 67 | [] 68 | let ``Compute 'Ord ([a] -> [a] -> Bool)' ~> '' and 'Eq (a -> a -> Bool)'`` () = 69 | let problem = Set.singleton (typeConstraint "Ord" [fnType (listType (valueVar "a")) (fnType (listType (valueVar "a")) boolType)]) 70 | let resultTwo = typeConstraint "Eq" [fnType (valueVar "a") (fnType (valueVar "a") boolType)] 71 | let fresh = new SimpleFresh(0) 72 | let res = solvePredicates fresh true ordEqRules problem 73 | Assert.StrictEqual(2, res.Length) 74 | Assert.StrictEqual(Set.empty, fst res[1]) 75 | Assert.True(isTypeMatch fresh resultTwo (fst res[0]).MaximumElement) 76 | Assert.True(isTypeMatch fresh (fst res[0]).MaximumElement resultTwo) 77 | 78 | [] 79 | let ``Multihead simplification 'Eq t, Leq t' ~> 'Ord t'`` () = 80 | let problem = 81 | Set.empty 82 | |> Set.add (typeConstraint "Leq" [valueVar "a"]) 83 | |> Set.add (typeConstraint "Eq" [valueVar "a"]) 84 | let result = typeConstraint "Ord" [valueVar "a"] 85 | let fresh = new SimpleFresh(0) 86 | let res = solvePredicates fresh true eqLeqSimplRules problem 87 | Assert.StrictEqual(1, res.Length) 88 | Assert.StrictEqual(1, Set.count (fst res[0])) 89 | Assert.True(isTypeMatch fresh result (fst res[0]).MaximumElement) 90 | Assert.True(isTypeMatch fresh (fst res[0]).MaximumElement result) 91 | 92 | [] 93 | let ``Multihead simplification that doesnt reduce`` () = 94 | let problem = 95 | Set.empty 96 | |> Set.add (typeConstraint "Leq" [valueVar "a"]) 97 | |> Set.add (typeConstraint "Eq" [valueVar "b"]) 98 | let fresh = new SimpleFresh(0) 99 | let res = solvePredicates fresh true eqLeqSimplRules problem 100 | Assert.StrictEqual(1, res.Length) 101 | Assert.StrictEqual(2, Set.count (fst res[0])) -------------------------------------------------------------------------------- /Boba.Core.Test/DotSeqTests.fs: -------------------------------------------------------------------------------- 1 | module DotSeqTests 2 | 3 | open Xunit 4 | open Boba.Core.DotSeq 5 | 6 | [] 7 | let ``DotSeq.ofList maintains list order`` () = 8 | Assert.StrictEqual(ind 1 (ind 2 (ind 3 SEnd)), ofList [1;2;3]) 9 | 10 | [] 11 | let ``DotSeq.toList maintains list order`` () = 12 | Assert.StrictEqual(toList (ind 1 (ind 2 (ind 3 SEnd))), [1;2;3]) -------------------------------------------------------------------------------- /Boba.Core.Test/KindTests.fs: -------------------------------------------------------------------------------- 1 | module KindTests 2 | 3 | open Xunit 4 | open Boba.Core.DotSeq 5 | open Boba.Core.Kinds 6 | 7 | [] 8 | let ``No top kind equality`` () = 9 | Assert.True( 10 | kindEq 11 | (karrow (kseq (krow (kvar "s"))) (krow (kseq (KUser ("K", KUSyntactic))))) 12 | (karrow (kseq (krow (kvar "s"))) (krow (kseq (KUser ("K", KUSyntactic)))))) 13 | 14 | [] 15 | let ``Top kind equality`` () = 16 | Assert.True(kindEq KAny (kvar "s")) 17 | Assert.True(kindEq (kvar "s") KAny) 18 | Assert.True( 19 | kindEq 20 | (karrow (kseq (krow KAny)) (krow (kseq (KUser ("K", KUSyntactic))))) 21 | (karrow (kseq (krow (kvar "s"))) (krow (kseq KAny)))) 22 | 23 | [] 24 | let ``Can apply kind respects _ supertype in arrow`` () = 25 | Assert.True(canApplyKind (karrow (kvar "i") (kvar "o")) (kvar "i")) 26 | Assert.True(canApplyKind (karrow KAny (kvar "o")) (kvar "i")) 27 | Assert.True(canApplyKind (karrow (kseq KAny) (kvar "o")) (kseq (kvar "i"))) 28 | 29 | [] 30 | let ``Can apply kind respects _ supertype in argument`` () = 31 | Assert.True(canApplyKind (karrow (krow (kvar "i")) (kvar "o")) (krow (kvar "i"))) 32 | Assert.True(canApplyKind (karrow (kvar "i") (kvar "o")) KAny) 33 | Assert.True(canApplyKind (karrow (kseq (kvar "i")) (kvar "o")) (kseq KAny)) 34 | Assert.True(canApplyKind (karrow (kseq (kseq (kvar "s"))) (kvar "o")) (kseq KAny)) 35 | 36 | [] 37 | let ``Can apply fails when not arrow and arg not equal input`` () = 38 | Assert.False(canApplyKind (kvar "s") (kvar "s")) 39 | Assert.False(canApplyKind (kseq (kvar "s")) KAny) 40 | Assert.False(canApplyKind KAny KAny) 41 | Assert.False(canApplyKind (karrow (kvar "i") (kvar "o")) (kvar "x")) 42 | Assert.False(canApplyKind (karrow (kseq (kseq (kvar "s"))) (kvar "o")) (kseq (kvar "s"))) 43 | 44 | [] 45 | let ``Kind apply respects _ supertype in arrow`` () = 46 | Assert.StrictEqual(kvar "o", applyKindExn (karrow (kvar "i") (kvar "o")) (kvar "i")) 47 | Assert.StrictEqual(kvar "o", applyKindExn (karrow KAny (kvar "o")) (kvar "i")) 48 | Assert.StrictEqual(kvar "o", applyKindExn (karrow (kseq KAny) (kvar "o")) (kseq (kvar "i"))) 49 | 50 | [] 51 | let ``Kind apply respects _ supertype in argument`` () = 52 | Assert.StrictEqual(kvar "o", applyKindExn (karrow (krow (kvar "i")) (kvar "o")) (krow (kvar "i"))) 53 | Assert.StrictEqual(kvar "o", applyKindExn (karrow (kvar "i") (kvar "o")) KAny) 54 | Assert.StrictEqual(kvar "o", applyKindExn (karrow (kseq (kvar "i")) (kvar "o")) (kseq KAny)) 55 | 56 | [] 57 | let ``Kind apply throws when not arrow and arg not equal input`` () = 58 | Assert.Throws(fun () -> applyKindExn (kvar "s") (kvar "s") |> ignore) |> ignore 59 | Assert.Throws(fun () -> applyKindExn (kseq (kvar "s")) KAny |> ignore) |> ignore 60 | Assert.Throws(fun () -> applyKindExn KAny KAny |> ignore) |> ignore 61 | Assert.Throws(fun () -> applyKindExn (karrow (kvar "i") (kvar "o")) (kvar "x") |> ignore) 62 | 63 | [] 64 | let ``Max kinds of empty and non-empty nested sequences`` () = 65 | Assert.StrictEqual(kseq (kseq (kseq KAny)), maxKindsExn (ind KAny (ind (kseq KAny) (ind (kseq (kseq KAny)) (ind (kseq (kseq (kseq KAny))) SEnd))))) -------------------------------------------------------------------------------- /Boba.Core.Test/LinearTests.fs: -------------------------------------------------------------------------------- 1 | module LinearTests 2 | 3 | open Xunit 4 | open Boba.Core 5 | open FsCheck 6 | open FsCheck.Xunit 7 | 8 | [] 9 | let ``Empty equation has no solution`` () = 10 | Assert.StrictEqual(None, Linear.solve { Coefficients = []; Constants = [] }) 11 | 12 | [] 13 | let ``Simple equality has just its equality as solution`` (NonZeroInt coeff) = 14 | let subst = Map.empty.Add(0, { Coefficients = [0]; Constants = [0] }) 15 | Assert.StrictEqual(Some subst, Linear.solve { Coefficients = [coeff]; Constants = [0] }) 16 | 17 | [] 18 | let ``Two variables with the same coefficients is equivalent to subtraction`` (NonZeroInt coeff) = 19 | let subst = Map.empty.Add(0, { Coefficients = [0; -1]; Constants = [0] }) 20 | Assert.StrictEqual(Some subst, Linear.solve { Coefficients = [coeff; coeff]; Constants = [0] }) 21 | 22 | [] 23 | let ``Two variables with inverted coefficients is equivalent to addition`` (NonZeroInt coeff) = 24 | let subst = Map.empty.Add(0, { Coefficients = [0; 1]; Constants = [0] }) 25 | Assert.StrictEqual(Some subst, Linear.solve { Coefficients = [coeff; -coeff]; Constants = [0] }) 26 | 27 | [] 28 | let ``Two variables with inverted coefficients equal to double the absoute value of their coefficients`` (NonZeroInt coeff) = 29 | let subst = Map.empty.Add(0, { Coefficients = [0; 1]; Constants = [2] }) 30 | Assert.StrictEqual(Some subst, Linear.solve { Coefficients = [coeff; -coeff]; Constants = [coeff * 2] }) 31 | 32 | [] 33 | let ``5x + 10y = 18 ~~> no solution`` () = 34 | Assert.StrictEqual(None, Linear.solve { Coefficients = [5; 10]; Constants = [18] }) 35 | 36 | [] 37 | let ``Complex matching two variable test #1: 5x + 3y = 0`` () = 38 | let subst = 39 | Map.empty 40 | .Add(0, { Coefficients = [0; 0; 0; 3]; Constants = [0] }) 41 | .Add(1, { Coefficients = [0; 0; 0; -5]; Constants = [0] }) 42 | Assert.StrictEqual(Some subst, Linear.solve { Coefficients = [5; 3]; Constants = [0] }) 43 | 44 | [] 45 | let ``Complex matching two variable test #2: 64x - 41y = 1`` () = 46 | let subst = 47 | Map.empty 48 | .Add(0, { Coefficients = [0; 0; 0; 0; 0; 0; -41]; Constants = [-16] }) 49 | .Add(1, { Coefficients = [0; 0; 0; 0; 0; 0; -64]; Constants = [-25] }) 50 | Assert.StrictEqual(Some subst, Linear.solve { Coefficients = [64; -41]; Constants = [1] }) -------------------------------------------------------------------------------- /Boba.Core.Test/Program.fs: -------------------------------------------------------------------------------- 1 | module Program = let [] main _ = 0 2 | -------------------------------------------------------------------------------- /Boba.Core.Test/QuineMcCluskeyTest.fs: -------------------------------------------------------------------------------- 1 | module QuineMcCluskeyTests 2 | 3 | open Xunit 4 | open Boba.Core.Boolean 5 | 6 | [] 7 | let ``Minimize: a => a`` () = 8 | Assert.StrictEqual(BVar "a", minimize (BVar "a")) 9 | 10 | [] 11 | let ``Minimize: a & a => a`` () = 12 | Assert.StrictEqual(BVar "a", minimize (BAnd (BVar "a", BVar "a"))) 13 | 14 | [] 15 | let ``Minimize: b | b => b`` () = 16 | Assert.StrictEqual(BVar "b", minimize (BOr (BVar "b", BVar "b"))) 17 | 18 | [] 19 | let ``Minimize: a | b | c | d | e => a | b | c | d | e`` () = 20 | let orVal = BOr (BOr (BOr (BOr (BVar "a", BVar "b"), BVar "c"), BVar "d"), BVar "e") 21 | Assert.StrictEqual(orVal, minimize orVal) 22 | 23 | [] 24 | let ``Minimize: a | b | c | d | e | f | g | h => a | b | c | d | e | f | g | h`` () = 25 | let orVal = BOr (BOr (BOr (BOr (BOr (BOr (BVar "a", BVar "b"), BVar "c"), BVar "d"), BVar "e"), BVar "g"), BVar "h") 26 | Assert.StrictEqual(orVal, minimize orVal) 27 | 28 | [] 29 | let ``Minimize: a | (b & c) => `` () = 30 | let eqn = BOr (BVar "a", BAnd (BVar "b", BVar "c")) 31 | Assert.StrictEqual(eqn, minimize eqn) 32 | 33 | [] 34 | let ``Minimize: a... | b => a... | b`` () = 35 | let eqn = BOr (BDotVar "a", BVar "b") 36 | Assert.StrictEqual(eqn, minimize eqn) 37 | 38 | [] 39 | let ``Minimize: a | (b & e) | (b & f) | a | (b & !g) | a => a | (b & e) | (b & f) | (b & !g)`` () = 40 | let eqn = BOr (BOr (BOr (BOr (BOr (BVar "a", BAnd (BVar "b", BVar "e")), BAnd (BVar "b", BVar "f")), BVar "a"), BAnd (BVar "f", BNot (BVar "g"))), BVar "a") 41 | let sol = BOr (BOr (BOr (BVar "a", BAnd (BVar "b", BVar "e")), BAnd (BVar "b", BVar "f")), BAnd (BVar "f", BNot (BVar "g"))) 42 | Assert.StrictEqual(sol, minimize eqn) -------------------------------------------------------------------------------- /Boba.Core.Test/SubstitutionTests.fs: -------------------------------------------------------------------------------- 1 | module SubstitutionTests 2 | 3 | open Xunit 4 | open Boba.Core.DotSeq 5 | open Boba.Core.Fresh 6 | open Boba.Core.Kinds 7 | open Boba.Core.Types 8 | open Boba.Core.TypeBuilder 9 | 10 | [] 11 | let ``Kind of sequence`` () = 12 | let seq1 = typeSeq (ind (typeCon "s" primValueKind) SEnd) 13 | let seq2 = typeSeq (ind (typeCon "s" primValueKind) (ind (typeCon "t" primValueKind) SEnd)) 14 | Assert.StrictEqual(kseq primValueKind, typeKindExn seq1) 15 | Assert.StrictEqual(kseq primValueKind, typeKindExn seq2) 16 | 17 | [] 18 | let ``Kind of empty sequence`` () = 19 | Assert.StrictEqual(kseq KAny, typeKindExn (typeSeq SEnd)) 20 | Assert.StrictEqual(kseq KAny, typeKindExn (typeSeq SEnd)) 21 | Assert.StrictEqual(kseq KAny, typeKindExn (typeSeq SEnd)) 22 | 23 | [] 24 | let ``Invalid kind of sequence`` () = 25 | let invalidSeq = typeSeq (ind (typeCon "s" primValueKind) (ind (typeCon "t" primDataKind) SEnd)) 26 | Assert.Throws(fun () -> typeKindExn invalidSeq |> ignore) 27 | 28 | [] 29 | let ``Compute value kind`` () = 30 | let valType = mkValueType (typeVar "d" primDataKind) (typeVar "s" primSharingKind) 31 | Assert.StrictEqual(primValueKind, typeKindExn valType) 32 | 33 | [] 34 | let ``Compute constraint kind`` () = 35 | let qual = qualType (ind (typeCon "C" primConstraintKind) SEnd) (typeVar "v" primValueKind) 36 | Assert.StrictEqual(primValueKind, typeKindExn qual) 37 | 38 | [] 39 | let ``Compute fn kind`` () = 40 | let fn = 41 | try 42 | typeKindExn 43 | (mkFunctionType 44 | (typeVar "e" (krow primEffectKind)) 45 | (typeVar "p" (krow primPermissionKind)) 46 | (typeVar "t" primTotalityKind) 47 | (typeSeq (dot (typeVar "z" primValueKind) SEnd)) 48 | (typeSeq (dot (typeVar "z" primValueKind) SEnd))) 49 | with 50 | | KindApplyArgMismatch (l, r) -> karrow l r 51 | Assert.StrictEqual(primDataKind, fn) -------------------------------------------------------------------------------- /Boba.Core.Test/UnificationTests.fs: -------------------------------------------------------------------------------- 1 | module UnificationTests 2 | 3 | open Xunit 4 | open Boba.Core.DotSeq 5 | open Boba.Core.Fresh 6 | open Boba.Core.Kinds 7 | open Boba.Core.Types 8 | open Boba.Core.Unification 9 | 10 | [] 11 | let ``Unify succeed: A ~ A`` () = 12 | let subst = typeUnifyExn (new SimpleFresh(0)) (typeCon "A" primValueKind) (typeCon "A" primValueKind) 13 | Assert.StrictEqual(Map.empty, subst.Types) 14 | Assert.StrictEqual(Map.empty, subst.Types) 15 | 16 | [] 17 | let ``Unify fail: A ~ B -- constructor mismatch`` () = 18 | Assert.Throws(fun () -> typeUnifyExn (new SimpleFresh(0)) (typeCon "A" primValueKind) (typeCon "B" primValueKind) |> ignore) 19 | 20 | [] 21 | let ``Unify succeed: a ~ a`` () = 22 | let subst = typeUnifyExn (new SimpleFresh(0)) (typeVar "a" primValueKind) (typeVar "a" primValueKind) 23 | Assert.StrictEqual(Map.empty, subst.Types) 24 | Assert.StrictEqual(Map.empty, subst.Kinds) 25 | 26 | [] 27 | let ``Unify succeed: a ~ b`` () = 28 | let subst = typeUnifyExn (new SimpleFresh(0)) (typeVar "a" primValueKind) (typeVar "b" primValueKind) 29 | Assert.StrictEqual(Map.empty.Add("a", (typeVar "b" primValueKind)), subst.Types) 30 | Assert.StrictEqual(Map.empty, subst.Kinds) 31 | 32 | [] 33 | let ``Unify fail: a ~ (b a) -- occurs check`` () = 34 | Assert.Throws(fun () -> typeUnifyExn (new SimpleFresh(0)) (typeVar "a" primValueKind) (typeApp (typeVar "b" (karrow primValueKind primValueKind)) (typeVar "a" primValueKind)) |> ignore) 35 | 36 | [] 37 | let ``Unify succeed: a ~ (B c)`` () = 38 | let subst = typeUnifyExn (new SimpleFresh(0)) (typeVar "a" primValueKind) (typeApp (typeCon "B" (karrow primValueKind primValueKind)) (typeVar "c" primValueKind)) 39 | Assert.StrictEqual( 40 | Map.empty.Add("a", (typeApp (typeCon "B" (karrow primValueKind primValueKind)) (typeVar "c" primValueKind))), 41 | subst.Types) 42 | Assert.StrictEqual(Map.empty, subst.Kinds) 43 | 44 | [] 45 | let ``Unify succeed: (a B) ~ (c d)`` () = 46 | let subst = typeUnifyExn (new SimpleFresh(0)) (typeApp (typeVar "a" (karrow primValueKind primValueKind)) (typeCon "B" primValueKind)) (typeApp (typeVar "c" (karrow primValueKind primValueKind)) (typeVar "d" primValueKind)) 47 | Assert.StrictEqual( 48 | Map.empty.Add("a", typeVar "c" (karrow primValueKind primValueKind)).Add("d", typeCon "B" primValueKind), 49 | subst.Types) 50 | Assert.StrictEqual(Map.empty, subst.Kinds) 51 | 52 | 53 | 54 | [] 55 | let ``Unify succeed: b B a ... ~ c c e d ...`` () = 56 | let subst = 57 | typeUnifyExn (new SimpleFresh(0)) 58 | (typeSeq (SInd (typeVar "b" primValueKind, SInd (typeCon "B" primValueKind, SDot (typeVar "a" primValueKind, SEnd))))) 59 | (typeSeq (SInd (typeVar "c" primValueKind, SInd (typeVar "c" primValueKind, SInd (typeVar "e" primValueKind, SDot (typeVar "d" primValueKind, SEnd)))))) 60 | Assert.StrictEqual( 61 | Map.empty 62 | .Add("b", typeCon "B" primValueKind) 63 | .Add("c", typeCon "B" primValueKind) 64 | .Add("a", typeSeq (SInd (typeVar "e" primValueKind, SDot (typeVar "d" primValueKind, SEnd)))) 65 | .Add("a0", typeVar "e" primValueKind) 66 | .Add("a1", typeVar "d" primValueKind), 67 | subst.Types) 68 | Assert.StrictEqual(Map.empty, subst.Kinds) 69 | 70 | [] 71 | let ``Unify succeed: (V a b) ~ (V c d)...`` () = 72 | let vcon = typeCon "V" (karrow primDataKind (karrow primSharingKind primValueKind)) 73 | let subst = 74 | typeUnifyExn (new SimpleFresh(0)) 75 | (typeSeq (ind (typeApp (typeApp vcon (typeVar "a" primDataKind)) (typeVar "b" primSharingKind)) SEnd)) 76 | (typeSeq (dot (typeApp (typeApp vcon (typeVar "c" primDataKind)) (typeVar "d" primSharingKind)) SEnd)) 77 | Assert.StrictEqual( 78 | Map.empty 79 | .Add("c", typeSeq (ind (typeVar "a" primDataKind) SEnd)) 80 | .Add("d", typeSeq (ind (typeVar "b" primSharingKind) SEnd)) 81 | .Add("c0", typeVar "a" primDataKind) 82 | .Add("c1", typeSeq SEnd) 83 | .Add("d2", typeVar "b" primSharingKind) 84 | .Add("d3", typeSeq SEnd), 85 | subst.Types) 86 | Assert.StrictEqual(Map.empty, subst.Kinds) 87 | 88 | [] 89 | let ``Unify succeed: V ~ a`` () = 90 | let subst = typeUnifyExn (new SimpleFresh(0)) (typeCon "V" (kvar "k")) (typeVar "a" primDataKind) 91 | Assert.StrictEqual(Map.empty.Add("k", primDataKind), subst.Kinds) 92 | Assert.StrictEqual(Map.empty.Add("a", typeCon "V" primDataKind), subst.Types) 93 | 94 | [] 95 | let ``Unify succeed: V ~ V o>`` () = 96 | let subst = typeUnifyExn (new SimpleFresh(0)) (typeCon "V" (kvar "k")) (typeCon "V" (karrow (kvar "i") (kvar "o"))) 97 | Assert.StrictEqual(Map.empty.Add("k", karrow (kvar "i") (kvar "o")), subst.Kinds) 98 | 99 | [] 100 | let ``Unify fail: a ... ~ b a...`` () = 101 | Assert.Throws(fun () -> 102 | typeUnifyExn (new SimpleFresh(0)) (typeSeq (SDot (typeVar "a" primValueKind, SEnd))) (typeSeq (SInd (typeVar "b" primValueKind, SDot (typeVar "a" primValueKind, SEnd)))) |> ignore) 103 | 104 | [] 105 | let ``Unify fail: one: a, b... ~ two: c, b...`` () = 106 | Assert.Throws(fun () -> 107 | typeUnifyExn (new SimpleFresh(0)) 108 | (typeApp (typeApp (TRowExtend primFieldKind) (typeApp (typeCon "one" (karrow primValueKind primFieldKind)) (typeVar "a" primValueKind))) (typeVar "b" (KRow primFieldKind))) 109 | (typeApp (typeApp (TRowExtend primFieldKind) (typeApp (typeCon "two" (karrow primValueKind primFieldKind)) (typeVar "c" primValueKind))) (typeVar "b" (KRow primFieldKind))) |> ignore) 110 | 111 | 112 | 113 | [] 114 | let ``Strict match fail: a... ~> io!, c...`` () = 115 | Assert.Throws(fun () -> 116 | strictTypeMatchExn (new SimpleFresh(0)) 117 | (typeVar "a" (krow primEffectKind)) 118 | (typeApp (typeApp (TRowExtend primEffectKind) (typeCon "io!" primEffectKind)) (typeVar "c" (krow primEffectKind))) |> ignore) -------------------------------------------------------------------------------- /Boba.Core/Abelian.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Core 2 | 3 | module Abelian = 4 | 5 | open System 6 | open System.Diagnostics 7 | open Common 8 | open Fresh 9 | 10 | /// Represents a simple Abelian equation composed of constant values and variables which can each have a signed integer exponent. 11 | /// The implementation uses dictionaries as a form of signed multiset, where an element in the set can have more than one occurence 12 | /// (represented by a positive exponent) or even negative occurences (represented by a negative exponent). If an element has exactly zero 13 | /// occurences, it is removed from the dictionary for efficiency. 14 | [] 15 | type Equation<'a, 'b> when 'a: comparison and 'b: comparison (variables: Map<'a, int>, constants: Map<'b, int>) = 16 | 17 | new(name: 'a) = 18 | Equation<'a, 'b>(Map.add name 1 Map.empty, Map.empty) 19 | 20 | new() = 21 | Equation<'a, 'b>(Map.empty, Map.empty) 22 | 23 | /// The set of variables in the unit equation, mapped to their exponents. 24 | member this.Variables = variables 25 | /// The set of constants in the unit equation, mapped to their exponents. 26 | member this.Constants = constants 27 | 28 | member this.IsIdentity () = this.Variables.IsEmpty && this.Constants.IsEmpty 29 | 30 | member this.IsConstant () = this.Variables.IsEmpty 31 | 32 | /// Get the exponent of the given variable name within this equation. Returns 0 if the variable is not present. 33 | member this.ExponentOf var = 34 | if this.Variables.ContainsKey(var) 35 | then this.Variables.[var] 36 | else 0 37 | 38 | /// Determines whether all exponents in the equation are integer multiples of the given divisor. 39 | member this.DividesPowers divisor = 40 | let divides k pow = pow % divisor = 0 41 | Map.forall divides this.Variables && Map.forall divides this.Constants 42 | 43 | /// For a given variable, returns whether there is another variable in the equation that has a higher exponent. 44 | member this.NotMax var = 45 | let examined = this.ExponentOf var |> abs 46 | let varHasGreaterExponent k v = k <> var && abs v >= examined 47 | Map.exists varHasGreaterExponent this.Variables 48 | 49 | /// Negates each exponent in the equation. 50 | member this.Invert () = 51 | new Equation<'a, 'b>(mapValues (( ~- )) this.Variables, mapValues (( ~- )) this.Constants) 52 | 53 | /// Combine two Abelian unit equations. Values that appear in both equations have their exponents multiplied. 54 | member this.Add (other: Equation<'a, 'b>) = 55 | let mergeAdd (v1, v2) = v1 + v2 56 | let isExponentNonZero _ v = v <> 0 57 | let vars = mapUnion mergeAdd this.Variables other.Variables |> Map.filter isExponentNonZero 58 | let constants = mapUnion mergeAdd this.Constants other.Constants |> Map.filter isExponentNonZero 59 | new Equation<'a, 'b>(vars, constants) 60 | 61 | /// Removes the given equation from this Abelian unit equation. Equivalent to `this.Add(other.Invert())`. 62 | member this.Subtract (other: Equation<'a, 'b>) = other.Invert() |> this.Add; 63 | 64 | /// Multiplies each exponent in the unit equation by the given factor. 65 | member this.Scale (factor: int) = 66 | let scale v = v * factor 67 | new Equation<'a, 'b>(mapValues scale this.Variables, mapValues scale this.Constants) 68 | 69 | /// Divides each exponent in the unit equation by the given factor. 70 | member this.Divide (factor: int) = 71 | let scale v = v / factor 72 | new Equation<'a, 'b>(mapValues scale this.Variables, mapValues scale this.Constants) 73 | 74 | /// Removes the specified variable from the unit, and divides all other powers by the removed variable's power. 75 | member this.Pivot (var: 'a) = 76 | let pivotPower = this.ExponentOf var 77 | let inverse = new Equation<'a, 'b>(var) 78 | this.Subtract(inverse.Scale(pivotPower)) 79 | .Divide(pivotPower) 80 | .Invert(); 81 | 82 | // Get the free variables of this equation. 83 | member this.Free () = mapKeys this.Variables 84 | 85 | /// Substitutes the given equation for the specified variable, applying the variable's power to the substituted unit. 86 | member this.Substitute (name: 'a) (other: Equation<'a, 'b>) = 87 | other.Subtract(new Equation<'a, 'b>(name)) 88 | .Scale(this.ExponentOf(name)) 89 | .Add(this); 90 | 91 | member this.FractionString () = 92 | let expToStr exps = 93 | Map.map (fun k v -> if v = 1 then $"{k}" else $"{k}^{v}") exps |> Map.toList |> List.map snd 94 | let posVars = Map.filter (fun k v -> v >= 0) this.Variables |> expToStr 95 | let posCons = Map.filter (fun k v -> v >= 0) this.Constants |> expToStr 96 | let negVars = Map.filter (fun k v -> v < 0) this.Variables |> Map.map (fun k v -> -v) |> expToStr 97 | let negCons = Map.filter (fun k v -> v < 0) this.Constants |> Map.map (fun k v -> -v) |> expToStr 98 | let pos = String.concat "*" (List.append posVars posCons) 99 | let neg = String.concat "*" (List.append negVars negCons) 100 | if neg.Length > 0 101 | then pos + "/" + neg 102 | elif pos.Length <= 0 103 | then "1" 104 | else pos 105 | 106 | override this.GetHashCode() = 107 | hash (this.Variables, this.Constants) 108 | 109 | override this.Equals(b) = 110 | match b with 111 | | :? Equation<'a, 'b> as p -> (this.Variables, this.Constants) = (p.Variables, p.Constants) 112 | | _ -> false 113 | 114 | override this.ToString() = 115 | if this.IsIdentity() 116 | then "-" 117 | else 118 | let vars = Map.map (fun k v -> $"{k}^{v}") this.Variables |> Map.toList |> List.map snd 119 | let cons = Map.map (fun k v -> $"{k}^{v}") this.Constants |> Map.toList |> List.map snd 120 | String.concat "*" (List.append vars cons) 121 | 122 | interface IComparable> with 123 | member this.CompareTo(other: Equation<'a, 'b>) = 124 | let x = compare this.Variables other.Variables 125 | if x = 0 then compare this.Constants other.Constants else x 126 | 127 | interface IComparable with 128 | member this.CompareTo(other: obj) = 129 | match other with 130 | | :? Equation<'a, 'b> -> 131 | let x = compare this.Variables (unbox> other).Variables 132 | if x = 0 then compare this.Constants (unbox> other).Constants else x 133 | | _ -> invalidArg "other" "Must be of type Equation<'a, 'b>" 134 | 135 | let matchEqns (fresh: FreshVars) (eqn1 : Equation) (eqn2 : Equation) = 136 | let mgu (vars : List) constVars constRigids (subst : Map) = 137 | let toTerm freshVars vars consts = 138 | (new Equation(List.zip freshVars vars |> Map.ofList, Map.empty)) 139 | .Add(new Equation(List.zip constVars (List.take (List.length constVars) consts) |> Map.ofList, Map.empty)) 140 | .Add(new Equation(Map.empty, List.zip constRigids (List.skip (List.length constVars) consts) |> Map.ofList)) 141 | let toEquation freshVars acc (var, ind) = 142 | match Map.tryFind ind subst with 143 | | Some eqn -> Map.add var (toTerm freshVars eqn.Coefficients eqn.Constants) acc 144 | | None -> Map.add var (new Equation(freshVars.[ind])) acc 145 | let freshies = 146 | if Map.isEmpty subst 147 | then [] 148 | else 149 | Map.toList subst 150 | |> List.head 151 | |> snd 152 | |> (fun (a : Linear.Equation) -> a.Coefficients) 153 | |> List.length 154 | |> fresh.FreshN "a" 155 | List.fold (toEquation freshies) Map.empty (List.mapi (fun i b -> (b, i)) vars) 156 | 157 | if eqn1.Variables.IsEmpty && eqn2.Variables.IsEmpty 158 | then 159 | if eqn1.Constants = eqn2.Constants 160 | then Some Map.empty 161 | else None 162 | elif eqn1.Variables.IsEmpty 163 | then None 164 | else 165 | let bases map = Map.toList map |> List.map fst 166 | let exponents map = Map.toList map |> List.map snd 167 | // put all constants on the 'constant' side of the equation, so that the matching side only has variables 168 | let right = eqn2.Subtract(new Equation(Map.empty, eqn1.Constants)) 169 | Linear.solve { Coefficients = exponents eqn1.Variables; Constants = List.append (exponents right.Variables) (exponents right.Constants) } 170 | |> Option.map (mgu (bases eqn1.Variables) (bases right.Variables) (bases right.Constants)) 171 | 172 | let unify (fresh: FreshVars) (eqn1 : Equation) (eqn2 : Equation) = 173 | matchEqns fresh (eqn1.Add(eqn2.Invert())) (new Equation()) -------------------------------------------------------------------------------- /Boba.Core/Boba.Core.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net6.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 | -------------------------------------------------------------------------------- /Boba.Core/Common.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Core 2 | 3 | module Common = 4 | 5 | open System.Text 6 | 7 | // Maybe monad 8 | type MaybeBuilder() = 9 | member this.Bind(x, f) = 10 | match x with 11 | | None -> None 12 | | Some a -> f a 13 | 14 | member this.Return(x) = 15 | Some x 16 | 17 | let maybe = new MaybeBuilder() 18 | 19 | 20 | // State monad 21 | type Stateful<'state, 'result> = 22 | Stateful of ('state -> 'result * 'state) 23 | 24 | let run state (Stateful f) = f state 25 | 26 | let get = Stateful (fun state -> (state, state)) 27 | 28 | let put item = Stateful (fun _ -> ((), item)) 29 | 30 | type StateBuilder() = 31 | member this.Zero () = Stateful(fun s -> (), s) 32 | member this.Return x = Stateful(fun s -> x, s) 33 | member inline this.ReturnFrom (x: Stateful<'s, 'a>) = x 34 | member this.Bind (x, f) : Stateful<'s, 'b> = 35 | Stateful(fun state -> 36 | let (result: 'a), state = run state x 37 | run state (f result)) 38 | member this.Combine (x1: Stateful<'s, 'a>, x2: Stateful<'s, 'b>) = 39 | Stateful(fun state -> 40 | let result, state = run state x1 41 | run state x2) 42 | member this.Delay f : Stateful<'s, 'a> = f () 43 | member this.For (seq, (f: 'a -> Stateful<'s, 'b>)) = 44 | if Seq.isEmpty seq 45 | then this.Zero () 46 | else 47 | seq 48 | |> Seq.map f 49 | |> Seq.reduceBack (fun x1 x2 -> this.Combine (x1, x2)) 50 | member this.While (f, x) = 51 | if f () then this.Combine (x, this.While (f, x)) 52 | else this.Zero () 53 | 54 | let state = StateBuilder() 55 | 56 | 57 | // Function helpers 58 | let constant a _ = a 59 | 60 | let drop _ b = b 61 | 62 | let pair x y = (x, y) 63 | 64 | let curry f a b = f (a,b) 65 | 66 | let uncurry f (a,b) = f a b 67 | 68 | 69 | // Number helpers 70 | let div_floor n m = 71 | let q = n/m; 72 | let r = n%m; 73 | if (r > 0 && m < 0) || (r < 0 && m > 0) 74 | then q-1 75 | else q 76 | 77 | let modulo n m = 78 | let r = n%m; 79 | if (r > 0 && m < 0) || (r < 0 && m > 0) 80 | then r+m 81 | else r 82 | 83 | 84 | // String helpers 85 | 86 | /// Join a sequence of strings using a delimiter. 87 | /// Equivalent to String.Join() but without arrays. 88 | let join items (delim : string) = 89 | if Seq.isEmpty items 90 | then "" 91 | else 92 | 93 | // Collect the result in the string builder buffer 94 | // The end-sequence will be "item1,delim,...itemN,delim" 95 | let buff = 96 | Seq.fold 97 | (fun (buff :StringBuilder) s -> buff.Append($"{s}").Append(delim)) 98 | (new StringBuilder()) 99 | items 100 | 101 | // We don't want the last delim in the result buffer, remove 102 | buff.Remove(buff.Length-delim.Length, delim.Length).ToString() 103 | 104 | 105 | // List helpers 106 | let appendBack r l = List.append l r 107 | 108 | let append3 l c r = List.append l (List.append c r) 109 | 110 | let removeAt index list = 111 | list |> List.indexed |> List.filter (fun (i, _) -> i <> index) |> List.map snd 112 | 113 | let zipWith f l r = List.zip l r |> List.map f 114 | 115 | let listTraverseOption lopts = 116 | let cons h t = h :: t 117 | let optApply f arg = 118 | match f with 119 | | Some fp -> Option.map fp arg 120 | | None -> None 121 | let folder optElem st = 122 | optApply (optApply (Some cons) optElem) st 123 | List.foldBack folder lopts (Some []) 124 | 125 | 126 | // Map helpers 127 | let mapKeys m = m |> Map.toSeq |> Seq.map fst |> Set.ofSeq 128 | 129 | let mapValues f m = Map.map (fun _ v -> f v) m 130 | 131 | let mapRemoveSet set m = Map.filter (fun k _ -> not (Set.contains k set)) m 132 | 133 | let mapUnion f l r = 134 | Map.fold (fun s k v -> 135 | match Map.tryFind k s with 136 | | Some v' -> Map.add k (f (v, v')) s 137 | | None -> Map.add k v s) l r -------------------------------------------------------------------------------- /Boba.Core/Environment.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Core 2 | 3 | module Environment = 4 | 5 | open Common 6 | open Types 7 | open Kinds 8 | open CHR 9 | 10 | type EnvEntry = { Type: TypeScheme; IsOverload: bool; IsRecursive: bool; IsVariable: bool } 11 | 12 | type Overload = { 13 | Pred: string; 14 | Template: TypeScheme; 15 | Instances: List; 16 | Params: List; 17 | } 18 | 19 | type TypeEnvironment = { 20 | Overloads: Map; 21 | Rules: List; 22 | Classes: List; 23 | Definitions: Map; 24 | Kinds: Map; 25 | TypeConstructors: Map; 26 | TypeSynonyms: Map; 27 | Patterns: Map; 28 | } 29 | 30 | 31 | let empty = { 32 | Overloads = Map.empty; 33 | Rules = []; 34 | Classes = []; 35 | Definitions = Map.empty; 36 | Kinds = Map.empty; 37 | TypeConstructors = Map.empty; 38 | TypeSynonyms = Map.empty; 39 | Patterns = Map.empty 40 | } 41 | 42 | let envRules env : List = env.Rules 43 | 44 | let addTypeCtor env name kind = { env with TypeConstructors = Map.add name kind env.TypeConstructors } 45 | 46 | let addUserKind env name unify = { env with Kinds = Map.add name unify env.Kinds } 47 | 48 | let addPattern env name ty = { env with Patterns = Map.add name ty env.Patterns } 49 | 50 | let addOverload env name pred template pars insts = { env with Overloads = Map.add name { Pred = pred; Template = template; Instances = insts; Params = pars } env.Overloads } 51 | 52 | let addRule env rule = { env with Rules = rule :: env.Rules } 53 | 54 | let addClass env classRule = { env with Classes = classRule :: env.Classes } 55 | 56 | let addSynonym env name scheme = { env with TypeSynonyms = Map.add name scheme env.TypeSynonyms } 57 | 58 | let extend env name entry = { env with Definitions = Map.add name entry env.Definitions } 59 | 60 | let extendVar env name ty = extend env name { Type = ty; IsOverload = false; IsRecursive = false; IsVariable = true; } 61 | 62 | let extendFn env name ty = extend env name { Type = ty; IsOverload = false; IsRecursive = false; IsVariable = false } 63 | 64 | let extendRec env name ty = extend env name { Type = ty; IsOverload = false; IsRecursive = true; IsVariable = false } 65 | 66 | let extendOver env name ty = extend env name { Type = ty; IsOverload = true; IsRecursive = true; IsVariable = false } 67 | 68 | let extendCtor env name pat ty = extendFn (addPattern env name pat) name ty 69 | 70 | let remove env name = { env with Definitions = (Map.remove name env.Definitions) } 71 | 72 | let lookup env name = env.Definitions.TryFind name 73 | 74 | let lookupType env name = env.TypeConstructors.TryFind name 75 | 76 | let lookupKind env name = env.Kinds.TryFind name 77 | 78 | let lookupPattern env name = env.Patterns.TryFind name 79 | 80 | let lookupPred env name = Seq.find (fun over -> over.Pred = name) (Map.values env.Overloads) 81 | 82 | let lookupSynonym env name = env.TypeSynonyms.TryFind name 83 | 84 | let printEnv nameFilter simplifier env = 85 | Map.filter (fun n t -> nameFilter n) env.Definitions 86 | |> Map.iter (fun n t -> printfn $"{n} : {prettyType (simplifier t.Type.Body)}") 87 | Map.filter (fun n o -> nameFilter n) env.Overloads 88 | |> Map.iter (fun n o -> 89 | printfn $"{n} : {prettyType o.Template.Body}" 90 | Seq.iter (fun (t : TypeScheme, n) -> printfn $"{n} : {prettyType t.Body}") o.Instances) 91 | -------------------------------------------------------------------------------- /Boba.Core/Fresh.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Core 2 | 3 | module Fresh = 4 | 5 | [] 6 | type FreshVars = 7 | /// Given a prefix, generates a fresh variable name for 8 | /// the prefix using a number affixed to the name. 9 | abstract member Fresh : string -> string 10 | /// Generates `count` fresh variable names 11 | /// all with the given prefix. 12 | abstract member FreshN : string -> int -> List 13 | 14 | type SimpleFresh = 15 | 16 | val mutable state: int 17 | 18 | new(s) = { state = s } 19 | 20 | interface FreshVars with 21 | /// Given a prefix, generates a fresh variable name for 22 | /// the prefix using a number affixed to the name. 23 | member this.Fresh prefix = 24 | let name = $"{prefix}{this.state}" 25 | this.state <- this.state + 1 26 | name 27 | 28 | /// Generates `count` fresh variable names 29 | /// all with the given prefix. 30 | member this.FreshN prefix count = 31 | [ for i in 0..count-1 do yield (this :> FreshVars).Fresh prefix ] -------------------------------------------------------------------------------- /Boba.Core/Kinds.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Core 2 | 3 | module Kinds = 4 | 5 | open System.Diagnostics 6 | open Boba.Core.Common 7 | 8 | type UnifySort = 9 | | KUSyntactic 10 | | KUBoolean 11 | | KUAbelian 12 | | KURow 13 | | KUSequence 14 | override this.ToString() = 15 | match this with 16 | | KUSyntactic -> "syn" 17 | | KUBoolean -> "bool" 18 | | KUAbelian -> "abel" 19 | | KURow -> $"row" 20 | | KUSequence -> $"seq" 21 | 22 | /// Each type in Boba can be categorized into a specific 'Kind'. 23 | /// 24 | /// Most kinds in Boba are simple 'base' kinds, and are used to control what type of unification 25 | /// is used during type inference. The aggregate kinds Seq(k) and Arrow(k1,k2) are used to construct 26 | /// more complex kinds, like the kind of the function type constructor and the tuple type constructor. 27 | /// 28 | /// Kind equality is determined by simple syntactic equality. 29 | [] 30 | type Kind = 31 | /// A user-defined kind that unifies via the given unification method. 32 | | KUser of name: string * unify: UnifySort 33 | /// Builds a new kind representing a scoped row of types of a particular kind. 34 | | KRow of elem: Kind 35 | /// Builds a new kind representing a sequence of types of a particular kind. 36 | | KSeq of elem: Kind 37 | /// Builds a new kind representing a type that consumes a type of the input kind, and returns a type of the output kind. 38 | | KArrow of input: Kind * output: Kind 39 | /// For supporting polymorphic kinds. 40 | | KVar of name: string 41 | /// The top kind in the kind lattice, supertype of all kinds. 42 | | KAny 43 | 44 | override this.ToString () = 45 | match this with 46 | | KRow k -> $"<{k}>" 47 | | KSeq k -> $"[{k}]" 48 | | KArrow (l, r) -> 49 | match l with 50 | | KArrow _ -> $"({l}) -> {r}" 51 | | _ -> $"{l} -> {r}" 52 | | KVar v -> v 53 | | KUser (n, _) -> n 54 | | KAny -> "_" 55 | 56 | type KindScheme = 57 | { Quantified: List; Body: Kind } 58 | override this.ToString() = $"{this.Body}" 59 | 60 | let primDataKind = KUser ("Data", KUSyntactic) 61 | let primSharingKind = KUser ("Sharing", KUBoolean) 62 | let primValueKind = KUser ("Value", KUSyntactic) 63 | let primConstraintKind = KUser ("Constraint", KUSyntactic) 64 | let primEffectKind = KUser ("Effect", KUSyntactic) 65 | let primFieldKind = KUser ("Field", KUSyntactic) 66 | let primPermissionKind = KUser ("Permission", KUSyntactic) 67 | let primTotalityKind = KUser ("Totality", KUBoolean) 68 | let primFixedKind = KUser ("Fixed", KUAbelian) 69 | 70 | let primMeasureKind = KUser ("Measure", KUAbelian) 71 | let primTrustKind = KUser ("Trust", KUBoolean) 72 | let primClearanceKind = KUser ("Clearance", KUBoolean) 73 | let primHeapKind = KUser ("Heap", KUSyntactic) 74 | 75 | 76 | let kvar name = KVar name 77 | let kseq elem = KSeq elem 78 | let krow elem = KRow elem 79 | let karrow inp out = KArrow (inp, out) 80 | 81 | 82 | let isKindSyntactic kind = 83 | match kind with 84 | | KUser (_, KUSyntactic) -> true 85 | | KArrow _ -> true 86 | | _ -> false 87 | 88 | let isKindSequence kind = 89 | match kind with 90 | | KSeq _ -> true 91 | | KUser (_, KUSequence _) -> true 92 | | _ -> false 93 | 94 | let isKindBoolean kind = 95 | match kind with 96 | | KUser (_, KUBoolean) -> true 97 | | _ -> false 98 | 99 | let isKindAbelian kind = 100 | match kind with 101 | | KUser (_, KUAbelian) -> true 102 | | _ -> false 103 | 104 | let isKindExtensibleRow kind = 105 | match kind with 106 | | KRow _ -> true 107 | | KUser (_, KURow _) -> true 108 | | _ -> false 109 | 110 | 111 | /// Raised when a kind is applied to an argument that does not match the arrow kind's input. 112 | exception KindApplyArgMismatch of Kind * Kind 113 | /// Raised when attempting to apply a kind that is not an arrow kind. 114 | exception KindApplyNotArrow of Kind * Kind 115 | exception IncomparableKinds of Kind * Kind 116 | 117 | /// Almost syntactic equality, with the variation that `_ = k` and `k = _` for all kinds `k`. 118 | let rec kindEq l r = 119 | match l, r with 120 | | KAny, _ -> true 121 | | _, KAny -> true 122 | | KSeq lk, KSeq rk -> kindEq lk rk 123 | | KUser (lk, lu), KUser (rk, ru) -> lk = rk && lu = ru 124 | | KArrow (li, lo), KArrow (ri, ro) -> kindEq li ri && kindEq lo ro 125 | | KRow lk, KRow rk -> kindEq lk rk 126 | | KVar lv, KVar rv -> lv = rv 127 | | _, _ -> false 128 | 129 | /// Given an arrow kind `(k1 -> k2)`, return whether the argument kind `k3` is equal to `k1`. 130 | /// If the arrow kind is not actually an arrow, returns false. 131 | let canApplyKind arrKind argKind = 132 | match arrKind with 133 | | KArrow (arg, _) -> kindEq arg argKind 134 | | _ -> false 135 | 136 | /// Given an arrow kind `(k1 -> k2)`, if the argument kind `k3` is equal to `k1`, return `k2`. 137 | /// If `k1` doesn't equal `k3`, or if arrKind is not actually an arrow kind, raises an exception. 138 | let applyKindExn arrKind argKind = 139 | match arrKind with 140 | | KArrow (input, output) when kindEq input argKind -> output 141 | | KArrow (input, _) -> raise (KindApplyArgMismatch (input, argKind)) 142 | | _ -> raise (KindApplyNotArrow (arrKind, argKind)) 143 | 144 | /// Gives a partial order to kinds via sequence nesting levels. More deeply nested sequences are 145 | /// considered 'bigger' than less deeply nested sequences, e.g. [data] <= [[data]]. Incomparable 146 | /// kinds are distinct from related kinds, and this is enforced by using Option as the result container. 147 | /// A Some says that the kinds are related, a None says they are not (incomparable). 148 | let rec kindLessOrEqualThan (l : Kind) (r : Kind) = 149 | match (l, r) with 150 | | (KSeq kl, KSeq kr) -> kindLessOrEqualThan kl kr 151 | | (KSeq _, _) -> Some true 152 | | (KAny, _) -> Some true 153 | | (_, KSeq _) -> Some false 154 | | (l, r) when kindEq l r -> Some true 155 | | _ -> None 156 | 157 | /// If the two kinds can be compared, returns the greater of the two. If the two kinds cannot be 158 | /// compared, raises an IncomparableKinds exception. 159 | let maxKindExn (l : Kind) (r : Kind) = 160 | match kindLessOrEqualThan l r with 161 | | Some true -> r 162 | | Some false -> l 163 | | None -> raise (IncomparableKinds (l, r)) 164 | 165 | /// In a dotted sequence of kinds, find the greatest of all the kinds. If any two kinds cannot be 166 | /// compared, raise an IncomparableKinds exception. If the dotted sequence is empty, raise an invalid 167 | /// argument exception. 168 | let maxKindsExn (ks : DotSeq.DotSeq) = 169 | match DotSeq.reduce maxKindExn ks with 170 | | None -> invalidArg "ks" "Cannot call maxKindsExn on an empty sequence." 171 | | Some k -> k 172 | 173 | /// Compute the set of free variables in the given kind. 174 | let rec kindFree k = 175 | match k with 176 | | KVar v -> Set.singleton v 177 | | KRow e -> kindFree e 178 | | KSeq s -> kindFree s 179 | | KArrow (l, r) -> Set.union (kindFree l) (kindFree r) 180 | | _ -> Set.empty 181 | 182 | let kindScheme q k = { Quantified = q; Body = k } 183 | 184 | let generalizeKind k = { Quantified = kindFree k |> Set.toList; Body = k } -------------------------------------------------------------------------------- /Boba.Core/Linear.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Core 2 | 3 | module Linear = 4 | 5 | open Common 6 | 7 | type Equation = { Coefficients: List; Constants: List } 8 | 9 | /// Find the smallest non-zero coefficient by absolute value and return it and the index at which it was found. 10 | let private smallest coeffs = 11 | let chooseSmaller (prevI, prevN) (testI, testN) = 12 | if prevN = 0 13 | then (testI, testN) 14 | elif testN = 0 || abs prevN <= abs testN 15 | then (prevI, prevN) 16 | else (testI, testN) 17 | List.mapi (fun i c -> (i, c)) coeffs 18 | |> List.fold chooseSmaller (-1, 0) 19 | 20 | /// Negate all the integers in a list. 21 | let private negate = List.map (~-) 22 | 23 | /// Replace the integer at index i in a list with 0. 24 | let private zeroAt index ls = List.mapi (fun i e -> if index = i then 0 else e) ls 25 | 26 | /// Check if every number in a list is divisible by a given divisor. 27 | let private divisible divisor ns = List.forall (fun n -> modulo n divisor = 0) ns 28 | 29 | /// Divide every number in a list by the given divisor. 30 | let private divide divisor ns = List.map (fun n -> div_floor n divisor) ns 31 | 32 | /// Eliminate a variable from the substitution. If the variable is in the original problem, 33 | /// add it to the substitution. 34 | let private eliminate v (i, orig) subst = 35 | let rec addMul n xs ys = 36 | match n, xs, ys with 37 | | 1, [], ys -> ys 38 | | n, [], ys -> List.map ((*) n) ys 39 | | _, xs, [] -> xs 40 | | n, x :: xs, y :: ys -> x + n * y :: addMul n xs ys 41 | // eliminate i from eqn if it occurs in eqn 42 | let elim eqn = 43 | if i >= eqn.Coefficients.Length 44 | then eqn 45 | elif eqn.Coefficients.[i] = 0 46 | then eqn 47 | else { Coefficients = addMul eqn.Coefficients.[i] (zeroAt i eqn.Coefficients) orig.Coefficients; 48 | Constants = addMul eqn.Coefficients.[i] eqn.Constants orig.Constants } 49 | if i < v 50 | then Map.add i orig (Map.map (constant elim) subst) 51 | else Map.map (constant elim) subst 52 | 53 | let rec private solveLoop originalEqnVarCount eqn subst = 54 | let (si, sc) = smallest eqn.Coefficients 55 | // make sure smallest coefficient is positive 56 | if sc < 0 57 | then solveLoop originalEqnVarCount { Coefficients = negate eqn.Coefficients; Constants = negate eqn.Constants } subst 58 | // no coefficient is an internal error 59 | elif sc = 0 60 | then None 61 | // solution found, eliminate the variable 62 | elif sc = 1 63 | then Some (eliminate originalEqnVarCount (si, { Coefficients = negate (zeroAt si eqn.Coefficients); Constants = eqn.Constants }) subst) 64 | // if both coefficients and constants are divisible, there's a solution 65 | // if coefficients but not constants are divisible, there can't be a solution 66 | elif divisible sc eqn.Coefficients 67 | then 68 | if divisible sc eqn.Constants 69 | then 70 | let coeffs = divide sc eqn.Coefficients 71 | let consts = divide sc eqn.Constants 72 | Some (eliminate originalEqnVarCount (si, { Coefficients = negate (zeroAt si coeffs); Constants = consts }) subst) 73 | else 74 | None 75 | // introduce a new variable and solve 76 | else 77 | let coeffs = divide sc (zeroAt si eqn.Coefficients) 78 | let newSubst = eliminate originalEqnVarCount (si, { Coefficients = List.append (negate coeffs) [1]; Constants = [] }) subst 79 | solveLoop originalEqnVarCount { Coefficients = List.append (List.map (fun m -> modulo m sc) eqn.Coefficients) [sc]; Constants = eqn.Constants } newSubst 80 | 81 | /// Find a solution for the equation, if one exists. 82 | let solve eqn = 83 | solveLoop (List.length eqn.Coefficients) eqn Map.empty -------------------------------------------------------------------------------- /Boba.Core/Syntax.fs: -------------------------------------------------------------------------------- 1 | namespace Boba.Core 2 | 3 | module Syntax = 4 | 5 | open Types 6 | 7 | type Word = 8 | | WHandle of pars: List * handled: Expression * handlers: List * ret: Expression 9 | | WNursery of par: string * body: Expression 10 | | WCancellable of par: string * body: Expression 11 | | WInject of effs: List * injected: Expression 12 | | WIf of thenClause: Expression * elseClause: Expression 13 | | WWhile of cond: Expression * body: Expression 14 | | WVars of vars: List * body: Expression 15 | 16 | | WFunctionLiteral of body: Expression 17 | | WLetRecs of List<(string * Expression)> * expr: Expression 18 | 19 | | WEmptyRecord 20 | | WExtension of string 21 | | WSelect of string 22 | 23 | | WVariantLiteral of string 24 | | WCase of tag: string * thenClause: Expression * elseClause: Expression 25 | 26 | | WHasPermission of string 27 | | WRequestPermission of string 28 | 29 | | WDo 30 | | WString of string 31 | | WInteger of string * IntegerSize 32 | | WDecimal of string * FloatSize 33 | | WChar of char 34 | 35 | | WCallVar of string 36 | | WNativeVar of string 37 | | WValueVar of string 38 | | WOverwriteValueVar of string 39 | | WOperatorVar of string 40 | | WConstructorVar of string 41 | | WTestConstructorVar of string 42 | | WDestruct 43 | and Expression = List 44 | and Handler = { Name: string; Body: Expression } 45 | 46 | let rec wordFree w = 47 | match w with 48 | | WHandle (p, h, hs, r) -> 49 | let retFree = Set.difference (exprFree r) (Set.ofList p) 50 | let handlersFree = Set.difference (Set.union (Set.unionMany (List.map handlerFree hs)) retFree) (Set.ofList p) 51 | Set.union handlersFree (exprFree h) 52 | | WIf (t, e) -> Set.union (exprFree t) (exprFree e) 53 | | WWhile (t, e) -> Set.union (exprFree t) (exprFree e) 54 | | WVars (v, e) -> Set.difference (exprFree e) (Set.ofList v) 55 | | WFunctionLiteral b -> exprFree b 56 | | WLetRecs (rs, b) -> 57 | let rsNames = List.map fst rs |> Set.ofList 58 | let rsFree = Set.difference (List.map (snd >> exprFree) rs |> Set.unionMany) rsNames 59 | let bFree = Set.difference (exprFree b) rsNames 60 | Set.union rsFree bFree 61 | | WCase (_, t, e) -> Set.union (exprFree t) (exprFree e) 62 | | WValueVar n -> Set.singleton n 63 | | WCallVar "resume" -> Set.singleton "resume" 64 | | _ -> Set.empty 65 | and exprFree e = 66 | Set.unionMany (List.map wordFree e) 67 | and handlerFree h = exprFree h.Body -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Glossopoeia 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Mochi.Core/Instructions.fs: -------------------------------------------------------------------------------- 1 | namespace Mochi.Core 2 | 3 | module Instructions = 4 | 5 | type JumpTarget = 6 | | Label of string 7 | | Index of int 8 | 9 | type Instruction = 10 | /// No op, doesn't do anything, moves on to the next instruction 11 | | INop 12 | /// Placeholder for breakpoints when debugging. 13 | | IBreakpoint 14 | /// Terminate the current fiber. 15 | | IAbort 16 | /// Given an index into the constant pool, place the value at that index on top of the stack. 17 | | IConstant of poolIndex: uint16 18 | 19 | /// Moves the instruction pointer forward by the specified amount. 20 | | IOffset of relative: int 21 | /// Sets the instruction pointer to the 'return instruction pointer' in the function frame on top of 22 | /// the frame stack. Pops the top of the frame stack. 23 | | IReturn 24 | /// Sets the instruction pointer to the target and pushes a new function frame. Expects the code block 25 | /// at the target to end with a return instruction. 26 | | ICall of target: JumpTarget 27 | /// Sets the instruction pointer to the target without pushing a new function frame. Expects the code block 28 | /// at the target to end with a return instruction. Equivalen to just jumping to the target location. 29 | | ITailCall of target: JumpTarget 30 | /// Create a new frame containing the top N values from the stack. Then pop N values off the stack. 31 | | IStore of count: int 32 | /// Overwrite the value at the index in the Nth frame from the top of the frame stack with the value 33 | /// at the top of the value stack. Then pop the top of the value stack. 34 | | IOverwrite of index: int 35 | /// Pop the top of the frame stack. 36 | | IForget of count: int 37 | /// Get the value stored in the given frame at the given index and put it on top of the stack. 38 | | IFind of index: int 39 | /// Pop the closure value on top of the stack. Push a new function frame with the values captured by 40 | /// the closure and set the return pointer to be the next instruction. Then jump to the instruction 41 | /// pointed to by the closure body. 42 | | ICallClosure 43 | /// Pop the closure value on top of the stack, and pop the top function frame. Push a new function 44 | /// frame with the values captured by the closure and the retur pointer stored in the previous top 45 | /// function frame. Then jump to the instruction pointed to by the closure body. Note that the replacement 46 | /// semantics for the return value imply that tail-calls cannot be performed at the top level of a program 47 | /// or within the scope of variable/mark-frames. Those scopes should use ICallClosure so that they get 48 | /// cleaned up properly. 49 | | ITailCallClosure 50 | /// Push a closure for the given pointer to a function body, storing references to the values in the frame 51 | /// stack referenced by the list of values to 'close' over. Also signify how many stack values will be taken 52 | /// directly off the stack at the call-site and stored into the closure frame. 53 | | IClosure of body: JumpTarget * closed: List 54 | /// Push a recursive closure for the given pointer to a function body, storing references to the values in the frame 55 | /// stack referenced by the list of values to 'close' over. The reference to the closure itself is stored at index 0 56 | /// of the closed values list. 57 | | IRecursive of body: JumpTarget * closed: List 58 | /// Given a list of n closures on top of the stack, make them all mutually recursive with respect to each other by 59 | /// inserting references to each other into their stored closed values. The layout of references is the same for each 60 | /// closure environment: closure at the top of the stack becomes item 0 in the closed list, closure one down from the 61 | /// top becomes item 1 in the closed list, etc. 62 | | IMutual of count: int 63 | 64 | | IClosureOnce 65 | | IClosureOnceTail 66 | | IClosureNever 67 | 68 | | ICallNative of nat: JumpTarget 69 | | IRequestPermission of perm: JumpTarget 70 | | IHasPermission of perm: JumpTarget 71 | 72 | | INewNursery 73 | | IWaitNursery 74 | | IPushCancel 75 | | IPopContext 76 | 77 | | IHandle of handleId: int * after: int * args: int * operations: int 78 | | IInject of handleId: int 79 | | IEject of handleId: int 80 | | IComplete 81 | | IEscape of handleId: int * opId: int * inputs: int 82 | | ICallContinuation of outputs: int * threaded: int 83 | | ITailCallContinuation of outputs: int * threaded: int 84 | | IRestore 85 | 86 | | IShuffle of count: int * indices: List 87 | 88 | | IJumpIf of target: JumpTarget 89 | | IJumpIfNot of target: JumpTarget 90 | | IJumpStruct of ctorId: int * target: JumpTarget 91 | | IJumpPermission of perm: JumpTarget * target: JumpTarget 92 | 93 | | IOffsetIf of relative: int 94 | | IOffsetIfNot of relative: int 95 | | IOffsetStruct of ctorId: int * relative: int 96 | | IOffsetPermission of permId: int * relative: int 97 | 98 | | IConstruct of ctorId: int * args: int 99 | | IDestruct 100 | | IIsStruct of ctorId: int 101 | 102 | | IEmptyRecord 103 | | IRecordExtend of int 104 | | IRecordSelect of int 105 | 106 | | IVariant of label: int 107 | | IIsCase of label: int 108 | | IJumpCase of label: int * target: JumpTarget 109 | | IOffsetCase of label: int * relative: int 110 | 111 | | II8 of value: sbyte 112 | | IU8 of value: byte 113 | | II16 of value: int16 114 | | IU16 of value: uint16 115 | | II32 of value: int32 116 | | IU32 of value: uint32 117 | | II64 of value: int64 118 | | IU64 of value: uint64 119 | | IINative of value: nativeint 120 | | IUNative of value: unativeint 121 | | ISingle of value: single 122 | | IDouble of value: double 123 | | IRune of value: char 124 | 125 | | IStringPlaceholder of string 126 | 127 | type Block = 128 | | BUnlabeled of List 129 | | BLabeled of string * List 130 | 131 | type LabeledBytecode = 132 | { Labels: Map; 133 | Instructions: List } 134 | 135 | let instructionByteLength instr = 136 | match instr with 137 | | IAbort _ -> 2 138 | | IConstant _ -> 3 139 | | IStringPlaceholder _ -> 3 // must be the same byte length as IConstants since this gets replaced with it later 140 | | IStore _ -> 2 141 | | IForget _ -> 2 142 | | IFind _ -> 5 143 | | IOverwrite _ -> 5 144 | | ICall _ -> 5 145 | | ITailCall _ -> 5 146 | | IOffset _ -> 5 147 | | IJumpIf _ -> 5 148 | | IJumpIfNot _ -> 5 149 | | IOffsetIf _ -> 5 150 | | IOffsetIfNot _ -> 5 151 | | IClosure (_, closed) -> 7 + 4 * closed.Length 152 | | IRecursive (_, closed) -> 7 + 4 * closed.Length 153 | | IMutual _ -> 2 154 | | ICallNative _ -> 5 155 | | IRequestPermission _ -> 5 156 | | IHasPermission _ -> 5 157 | | IJumpPermission _ -> 9 158 | | IOffsetPermission _ -> 9 159 | | IHandle _ -> 9 160 | | IEscape _ -> 7 161 | | IInject _ -> 5 162 | | IEject _ -> 5 163 | | ICallContinuation _ -> 3 164 | | ITailCallContinuation _ -> 3 165 | | IConstruct _ -> 6 166 | | IIsStruct _ -> 5 167 | | IJumpStruct _ -> 9 168 | | IOffsetStruct _ -> 9 169 | | IRecordExtend _ -> 5 170 | | IRecordSelect _ -> 5 171 | | IVariant _ -> 5 172 | | IIsCase _ -> 5 173 | | IJumpCase _ -> 9 174 | | IOffsetCase _ -> 9 175 | 176 | | II8 _ -> 2 177 | | IU8 _ -> 2 178 | | II16 _ -> 3 179 | | IU16 _ -> 3 180 | | II32 _ -> 5 181 | | IU32 _ -> 5 182 | | IINative _ -> sizeof + 1 183 | | IUNative _ -> sizeof + 1 184 | | II64 _ -> 9 185 | | IU64 _ -> 9 186 | | ISingle _ -> 5 187 | | IDouble _ -> 9 188 | | IRune _ -> 5 189 | 190 | | _ -> 1 191 | 192 | let codeByteLength = List.sumBy instructionByteLength 193 | 194 | let blockInstructions block = 195 | match block with 196 | | BUnlabeled ls -> ls 197 | | BLabeled (_, ls) -> ls 198 | 199 | let blockLength block = List.length (blockInstructions block) 200 | 201 | let blockByteLength block = List.sumBy instructionByteLength (blockInstructions block) 202 | 203 | let delabelBytes blocks = 204 | let lengths = List.map blockByteLength blocks 205 | let (startIndices, endInd) = List.mapFold (fun indAcc len -> indAcc, indAcc + len) 0 lengths 206 | let labelPointers = 207 | List.fold2 208 | (fun ptrs block ind -> 209 | match block with 210 | | BLabeled (label, _) -> Map.add label ind ptrs 211 | | _ -> ptrs) 212 | Map.empty blocks startIndices 213 | { Labels = labelPointers; 214 | Instructions = List.map blockInstructions blocks |> List.concat } -------------------------------------------------------------------------------- /Mochi.Core/Mochi.Core.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | net6.0 5 | true 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /Mochi.Core/Permissions.fs: -------------------------------------------------------------------------------- 1 | namespace Mochi.Core 2 | 3 | module Permissions = 4 | 5 | let map = Map.ofList [ 6 | ("FileRead", 0) 7 | ("FileWrite", 1) 8 | ("FileDelete", 2) 9 | ] -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Boba - A Structured Concatenative Language 2 | 3 | Boba is an early-stage, general purpose [concatenative](https://concatenative.org/) programming language. 4 | 5 | Key features include: 6 | 1. Expressive, mostly implicit static types and kinds 7 | 2. Language-incorporated unit and property tests + runners 8 | 3. Algebraic effects via scoped effect handlers 9 | 4. Algebraic data types and pattern matching on constructors 10 | 5. Compile-time resolved function overloading 11 | 6. Structurally typed tuples, records and variants 12 | 8. Byte-code VM-in-Go backend with straight-forward first-order FFI access 13 | 9. Familiar looping, branching, and variable definition syntax constructs 14 | 15 | ## Hailstone Example 16 | 17 | ``` 18 | func is-even n = n 2 rem-i32 0 eq-i32 19 | 20 | about : 21 | /// The `hailstone` function is sometimes named that because of how the values 22 | /// 'bounce' up and down (like hail in a storm cloud) as the sequence computes. 23 | rec func hailstone n = 24 | switch { 25 | | n 1 eq-i32 => [] 26 | | n is-even => n 2 div-i32 hailstone 27 | | else => 3 n mul-i32 inc-i32 hailstone 28 | } 29 | n cons-list 30 | 31 | test hailstone-1? = 1 hailstone is [1] 32 | test hailstone-2? = 2 hailstone is [1, 2] 33 | test hailstone-3? = 3 hailstone is [1, 2, 4, 8, 16, 5, 10, 3] 34 | test hailstone-6? = 6 hailstone is [1, 2, 4, 8, 16, 5, 10, 3, 6] 35 | 36 | export { hailstone } 37 | ``` 38 | 39 | See the `test/` folder for many more examples of Boba syntactic and semantic features. 40 | 41 | ## Building from source 42 | 43 | The Boba compiler is currently implemented in F#. Recommended to have both .NET 6 and Go language version 1.18 installed on the system before building. This repository is [Gitpod](https://gitpod.io/) compatible and will automatically create a container capable of building and running the compiler. 44 | 45 | Example build-and-run command: 46 | 47 | ``` 48 | dotnet run --project Boba.Compiler compile test/while-expr 49 | ``` 50 | 51 | This will build the compiler, then `compile` the `test/while-expr.boba` file in the tests directory into an executable and then run it. 52 | 53 | To use Boba's inline testing features, simply replace `compile` with `test`: 54 | 55 | ``` 56 | dotnet run --project Boba.Compiler test test/ackermann 57 | ``` 58 | 59 | This will run all the tests present in the `test/ackermann.boba` file and report on their success/failure. 60 | 61 | To run a test or program without the current runtime debug trace, include a `release` flag: 62 | 63 | ``` 64 | dotnet run --project Boba.Compiler test test/hailstone release 65 | ``` 66 | 67 | ## Installation 68 | 69 | Installers and binary packages are not yet available while the compiler CLI further stabilizes. 70 | 71 | ## License 72 | 73 | Boba is available and distributed under the terms of the MIT license. See LICENSE for details. 74 | 75 | ## Roadmap 76 | 77 | In no particular order, and missing some potential work that may take priority: 78 | 79 | - Community feature: Better showcase examples 80 | - Ecosystem feature: Flesh-out primitives library further 81 | - Codegen feature: Compile some Boba functions to Go rather than byte-code -------------------------------------------------------------------------------- /boba.sln: -------------------------------------------------------------------------------- 1 |  2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 16 4 | VisualStudioVersion = 16.0.30907.101 5 | MinimumVisualStudioVersion = 15.0.26124.0 6 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Boba.Core", "Boba.Core\Boba.Core.fsproj", "{B7966108-72A5-4C0A-9324-32A282589599}" 7 | EndProject 8 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Boba.Core.Test", "Boba.Core.Test\Boba.Core.Test.fsproj", "{F05B7E00-7D07-4783-809F-B2E77B3A1991}" 9 | EndProject 10 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Mochi.Core", "Mochi.Core\Mochi.Core.fsproj", "{625A0D45-A7A0-4F6F-A74D-A79972BDC36B}" 11 | EndProject 12 | Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Boba.Compiler", "Boba.Compiler\Boba.Compiler.fsproj", "{B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}" 13 | EndProject 14 | Global 15 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 16 | Debug|Any CPU = Debug|Any CPU 17 | Debug|x64 = Debug|x64 18 | Debug|x86 = Debug|x86 19 | Release|Any CPU = Release|Any CPU 20 | Release|x64 = Release|x64 21 | Release|x86 = Release|x86 22 | EndGlobalSection 23 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 24 | {B7966108-72A5-4C0A-9324-32A282589599}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 25 | {B7966108-72A5-4C0A-9324-32A282589599}.Debug|Any CPU.Build.0 = Debug|Any CPU 26 | {B7966108-72A5-4C0A-9324-32A282589599}.Debug|x64.ActiveCfg = Debug|Any CPU 27 | {B7966108-72A5-4C0A-9324-32A282589599}.Debug|x64.Build.0 = Debug|Any CPU 28 | {B7966108-72A5-4C0A-9324-32A282589599}.Debug|x86.ActiveCfg = Debug|Any CPU 29 | {B7966108-72A5-4C0A-9324-32A282589599}.Debug|x86.Build.0 = Debug|Any CPU 30 | {B7966108-72A5-4C0A-9324-32A282589599}.Release|Any CPU.ActiveCfg = Release|Any CPU 31 | {B7966108-72A5-4C0A-9324-32A282589599}.Release|Any CPU.Build.0 = Release|Any CPU 32 | {B7966108-72A5-4C0A-9324-32A282589599}.Release|x64.ActiveCfg = Release|Any CPU 33 | {B7966108-72A5-4C0A-9324-32A282589599}.Release|x64.Build.0 = Release|Any CPU 34 | {B7966108-72A5-4C0A-9324-32A282589599}.Release|x86.ActiveCfg = Release|Any CPU 35 | {B7966108-72A5-4C0A-9324-32A282589599}.Release|x86.Build.0 = Release|Any CPU 36 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 37 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Debug|Any CPU.Build.0 = Debug|Any CPU 38 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Debug|x64.ActiveCfg = Debug|Any CPU 39 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Debug|x64.Build.0 = Debug|Any CPU 40 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Debug|x86.ActiveCfg = Debug|Any CPU 41 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Debug|x86.Build.0 = Debug|Any CPU 42 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Release|Any CPU.ActiveCfg = Release|Any CPU 43 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Release|Any CPU.Build.0 = Release|Any CPU 44 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Release|x64.ActiveCfg = Release|Any CPU 45 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Release|x64.Build.0 = Release|Any CPU 46 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Release|x86.ActiveCfg = Release|Any CPU 47 | {F05B7E00-7D07-4783-809F-B2E77B3A1991}.Release|x86.Build.0 = Release|Any CPU 48 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 49 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Debug|Any CPU.Build.0 = Debug|Any CPU 50 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Debug|x64.ActiveCfg = Debug|Any CPU 51 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Debug|x64.Build.0 = Debug|Any CPU 52 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Debug|x86.ActiveCfg = Debug|Any CPU 53 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Debug|x86.Build.0 = Debug|Any CPU 54 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Release|Any CPU.ActiveCfg = Release|Any CPU 55 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Release|Any CPU.Build.0 = Release|Any CPU 56 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Release|x64.ActiveCfg = Release|Any CPU 57 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Release|x64.Build.0 = Release|Any CPU 58 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Release|x86.ActiveCfg = Release|Any CPU 59 | {625A0D45-A7A0-4F6F-A74D-A79972BDC36B}.Release|x86.Build.0 = Release|Any CPU 60 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 61 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Debug|Any CPU.Build.0 = Debug|Any CPU 62 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Debug|x64.ActiveCfg = Debug|Any CPU 63 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Debug|x64.Build.0 = Debug|Any CPU 64 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Debug|x86.ActiveCfg = Debug|Any CPU 65 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Debug|x86.Build.0 = Debug|Any CPU 66 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Release|Any CPU.ActiveCfg = Release|Any CPU 67 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Release|Any CPU.Build.0 = Release|Any CPU 68 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Release|x64.ActiveCfg = Release|Any CPU 69 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Release|x64.Build.0 = Release|Any CPU 70 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Release|x86.ActiveCfg = Release|Any CPU 71 | {B7BB9C0F-6AC0-4944-9C7E-77CDAE767545}.Release|x86.Build.0 = Release|Any CPU 72 | EndGlobalSection 73 | GlobalSection(SolutionProperties) = preSolution 74 | HideSolutionNode = FALSE 75 | EndGlobalSection 76 | GlobalSection(ExtensibilityGlobals) = postSolution 77 | SolutionGuid = {98BF313F-03C5-4D5D-8213-3512D20CE1F8} 78 | EndGlobalSection 79 | EndGlobal 80 | -------------------------------------------------------------------------------- /go.mod: -------------------------------------------------------------------------------- 1 | module github.com/glossopoeia/boba 2 | 3 | go 1.17 4 | -------------------------------------------------------------------------------- /runtime/fiber.go: -------------------------------------------------------------------------------- 1 | package runtime 2 | 3 | import "context" 4 | 5 | type Marker struct { 6 | afterComplete CodePointer 7 | markId int 8 | nesting uint 9 | handlers []Closure 10 | finisher *Fiber 11 | 12 | valuesMark int 13 | storedMark int 14 | aftersMark int 15 | } 16 | 17 | type Context struct { 18 | Ctx context.Context 19 | } 20 | 21 | type Fiber struct { 22 | Id int 23 | HandlerId *int 24 | Instruction CodePointer 25 | Cancelled bool 26 | // The stack of values operated on directly by most instructions, such as add or multiply. 27 | values []Value 28 | // Used to save values and put them back on the value stack later by referring to their particular 29 | // index in the store stack. 30 | Stored []Value 31 | // Used to save a location to jump back to after executing a particular block of instructions. 32 | afters []CodePointer 33 | // Used to mark a particular location in the stored and after stacks so they can be captured during 34 | // escape handler operations and replayed as continuations. 35 | marks []Marker 36 | Context []Context 37 | caller *Fiber 38 | } 39 | 40 | func NewFiber(machine *Machine, caller *Fiber, ctxStack []Context) *Fiber { 41 | fiber := new(Fiber) 42 | fiber.Id = machine.nextFiberId 43 | machine.nextFiberId += 1 44 | fiber.Instruction = 0 45 | fiber.Cancelled = false 46 | fiber.values = make([]Value, 0) 47 | fiber.Stored = make([]Value, 0) 48 | fiber.afters = make([]CodePointer, 0) 49 | fiber.marks = make([]Marker, 0) 50 | fiber.caller = caller 51 | fiber.Context = make([]Context, len(ctxStack)) 52 | copy(fiber.Context, ctxStack) 53 | return fiber 54 | } 55 | 56 | func (f *Fiber) CloneFiber(machine *Machine, caller *Fiber) *Fiber { 57 | fiber := new(Fiber) 58 | fiber.Id = machine.nextFiberId 59 | machine.nextFiberId += 1 60 | fiber.HandlerId = f.HandlerId 61 | fiber.Instruction = f.Instruction 62 | fiber.Cancelled = f.Cancelled 63 | fiber.values = make([]Value, len(f.values)) 64 | fiber.Stored = make([]Value, len(f.Stored)) 65 | fiber.afters = make([]uint, len(f.afters)) 66 | fiber.marks = make([]Marker, len(f.marks)) 67 | fiber.caller = caller 68 | fiber.Context = make([]Context, len(f.Context)) 69 | 70 | copy(fiber.values, f.values) 71 | copy(fiber.Stored, f.Stored) 72 | copy(fiber.afters, f.afters) 73 | copy(fiber.marks, f.marks) 74 | copy(fiber.Context, f.Context) 75 | return fiber 76 | } 77 | 78 | func (f *Fiber) PushValue(v Value) { 79 | f.values = append(f.values, v) 80 | } 81 | 82 | func (f *Fiber) PopOneValue() Value { 83 | stackLen := len(f.values) 84 | if stackLen <= 0 { 85 | panic("Stack underflow detected.") 86 | } 87 | 88 | result := f.values[stackLen-1] 89 | f.values = f.values[:stackLen-1] 90 | return result 91 | } 92 | 93 | func (f *Fiber) PushAfter(a uint) { 94 | f.afters = append(f.afters, a) 95 | } 96 | 97 | func (f *Fiber) PopAfter() uint { 98 | stackLen := len(f.afters) 99 | if stackLen <= 0 { 100 | panic("After-stack underflow detected.") 101 | } 102 | 103 | result := f.afters[stackLen-1] 104 | f.afters = f.afters[:stackLen-1] 105 | return result 106 | } 107 | 108 | func (f *Fiber) PushMarker(m Marker) { 109 | f.marks = append(f.marks, m) 110 | } 111 | 112 | func (f *Fiber) PopMarker() Marker { 113 | stackLen := len(f.marks) 114 | if stackLen <= 0 { 115 | panic("Marker-stack underflow detected.") 116 | } 117 | 118 | result := f.marks[stackLen-1] 119 | f.marks = f.marks[:stackLen-1] 120 | return result 121 | } 122 | 123 | func (f *Fiber) PeekMarker() Marker { 124 | stackLen := len(f.marks) 125 | if stackLen <= 0 { 126 | panic("Marker-stack underflow detected.") 127 | } 128 | return f.marks[stackLen-1] 129 | } 130 | 131 | func (f *Fiber) Clear() { 132 | f.values = make([]Value, 0) 133 | } 134 | 135 | func (f *Fiber) Gather() { 136 | tpl := f.values 137 | f.values = make([]Value, 0) 138 | f.PushValue(tpl) 139 | } 140 | 141 | func (f *Fiber) Spread() { 142 | tpl := f.PopOneValue().([]Value) 143 | f.values = append(tpl, f.values...) 144 | } 145 | 146 | func (f *Fiber) PopTwoValues() (fst Value, snd Value) { 147 | stackLen := len(f.values) 148 | if stackLen <= 1 { 149 | panic("Stack underflow detected.") 150 | } 151 | 152 | r1 := f.values[stackLen-1] 153 | r2 := f.values[stackLen-2] 154 | f.values = f.values[:stackLen-2] 155 | return r1, r2 156 | } 157 | 158 | func (f *Fiber) PeekOneValue() Value { 159 | stackLen := len(f.values) 160 | if stackLen <= 0 { 161 | panic("Stack underflow detected.") 162 | } 163 | return f.values[:stackLen-1] 164 | } 165 | 166 | func (f *Fiber) PushContext(ctx context.Context) { 167 | f.Context = append(f.Context, Context{ctx}) 168 | } 169 | 170 | func (f *Fiber) PopContext() context.Context { 171 | stackLen := len(f.Context) 172 | if stackLen <= 0 { 173 | panic("Context-stack underflow detected.") 174 | } 175 | 176 | result := f.Context[stackLen-1] 177 | f.Context = f.Context[:stackLen-1] 178 | return result.Ctx 179 | } 180 | 181 | func (f *Fiber) LastCancelContext() Context { 182 | return f.Context[len(f.Context)-1] 183 | } 184 | 185 | // Walk the frame stack backwards looking for a handle frame with the given 186 | // handle id that is 'unnested', i.e. with a nesting level of 0. Injecting 187 | // increases the nesting levels of the nearest handle frames with a giContext 188 | // handle id, while ejecting decreases the nesting level. This dual 189 | // functionality allows some actions to be handled by handlers 'containing' 190 | // inner handlers that would otherwise have handled the action. This function 191 | // drives the actual effect of the nesting by continuing to walk down handle 192 | // frames even if a handle frame with the requested id is found if it is 193 | // 'nested', i.e. with a nesting level greater than 0. 194 | func (f *Fiber) FindFreeMarker(markId int) int { 195 | for i := len(f.marks) - 1; i >= 0; i-- { 196 | marker := f.marks[i] 197 | if marker.markId == markId && marker.nesting == 0 { 198 | return i 199 | } 200 | } 201 | return -1 202 | } 203 | -------------------------------------------------------------------------------- /runtime/numeric.go: -------------------------------------------------------------------------------- 1 | package runtime 2 | 3 | import "math" 4 | 5 | func DivRemT(instr Instruction, l Value, r Value) (Value, Value) { 6 | switch instr { 7 | case I8: 8 | return l.(int8) / r.(int8), l.(int8) % r.(int8) 9 | case U8: 10 | return l.(uint8) / r.(uint8), l.(uint8) % r.(uint8) 11 | case I16: 12 | return l.(int16) / r.(int16), l.(int16) % r.(int16) 13 | case U16: 14 | return l.(uint16) / r.(uint16), l.(uint16) % r.(uint16) 15 | case I32: 16 | return l.(int32) / r.(int32), l.(int32) % r.(int32) 17 | case U32: 18 | return l.(uint32) / r.(uint32), l.(uint32) % r.(uint32) 19 | case I64: 20 | return l.(int64) / r.(int64), l.(int64) % r.(int64) 21 | case U64: 22 | return l.(uint64) / r.(uint64), l.(uint64) % r.(uint64) 23 | case INATIVE: 24 | return l.(int) / r.(int), l.(int) % r.(int) 25 | case UNATIVE: 26 | return l.(uint) / r.(uint), l.(uint) % r.(uint) 27 | case SINGLE: 28 | return l.(float32) / r.(float32), float32(math.Mod(float64(l.(float32)), float64(r.(float32)))) 29 | case DOUBLE: 30 | return l.(float64) / r.(float64), math.Mod(l.(float64), r.(float64)) 31 | default: 32 | panic("Invalid divremt argument type.") 33 | } 34 | } 35 | 36 | func DivRemF(instr Instruction, l Value, r Value) (Value, Value) { 37 | switch instr { 38 | case I8: 39 | quot, rem := l.(int8)/r.(int8), l.(int8)%r.(int8) 40 | if (rem > 0 && r.(int8) < 0) || (rem < 0 && r.(int8) > 0) { 41 | quot = quot - 1 42 | rem = rem + r.(int8) 43 | } 44 | return quot, rem 45 | case U8: 46 | return l.(uint8) / r.(uint8), l.(uint8) % r.(uint8) 47 | case I16: 48 | quot, rem := l.(int16)/r.(int16), l.(int16)%r.(int16) 49 | if (rem > 0 && r.(int16) < 0) || (rem < 0 && r.(int16) > 0) { 50 | quot = quot - 1 51 | rem = rem + r.(int16) 52 | } 53 | return quot, rem 54 | case U16: 55 | return l.(uint16) / r.(uint16), l.(uint16) % r.(uint16) 56 | case I32: 57 | quot, rem := l.(int32)/r.(int32), l.(int32)%r.(int32) 58 | if (rem > 0 && r.(int32) < 0) || (rem < 0 && r.(int32) > 0) { 59 | quot = quot - 1 60 | rem = rem + r.(int32) 61 | } 62 | return quot, rem 63 | case U32: 64 | return l.(uint32) / r.(uint32), l.(uint32) % r.(uint32) 65 | case I64: 66 | quot, rem := l.(int64)/r.(int64), l.(int64)%r.(int64) 67 | if (rem > 0 && r.(int64) < 0) || (rem < 0 && r.(int64) > 0) { 68 | quot = quot - 1 69 | rem = rem + r.(int64) 70 | } 71 | return quot, rem 72 | case U64: 73 | return l.(uint64) / r.(uint64), l.(uint64) % r.(uint64) 74 | case INATIVE: 75 | quot, rem := l.(int)/r.(int), l.(int)%r.(int) 76 | if (rem > 0 && r.(int) < 0) || (rem < 0 && r.(int) > 0) { 77 | quot = quot - 1 78 | rem = rem + r.(int) 79 | } 80 | return quot, rem 81 | case UNATIVE: 82 | return l.(uint) / r.(uint), l.(uint) % r.(uint) 83 | case SINGLE: 84 | panic("divremf does not yet support float32 type.") 85 | case DOUBLE: 86 | panic("divremf does not yet support float64 type.") 87 | default: 88 | panic("Invalid divremf argument type.") 89 | } 90 | } 91 | 92 | func DivRemE(instr Instruction, l Value, r Value) (Value, Value) { 93 | switch instr { 94 | case I8: 95 | quot, rem := l.(int8)/r.(int8), l.(int8)%r.(int8) 96 | if rem < 0 { 97 | if r.(int8) > 0 { 98 | quot = quot - 1 99 | rem = rem + r.(int8) 100 | } else { 101 | quot = quot + 1 102 | rem = rem - r.(int8) 103 | } 104 | } 105 | return quot, rem 106 | case U8: 107 | return l.(uint8) / r.(uint8), l.(uint8) % r.(uint8) 108 | case I16: 109 | quot, rem := l.(int16)/r.(int16), l.(int16)%r.(int16) 110 | if rem < 0 { 111 | if r.(int16) > 0 { 112 | quot = quot - 1 113 | rem = rem + r.(int16) 114 | } else { 115 | quot = quot + 1 116 | rem = rem - r.(int16) 117 | } 118 | } 119 | return quot, rem 120 | case U16: 121 | return l.(uint16) / r.(uint16), l.(uint16) % r.(uint16) 122 | case I32: 123 | quot, rem := l.(int32)/r.(int32), l.(int32)%r.(int32) 124 | if rem < 0 { 125 | if r.(int32) > 0 { 126 | quot = quot - 1 127 | rem = rem + r.(int32) 128 | } else { 129 | quot = quot + 1 130 | rem = rem - r.(int32) 131 | } 132 | } 133 | return quot, rem 134 | case U32: 135 | return l.(uint32) / r.(uint32), l.(uint32) % r.(uint32) 136 | case I64: 137 | quot, rem := l.(int64)/r.(int64), l.(int64)%r.(int64) 138 | if rem < 0 { 139 | if r.(int64) > 0 { 140 | quot = quot - 1 141 | rem = rem + r.(int64) 142 | } else { 143 | quot = quot + 1 144 | rem = rem - r.(int64) 145 | } 146 | } 147 | return quot, rem 148 | case U64: 149 | return l.(uint64) / r.(uint64), l.(uint64) % r.(uint64) 150 | case INATIVE: 151 | quot, rem := l.(int)/r.(int), l.(int)%r.(int) 152 | if rem < 0 { 153 | if r.(int) > 0 { 154 | quot = quot - 1 155 | rem = rem + r.(int) 156 | } else { 157 | quot = quot + 1 158 | rem = rem - r.(int) 159 | } 160 | } 161 | return quot, rem 162 | case UNATIVE: 163 | return l.(uint) / r.(uint), l.(uint) % r.(uint) 164 | case SINGLE: 165 | panic("divreme does not yet support float32 types.") 166 | case DOUBLE: 167 | panic("divreme does not yet support float64 types.") 168 | default: 169 | panic("Invalid divreme argument type.") 170 | } 171 | } 172 | 173 | func Complement(instr Instruction, val Value) Value { 174 | switch instr { 175 | case I8: 176 | return ^val.(int8) 177 | case U8: 178 | return ^val.(uint8) 179 | case I16: 180 | return ^val.(int16) 181 | case U16: 182 | return ^val.(uint16) 183 | case I32: 184 | return ^val.(int32) 185 | case U32: 186 | return ^val.(uint32) 187 | case I64: 188 | return ^val.(int64) 189 | case U64: 190 | return ^val.(uint64) 191 | case INATIVE: 192 | return ^val.(int) 193 | case UNATIVE: 194 | return ^val.(uint) 195 | default: 196 | panic("Invalid bitwise xor argument type.") 197 | } 198 | } 199 | 200 | func Sign(instr Instruction, val Value) Value { 201 | switch instr { 202 | case I8: 203 | if val.(int8) < 0 { 204 | return -1 205 | } else if val.(int8) > 0 { 206 | return 1 207 | } else { 208 | return 0 209 | } 210 | case U8: 211 | if val.(uint8) > 0 { 212 | return 1 213 | } else { 214 | return 0 215 | } 216 | case I16: 217 | if val.(int16) < 0 { 218 | return -1 219 | } else if val.(int16) > 0 { 220 | return 1 221 | } else { 222 | return 0 223 | } 224 | case U16: 225 | if val.(uint16) > 0 { 226 | return 1 227 | } else { 228 | return 0 229 | } 230 | case I32: 231 | if val.(int32) < 0 { 232 | return -1 233 | } else if val.(int32) > 0 { 234 | return 1 235 | } else { 236 | return 0 237 | } 238 | case U32: 239 | if val.(uint32) > 0 { 240 | return 1 241 | } else { 242 | return 0 243 | } 244 | case I64: 245 | if val.(int64) < 0 { 246 | return -1 247 | } else if val.(int64) > 0 { 248 | return 1 249 | } else { 250 | return 0 251 | } 252 | case U64: 253 | if val.(uint64) > 0 { 254 | return 1 255 | } else { 256 | return 0 257 | } 258 | case INATIVE: 259 | if val.(int) < 0 { 260 | return -1 261 | } else if val.(int) > 0 { 262 | return 1 263 | } else { 264 | return 0 265 | } 266 | case UNATIVE: 267 | if val.(uint) > 0 { 268 | return 1 269 | } else { 270 | return 0 271 | } 272 | case SINGLE: 273 | if val.(float32) < 0 { 274 | return -1 275 | } else if val.(float32) > 0 { 276 | return 1 277 | } else { 278 | return 0 279 | } 280 | case DOUBLE: 281 | if val.(float64) < 0 { 282 | return -1 283 | } else if val.(float64) > 0 { 284 | return 1 285 | } else { 286 | return 0 287 | } 288 | default: 289 | panic("Invalid multiply argument type.") 290 | } 291 | } 292 | -------------------------------------------------------------------------------- /runtime/value.go: -------------------------------------------------------------------------------- 1 | package runtime 2 | 3 | import ( 4 | "context" 5 | "sync" 6 | ) 7 | 8 | type ResumeLimit = int 9 | 10 | // This enum provides a way for compiler writers to specify that some closures-as-handlers have 11 | // certain assumptions guaranteed that allow more efficient operation. For instance, RESUME_NONE 12 | // will prevent a handler closure from capturing the continuation, since it is never resumed anyway, 13 | // saving a potentially large allocation and copy. RESUME_ONCE_TAIL treats a handler closure call 14 | // just like any other closure call. The most general option, but the least efficient, is RESUME_MANY, 15 | // which can be thought of as the default for handler closures. The default for all closures is 16 | // RESUME_MANY, even those which are never used as handlers, because continuation saving is only done 17 | // during the ESCAPE instruction and so RESUME_MANY is never acted upon for the majority of closures. 18 | const ( 19 | ResumeMany ResumeLimit = iota 20 | ResumeOnce 21 | ResumeOnceTail 22 | ResumeNever 23 | ) 24 | 25 | type Value interface{} 26 | 27 | type Closure struct { 28 | CodeStart CodePointer 29 | ResumeLimit ResumeLimit 30 | Captured []Value 31 | } 32 | 33 | type NativeVal struct { 34 | val interface{} 35 | } 36 | 37 | type ValueArray struct { 38 | elements []Value 39 | } 40 | 41 | type ByteArray struct { 42 | elements []byte 43 | } 44 | 45 | type Ref struct { 46 | Pointer HeapKey 47 | } 48 | 49 | type CompositeId = int 50 | 51 | type Composite struct { 52 | id CompositeId 53 | elements []Value 54 | } 55 | 56 | type Variant struct { 57 | label int 58 | value Value 59 | } 60 | 61 | func (variant Variant) Clone() Variant { 62 | return Variant{variant.label, variant.value} 63 | } 64 | 65 | type Nursery struct { 66 | Waiter *sync.WaitGroup 67 | } 68 | 69 | type CancelToken struct { 70 | Cancel context.CancelFunc 71 | } 72 | -------------------------------------------------------------------------------- /test/caesar-cipher.boba: -------------------------------------------------------------------------------- 1 | 2 | // ================================================ 3 | // Part 1: Caesar Cipher Encoding 4 | // ================================================ 5 | 6 | about : 7 | /// Convert an 'a' - 'z' rune to an integer from 0 to 25 respectively. 8 | func alpha-ind = conv-rune-i32 'a' conv-rune-i32 sub-i32 9 | 10 | about: 11 | /// Convert an integer from 0 to 25 into a rune from 'a' to 'z' respectively. 12 | func ind-alpha = 'a' conv-rune-i32 add-i32 conv-i32-rune 13 | 14 | test a-is-zero? = 'a' alpha-ind is 0i32 15 | test z-is-twentyfive? = 'z' alpha-ind is 25i32 16 | test zero-is-a? = 0i32 ind-alpha trust-rune clear-rune is 'a' 17 | test twentyfive-is-z? = 25i32 ind-alpha trust-rune clear-rune is 'z' 18 | 19 | func shift c n = 20 | if c ' ' eq 21 | then { c } 22 | else { 23 | let shifted = c alpha-ind n add-i32; 24 | let wrapped = shifted 26i32 rem-i32; 25 | wrapped ind-alpha trust-rune clear-rune 26 | } 27 | 28 | func encode str n = 29 | for c in string str as string then { 30 | c n shift 31 | } 32 | 33 | test encode-pos? = "boba is fun" 3i32 encode is "ered lv ixq" 34 | test encode-neg? = "ered lv ixq" -3i32 encode is "boba is fun" 35 | 36 | 37 | // ================================================ 38 | // Part 2: Frequency Tables 39 | // ================================================ 40 | 41 | func table = [ 0.1, 2.0, 0.2, 2.4, 1.0, 2.8, 9.0, 6.3, 42 | 6.0, 0.1, 1.9, 7.5, 6.7, 2.4, 4.0, 0.8, 0.2, 43 | 7.0, 6.1, 2.0, 2.2, 12.7, 4.2, 2.8, 1.5, 8.1 ] 44 | 45 | func percent m n = n conv-inative-single m conv-inative-single div-single 100.0 mul-single 46 | 47 | test percent-ex? = 15 5 percent is 33.333336 48 | 49 | func lowers str = 50 | for c in string str result amt = 0 then { 51 | let tc = c conv-rune-i32; 52 | if tc 'a' conv-rune-i32 gte-i32 53 | tc 'z' conv-rune-i32 lte-i32 and-bool then { 54 | amt inc-inative 55 | } else { 56 | amt 57 | } 58 | } 59 | 60 | test lowers-ex? = "boba is fun" lowers is 9 61 | 62 | func count str c = 63 | for t in string str result amt = 0 then { 64 | if c t eq-rune then { amt inc-inative } else { amt } 65 | } 66 | 67 | test count-ex? = "Mississippi" 's' count is 4 68 | 69 | func freqs str = { 70 | let n = str lowers; 71 | for c in 'z' 'a' 1 conv-inative-i32 conv-i32-rune trust-rune clear-rune range as list then { 72 | n str c count percent 73 | } 74 | } 75 | 76 | test freqs-ex? = "abbcccddddeeeee" freqs is 77 | [ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 78 | 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 79 | 0.0, 0.0, 0.0, 0.0, 33.333336, 26.666668, 20.0, 13.333334, 6.666667 ] 80 | 81 | 82 | // ================================================ 83 | // Part 3: Cracking Encoded Messages 84 | // ================================================ 85 | 86 | func zip = 87 | match { 88 | | [ rs... r ] [ ls... l ] => [ rs ls zip ... with [| r, l |] ] 89 | | otherwise => drop drop [] 90 | } 91 | 92 | func chisqr observed expected = 93 | for p in list observed expected zip as list then { 94 | p match { 95 | | [| o e |] => { 96 | let diff = o e sub-single; 97 | let absDiff = diff diff mul-single; 98 | absDiff e div-single 99 | } 100 | } 101 | } 102 | for r in list result sum = 0.0 then { 103 | sum r add-single 104 | } 105 | 106 | rec func take xs n = 107 | if n 0 eq-inative then { 108 | [] 109 | } else { 110 | xs match { 111 | | [] => [] 112 | | [ r... x ] => [ r n dec-inative take ... with x ] 113 | } 114 | } 115 | 116 | test take-all? = [ 5, 4, 3, 2, 1 ] 5 take is [ 5, 4, 3, 2, 1 ] 117 | 118 | rec func drop xs n = 119 | if n 0 eq-inative then { 120 | xs 121 | } else { 122 | xs match { 123 | | [] => [] 124 | | [ r... _ ] => r n dec-inative drop 125 | } 126 | } 127 | 128 | test drop-all? = [ 9, 8, 7, 6, 5 ] 5 drop is [] 129 | 130 | func rotate xs n = xs n take xs n drop append-list 131 | 132 | test rotate-3? = [ 5, 4, 3, 2, 1 ] 3 rotate is [ 3, 2, 1, 5, 4 ] 133 | 134 | func positions xs x = 135 | for e in xs iterate, i in 0 xs length-list 1 range result ps = [] then { 136 | if x e eq then { ps i 137 | } 138 | 139 | func crack str = { 140 | let ftable = str freqs; 141 | let chitable = 142 | for n in 0i32 25i32 1i32 range as list then { 143 | table ftable n rotate chisqr 144 | }; 145 | let factor = 146 | } 147 | 148 | 149 | export { } -------------------------------------------------------------------------------- /test/correct-main/closure-capture-order.boba: -------------------------------------------------------------------------------- 1 | 2 | //test swap-cap? = 3 | // { let x = 1; let y = True; (| 0 drop x y |) do swap } drop satisfies 4 | 5 | effect swapper! 6 | = swap! : z... a^r b^s ===[ e..., swapper! ][ p... ][ True ]==> z... b^s a^r 7 | 8 | //test hdlr-cap? = { 9 | // let x = True; 10 | // let y = 0; 11 | // handle 2 { x y swap! } 12 | // with { 13 | // | swap! => swap resume 14 | // } 15 | // } 16 | // satisfies 17 | 18 | main = { 19 | let x = True; 20 | let y = 0; 21 | handle 2 { x y swap! } 22 | with { 23 | | swap! => swap resume 24 | } 25 | drop 26 | } 27 | -------------------------------------------------------------------------------- /test/correct-main/datatype.boba: -------------------------------------------------------------------------------- 1 | 2 | type Boolean 3 | = BTrue : => Boolean 4 | | BFalse : => Boolean 5 | 6 | type Option a 7 | = Some : a => (Option a) 8 | | None : => (Option a) 9 | 10 | func optMap f = 11 | match { 12 | | (Some a) => a f do Some 13 | | None => None 14 | } 15 | 16 | main = 17 | 0 Some match { 18 | | (Some a) => a 19 | | None => 1 20 | } -------------------------------------------------------------------------------- /test/correct-main/else-expr.boba: -------------------------------------------------------------------------------- 1 | func isEven n = n 2 rem-inative 0 eq-inative 2 | 3 | main = 4 | if 4 isEven not-bool then { 5 | 1 6 | } else { 7 | 0 8 | } -------------------------------------------------------------------------------- /test/correct-main/go-native-wrap.boba: -------------------------------------------------------------------------------- 1 | import native "math" 2 | 3 | native abs-double 4 | : z... (Double u)^s ===[ e... ][ p... ][ True ]==> z... (Double u)^r 5 | = 6 | # num := fiber.PopOneValue().(float64) 7 | # fiber.PushValue(math.Abs(num)) 8 | 9 | native cos-double 10 | : z... (Double one)^s ===[ e... ][ p... ][ True ]==> z... (Double one)^r 11 | = 12 | # num := fiber.PopOneValue().(float64) 13 | # fiber.PushValue(math.Cos(num)) 14 | 15 | main = 1.57079633 conv-single-double cos-double abs-double conv-double-inative -------------------------------------------------------------------------------- /test/correct-main/handle-closure.boba: -------------------------------------------------------------------------------- 1 | 2 | effect num! 3 | = num! : z... ===[ e..., num! ][ p... ][ True ]==> z... (INative one)^s 4 | 5 | effect add! 6 | = add! : z... (INative one)^r (INative one)^q ===[ e..., add! ][ p... ][ True ]==> z... (INative one)^s 7 | 8 | effect amb! 9 | = flip! : z... ===[ e..., amb! ][ p... ][ t ]==> z... Bool^s 10 | 11 | func t-closure-construct = (| num! |) 12 | func t-closure-call = (| num! |) do 13 | func t-handle-closure-construct = 14 | handle 1 { (| num! |) } with { | num! => 1 resume } 15 | func t-handle-closure-call = 16 | handle 1 { (| num! |) do } with { | num! => 1 resume } 17 | func t-handle-closure-param c = 18 | handle 1 { c do } with { | num! => 1 resume } 19 | func t-handle-empty-closure = (| 0 |) t-handle-closure-param 20 | 21 | main = 0 -------------------------------------------------------------------------------- /test/correct-main/handle-escape.boba: -------------------------------------------------------------------------------- 1 | 2 | effect exn! 3 | = raise! : z... ===[ e..., exn! ][ p... ][ True ]==> y... 4 | 5 | func esc = 6 | handle 1 { 7 | 2 1 8 | if dup 0 eq then { 9 | raise! 10 | } else { 11 | div-inative 12 | } 13 | } with { 14 | | raise! => 0 15 | } 16 | 17 | main = 18 | handle 1 { 19 | 2 0 20 | if dup 0 eq then { 21 | raise! 22 | } else { 23 | div-inative 24 | } 25 | } with { 26 | | raise! => 0 27 | } -------------------------------------------------------------------------------- /test/correct-main/handle-multiret.boba: -------------------------------------------------------------------------------- 1 | 2 | effect nums! 3 | = nums! : z... ===[ e..., nums! ][ p... ][ True ]==> z... (I32 one)^r (INative one)^s 4 | 5 | main = 6 | handle 2 { nums! } with { | nums! => 1i32 0 resume } swap drop 7 | -------------------------------------------------------------------------------- /test/correct-main/if-expr.boba: -------------------------------------------------------------------------------- 1 | func isEven n = n 2 rem-inative 0 eq-inative 2 | 3 | main = 4 | if 4 isEven then { 5 | 0 6 | } else { 7 | 1 8 | } -------------------------------------------------------------------------------- /test/correct-main/lists.boba: -------------------------------------------------------------------------------- 1 | 2 | func nil = [ ] 3 | 4 | func cons x y = [ x... with y ] 5 | 6 | func break-list = 7 | match { 8 | | [ b... a ] => [ b... ] a 9 | } 10 | 11 | func one-elem = [ 2 ] 2 12 | 13 | func with-data = [ True, False, True ] 14 | 15 | func ext r = [ r... with False, True, False ] 16 | 17 | func fst = 18 | match { 19 | | [ b... a ] => a 20 | } 21 | 22 | func snd = 23 | match { 24 | | [ c... b a ] => b 25 | } 26 | 27 | func fstFst = 28 | match { 29 | | [ b... [ c... a ] ] => a 30 | } 31 | 32 | func tail = 33 | match { 34 | | [ b... a ] => [ b... ] 35 | } 36 | 37 | func print-list l = 38 | "(" clear-string print-string 39 | for e in list l then { 40 | e print-string 41 | ", " clear-string print-string 42 | } 43 | ")" clear-string print-string 44 | 45 | func print-two-list l1 l2 = 46 | "(" clear-string print-string 47 | for el in list l1, er in list l2 then { 48 | el print-string 49 | ";" clear-string print-string 50 | er print-string 51 | ", " clear-string print-string 52 | } 53 | ")" clear-string print-string 54 | 55 | func map-list l f = 56 | for e in list l as list then { 57 | e f do 58 | } 59 | 60 | func all-list l = 61 | for e in list l result res = True then { 62 | res e and-bool 63 | } 64 | 65 | func extracting = 66 | [ 0 ] fst 67 | [ 2, 0, 1 ] snd 68 | add-inative 69 | 70 | //main = [ "hello", "printed", "lists!" ] print-list extracting 71 | //main = [ true, false, true ] all-list conv-bool-i32 72 | main = { 73 | if [0, 1] [0, 2] eq then { 74 | "List inequality doesn't work!" clear-string print-string 75 | } else { 76 | "List inequality works" clear-string print-string 77 | } 78 | 79 | [ "hello", "printed", "lists" ] (| "!" concat-string clear-string |) map-list print-list 80 | 0 81 | } -------------------------------------------------------------------------------- /test/correct-main/nested-handlers.boba: -------------------------------------------------------------------------------- 1 | 2 | effect state! s 3 | = get! : z... ===[ e..., (state! s) ][ p... ][ True ]==> z... s 4 | | put! : z... s ===[ e..., (state! s) ][ p... ][ True ]==> z... 5 | 6 | effect amb! 7 | = flip! : z... ===[ e..., amb! ][ p... ][ t ]==> z... Bool^s 8 | 9 | func xor = flip! flip! neq-bool 10 | 11 | func inner = { 12 | let p = flip!; 13 | let i = get!; 14 | i inc-inative put! 15 | if i 1 gte-inative p and-bool then { 16 | xor 17 | } else { 18 | False 19 | } 20 | } 21 | 22 | func state-elim = 23 | 0 handle 1 s { 24 | inner 25 | } with { 26 | | get! => s s resume 27 | | put! n => n resume 28 | | after r => [| s, r |] 29 | } 30 | 31 | func amb-wrap-state = 32 | handle 1 { 33 | state-elim 34 | } with { 35 | | flip! => False resume True resume append-list 36 | | after v => [v] 37 | } 38 | 39 | main = amb-wrap-state drop 0 40 | -------------------------------------------------------------------------------- /test/correct-main/overload.boba: -------------------------------------------------------------------------------- 1 | overload eq as Eq? a 2 | : z... a^s a^r ===[ e... ][ p... ][ True ]==> z... Bool^q 3 | 4 | instance eq : Bool 5 | = eq-bool 6 | 7 | instance eq : (INative u) 8 | = eq-inative 9 | 10 | instance eq : <= Eq? y => [y^_] 11 | = 12 | { 13 | let l r; 14 | if l length-list r length-list eq then { 15 | for el in list l, er in list r result res = True then { 16 | el er eq res and-bool 17 | } 18 | } else { False } 19 | } 20 | 21 | 22 | func test-eq-1 = True False eq 23 | 24 | func test-eq-2 = True eq 25 | 26 | func test-eq-3 = 1 eq 27 | 28 | func test-eq-4 w x y z = w x eq y z eq and-bool 29 | 30 | func call-test-eq-4 = 1 1 False False test-eq-4 31 | 32 | // TODO: this is broken currently 33 | //func eq-tuple = 34 | // for fold res <= true with e1 <= tuple, e2 <= tuple then { 35 | // e1 e2 eq res and-bool 36 | // } 37 | 38 | test func-with-context? = 1 1 False False test-eq-4 satisfies 39 | 40 | main = { 1 test-eq-3; let x; 0 } -------------------------------------------------------------------------------- /test/correct-main/permissions.boba: -------------------------------------------------------------------------------- 1 | 2 | func do-print = 3 | with permission console then { 4 | "hello, world!" clear-string print-string 0 5 | } else { 6 | 1 7 | } 8 | 9 | func no-perm = "foo bar" clear-string print-string 10 | 11 | //main = do-print 12 | main = 0 -------------------------------------------------------------------------------- /test/correct-main/records.boba: -------------------------------------------------------------------------------- 1 | func ext = 1 ->label 2 | 3 | func extTwice = 1 ->label 2 ->label 4 | 5 | func extUpd = *-label drop 1 ->label 6 | 7 | func extUpdType = 1 ->label False ->label <-label 8 | 9 | func sel = <-label 10 | func multiSel = dup <-label drop <-label 11 | 12 | func keep = *-label 13 | func keepSel = *-label drop *-label 14 | 15 | func point y x = {| x = x, y = y |} 16 | 17 | func addX r = if True then { {| r... with x = 1 |} } else { {| x = 2 |} } 18 | 19 | func matchRec = 20 | match { 21 | | {| hello = 1, world = {| nest = nest |} |} => nest 22 | } 23 | 24 | // func invPointAccess = 1 0 point <-z 25 | 26 | // main = 1 0 point <-x 27 | 28 | main = {| hello = 1, world = {| nest = 0 |} |} matchRec -------------------------------------------------------------------------------- /test/correct-main/state-handler.boba: -------------------------------------------------------------------------------- 1 | 2 | effect state! s 3 | = get! : ===[ e..., (state! s) ][ p... ][ True ]==> s 4 | | put! : s ===[ e..., (state! s) ][ p... ][ True ]==> 5 | 6 | func counter = 7 | get! 1 add-inative 8 | put! 9 | get! 1 add-inative 10 | put! 11 | get! 1 add-inative 12 | 13 | main = 14 | 2 15 | handle 1 s { 16 | counter 17 | } with { 18 | | get! => s s resume 19 | | put! n => n resume 20 | | after r => [s, r] 21 | } 22 | head-list 23 | 24 | if 5 eq then { 0 } else { 1 } -------------------------------------------------------------------------------- /test/correct-main/tags.boba: -------------------------------------------------------------------------------- 1 | 2 | tag M = meter 3 | 4 | tag H = hour 5 | 6 | tag G = gram 7 | 8 | tag Kg = kilogram 9 | 10 | func meters-squared = of { meter meter } 11 | 12 | func velocity = of { meter per hour } 13 | 14 | func accel = of { meter per hour hour } 15 | 16 | func gramsPerKilogram = 1000 of { gram per kilogram } 17 | 18 | func grams-to-kilograms x = x gramsPerKilogram div-inative 19 | 20 | func kilogram = 10 of gram grams-to-kilograms 21 | 22 | func untag = of { } 23 | 24 | main = 0 velocity untag -------------------------------------------------------------------------------- /test/correct-main/test-example.boba: -------------------------------------------------------------------------------- 1 | 2 | effect test-demo! 3 | = test-demo! : (INative u)^q Bool^s (String t c)^r ===[ e..., test-demo! ][ p... ][ True ]==> (INative u)^g 4 | 5 | func test-checker test-success test-name failed = 6 | if test-success 7 | then { test-name " succeeded.\n" } 8 | else { test-name " failed.\n" } 9 | concat-string 10 | clear-string 11 | print-string 12 | 13 | if test-success then { failed } else { 1 failed add-inative } 14 | 15 | func test-model-one = 0 0 eq-inative 16 | func test-model-two = 1 1 eq-inative 17 | 18 | func run-test = 19 | handle 1 { 20 | 0 21 | test-model-one "test-model-one" test-demo! 22 | test-model-two "test-model-two" test-demo! 23 | } with { 24 | | test-demo! count res name => res name count test-checker resume 25 | } 26 | 27 | main = run-test -------------------------------------------------------------------------------- /test/correct-main/tiny-test.boba: -------------------------------------------------------------------------------- 1 | 2 | test eq-list? = [0] is [0] 3 | 4 | //test eq-tuple? = [| 0 |] is [| 0 |] 5 | 6 | //test tiny-one? = [ [| 0 |] ] is [ [| 0 |] ] 7 | 8 | effect num! 9 | = num! : z... ===[ e..., num! ][ p... ][ True ]==> z... (INative one)^s 10 | 11 | effect add! 12 | = add! : z... (INative one)^r (INative one)^q ===[ e..., add! ][ p... ][ True ]==> z... (INative one)^s 13 | 14 | effect amb! 15 | = flip! : z... ===[ e..., amb! ][ p... ][ t ]==> z... Bool^s 16 | 17 | func branch-eff = if then { num! } else { 0 1 add! } 18 | 19 | func unhandled-eff = handle 1 { num! } with { | add! x y => x y add-inative resume } 20 | 21 | func unhandled-handler-eff = handle 1 { flip! } with { | add! x y => x num! add-inative resume } 22 | 23 | //main = { 24 | // let z = 0; 25 | // handle { z 1 add! } //2 add! z add! } 26 | // with { 27 | // | add! x y => x y add-inative resume 0 drop 28 | // } 29 | // 0 drop 30 | //} 31 | 32 | //main = 33 | // handle { 34 | // flip! flip! neq-bool 35 | // } with { 36 | // | flip! => { 37 | // let x = False resume; 38 | // let y = True resume; 39 | // x y append-list 40 | // } 41 | // | after v => [v] 42 | // } 43 | // drop 0 44 | 45 | main = 46 | 0 handle 1 { 0 } with { | add! x y => x y add-inative resume } add-inative 47 | -------------------------------------------------------------------------------- /test/correct-main/tuples.boba: -------------------------------------------------------------------------------- 1 | 2 | func nil = [| |] 3 | 4 | func id-tuple x = [| x... |] 5 | 6 | func one-elem = [| 2 |] 7 | 8 | func with-data = [| 1, True |] 9 | 10 | func ext r = [| r... with False, 2, 1.2 |] 11 | 12 | func fst = 13 | match { 14 | | [| b... a |] => a 15 | } 16 | 17 | func snd = 18 | match { 19 | | [| c... b a |] => b 20 | } 21 | 22 | func fstFst = 23 | match { 24 | | [| b... [| c... a |] |] => a 25 | } 26 | 27 | func tail = 28 | match { 29 | | [| b... a |] => [| b... |] 30 | } 31 | 32 | func print-tuple t = 33 | "(" clear-string print-string 34 | for e in tuple t then { 35 | e print-string 36 | ", " clear-string print-string 37 | } 38 | ")" clear-string print-string 39 | 40 | func map-tuple t f = 41 | for e in tuple t as tuple then { 42 | let x = e f do; 43 | x 44 | } 45 | 46 | func all-tuple t = 47 | for e in tuple t result res = True then { 48 | res e and-bool 49 | } 50 | 51 | func extracting = 52 | [| 0 |] fst 53 | [| 2, 0, 1 |] snd 54 | add-inative 55 | 56 | test eq-tuple? = [| 0 |] is [| 0 |] 57 | 58 | //main = [| "hello", "printed", "tuples!" |] print-tuple extracting 59 | //main = [| true, false, true |] all-tuple conv-bool-i32 60 | main = { 61 | [| "hello" clear-string, "printed" clear-string, "tuples" clear-string |] 62 | (| "!" clear-string concat-string |) map-tuple print-tuple 63 | 0 64 | } 65 | -------------------------------------------------------------------------------- /test/correct-main/type-assert.boba: -------------------------------------------------------------------------------- 1 | func add2 = 2 add-inative 2 | 3 | check type add2 : z... (INative one)^s1 ===[ e... ][ p... ][ True ]==> z... (INative one)^s2 4 | 5 | main = 1 add2 drop 0 -------------------------------------------------------------------------------- /test/correct-main/variants.boba: -------------------------------------------------------------------------------- 1 | func drop x = 2 | 3 | func sign = 4 | case { 5 | | greater => drop 1 6 | | smaller => drop -1 7 | | else => drop 0 8 | } 9 | 10 | main = <| greater = 2 |> sign if 1 eq then { 0 } else { 1 } -------------------------------------------------------------------------------- /test/correct-main/while-expr.boba: -------------------------------------------------------------------------------- 1 | 2 | func not-zero = 0 eq-inative not-bool 3 | 4 | func count n = 5 | 0 n while dup not-zero then { 6 | let x y; 7 | x inc-inative y dec-inative 8 | } 9 | drop 10 | 11 | func condless-count n = 12 | 0 n dup not-zero while then { 13 | let x y; 14 | x inc-inative y dec-inative dup not-zero 15 | } 16 | drop 17 | 18 | func weird-loop = 19 | while True True True then { 20 | drop drop 21 | } 22 | 23 | main = 5 count if 5 eq then { 0 } else { 1 } -------------------------------------------------------------------------------- /test/correct-test/ackermann.boba: -------------------------------------------------------------------------------- 1 | func is-zero = 0 eq-inative 2 | func gt-zero = 0 gt-inative 3 | func lt-zero = 0 lt-inative 4 | 5 | rec func ackermann n m = 6 | switch { 7 | | m is-zero => n inc-inative 8 | | m gt-zero n is-zero and-bool => 1 m dec-inative ackermann 9 | | else => n dec-inative m ackermann m dec-inative ackermann 10 | } 11 | 12 | test ackermann-0-0? = 0 0 ackermann satisfies 1 eq-inative 13 | test ackermann-1-0? = 1 0 ackermann satisfies 2 eq-inative 14 | test ackermann-5-0? = 5 0 ackermann satisfies 6 eq-inative 15 | test ackermann-0-1? = 0 1 ackermann satisfies 2 eq-inative 16 | test ackermann-2-1? = 1 2 ackermann satisfies 5 eq-inative 17 | test ackermann-1-2? = 2 1 ackermann satisfies 4 eq-inative 18 | test ackermann-2-3? = 3 2 ackermann satisfies 9 eq-inative 19 | test ackermann-3-2? = 2 3 ackermann satisfies 29 eq-inative 20 | 21 | export { ackermann } -------------------------------------------------------------------------------- /test/correct-test/classes.boba: -------------------------------------------------------------------------------- 1 | 2 | overload identity as Identity? a 3 | : z... ===[ e... ][ p... ][ True ]==> z... a^s 4 | 5 | overload append as Semigroup? a 6 | : z... a^s a^r ===[ e... ][ p... ][ True ]==> z... a^q 7 | 8 | class Monoid? a = Identity? a, Semigroup? a 9 | 10 | func app-id = identity identity append 11 | 12 | func app-id-eq = identity append eq 13 | 14 | export { } -------------------------------------------------------------------------------- /test/correct-test/dot-overload.boba: -------------------------------------------------------------------------------- 1 | 2 | overload show as Show? a 3 | : z... a^s ===[ e... ][ p... ][ True ]==> z... (String t c)^r 4 | 5 | instance show : Bool 6 | = if then { "true" } else { "false" } 7 | 8 | instance show : (I32 u) 9 | = 10 | match { 11 | | 0i32 => "0" 12 | | else => drop "0" 13 | } 14 | 15 | instance show : (INative u) 16 | = 17 | match { 18 | | 0 => "1" 19 | | else => drop "1" 20 | } 21 | 22 | instance show : [| |] 23 | = 24 | match { 25 | | [| |] => "." 26 | } 27 | 28 | instance show : <= Show? [| a... |], Show? b => [| a... b^_ |] 29 | = 30 | match { 31 | | [| a... b |] => b show "," concat-string a show concat-string 32 | } 33 | 34 | func show-tuple r = [| r... with 3, 2, True |] show 35 | 36 | test show-i32? = 0i32 show is "0" 37 | test show-empty-tuple? = [| |] show is "." 38 | test show-one-tuple? = [| 0 |] show is "1,." 39 | test show-three-tuple? = [| True, 0, 1i32 |] show is "0,1,true,." 40 | test show-four-tuple? = [| False |] show-tuple is "true,1,1,false,." 41 | 42 | export { show } -------------------------------------------------------------------------------- /test/correct-test/export.boba: -------------------------------------------------------------------------------- 1 | func export-1 n m = m n 2 | 3 | func export-2 = export-1 4 | 5 | func non-export-3 = export-2 6 | 7 | func export-4 = non-export-3 8 | 9 | test export-succeed? = 1 1 satisfies eq-inative 10 | //test export-failure? = 1 2 satisfies eq-inative 11 | 12 | export { export-1 export-2 export-4 } -------------------------------------------------------------------------------- /test/correct-test/functor.boba: -------------------------------------------------------------------------------- 1 | 2 | overload map as Functor? f 3 | : z... (f a)^s (| y... a ===[ e... ][ p... ][ t ]==> y... b |)^qq ===[ e... ][ p... ][ t ]==> z... (f b)^r 4 | 5 | instance map : [] 6 | = { let l f; for e in list l as list then { e f do } } 7 | 8 | test map-list? = [ 0, 1, 2, 3 ] (| 1 add-inative |) map is [ 1, 2, 3, 4 ] 9 | 10 | export { } -------------------------------------------------------------------------------- /test/correct-test/fundeps.boba: -------------------------------------------------------------------------------- 1 | 2 | overload extract as Extract? coll el 3 | : z... coll ===[ e... ][ p... ][ True ]==> z... el 4 | 5 | instance extract : [| b^r... a^s |]^((r...) || s) a^s 6 | = head-tuple 7 | 8 | instance extract : [a^s]^(s || r) a^s 9 | = head-list 10 | 11 | rule coll-det-el? = Extract? c e1, Extract? c e2 => e1 = e2 12 | rule coll-tuple? = Extract? [| e2^r... e1^s |]^(s || (r...)) e3 => e1^s = e3 13 | rule coll-list? = Extract? [a1^s]^(s || r) a2 => a1^s = a2 14 | 15 | func et = [| 1, 1.2, True |] extract 16 | 17 | test fun-dep-reduces? = et satisfies 18 | test fun-dep-in-expr? = [ 3, 2, 1 ] extract is 1 19 | 20 | export { et } -------------------------------------------------------------------------------- /test/correct-test/hailstone.boba: -------------------------------------------------------------------------------- 1 | func is-even n = n 2 rem-inative 0 eq-inative 2 | 3 | rec func hailstone n = 4 | switch { 5 | | n 1 eq-inative => [] 6 | | n is-even => n 2 div-inative hailstone 7 | | else => 3 n mul-inative inc-inative hailstone 8 | } 9 | n cons-list 10 | 11 | test hailstone-1? = 1 hailstone is [1] 12 | test hailstone-2? = 2 hailstone is [1, 2] 13 | test hailstone-3? = 3 hailstone is [1, 2, 4, 8, 16, 5, 10, 3] 14 | test hailstone-6? = 6 hailstone is [1, 2, 4, 8, 16, 5, 10, 3, 6] 15 | 16 | export { hailstone } -------------------------------------------------------------------------------- /test/correct-test/handle-context.boba: -------------------------------------------------------------------------------- 1 | 2 | effect num! 3 | = num! : z... ===[ e..., num! ][ p... ][ True ]==> z... (INative one)^s 4 | 5 | effect add! 6 | = add! : z... (INative one)^r (INative one)^q ===[ e..., add! ][ p... ][ True ]==> z... (INative one)^s 7 | 8 | effect amb! 9 | = flip! : z... ===[ e..., amb! ][ p... ][ t ]==> z... Bool^s 10 | 11 | func t-hdl-ctx-inner z y = 12 | handle 1 { z y eq } with { | num! => 0 resume } 13 | func t-hdl-ctx-hdlr z y x w = 14 | handle 1 { z y eq drop flip! } with { | flip! => x w eq resume } 15 | func t-hdl-ctx-after z y x w = 16 | handle 1 { z y eq } with { | flip! => True resume | after => drop x w eq } 17 | 18 | test ctx-hdlr? = 1 2 [ 8 ] [ 8 ] t-hdl-ctx-hdlr satisfies 19 | test ctx-after? = 1 2 [ 8 ] [ 8 ] t-hdl-ctx-after satisfies 20 | 21 | export { } -------------------------------------------------------------------------------- /test/correct-test/handler-order.boba: -------------------------------------------------------------------------------- 1 | 2 | effect swapper! 3 | = swap! : z... a^r b^s ===[ e..., swapper! ][ p... ][ True ]==> z... b^s a^r 4 | 5 | effect swapper-p! x 6 | = swapp! : z... a^r b^s ===[ e..., (swapper-p! x) ][ p... ][ True ]==> z... b^s a^r 7 | 8 | func f-swap-em-esc = handle 2 { True 2 swap! } with { | swap! a b => b a } 9 | func f-swap-em-res = handle 2 { True 2 swap! } with { | swap! a b => b a resume } 10 | func f-swapp-em-esc = 0i8 handle 2 p { True 2 swapp! } with { | swapp! a b => b a } 11 | func f-swapp-em-res = 0i8 handle 2 p { True 2 swapp! } with { | swapp! a b => b a p resume } 12 | 13 | test swap-em-escape? = 14 | handle 2 { 15 | True 2 swap! 16 | } with { 17 | | swap! a b => b a 18 | } 19 | [| |] swap cons-tuple swap cons-tuple 20 | is 21 | [| True, 2 |] 22 | 23 | test swap-em-resume? = 24 | handle 2 { 25 | True 2 swap! 26 | } with { 27 | | swap! a b => b a resume 28 | } 29 | [| |] swap cons-tuple swap cons-tuple 30 | is 31 | [| True, 2 |] 32 | 33 | test swapp-em-escape? = 34 | 1 handle 2 p { 35 | True 2 swapp! 36 | } with { 37 | | swapp! a b => b a 38 | } 39 | [| |] swap cons-tuple swap cons-tuple 40 | is 41 | [| True, 2 |] 42 | 43 | test swapp-em-resume? = 44 | 0i8 handle 2 p { 45 | True 2 swapp! 46 | } with { 47 | | swapp! a b => b a p resume 48 | } 49 | [| |] swap cons-tuple swap cons-tuple 50 | is 51 | [| True, 2 |] 52 | 53 | export { } -------------------------------------------------------------------------------- /test/correct-test/import-reexport.boba: -------------------------------------------------------------------------------- 1 | import { export-2 } "import" as rexp 2 | 3 | func ref-export = export-2 rexp::export-2 drop 4 | 5 | func ref-prim = true-bool 6 | 7 | test ref-export? = 1 2 ref-export is 1 8 | 9 | export { } -------------------------------------------------------------------------------- /test/correct-test/import.boba: -------------------------------------------------------------------------------- 1 | import { export-2 } "export" as exp 2 | 3 | func ref-export = exp::export-4 export-2 exp::export-2 drop 4 | 5 | func ref-prim = true-bool 6 | 7 | test ref-export? = 1 2 ref-export satisfies 2 eq-inative 8 | 9 | export { ref-prim } 10 | // re-export the name 'export-2' from "export" module 11 | from exp { export-2 } -------------------------------------------------------------------------------- /test/correct-test/iterators.boba: -------------------------------------------------------------------------------- 1 | 2 | func iter-in-test iterable = 3 | for el in iterable iterate result res = 0 then { 4 | res el add-inative 5 | } 6 | 7 | func iter-print = 8 | for el in [ "!", "World", "Hello, " ] iterate then { 9 | el clear-string print-string 10 | } 11 | 12 | func iter-to-list iterable = 13 | for el in iterable iterate as list then { 14 | el 15 | } 16 | 17 | func iter-two-print = 18 | for el in [ "wolf", "bad", "big" ] iterate, er in list [ "ly", "ish" ] then { 19 | el er concat-string clear-string print-string 20 | } 21 | 22 | func iter-strings str = 23 | for ec in string str as list then { 24 | ec 25 | } 26 | 27 | func print-runes-iter iterable = 28 | for r in iterable iterate then { 29 | r clear-rune print-rune 30 | } 31 | 32 | test iter-in-test? = [3, 2, 1] iter-in-test is 6 33 | test iter-with-below? = 0 [3, 2, 1] iter-in-test drop is 0 34 | test iter-to-list-id? = [ 3, 2, 1 ] iter-to-list is [ 3, 2, 1 ] 35 | test iter-two-prints? = 0 iter-two-print is 0 36 | 37 | 38 | 39 | // TODO: code generation is broken for more than one map output 40 | //test for-iter-map-two-list? = 41 | // for el in [ 3, 2, 1 ] iterate as list, list then { 42 | // el el 43 | // } 44 | // satisfies 45 | // { 46 | // let l = [ 3, 2, 1 ] eq; 47 | // let r = [ 3, 2, 1 ] eq; 48 | // l r and-bool 49 | // } 50 | 51 | main = "hello" print-runes-iter 0 -------------------------------------------------------------------------------- /test/correct-test/let-order.boba: -------------------------------------------------------------------------------- 1 | 2 | test let-fst? = { 2 1 0; let z y x; x } satisfies 0 eq-inative 3 | test let-snd? = { 2 1 0; let z y x; y } satisfies 1 eq-inative 4 | test let-thd? = { 2 1 0; let z y x; z } satisfies 2 eq-inative 5 | 6 | test let-body-fst? = { let z y x = 2 1 0; x } satisfies 0 eq-inative 7 | test let-body-snd? = { let z y x = 2 1 0; y } satisfies 1 eq-inative 8 | test let-body-thd? = { let z y x = 2 1 0; z } satisfies 2 eq-inative 9 | 10 | test match-order-fst? = 2 1 0 match { | z y x => x } satisfies 0 eq-inative 11 | test match-order-snd? = 2 1 0 match { | z y x => y } satisfies 1 eq-inative 12 | test match-order-thd? = 2 1 0 match { | z y x => z } satisfies 2 eq-inative 13 | 14 | rec func rec-test z y x = 15 | z y x match { 16 | | _ _ 0 => 1 17 | | else => dec-inative rec-test inc-inative 18 | } 19 | 20 | test rec-test-base? = 5 4 0 rec-test satisfies 1 eq-inative 21 | test rec-test-rec? = 0 0 5 rec-test satisfies 6 eq-inative 22 | 23 | export { } -------------------------------------------------------------------------------- /test/correct-test/multiple-fundeps.boba: -------------------------------------------------------------------------------- 1 | 2 | test for-two-iter-map-list? = 3 | for el in [ 3, 2, 1 ] iterate, er in [ 6, 5, 4 ] iterate as list then { 4 | el er add-inative 5 | } 6 | is [ 9, 8, 7, 8, 7, 6, 7, 6, 5 ] 7 | 8 | export { } -------------------------------------------------------------------------------- /test/correct-test/multiple-resume.boba: -------------------------------------------------------------------------------- 1 | 2 | effect amb! 3 | = flip! : z... ===[ e..., amb! ][ p... ][ t ]==> z... Bool^s 4 | 5 | test simple-amb? = 6 | handle 1 { 7 | flip! flip! neq-bool 8 | } with { 9 | | flip! => False resume True resume append-list 10 | | after v => [v] 11 | } 12 | is 13 | [False, True, True, False] 14 | 15 | export { } -------------------------------------------------------------------------------- /test/correct-test/numbers.boba: -------------------------------------------------------------------------------- 1 | 2 | test add-inative-1-1? = 1 1 add-inative is 2 3 | test add-inative-100-100? = 100 100 add-inative is 200 4 | test add-inative--1-1? = -1 +1 add-inative is 0 5 | 6 | law add-commute? 7 | x in 50 0 1 range, 8 | y in 25 0 1 range 9 | = x y add-inative is y x add-inative 10 | 11 | //law sub-commute? 12 | // x in 50 0 1 range, 13 | // y in 25 0 1 range 14 | // = x y sub-i32 is y x sub-i32 15 | 16 | test conv-i32-bool-0? = 0i32 conv-i32-bool is False 17 | test conv-i32-bool-1? = 1i32 conv-i32-bool is True 18 | test conv-i32-bool-2? = 2i32 conv-i32-bool is True 19 | test conv-i32-bool--1? = 1i32 neg-i32 conv-i32-bool is True 20 | test conv-i32-bool-256? = 256i32 conv-i32-bool is True 21 | test conv-i32-bool--256? = -256i32 conv-i32-bool is True 22 | 23 | test conv-i32-i8-0? = 0i32 conv-i32-i8 is 0i8 24 | test conv-i32-i8-1? = 1i32 conv-i32-i8 is 1i8 25 | test conv-i32-i8-127? = 127i32 conv-i32-i8 is 127i8 26 | test conv-i32-i8-128? = 128i32 conv-i32-i8 is -128i8 27 | test conv-i32-i8-255? = 255i32 conv-i32-i8 is 1i8 neg-i8 28 | 29 | test add-single-1-1? = 1.0 1.0 add-single is 2.0 30 | test add-single-100-100? = 100.0 100.0 add-single is 200.0 31 | test add-single--1-1? = -1.0 +1.0 add-single is 0.0 32 | 33 | test gt-i32-0--1-true? = 0i32 -1i32 gt-i32 satisfies 34 | test gt-i32-1-0-true? = 1i32 0i32 gt-i32 satisfies 35 | test gt-i32--1-0-false? = -1i32 0i32 gt-i32 violates 36 | 37 | test lt-i32-true? = -1i32 0i32 lt-i32 satisfies 38 | test lt-i32-false? = 0i32 -1i32 lt-i32 violates 39 | 40 | export { } -------------------------------------------------------------------------------- /test/correct-test/nurseries.boba: -------------------------------------------------------------------------------- 1 | 2 | test no-spawn-finish? = nursery n { True } satisfies 3 | 4 | test single-spawn-exec? = 5 | nursery n { 6 | (| "Hello fiber!" clear-string print-string |) n spawn 7 | True 8 | } 9 | satisfies 10 | 11 | test cancel-point? = 12 | nursery n { 13 | cancellable c { 14 | (| "Hello fiber!" clear-string print-string 15 | check-cancel 16 | "Hello again!" clear-string print-string |) 17 | n spawn 18 | c cancel 19 | True 20 | } 21 | } 22 | satisfies 23 | 24 | export { } -------------------------------------------------------------------------------- /test/correct-test/pattern-synonyms.boba: -------------------------------------------------------------------------------- 1 | 2 | pattern TwoElemList a b = [ a b ] 3 | 4 | //pattern Invalid a = [ a b ] 5 | 6 | func first-two = 7 | match { 8 | | (TwoElemList 1 2) => 0 9 | | (TwoElemList a b) => b a sub-inative 10 | | else => drop -1 11 | } 12 | 13 | test first-two-spec? = [ 1, 2 ] first-two is 0 14 | test first-two-gen? = [ 3, 5 ] first-two is 2 15 | test first-two-three? = [ 5, 2, 1 ] first-two is -1 16 | test first-two-one? = [ 1 ] first-two is -1 17 | 18 | export { } -------------------------------------------------------------------------------- /test/correct-test/patterns.boba: -------------------------------------------------------------------------------- 1 | 2 | test list-empty-sat? = 3 | [] match { 4 | | [] => True 5 | | else => drop False 6 | } 7 | satisfies 8 | 9 | test list-empty-vio? = 10 | [ 1 ] match { 11 | | [] => True 12 | | else => drop False 13 | } 14 | violates 15 | 16 | test list-one-sat? = 17 | [ 1 ] match { 18 | | [ 1 ] => True 19 | | else => drop False 20 | } 21 | satisfies 22 | 23 | test list-one-vio? = 24 | [ 1, 2 ] match { 25 | | [ 1 ] => True 26 | | else => drop False 27 | } 28 | violates 29 | 30 | test list-two-sat? = 31 | [ 1, 2 ] match { 32 | | [ 1 2 ] => True 33 | | else => drop False 34 | } 35 | satisfies 36 | 37 | test list-two-vio? = 38 | [ 2 ] match { 39 | | [ 1 2 ] => True 40 | | else => drop False 41 | } 42 | violates 43 | 44 | test two-list-sat? = 45 | [] [ 1 ] match { 46 | | [] [ 1 ] => True 47 | | [ 1 ] [] => False 48 | } 49 | satisfies 50 | 51 | test two-list-second-branch-sat? = 52 | [] [ 1 ] match { 53 | | [ 1 ] [] => False 54 | | [] [ 1 ] => True 55 | } 56 | satisfies 57 | 58 | test two-tuple-sat? = 59 | [| 1 |] [| 0 |] match { 60 | | [| 1 |] [| 0 |] => True 61 | | [| 0 |] [| 1 |] => False 62 | } 63 | satisfies 64 | 65 | test two-tuple-vars? = 66 | [| 1 |] [| 2 |] match { 67 | | [| rs... r |] [| ls... l |] => 68 | l r sub-inative 69 | rs length-tuple add-inative 70 | ls length-tuple add-inative 71 | // TODO: this should be drop drop 0, but type inference breaks when it is! 72 | | otherwise => drop 0 73 | } 74 | is 1 75 | 76 | test two-tuple-vars-overload? = 77 | [| 1 |] [| 2 |] match { 78 | | [| rs... r |] [| ls... l |] => 79 | if r l eq then { False } else { rs ls eq } 80 | | else => drop drop False 81 | } 82 | satisfies 83 | 84 | test two-tuple-vars-below? = 85 | 0 [| 1 |] [| 2 |] match { 86 | | [| rs... r |] [| ls... l |] => 87 | l r sub-inative 88 | rs length-tuple add-inative 89 | ls length-tuple add-inative 90 | | else => drop drop 0 91 | } 92 | swap drop 93 | is 1 94 | 95 | test two-list-diff-size-else? = 96 | [ ] [ 0 ] match { 97 | | [ ] [ ] => False 98 | | [ rs... r ] [ ls... l ] => False 99 | | else => drop drop True 100 | } 101 | satisfies 102 | 103 | test two-list-diff-size-else-below? = 104 | 0 [ ] [ 0 ] match { 105 | | [ ] [ ] => False 106 | | [ rs... r ] [ ls... l ] => False 107 | | else => drop drop True 108 | } 109 | swap drop 110 | satisfies 111 | 112 | test two-list-of-tuple? = 113 | [ [| 0, 1 |] ] [ [| 0, 1 |] ] match { 114 | | [ [| 0 1 |] ] [ [| 0 1 |] ] => True 115 | | else => drop drop False 116 | } 117 | satisfies 118 | 119 | export { } -------------------------------------------------------------------------------- /test/correct-test/prims.boba: -------------------------------------------------------------------------------- 1 | test gather-spread-id? = 1 2 3 gather spread drop drop is 1 2 | test gather-2-order? = 1 True gather head-tuple is True 3 | 4 | test neg-inative-one? = 1 neg-inative is -1 5 | 6 | test bool-eq? = True is True 7 | 8 | test inative-eq? = 3 is 3 9 | 10 | test list-eq-one-elem? = [4] [4] eq satisfies 11 | test list-eq-size-diff? = [] [0] eq violates 12 | test list-eq-same-elem? = [1, 2] [1, 2] eq satisfies 13 | test list-eq-diff-elem? = [1, 2] [1, 3] eq violates 14 | 15 | export { } -------------------------------------------------------------------------------- /test/correct-test/pseudorandom.boba: -------------------------------------------------------------------------------- 1 | import native "math/rand" 2 | 3 | type RandomGen : Data 4 | 5 | native makeRandomGen : z... (I64 u)^r ===[ e... ][ p... ][ True ]==> z... RandomGen^s 6 | = 7 | # seed := fiber.PopOneValue().(int64) 8 | # src := rand.NewSource(seed) 9 | # fiber.PushValue(rand.New(src)) 10 | 11 | native next-inative : z... RandomGen^True ===[ e... ][ p... ][ True ]==> z... (INative u)^r RandomGen^s 12 | = 13 | # gen := fiber.PopOneValue().(*rand.Rand) 14 | # fiber.PushValue(gen.Int()) 15 | # fiber.PushValue(gen) 16 | 17 | native next-inative-n : z... (INative u)^r RandomGen^True ===[ e... ][ p... ][ True ]==> z... (INative u)^s RandomGen^q 18 | = 19 | # gen := fiber.PopOneValue().(*rand.Rand) 20 | # ceil := fiber.PopOneValue().(int) 21 | # fiber.PushValue(gen.Intn(ceil)) 22 | # fiber.PushValue(gen) 23 | 24 | effect prng! 25 | = next-inative! : ===[ e..., prng! ][ p... ][ True ]==> (INative u)^r 26 | | next-inative-n! : (INative u)^r ===[ e..., prng! ][ p... ][ True ]==> (INative u)^s 27 | 28 | func dropd x y = y 29 | 30 | func with-random seed expr = 31 | seed makeRandomGen 32 | handle 0 gen { 33 | expr do 34 | } with { 35 | | next-inative! => gen next-inative resume 36 | | next-inative-n! c => c gen next-inative-n resume 37 | } 38 | 39 | func none-with-rand = 0i64 (| |) with-random 40 | 41 | test seed-0-1st? = 0i64 makeRandomGen next-inative drop is 8717895732742165505 42 | test seed-0-2nd? = 0i64 makeRandomGen next-inative dropd next-inative drop is 2259404117704393152 43 | 44 | export { makeRandomGen RandomGen next-inative prng! next-inative! } -------------------------------------------------------------------------------- /test/correct-test/ranges.boba: -------------------------------------------------------------------------------- 1 | 2 | func sum-0 = 3 | for i in 0 0 1 range result res = 0 then { 4 | res i add-inative 5 | } 6 | 7 | func sum-5 = 8 | for i in 5 0 1 range result res = 0 then { 9 | res i add-inative 10 | } 11 | 12 | func sum-100 = 13 | for i in 100 0 1 range result res = 0 then { 14 | res i add-inative 15 | } 16 | 17 | func alphabet-str = 18 | for c in 'z' 'a' 1i32 conv-i32-rune range as string then { 19 | c 20 | } 21 | 22 | test sum-0? = sum-0 is 0 23 | test sum-5? = sum-5 is 15 24 | test sum-100? = sum-100 is 5050 25 | test alphastr? = alphabet-str is "abcdefghijklmnopqrstuvwxyz" 26 | 27 | export { } -------------------------------------------------------------------------------- /test/correct-test/rec-overload.boba: -------------------------------------------------------------------------------- 1 | 2 | //rec func all-elems-self-equal = 3 | // match { 4 | // | [] => [] 5 | // | [ b... a ] => [ b... ] all-elems-self-equal a a eq cons-list 6 | // } 7 | 8 | rec func two-elems-self-equal = 9 | match { 10 | | [] [] => [] 11 | | [ d... c ] [ b... a ] => [ d... ] [ b... ] two-elems-self-equal c c eq a a eq and-bool cons-list 12 | } 13 | 14 | //test rec-overload-one? = [ 3, 2, 1 ] all-elems-self-equal is [ True, True, True ] 15 | test rec-overload-two? = [ 3, 2, 1 ] [ False, True, False ] two-elems-self-equal is [ True, True, True ] 16 | 17 | export { } -------------------------------------------------------------------------------- /test/correct-test/recdata.boba: -------------------------------------------------------------------------------- 1 | 2 | rec type List x 3 | = Cons : (List a)^q a => (List a) 4 | | Nil : => (List a) 5 | 6 | rec func twice-cons = Cons Cons 7 | 8 | rec func list-len = 9 | match { 10 | | (Cons t _) => t list-len inc-inative 11 | | Nil => 0 12 | } 13 | 14 | test list-len-0? = Nil list-len satisfies 0 eq-inative 15 | test list-len-2? = Nil 1 Cons 2 Cons list-len satisfies 2 eq-inative 16 | 17 | export { } -------------------------------------------------------------------------------- /test/correct-test/semigroupoid.boba: -------------------------------------------------------------------------------- 1 | 2 | overload compose as Semigroupoid? f 3 | : z... (f a b)^s (f b c)^r ===[ e... ][ p... ][ t ]==> z... (f a c)^q 4 | 5 | check kind Semigroupoid? : (k1 --> k2 --> Data) --> Constraint 6 | 7 | instance compose : (--> _ _ _) 8 | = { let l r; (| l do r do |) } 9 | 10 | test compose-out? = (| 0 |) (| 1 |) compose do is 0 1 11 | 12 | export { } -------------------------------------------------------------------------------- /test/correct-test/show.boba: -------------------------------------------------------------------------------- 1 | 2 | import native "strconv" 3 | 4 | overload show as Show? t 5 | : z... t^s ===[ e... ][ p... ][ True ]==> z... (String False False)^r 6 | 7 | instance show : Bool 8 | = match { 9 | | True => "true" 10 | | else => drop "false" 11 | } 12 | 13 | native conv-i8-string 14 | : z... (I8 u)^s (INative one)^q ===[ e... ][ p... ][ True ]==> z... (String False False)^r Bool^rr 15 | = 16 | # base := fiber.PopOneValue().(int) 17 | # val := fiber.PopOneValue().(int8) 18 | # if base < 2 || base > 36 { 19 | # fiber.PushValue("") 20 | # fiber.PushValue(false) 21 | # } else { 22 | # fiber.PushValue(strconv.FormatInt(int64(val), base)) 23 | # fiber.PushValue(true) 24 | # } 25 | 26 | native conv-u8-string 27 | : z... (U8 u)^s (INative one)^q ===[ e... ][ p... ][ True ]==> z... (String False False)^r Bool^rr 28 | = 29 | # base := fiber.PopOneValue().(int) 30 | # val := fiber.PopOneValue().(uint8) 31 | # if base < 2 || base > 36 { 32 | # fiber.PushValue("") 33 | # fiber.PushValue(false) 34 | # } else { 35 | # fiber.PushValue(strconv.FormatUint(uint64(val), base)) 36 | # fiber.PushValue(true) 37 | # } 38 | 39 | native conv-i16-string 40 | : z... (I16 u)^s (INative one)^q ===[ e... ][ p... ][ True ]==> z... (String False False)^r Bool^rr 41 | = 42 | # base := fiber.PopOneValue().(int) 43 | # val := fiber.PopOneValue().(int16) 44 | # if base < 2 || base > 36 { 45 | # fiber.PushValue("") 46 | # fiber.PushValue(false) 47 | # } else { 48 | # fiber.PushValue(strconv.FormatInt(int64(val), base)) 49 | # fiber.PushValue(true) 50 | # } 51 | 52 | native conv-u16-string 53 | : z... (U16 u)^s (INative one)^q ===[ e... ][ p... ][ True ]==> z... (String False False)^r Bool^rr 54 | = 55 | # base := fiber.PopOneValue().(int) 56 | # val := fiber.PopOneValue().(uint16) 57 | # if base < 2 || base > 36 { 58 | # fiber.PushValue("") 59 | # fiber.PushValue(false) 60 | # } else { 61 | # fiber.PushValue(strconv.FormatUint(uint64(val), base)) 62 | # fiber.PushValue(true) 63 | # } 64 | 65 | export { * } -------------------------------------------------------------------------------- /test/correct-test/test-multi-result.boba: -------------------------------------------------------------------------------- 1 | 2 | test multi-eq? = 1 2 is 1 2 3 | 4 | export { } -------------------------------------------------------------------------------- /test/correct-test/type-synonym.boba: -------------------------------------------------------------------------------- 1 | 2 | tag M = meters 3 | 4 | tag S = seconds 5 | 6 | synonym MpsNative = (INative (M^1)*(S^-1)) 7 | 8 | func velocity = 1 add-inative of { meters per seconds } 9 | 10 | check type velocity : z... (INative one)^r ===[ e... ][ p... ][ True ]==> z... MpsNative^r 11 | 12 | export { } -------------------------------------------------------------------------------- /test/run-tests.fsx: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env dotnet fsi 2 | 3 | open System.Diagnostics 4 | open System.Threading.Tasks 5 | 6 | type CommandResult = { 7 | ExitCode: int; 8 | StandardOutput: string; 9 | StandardError: string 10 | } 11 | 12 | let executeCommand executable args = 13 | task { 14 | let startInfo = ProcessStartInfo() 15 | startInfo.FileName <- executable 16 | for a in args do 17 | startInfo.ArgumentList.Add(a) 18 | startInfo.RedirectStandardOutput <- true 19 | startInfo.RedirectStandardError <- true 20 | startInfo.UseShellExecute <- false 21 | startInfo.CreateNoWindow <- true 22 | use p = new Process() 23 | p.StartInfo <- startInfo 24 | p.Start() |> ignore 25 | 26 | let outTask = Task.WhenAll([| 27 | p.StandardOutput.ReadToEndAsync(); 28 | p.StandardError.ReadToEndAsync() 29 | |]) 30 | 31 | do! p.WaitForExitAsync() 32 | let! out = outTask 33 | return { 34 | ExitCode = p.ExitCode; 35 | StandardOutput = out.[0]; 36 | StandardError = out.[1] 37 | } 38 | } 39 | 40 | let executeShellCommand command = 41 | executeCommand "/usr/bin/env" [ "-S"; "bash"; "-c"; command ] 42 | 43 | let testPath p = System.IO.Path.Combine(".", "test", p) 44 | 45 | let correctMainFiles = System.IO.Directory.GetFiles(testPath "correct-main", "*.boba") 46 | let correctTestFiles = System.IO.Directory.GetFiles(testPath "correct-test", "*.boba") 47 | let wrongFiles = System.IO.Directory.GetFiles(testPath "wrong", "*.boba") 48 | 49 | let expectCorrect test file = 50 | executeCommand "dotnet" ["run"; "--project"; "Boba.Compiler"; test; file] 51 | 52 | let expectCorrectMain test cmp file = 53 | task { 54 | printfn $"Running test '{file}'" 55 | let! runRes = expectCorrect test file 56 | if cmp runRes.ExitCode 0 57 | then 58 | printfn $"Test '{file}' failed" 59 | return 1 60 | else 61 | printfn $"Test '{file}' succeeded" 62 | return 0 63 | } 64 | 65 | let batchesOf n = 66 | let mutable i = -1 67 | List.groupBy (fun _ -> i <- i + 1; i / n) >> Seq.map snd 68 | 69 | let sumAsyncInt (tasks: List Task>) = 70 | task { 71 | let batches = batchesOf 7 tasks 72 | let mutable sum = 0 73 | for b in batches do 74 | let! ints = Task.WhenAll [for t in b -> t ()] 75 | sum <- sum + Array.sum ints 76 | return sum 77 | } 78 | 79 | let res = task { 80 | let! mainRes = sumAsyncInt [for f in correctMainFiles -> fun () -> expectCorrectMain "run" (<>) f] 81 | let! testRes = sumAsyncInt [for f in correctTestFiles -> fun () -> expectCorrectMain "test" (<>) f] 82 | let! wrongRes = sumAsyncInt [for f in wrongFiles -> fun () -> expectCorrectMain "test" (=) f] 83 | return mainRes + testRes + wrongRes 84 | } 85 | 86 | Async.RunSynchronously (Async.AwaitTask res) 87 | |> System.Environment.Exit -------------------------------------------------------------------------------- /test/typeable.boba: -------------------------------------------------------------------------------- 1 | 2 | type Proxy a 3 | = ProxyT : => (Proxy a) 4 | 5 | type TypeRep 6 | = OneCtor : (String t c)^s => TypeRep 7 | | TwoCtor : (String t c)^s => TypeRep 8 | 9 | check kind TypeRep : Data 10 | check kind Proxy : k --> Data 11 | 12 | overload typeOf as Typeable? a 13 | : z... (Proxy a)^s ===[ e... ][ p... ][ t ]==> z... TypeRep^r 14 | 15 | check kind Typeable? : k --> Constraint 16 | 17 | instance typeOf : Bool 18 | = drop "Bool" OneCtor 19 | 20 | //instance typeOf : [] 21 | // = "List" TwoCtor 22 | 23 | export { } -------------------------------------------------------------------------------- /test/wrong/ambiguous.boba: -------------------------------------------------------------------------------- 1 | // This file fails type inference 2 | 3 | overload show as Show? a 4 | : z... a^s ===[ e... ][ p... ][ True ]==> z... (String True False)^r 5 | 6 | overload read as Read? a 7 | : z... (String True False)^s ===[ e... ][ p... ][ True ]==> z... a^r 8 | 9 | func ambig = read show 10 | 11 | export { } -------------------------------------------------------------------------------- /test/wrong/for-comp-incomplete.boba: -------------------------------------------------------------------------------- 1 | 2 | func iter-to-list = 3 | for el in iterate as list then { 4 | el 5 | } 6 | 7 | func iter-strings = 8 | for ec in string as list then { 9 | ec 10 | } 11 | 12 | export { } -------------------------------------------------------------------------------- /test/wrong/for-effect-incomplete.boba: -------------------------------------------------------------------------------- 1 | 2 | func print-runes-iter = 3 | for r in iterate then { 4 | r clear-rune print-rune 5 | } 6 | 7 | export { } -------------------------------------------------------------------------------- /test/wrong/for-fold-incomplete.boba: -------------------------------------------------------------------------------- 1 | 2 | func iter-in-test = 3 | for el in iterate result res = 0 then { 4 | res el add-inative 5 | } 6 | 7 | export { } -------------------------------------------------------------------------------- /test/wrong/instance-consume-extra.boba: -------------------------------------------------------------------------------- 1 | overload eq as Eq? a 2 | : z... a^s a^r ===[ e... ][ p... ][ True ]==> z... Bool^q 3 | 4 | instance eq : Bool 5 | = eq-bool swap drop 6 | 7 | export { } -------------------------------------------------------------------------------- /test/wrong/instance-extra-effect.boba: -------------------------------------------------------------------------------- 1 | overload eq as Eq? a 2 | : z... a^s a^r ===[ e... ][ p... ][ True ]==> z... Bool^q 3 | 4 | instance eq : Bool 5 | = eq-bool "print" clear-string print-string 6 | 7 | export { } -------------------------------------------------------------------------------- /test/wrong/instance-produce-extra.boba: -------------------------------------------------------------------------------- 1 | overload eq as Eq? a 2 | : z... a^s a^r ===[ e... ][ p... ][ True ]==> z... Bool^q 3 | 4 | instance eq : (INative u) 5 | = eq-inative 1 swap 6 | 7 | export { } -------------------------------------------------------------------------------- /test/wrong/instance-touch-extra.boba: -------------------------------------------------------------------------------- 1 | overload eq as Eq? a 2 | : z... a^s a^r ===[ e... ][ p... ][ True ]==> z... Bool^q 3 | 4 | instance eq : Bool 5 | = eq-bool swap inc-inative swap 6 | 7 | export { } -------------------------------------------------------------------------------- /test/wrong/nursery-no-escape.boba: -------------------------------------------------------------------------------- 1 | 2 | test no-escape? = 3 | nursery n { 4 | True n 5 | } 6 | drop satisfies 7 | 8 | export { } -------------------------------------------------------------------------------- /test/zip-iterators.boba: -------------------------------------------------------------------------------- 1 | 2 | func zip-iterators itr itl = 3 | (| |) handle 0 c { 4 | itr do 5 | } with { 6 | | yield! r => { 7 | c do; 8 | let super-res = (| resume |); 9 | handle 0 { 10 | itl do 11 | } with { 12 | | yield! l => [| r, l |] yield! (| resume |) super-res do 13 | } 14 | } 15 | } 16 | 17 | func zip-iters-to-list itr itl = 18 | for p in itr itl zip-iterators as list then { p } 19 | 20 | //test zip-iter-one? = for p in (| 0 yield! |) (| 1 yield! |) zip-iterators as list then { p } is [ [| 0, 1 |] ] 21 | 22 | //test zip-iter-list? = 23 | // for p in (| [ 3, 2, 1 ] iterate |) (| [ 2, 1, 0 ] iterate |) zip-iterators iterate as list then { p } 24 | // is 25 | // [ [| 3, 2 |], [| 2, 1 |], [| 1, 0 |] ] 26 | 27 | main = 28 | for p in (| 0 yield! |) (| True yield! |) zip-iterators as list then { p } drop 0 29 | --------------------------------------------------------------------------------