├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .hlint.yaml ├── HACKING.rst ├── LICENSE ├── README.rst ├── bibliography.rst ├── cabal.project ├── commentary.md ├── examples ├── ambiguous-kind.golden ├── ambiguous-kind.kl ├── anaphoric-if.golden ├── anaphoric-if.kl ├── bool.golden ├── bool.kl ├── bound-identifier.golden ├── bound-identifier.kl ├── contract.golden ├── contract.kl ├── custom-literals-test.golden ├── custom-literals-test.kl ├── custom-literals.golden ├── custom-literals.kl ├── custom-module-test.golden ├── custom-module-test.kl ├── custom-module.golden ├── custom-module.kl ├── datatype-import.golden ├── datatype-import.kl ├── datatype-macro.golden ├── datatype-macro.kl ├── datatypes.golden ├── datatypes.kl ├── deep-patterns.golden ├── deep-patterns.kl ├── define-syntax-rule-test.golden ├── define-syntax-rule-test.kl ├── define-syntax-rule.golden ├── define-syntax-rule.kl ├── defun-test.golden ├── defun-test.kl ├── defuns-test.golden ├── defuns-test.kl ├── defuns.golden ├── defuns.kl ├── do.golden ├── do.kl ├── double-define.golden ├── double-define.kl ├── either-datatype.golden ├── either-datatype.kl ├── error.golden ├── error.kl ├── eta-case.golden ├── eta-case.kl ├── exports-macro.golden ├── exports-macro.kl ├── failing-examples │ ├── bound-vs-free.golden │ ├── bound-vs-free.kl │ ├── incorrect-context.golden │ ├── incorrect-context.kl │ ├── keyword-used-incorrectly.golden │ ├── keyword-used-incorrectly.kl │ ├── wrong-keyword.golden │ └── wrong-keyword.kl ├── fix.golden ├── fix.kl ├── free-identifier-case-test.golden ├── free-identifier-case-test.kl ├── free-identifier-case.golden ├── free-identifier-case.kl ├── fun-exports-test.golden ├── fun-exports-test.kl ├── fun-exports.golden ├── fun-exports.kl ├── group.golden ├── group.kl ├── hello.golden ├── hello.kl ├── higher-kinded-patterns.golden ├── higher-kinded-patterns.kl ├── higher-kinded.golden ├── higher-kinded.kl ├── hygiene.golden ├── hygiene.kl ├── id-compare.golden ├── id-compare.kl ├── implicit-conversion-test.golden ├── implicit-conversion-test.kl ├── implicit-conversion.golden ├── implicit-conversion.kl ├── import-import-renaming.golden ├── import-import-renaming.kl ├── import-list-and-do.golden ├── import-list-and-do.kl ├── import-renaming.golden ├── import-renaming.kl ├── import-scoping-m1.golden ├── import-scoping-m1.kl ├── import-scoping-m2.golden ├── import-scoping-m2.kl ├── import-scoping.golden ├── import-scoping.kl ├── import.golden ├── import.kl ├── imports-shifted-macro.golden ├── imports-shifted-macro.kl ├── int-ops.golden ├── int-ops.kl ├── integer-syntax.golden ├── integer-syntax.kl ├── io.golden ├── io.kl ├── keyword-test.golden ├── keyword-test.kl ├── keyword.golden ├── keyword.kl ├── lambda-case-test.golden ├── lambda-case-test.kl ├── lambda-case.golden ├── lambda-case.kl ├── lang.golden ├── lang.kl ├── let.golden ├── let.kl ├── let1.golden ├── let1.kl ├── lets.golden ├── lets.kl ├── lispy-do.golden ├── lispy-do.kl ├── list-syntax.golden ├── list-syntax.kl ├── list-test.golden ├── list-test.kl ├── macro-body-shift.golden ├── macro-body-shift.kl ├── mcond-test.golden ├── mcond-test.kl ├── mcond.golden ├── mcond.kl ├── meta-macro.golden ├── meta-macro.kl ├── monad.golden ├── monad.kl ├── non-examples │ ├── circular-1.golden │ ├── circular-1.kl │ ├── circular-2.golden │ ├── circular-2.kl │ ├── error.golden │ ├── error.kl │ ├── import-phase.golden │ ├── import-phase.kl │ ├── missing-import.golden │ ├── missing-import.kl │ ├── type-errors.golden │ ├── type-errors.kl │ └── type-errors │ │ ├── not-a-function.golden │ │ └── not-a-function.kl ├── one-def.golden ├── one-def.kl ├── pair-datatype.golden ├── pair-datatype.kl ├── phase1.golden ├── phase1.kl ├── pmatch.golden ├── pmatch.kl ├── prelude-test.golden ├── prelude-test.kl ├── primitive-datatypes.golden ├── primitive-datatypes.kl ├── primitives-documentation.golden ├── primitives-documentation.kl ├── product-type.golden ├── product-type.kl ├── quasiquote-syntax-test.golden ├── quasiquote-syntax-test.kl ├── reader-test.golden ├── reader-test.kl ├── reader.golden ├── reader.kl ├── regenerate-golden-files.sh ├── rpn-test.golden ├── rpn-test.kl ├── rpn.golden ├── rpn.kl ├── small.golden ├── small.kl ├── string-syntax.golden ├── string-syntax.kl ├── string.golden ├── string.kl ├── syntax-loc.golden ├── syntax-loc.kl ├── syntax.golden ├── syntax.kl ├── temporaries-test.golden ├── temporaries-test.kl ├── temporaries.golden ├── temporaries.kl ├── test-quasiquote.golden ├── test-quasiquote.kl ├── tiny-types.golden ├── tiny-types.kl ├── two-defs.golden ├── two-defs.kl ├── type-eq-test.golden ├── type-eq-test.kl ├── type-eq.golden ├── type-eq.kl ├── unknown-type.golden ├── unknown-type.kl ├── which-problem.golden └── which-problem.kl ├── flake.lock ├── flake.nix ├── klister.cabal ├── klister.el ├── repl └── Main.hs ├── src ├── Alpha.hs ├── Binding.hs ├── Binding │ └── Info.hs ├── Control │ └── Lens │ │ └── IORef.hs ├── Core.hs ├── Core │ └── Builder.hs ├── Datatype.hs ├── Env.hs ├── Evaluator.hs ├── Expander.hs ├── Expander │ ├── DeclScope.hs │ ├── Error.hs │ ├── Monad.hs │ ├── Primitives.hs │ ├── Syntax.hs │ ├── TC.hs │ └── Task.hs ├── Kind.hs ├── KlisterPath.hs ├── Module.hs ├── ModuleName.hs ├── Parser.hs ├── Parser │ ├── Command.hs │ └── Common.hs ├── PartialCore.hs ├── PartialType.hs ├── Phase.hs ├── Pretty.hs ├── Scope.hs ├── ScopeSet.hs ├── ShortShow.hs ├── SplitCore.hs ├── SplitType.hs ├── Syntax.hs ├── Syntax │ ├── Lexical.hs │ ├── SrcLoc.hs │ └── Syntax.hs ├── Type.hs ├── Type │ └── Context.hs ├── Unique.hs ├── Util │ ├── Key.hs │ ├── Set.hs │ └── Store.hs ├── Value.hs └── World.hs ├── stack.yaml ├── stdlib ├── defun.kl ├── list.kl ├── n-ary-app.kl ├── optional-parens.kl ├── prelude.kl └── quasiquote.kl └── tests ├── Golden.hs ├── MiniTests.hs └── Test.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [master] 8 | 9 | env: 10 | KLISTERPATH: ${{ github.workspace }}/examples 11 | 12 | jobs: 13 | cabal: 14 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 15 | runs-on: ${{ matrix.os }} 16 | strategy: 17 | matrix: 18 | include: 19 | # latest GHC, default OS 20 | - cabal: "3.8" 21 | ghc: "9.6" 22 | os: ubuntu-latest 23 | 24 | # non-latest GHC, default OS 25 | - cabal: "3.8" 26 | ghc: "9.4" 27 | os: ubuntu-latest 28 | 29 | # non-latest GHC, default OS 30 | - cabal: "3.6" 31 | ghc: "9.2.5" 32 | os: ubuntu-latest 33 | 34 | # latest GHC, non-default OS 35 | - cabal: "3.8" 36 | ghc: "9.6" 37 | os: macOS-latest 38 | 39 | steps: 40 | - uses: actions/checkout@v4 41 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 42 | 43 | - uses: haskell-actions/setup@v2 44 | id: setup-haskell-cabal 45 | name: Setup Haskell 46 | with: 47 | ghc-version: ${{ matrix.ghc }} 48 | cabal-version: ${{ matrix.cabal }} 49 | 50 | - name: Freeze 51 | run: | 52 | cabal configure --enable-tests --enable-benchmarks --test-show-details=direct 53 | cabal freeze 54 | 55 | - uses: actions/cache@v4 56 | name: Cache ~/.cabal/store 57 | with: 58 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 59 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 60 | 61 | - name: Build 62 | run: | 63 | cabal build all 64 | 65 | - name: Path 66 | run: | 67 | echo "$KLISTERPATH" 68 | 69 | - name: Test 70 | run: | 71 | cabal test all 72 | 73 | - name: TestDebug 74 | run: | 75 | cabal test all --ghc-options='-debug' 76 | 77 | stack: 78 | name: stack / ghc ${{ matrix.ghc }} 79 | runs-on: ubuntu-latest 80 | strategy: 81 | # only test stack with one OS and one GHC version; if it works with 82 | # cabal, it probably also works with stack. 83 | matrix: 84 | ghc: ['9.2.8'] 85 | 86 | steps: 87 | - uses: actions/checkout@v4 88 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 89 | 90 | - uses: haskell-actions/setup@v2 91 | name: Setup Haskell Stack 92 | with: 93 | enable-stack: true 94 | ghc-version: ${{ matrix.ghc }} 95 | stack-version: 'latest' 96 | 97 | - uses: actions/cache@v4 98 | name: Cache ~/.stack 99 | with: 100 | path: ~/.stack 101 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 102 | 103 | - name: Build 104 | run: | 105 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --no-nix 106 | 107 | - name: Test 108 | run: | 109 | stack test --system-ghc --no-nix 110 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | *~ 3 | *# 4 | dist/ 5 | dist-newstyle/ 6 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # Warnings currently triggered by your code 2 | - ignore: {name: "Avoid lambda"} # 1 hint 3 | - ignore: {name: "Eta reduce"} # 12 hints 4 | - ignore: {name: "Fuse foldr/map"} # 1 hint 5 | - ignore: {name: "Move brackets to avoid $"} # 6 hints 6 | - ignore: {name: "Redundant $"} # 32 hints 7 | - ignore: {name: "Redundant <$>"} # 17 hints 8 | - ignore: {name: "Redundant bracket"} # 12 hints 9 | - ignore: {name: "Replace case with fromMaybe"} # 3 hints 10 | - ignore: {name: "Unused LANGUAGE pragma"} # 16 hints 11 | - ignore: {name: "Use $>"} # 2 hints 12 | - ignore: {name: "Use <&>"} # 1 hint 13 | - ignore: {name: "Use >=>"} # 1 hint 14 | - ignore: {name: "Use asks"} # 5 hints 15 | - ignore: {name: "Use camelCase"} # 2 hints 16 | - ignore: {name: "Use const"} # 4 hints 17 | - ignore: {name: "Use evalState"} # 2 hints 18 | - ignore: {name: "Use fold"} # 1 hint 19 | - ignore: {name: "Use for"} # 1 hint 20 | - ignore: {name: "Use fromMaybe"} # 1 hint 21 | - ignore: {name: "Use id"} # 6 hints 22 | - ignore: {name: "Use newtype instead of data"} # 3 hints 23 | - ignore: {name: "Use record patterns"} # 4 hints 24 | - ignore: {name: "Use tuple-section"} # 2 hints 25 | - ignore: {name: "Use uncurry"} # 2 hints 26 | - ignore: {name: "Use unless"} # 3 hints 27 | - ignore: {name: "Use unwords"} # 1 hint 28 | - ignore: {name: "Use void"} # 5 hints 29 | - ignore: {name: "Use when"} # 2 hints 30 | -------------------------------------------------------------------------------- /HACKING.rst: -------------------------------------------------------------------------------- 1 | Overall Design 2 | ============== 3 | 4 | The macro expander itself is a set-of-scopes expander, based on 5 | `Matthew Flatt's paper`_ from POPL 2016 and described quite accessibly in 6 | his talk from `Strange Loop`_. 7 | 8 | .. _Matthew Flatt's paper: https://www.cs.utah.edu/plt/publications/popl16-f.pdf 9 | 10 | .. _Strange Loop: https://www.youtube.com/watch?v=Or_yKiI3Ha4 11 | 12 | Additionally, there is a module system patterned after `Racket's`_. 13 | 14 | .. _Racket's: https://www.cs.utah.edu/plt/publications/macromod.pdf 15 | 16 | This macro expander has a few differences: 17 | 18 | * Rather than performing a depth-first traversal of the input syntax, 19 | expanding as it goes, our expander maintains a queue of expansion 20 | tasks. Tasks indicate the expression to be expanded as well as its 21 | resulting location in the final output. Dependency information is 22 | tracked in order to constrain the scheduling of expansion tasks. 23 | 24 | * The core language does not coincide with the input language. Having 25 | an independent core language will hopefully allow us to overcome the 26 | overhead associated with recursive uses of ``local-expand``, as well 27 | as enabling a second, trusted type checking pass. 28 | 29 | * Type checking and macro expansion are interleaved. Every expansion 30 | step in an expression or pattern context knows what type the 31 | resulting program will have. 32 | 33 | The type checker is a mostly-vanilla Hindley-Milner, based on 34 | Sestoft's description in `Programming Language Concepts`_, extended 35 | with user-definable datatypes and Racket-style phase stratification of 36 | bindings. It uses Rémy's optimization_ of generalization, where type 37 | metavariables are assigned levels to avoid scanning the context at 38 | generalization time. 39 | 40 | .. _Programming Language Concepts: https://www.itu.dk/~sestoft/plc/ 41 | 42 | .. _optimization: https://hal.inria.fr/inria-00077006/document 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2019-2020, Samuel Gélineau and Galois Inc. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /bibliography.rst: -------------------------------------------------------------------------------- 1 | Bibliography 2 | ============ 3 | 4 | This annotated bibliography is very much under construction! 5 | 6 | Macros and module systems 7 | ------------------------- 8 | 9 | The overall macro expander uses Flatt's set-of-scopes algorithm for hygiene: https://www.cs.utah.edu/plt/publications/popl16-f.pdf 10 | 11 | The module system is based on Racket's: https://www.cs.utah.edu/plt/publications/macromod.pdf 12 | 13 | We'd like to find a way to do the things described in `Macros that Work Together`_, but with types. It's mostly just design sketches so far for us. We expect that we can adapt the design of `MetaPRL's resources`_ to replace compile-time bindings, at least. 14 | 15 | .. _Macros that Work Together: https://www.cs.utah.edu/plt/publications/jfp12-draft-fcdf.pdf 16 | 17 | .. _MetaPRL's resources: http://web.archive.org/web/20061005013840/http://files.metaprl.org/papers/metaprl.pdf 18 | 19 | Type checker implementation 20 | --------------------------- 21 | 22 | The type checker is based on Sestoft's description in `Programming Language Concepts`_. It uses Rémy's optimization_ of generalization, where type metavariables are assigned levels to avoid scanning the context at generalization time. 23 | 24 | LVars have been used to `parallelize type checkers`_. 25 | 26 | .. _Programming Language Concepts: https://www.itu.dk/~sestoft/plc/ 27 | 28 | .. _optimization: https://hal.inria.fr/inria-00077006/document 29 | 30 | .. _parallelize type checkers: https://dl.acm.org/doi/10.1145/2851141.2851142 31 | 32 | 33 | Related Work 34 | ------------ 35 | 36 | These systems have some form of type-aware hygienic macro, or other typed metaprogramming. 37 | 38 | Lean 39 | ~~~~ 40 | 41 | `Lean's macros`_ are the closest thing to Klister right now. 42 | 43 | .. _Lean's macros: https://arxiv.org/pdf/2001.10490.pdf 44 | 45 | Scala 46 | ~~~~~ 47 | 48 | * https://infoscience.epfl.ch/record/257176?ln=en 49 | 50 | - Precursor: https://github.com/epfldata/squid#publications 51 | 52 | MetaML 53 | ~~~~~~ 54 | 55 | MetaML_ is a staged programming system rather than a macro system, but it pays to be familiar with it. 56 | 57 | .. _MetaML: https://doi.org/10.1016/S0304-3975(00)00053-0 58 | 59 | MacroML 60 | ~~~~~~~ 61 | 62 | MacroML_ compiles down to MetaML, and thus provides very strong guarantees. It's less expressive than a full procedural macro system, though. 63 | 64 | .. _MacroML: https://dl.acm.org/doi/10.1145/507635.507646 65 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./ 3 | 4 | tests: True 5 | profiling: False 6 | -------------------------------------------------------------------------------- /examples/ambiguous-kind.golden: -------------------------------------------------------------------------------- 1 | (ctor) : ∀(α : *). (T α) 2 | -------------------------------------------------------------------------------- /examples/ambiguous-kind.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -- If we didn't default kinds to * at the end of elaborating modules, 4 | -- the kind of A would be left as a meta rather than becoming *. 5 | (datatype (T A) 6 | (ctor)) 7 | 8 | (example (ctor)) 9 | -------------------------------------------------------------------------------- /examples/anaphoric-if.golden: -------------------------------------------------------------------------------- 1 | (:: 0 (:: 1 (:: 2 (:: 3 (:: 4 (nil)))))) : (List Integer) 2 | -------------------------------------------------------------------------------- /examples/anaphoric-if.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import "define-syntax-rule.kl") 5 | (import "list.kl") 6 | 7 | (define-macro (if-non-empty cond then else) 8 | -- Consider the following simpler implementation. 9 | -- 10 | -- (pure `(let [it ,cond] 11 | -- (case it 12 | -- [(:: _ _) 13 | -- ,then] 14 | -- [(nil) 15 | -- ,else]))) 16 | -- 17 | -- Since the "it" variable is bound by code generated by the macro, hygiene 18 | -- dictates that it is only visible to the rest of the code generated by the 19 | -- macro. Thus, it would be visible in (case it ...), but not in the caller's 20 | -- (:: 0 it). 21 | -- 22 | -- This is not what we want, so we override hygiene by constructing an 23 | -- identifier which inherits the lexical scope (and the source location) of 24 | -- one of the input syntax objects. This allows the identifier to be visible 25 | -- to the code in that input as well. 26 | (let [it 27 | (ident-syntax 'it cond)] 28 | (pure `(let [,it ,cond] 29 | (case ,it 30 | [(:: _ _) 31 | ,then] 32 | [(nil) 33 | ,else]))))) 34 | 35 | (example 36 | (if-non-empty (snoc (list 1 2 3) 4) 37 | (:: 0 it) 38 | (list 0))) 39 | -------------------------------------------------------------------------------- /examples/bool.golden: -------------------------------------------------------------------------------- 1 | (false) : Bool 2 | (false) : Bool 3 | (false) : Bool 4 | (true) : Bool 5 | (false) : Bool 6 | (true) : Bool 7 | (true) : Bool 8 | (true) : Bool 9 | (true) : Bool 10 | (false) : Bool 11 | (true) : Bool 12 | (false) : Bool 13 | (true) : Bool 14 | (false) : Bool 15 | (true) : Bool 16 | (false) : Bool 17 | (true) : Bool 18 | (false) : Bool 19 | (true) : Bool 20 | (false) : Bool 21 | (true) : Bool 22 | (false) : Bool 23 | -------------------------------------------------------------------------------- /examples/bool.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | 6 | (define not 7 | (lambda (b) 8 | (if b (false) (true)))) 9 | 10 | (define binary-and 11 | (lambda (x y) 12 | (if x y (false)))) 13 | 14 | (define binary-or 15 | (lambda (x y) 16 | (if x (true) y))) 17 | 18 | (define-macros 19 | ((and (lambda (stx) 20 | (syntax-case stx 21 | ((cons _ args) 22 | (syntax-case args 23 | (() 24 | (pure '(true))) 25 | ((cons x xs) 26 | (pure `(binary-and ,x 27 | ,(cons-list-syntax 'and xs stx))))))))) 28 | (or (lambda (stx) 29 | (syntax-case stx 30 | ((cons _ args) 31 | (syntax-case args 32 | (() 33 | (pure '(false))) 34 | ((cons x xs) 35 | (pure `(binary-or ,x 36 | ,(cons-list-syntax 'or xs stx))))))))))) 37 | 38 | (example (binary-and (false) (false))) 39 | (example (binary-and (false) (true))) 40 | (example (binary-and (true) (false))) 41 | (example (binary-and (true) (true))) 42 | 43 | (example (binary-or (false) (false))) 44 | (example (binary-or (false) (true))) 45 | (example (binary-or (true) (false))) 46 | (example (binary-or (true) (true))) 47 | 48 | (example (and)) 49 | (example (and (false))) 50 | (example (and (true))) 51 | (example (and (true) (false))) 52 | (example (and (true) (true))) 53 | (example (and (true) (false) (true))) 54 | (example (and (true) (true) (true))) 55 | 56 | (example (or)) 57 | (example (or (true))) 58 | (example (or (false))) 59 | (example (or (false) (true))) 60 | (example (or (false) (false))) 61 | (example (or (false) (true) (false))) 62 | (example (or (false) (false) (false))) 63 | 64 | (export not binary-and binary-or and or) 65 | -------------------------------------------------------------------------------- /examples/bound-identifier.golden: -------------------------------------------------------------------------------- 1 | #[bound-identifier.kl:12.37-12.38] : Syntax 2 | #[bound-identifier.kl:13.38-13.39] : Syntax 3 | -------------------------------------------------------------------------------- /examples/bound-identifier.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (import (shift kernel 1)) 4 | 5 | (define-macros 6 | ((m (lambda (stx) 7 | (syntax-case stx 8 | ((list (_ x y)) 9 | (>>= (bound-identifier=? x y) 10 | (lambda (bool) 11 | (pure (case bool 12 | [(true) ''t] 13 | [(false) ''f])))))))))) 14 | 15 | (example (m x x)) 16 | (example (m x y)) 17 | -------------------------------------------------------------------------------- /examples/contract.golden: -------------------------------------------------------------------------------- 1 | # : (Syntax → Syntax) 2 | # : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) 3 | # : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) 4 | # : ∀(α : *). (α → α) 5 | (true) : Bool 6 | -------------------------------------------------------------------------------- /examples/contract.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | [import "defun.kl"] 3 | [import "bool.kl"] 4 | [import [shift "prelude.kl" 1]] 5 | [import [shift "defun.kl"1]] 6 | 7 | (meta 8 | (defun contract-violation (contract) 9 | (list-syntax ('error (quote '"Contract violation!")) contract))) 10 | 11 | (meta -- type annotation 12 | (example (the (-> Syntax Syntax) 13 | contract-violation))) 14 | 15 | (meta 16 | (defun enforce-single (arg contract body) 17 | (pure 18 | (list-syntax 19 | ('if 20 | (list-syntax (contract arg) contract) 21 | body 22 | (contract-violation contract)) 23 | contract)))) 24 | 25 | (meta -- type annotation 26 | (example (the (-> Syntax (-> Syntax (-> Syntax (Macro Syntax)))) 27 | enforce-single))) 28 | 29 | (meta 30 | (defun enforce-many (args contracts body) 31 | (syntax-case args 32 | [(cons arg more-args) 33 | (syntax-case contracts 34 | [(cons contract more-contracts) 35 | (>>= (enforce-single arg contract body) 36 | (lambda (new-body) 37 | (enforce-many 38 | more-args 39 | more-contracts 40 | new-body)))] 41 | [_ (syntax-error '"Wrong number of contracts" contracts)])] 42 | [() 43 | (syntax-case contracts 44 | [(list (ret-contract)) 45 | (pure 46 | (list-syntax 47 | -- TODO: This is inefficient, use a let-binding 48 | ('if 49 | (list-syntax (ret-contract body) ret-contract) 50 | body 51 | (contract-violation ret-contract)) 52 | ret-contract))] 53 | [_ (syntax-error '"Wrong number of contracts" contracts)])]))) 54 | 55 | (meta -- type annotation 56 | (example (the (-> Syntax (-> Syntax (-> Syntax (Macro Syntax)))) 57 | enforce-many))) 58 | 59 | (define-macros 60 | ([defun/contract 61 | [lambda (stx) 62 | (syntax-case stx 63 | [[list [_ f args contracts body]] 64 | (>>= (enforce-many args contracts body) 65 | (lambda (new-body) 66 | (pure 67 | (list-syntax 68 | ('defun f args new-body) 69 | stx))))] 70 | [_ (syntax-error '"bad syntax" stx)])]])) 71 | 72 | (defun const (x y) x) 73 | (define any (const (true))) 74 | (defun true? (b) (if b (true) (false))) 75 | (defun/contract id (x) (any any) x) 76 | (defun/contract id-bool (x) (true? true?) x) 77 | (example (id id)) 78 | (example (id-bool (true))) 79 | -------------------------------------------------------------------------------- /examples/custom-literals-test.golden: -------------------------------------------------------------------------------- 1 | 43 : Integer 2 | 6 : Integer 3 | "foo!" : String 4 | -------------------------------------------------------------------------------- /examples/custom-literals-test.kl: -------------------------------------------------------------------------------- 1 | #lang "custom-literals.kl" 2 | 3 | (example 42) 4 | (example (+ 2 2)) 5 | (example "foo") 6 | -------------------------------------------------------------------------------- /examples/custom-literals.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/custom-literals.golden -------------------------------------------------------------------------------- /examples/custom-literals.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import "define-syntax-rule.kl") 5 | 6 | 7 | (define-macro (my-integer n) 8 | (pure `(+ 1 (#%integer-literal ,n)))) 9 | 10 | (define-macro (my-string s) 11 | (pure `(string-append (#%string-literal ,s) (#%string-literal "!")))) 12 | 13 | (export (rename ([my-integer #%integer-literal] 14 | [my-string #%string-literal]) 15 | #%module 16 | #%app 17 | my-integer 18 | my-string 19 | example 20 | + 21 | string-append)) 22 | -------------------------------------------------------------------------------- /examples/custom-module-test.golden: -------------------------------------------------------------------------------- 1 | "before module" : String 2 | "inside module" : String 3 | "after module" : String 4 | -------------------------------------------------------------------------------- /examples/custom-module-test.kl: -------------------------------------------------------------------------------- 1 | #lang "custom-module.kl" 2 | 3 | (example "inside module") 4 | -------------------------------------------------------------------------------- /examples/custom-module.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/custom-module.golden -------------------------------------------------------------------------------- /examples/custom-module.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import "define-syntax-rule.kl") 5 | 6 | 7 | (define-macro (my-module body) 8 | (pure `(#%module 9 | (example "before module") 10 | ,body 11 | (example "after module")))) 12 | 13 | (export (rename ([my-module #%module]) 14 | #%integer-literal 15 | #%string-literal 16 | my-module 17 | example)) 18 | -------------------------------------------------------------------------------- /examples/datatype-import.golden: -------------------------------------------------------------------------------- 1 | (add1 (add1 (add1 (add1 (add1 (zero)))))) : Nat 2 | -------------------------------------------------------------------------------- /examples/datatype-import.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "datatypes.kl") 4 | (import "defun.kl") 5 | 6 | (defun plus (n k) 7 | (case n 8 | [(zero) k] 9 | [(add1 n*) (plus n* (add1 k))])) 10 | 11 | (example (plus (add1 (add1 (zero))) (add1 (add1 (add1 (zero)))))) 12 | 13 | -------------------------------------------------------------------------------- /examples/datatype-macro.golden: -------------------------------------------------------------------------------- 1 | (:: 3 (:: 2 (:: 1 (nil)))) : (List Integer) 2 | (:: 3 (:: 2 (:: 1 (nil)))) : (List Integer) 3 | #[datatype-macro.kl:49.38-49.39] : Syntax 4 | 3 : Integer 5 | -------------------------------------------------------------------------------- /examples/datatype-macro.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | (import "defun.kl") 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "lispy-do.kl" 1)) 5 | (import (shift "let.kl" 1)) 6 | (import (shift "quasiquote.kl" 1)) 7 | (import (shift (only "list-syntax.kl" map) 1)) 8 | 9 | 10 | (datatype (List A) 11 | (nil) 12 | (:: A (List A))) 13 | 14 | (defun snoc (xs x) 15 | (case xs 16 | [(nil) (:: x (nil))] 17 | [(:: y ys) (:: y (snoc ys x))])) 18 | 19 | (defun reverse (xs) 20 | (case xs 21 | [(nil) (nil)] 22 | [(:: x xs) (snoc (reverse xs) x)])) 23 | 24 | (define-macros 25 | ([list 26 | (lambda (stx) 27 | (syntax-case stx 28 | [(cons _ more) 29 | (syntax-case more 30 | [() 31 | (pure (replace-loc more '(nil)))] 32 | [(cons x xs) 33 | (pure (quasiquote/loc more (:: ,x ,(cons-list-syntax 'list xs xs))))])]))])) 34 | 35 | (example (reverse (:: 1 (:: 2 (:: 3 (nil)))))) 36 | 37 | (example (reverse (list 1 2 3))) 38 | 39 | (define-macros 40 | ([null (lambda (stx) (pure '(nil)))])) 41 | 42 | (define-macros 43 | ([head 44 | (lambda (stx) 45 | (syntax-case stx 46 | [(list (_ x)) 47 | (pure (quasiquote/loc stx (:: ,x xs)))]))])) 48 | 49 | (example (case (reverse null) [null 'a])) 50 | 51 | (example (case (reverse (list 1 2 3)) [(head x) x])) 52 | 53 | -------------------------------------------------------------------------------- /examples/datatypes.golden: -------------------------------------------------------------------------------- 1 | (left (branch (branch (leaf) (zero) (leaf)) (add1 (zero)) (leaf))) : ∀(α : *). (Either (Tree Nat) α) 2 | (right (right (right (nil)))) : ∀(α : *) (β : *) (γ : *) (δ : *). (Either α (Either β (Either γ (List δ)))) 3 | (add1 (add1 (add1 (add1 (zero))))) : Nat 4 | (right (true)) : ∀(α : *). (Either α Bool) 5 | (left (:: (add1 (zero)) (nil))) : ∀(α : *). (Either (List Nat) α) 6 | # : (Nat → (Nat → Nat)) 7 | (add1 (add1 (add1 (add1 (add1 (zero)))))) : Nat 8 | # : (Alphabet → Integer) 9 | # : (Alphabet → Bool) 10 | (true) : Bool 11 | (false) : Bool 12 | -------------------------------------------------------------------------------- /examples/datatypes.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (datatype (Nat) 4 | (zero) 5 | (add1 (Nat))) 6 | 7 | (datatype (List A) 8 | (nil) 9 | (:: A (List A))) 10 | 11 | (datatype (Tree A) 12 | (leaf) 13 | (branch (Tree A) A (Tree A))) 14 | 15 | (datatype (Either A B) 16 | (left A) 17 | (right B)) 18 | 19 | (define nothing (zero)) 20 | 21 | (define something (add1 (add1 (zero)))) 22 | 23 | (example (left (branch (branch (leaf) (zero) (leaf)) (add1 (zero)) (leaf)))) 24 | (example (right (right (right (nil))))) 25 | 26 | 27 | (define double 28 | (flet (f (n) 29 | (case n 30 | [(zero) (zero)] 31 | [(add1 k) (add1 (add1 (f k)))])) 32 | f)) 33 | 34 | (example (double (add1 (add1 (zero))))) 35 | 36 | (define flop 37 | (lambda (either) 38 | (case either 39 | [(left a) (right a)] 40 | [(right b) (left b)]))) 41 | 42 | (example (flop (left (true)))) 43 | (example (flop (right (:: (add1 (zero)) (nil))))) 44 | 45 | (define plus 46 | (flet (f (n) 47 | (case n 48 | [(zero) (lambda (k) k)] 49 | [(add1 n*) (lambda (k) ((f n*) (add1 k)))])) 50 | f)) 51 | 52 | (example 53 | (flet (plus* (n) 54 | (case n 55 | [(zero) (lambda (k) k)] 56 | [(add1 n*) (lambda (k) ((plus* n*) (add1 k)))])) 57 | plus*)) 58 | 59 | (example ((plus (add1 (add1 (zero)))) (add1 (add1 (add1 (zero)))))) 60 | 61 | (datatype (Alphabet) 62 | (a) (b) (c) (d) (e) (f) (g) (h) (i) (j) (k) (l) (m) (n) 63 | (o) (p) (q) (r) (s) (t) (u) (v) (x) (y) (z) (æ) (ø) (å)) 64 | 65 | (example 66 | (lambda (letter) 67 | (case letter 68 | [(a) 1] 69 | [(b) 2] 70 | [(c) 3] 71 | [(d) 4] 72 | [(e) 5] 73 | [(f) 6] 74 | [(g) 7] 75 | [(h) 8] 76 | [(i) 9] 77 | [(j) 10] 78 | [(k) 11] 79 | [(l) 12] 80 | [(m) 13] 81 | [(n) 14] 82 | [(o) 15] 83 | [(p) 16] 84 | [(q) 17] 85 | [(r) 18] 86 | [(s) 19] 87 | [(t) 20] 88 | [(u) 21] 89 | [(v) 22] 90 | [(x) 23] 91 | [(y) 24] 92 | [(z) 25] 93 | [(æ) 26] 94 | [(ø) 27] 95 | [(å) 28]))) 96 | 97 | (define vowel? 98 | (lambda (letter) 99 | (case letter 100 | [(a) (true)] 101 | [(e) (true)] 102 | [(i) (true)] 103 | [(o) (true)] 104 | [(u) (true)] 105 | [(y) (true)] 106 | [(æ) (true)] 107 | [(ø) (true)] 108 | [(å) (true)] 109 | [(else x) (false)]))) 110 | (example vowel?) 111 | (example (vowel? (y))) 112 | (example (vowel? (x))) 113 | 114 | (export Nat zero add1) 115 | -------------------------------------------------------------------------------- /examples/deep-patterns.golden: -------------------------------------------------------------------------------- 1 | (add1 (add1 (zero))) : Nat 2 | (add1 (add1 (zero))) : Nat 3 | (add1 (add1 (zero))) : Nat 4 | (add1 (add1 (zero))) : Nat 5 | (true) : Bool 6 | (false) : Bool 7 | (false) : Bool 8 | (pair 0 (pair (zero) "zero")) : (Pair Integer (Pair Nat String)) 9 | -------------------------------------------------------------------------------- /examples/deep-patterns.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (datatype (Nat) 4 | (zero) 5 | (add1 (Nat))) 6 | 7 | (define half 8 | (flet (half (n) 9 | (case n 10 | ((zero) (zero)) 11 | ((add1 (zero)) (zero)) 12 | ((add1 (add1 k)) (add1 (half k))))) 13 | half)) 14 | 15 | (example (half (add1 (add1 (add1 (add1 (zero))))))) 16 | (example (half (add1 (add1 (add1 (add1 (add1 (zero)))))))) 17 | 18 | (define half* 19 | (flet (half* (n) 20 | (case n 21 | ((add1 (add1 k)) (add1 (half* k))) 22 | (_ (zero)))) 23 | half*)) 24 | 25 | (example (half* (add1 (add1 (add1 (add1 (zero))))))) 26 | (example (half* (add1 (add1 (add1 (add1 (add1 (zero)))))))) 27 | 28 | 29 | (define four? 30 | (lambda (x) 31 | (case x 32 | ((add1 (add1 (add1 (add1 (zero))))) (true)) 33 | (_ (false))))) 34 | 35 | (example (four? (add1 (add1 (add1 (add1 (zero))))))) 36 | (example (four? (add1 (add1 (add1 (zero)))))) 37 | (example (four? (add1 (add1 (add1 (add1 (add1 (zero)))))))) 38 | 39 | 40 | (datatype (Pair A B) 41 | (pair A B)) 42 | 43 | (define reassoc 44 | (lambda (x) 45 | (case x 46 | ((pair (pair x y) z) (pair x (pair y z)))))) 47 | 48 | (example (reassoc (pair (pair 0 (zero)) "zero"))) 49 | 50 | -------------------------------------------------------------------------------- /examples/define-syntax-rule-test.golden: -------------------------------------------------------------------------------- 1 | (pair 1 2) : (Pair Integer Integer) 2 | (pair 1 2) : (Pair Integer Integer) 3 | (pair 1 2) : (Pair Integer Integer) 4 | -------------------------------------------------------------------------------- /examples/define-syntax-rule-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "define-syntax-rule.kl") 4 | (import "pair-datatype.kl") 5 | (import (shift "prelude.kl" 1)) 6 | (import (shift "list.kl" 1)) 7 | 8 | 9 | (define-macro (lambda2a x y body) 10 | (pure `(lambda (,x ,y) ,body))) 11 | (define mk-pair-a (lambda2a x y (pair x y))) 12 | (example (mk-pair-a 1 2)) 13 | 14 | (define-variadic-macro (lambda2b stx) 15 | (case (open-syntax stx) 16 | [(list-contents (list _ x y body)) 17 | (pure `(lambda (,x ,y) ,body))])) 18 | (define mk-pair-b (lambda2b x y (pair x y))) 19 | (example (mk-pair-b 1 2)) 20 | 21 | (define-syntax-rule (lambda2c x y body) 22 | (lambda (x y) body)) 23 | (define mk-pair-c (lambda2c x y (pair x y))) 24 | (example (mk-pair-c 1 2)) 25 | -------------------------------------------------------------------------------- /examples/define-syntax-rule.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/define-syntax-rule.golden -------------------------------------------------------------------------------- /examples/define-syntax-rule.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "do.kl" 1)) 5 | (import (shift "list.kl" 1)) 6 | (import (shift "list-syntax.kl" 1)) 7 | (import (shift "quasiquote.kl" 1)) 8 | (import (shift "syntax.kl" 1)) 9 | 10 | -- (define-macro (lambda2 x y body) 11 | -- (pure `(lambda (,x ,y) ,body))) 12 | (define-macros 13 | ((define-macro 14 | (lambda (stx) 15 | (syntax-case stx 16 | ((list (_ pattern body)) 17 | (syntax-case pattern 18 | ((cons macro-name args) 19 | (pure `(define-macros 20 | ([,macro-name (lambda (stx) 21 | (syntax-case stx 22 | ((list ,pattern) 23 | ,body)))]))))))))))) 24 | 25 | -- (define-variadic-macro (lambda2 stx) 26 | -- (case (open-syntax stx) 27 | -- [(list-contents (list _ x y body)) 28 | -- (pure `(lambda (,x ,y) ,body))])) 29 | (define-macro (define-variadic-macro macro-stx body) 30 | (case (open-syntax macro-stx) 31 | [(list-contents (list macro-name stx-name)) 32 | (pure `(define-macros 33 | ([,macro-name (lambda (,stx-name) 34 | ,body)])))])) 35 | 36 | -- (define-syntax-rule (lambda2 x y body) 37 | -- (lambda (x y) body)) 38 | (define-variadic-macro (define-syntax-rule stx) 39 | (syntax-case stx 40 | ((list (_ pattern template)) 41 | (syntax-case pattern 42 | ((cons macro-name args) 43 | (do (unquoted-template <- (foldlM (lambda (t arg) 44 | (replace-identifier 45 | arg 46 | (list-syntax ('unquote arg) stx) 47 | t)) 48 | template 49 | args)) 50 | (quasiquoted-template <- (pure (list-syntax ('quasiquote unquoted-template) stx))) 51 | (pure `(define-macros 52 | ([,macro-name (lambda (stx) 53 | (syntax-case stx 54 | ((list ,pattern) 55 | (pure ,quasiquoted-template))))]))))))))) 56 | 57 | 58 | (export define-macro define-variadic-macro define-syntax-rule) 59 | -------------------------------------------------------------------------------- /examples/defun-test.golden: -------------------------------------------------------------------------------- 1 | #[defun-test.kl:12.22-12.23] : Syntax 2 | #[defun-test.kl:13.34-13.35] : Syntax 3 | -------------------------------------------------------------------------------- /examples/defun-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | [defun last-stx (stx) 4 | (syntax-case stx 5 | [[cons a d] 6 | (syntax-case d 7 | [() a] 8 | [_ (last-stx d)])] -- note that this is a recursive call to last-stx, whereas earlier (e.g. in n-ary-app.kl) 9 | -- we'd have to return the syntax of a macro call to last-stx. 10 | [_ stx])] 11 | 12 | [example (last-stx '(a))] 13 | [example (last-stx '(a b c d e f g))] 14 | -------------------------------------------------------------------------------- /examples/defuns-test.golden: -------------------------------------------------------------------------------- 1 | (:: (false) (:: (true) (:: (false) (:: (true) (:: (false) (nil)))))) : (List Bool) 2 | (:: (true) (:: (false) (:: (true) (:: (false) (:: (true) (nil)))))) : (List Bool) 3 | (:: 1 (:: 2 (:: 6 (:: 24 (:: 120 (nil)))))) : (List Integer) 4 | (:: 0 (:: 1 (:: 7 (:: 2 (:: 5 (nil)))))) : (List Integer) 5 | -------------------------------------------------------------------------------- /examples/defuns-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | (import "defuns.kl") 3 | (import "list.kl") 4 | (import "either-datatype.kl") 5 | (import "pair-datatype.kl") 6 | 7 | 8 | (defuns 9 | [even? (n) 10 | (if (= n 0) true (odd? (- n 1)))] 11 | [odd? (n) 12 | (if (= n 0) false (even? (- n 1)))]) 13 | 14 | -- (list (false) (true) (false) (true) (false)) 15 | (example (map even? (list 1 2 3 4 5))) 16 | 17 | -- (list (true) (false) (true) (false) (true)) 18 | (example (map odd? (list 1 2 3 4 5))) 19 | 20 | 21 | -- exercise the edge case in which only one function is defined. 22 | (defuns 23 | [fact (n) 24 | (if (= n 0) 1 (* n (fact (- n 1))))]) 25 | 26 | -- (list 1 2 6 24 120) 27 | (example 28 | (map fact (list 1 2 3 4 5))) 29 | 30 | 31 | -- exercise the edge case in which zero functions are defined. 32 | (defuns) 33 | 34 | 35 | -- exercise a more complicated case, with more than two functions taking more than one argument. 36 | (defuns 37 | [collatz (n) 38 | (go n 0)] 39 | [go (n steps) 40 | (if (= n 1) 41 | steps 42 | (if (even? n) 43 | (go-even n steps) 44 | (go-odd n steps)))] 45 | [go-even (n steps) 46 | (go (/ n 2) 47 | (+ steps 1))] 48 | [go-odd (n steps) 49 | (go (+ (* 3 n) 1) 50 | (+ steps 1))]) 51 | 52 | -- (list 0 1 7 2 5) 53 | (example 54 | (map collatz (list 1 2 3 4 5))) 55 | -------------------------------------------------------------------------------- /examples/defuns.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/defuns.golden -------------------------------------------------------------------------------- /examples/do.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/do.golden -------------------------------------------------------------------------------- /examples/do.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import (shift "let.kl" 1)) 6 | 7 | (define-macros 8 | -- (do (x <- foo) 9 | -- (bar x) 10 | -- (y <- baz x) 11 | -- (quux x y)) 12 | -- => 13 | -- (>>= foo (lambda (x) 14 | -- (>>= (bar x) (lambda (_) 15 | -- (>>= (baz x) (lambda (y) 16 | -- (quux x y))))))) 17 | ((<- 18 | (lambda (stx) 19 | (syntax-error (quote "<- used out of context") stx))) 20 | (do (lambda (stx) 21 | (syntax-case stx 22 | ((cons _ all-actions) 23 | (syntax-case all-actions 24 | ((list (last-action)) 25 | (pure last-action)) 26 | ((cons first-action actions) 27 | (let ((otherwise (pure `(>>= ,first-action (lambda (_) 28 | ,(cons-list-syntax 'do actions stx)))))) 29 | (syntax-case first-action 30 | ((list (var <-? action)) 31 | (>>= (free-identifier=? '<- <-?) 32 | (lambda (isArrow) 33 | (if isArrow 34 | (pure `(>>= ,action (lambda (,var) 35 | ,(cons-list-syntax 'do actions stx)))) 36 | otherwise)))) 37 | (_ 38 | otherwise))))))))))) 39 | 40 | (export <- do) 41 | -------------------------------------------------------------------------------- /examples/double-define.golden: -------------------------------------------------------------------------------- 1 | 1 : Integer 2 | 1 : Integer 3 | -------------------------------------------------------------------------------- /examples/double-define.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (import "define-syntax-rule.kl") 4 | 5 | (define-syntax-rule (double-define x y value) 6 | (group 7 | (define x value) 8 | (define y value))) 9 | 10 | (double-define a b 1) 11 | (example a) 12 | (example b) 13 | -------------------------------------------------------------------------------- /examples/either-datatype.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/either-datatype.golden -------------------------------------------------------------------------------- /examples/either-datatype.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (datatype (Either A B) 4 | (left A) 5 | (right B)) 6 | 7 | (export Either left right) 8 | -------------------------------------------------------------------------------- /examples/error.golden: -------------------------------------------------------------------------------- 1 | # : ∀(α : *). (Syntax → α) 2 | -------------------------------------------------------------------------------- /examples/error.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (define fail (lambda (msg) (error msg))) 4 | 5 | (example fail) 6 | 7 | -------------------------------------------------------------------------------- /examples/eta-case.golden: -------------------------------------------------------------------------------- 1 | (pair 0 (nil)) : (Pair Integer (List Integer)) 2 | (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) 3 | #[eta-case.kl:188.13-195.38] 4 | <(case 5 | (list 1 2 3) 6 | ((:: x xs) (pair x xs)) 7 | ((else evaluated-scrutinee) 8 | (eta-case evaluated-scrutinee ((nil) (pair 0 (nil))))))> : Syntax 9 | #[eta-case.kl:214.13-215.20]<(lambda (_) (case (list 1 2 3) ...))> : Syntax 10 | #[eta-case.kl:225.13-225.20]<((eta-case-aux ...) (::))> : Syntax 11 | #[eta-case.kl:243.19-243.22] 12 | <(eta-case-aux (list 1 2 3) (::) (pair) ((nil) (pair 0 (nil))))> : Syntax 13 | # : ∀(α : *). (α → ((List α) → (List α))) 14 | # : ((List Integer) → (List Integer)) 15 | (:: 1 (:: 2 (:: 3 (nil)))) : (List Integer) 16 | # : ∀(α : *). (α → ((List α) → (List α))) 17 | # : ((List Integer) → (List Integer)) 18 | (:: 1 (:: 2 (:: 3 (nil)))) : (List Integer) 19 | (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) 20 | (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) 21 | (pair 0 (nil)) : (Pair Integer (List Integer)) 22 | (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) 23 | -------------------------------------------------------------------------------- /examples/exports-macro.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/exports-macro.golden -------------------------------------------------------------------------------- /examples/exports-macro.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import [shift (only kernel lambda pure quote) 1]] 4 | 5 | 6 | [define-macros 7 | ([id-m [lambda [stx] 8 | [pure [quote [quote (false)]]]]])] 9 | 10 | 11 | 12 | [export id-m] 13 | -------------------------------------------------------------------------------- /examples/failing-examples/bound-vs-free.golden: -------------------------------------------------------------------------------- 1 | Syntax error from macro: 2 | #[bound-vs-free.kl:20.39-20.67]<"variables must be distinct"> 3 | -------------------------------------------------------------------------------- /examples/failing-examples/bound-vs-free.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import (shift "do.kl" 1)) 6 | (import (shift "bool.kl" 1)) 7 | 8 | (define-macros 9 | ((_ (lambda (stx) 10 | (syntax-error '(underscore used outside parameter list)))) 11 | (lambda2 (lambda (stx) 12 | (syntax-case stx 13 | ((list (_ var1 var2 body)) 14 | (do (var1=_ <- (free-identifier=? '_ var1)) 15 | (var2=_ <- (free-identifier=? '_ var2)) 16 | (var1=var2 <- (bound-identifier=? var1 var2)) 17 | (if (and (not var1=_) 18 | (not var2=_) 19 | var1=var2) 20 | (syntax-error '"variables must be distinct") 21 | (pure `(lambda (,var1 ,var2) ,body)))))))))) 22 | 23 | (example ((lambda2 _ _ 'result) 1 2)) 24 | (example ((lambda2 _ y 'result) 1 2)) 25 | (example ((lambda2 x _ 'result) 1 2)) 26 | (example ((lambda2 x y 'result) 1 2)) 27 | (example ((lambda2 x x 'result) 1 2)) -- variables must be distinct 28 | -------------------------------------------------------------------------------- /examples/failing-examples/incorrect-context.golden: -------------------------------------------------------------------------------- 1 | #[incorrect-context.kl:5.10-5.22]<(define x 5)>: 2 | Used in a position expecting an expression 3 | but is valid in a position expecting a top-level declaration or example 4 | -------------------------------------------------------------------------------- /examples/failing-examples/incorrect-context.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | -- Expected to fail. Define should only work in a declaration context. But 4 | -- example expects an expression 5 | (example (define x 5)) 6 | -------------------------------------------------------------------------------- /examples/failing-examples/keyword-used-incorrectly.golden: -------------------------------------------------------------------------------- 1 | Syntax error from macro: 2 | #[keyword.kl:9.22-9.64]<(Keyword my-then cannot appear on its own)> 3 | -------------------------------------------------------------------------------- /examples/failing-examples/keyword-used-incorrectly.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "keyword-test.kl") 4 | 5 | (example 6 | (my-then "math works" 7 | my-else "math is broken")) 8 | -------------------------------------------------------------------------------- /examples/failing-examples/wrong-keyword.golden: -------------------------------------------------------------------------------- 1 | Syntax error from macro: 2 | #[keyword-test.kl:19.26-19.51]<(my-if: expected my-then)> 3 | -------------------------------------------------------------------------------- /examples/failing-examples/wrong-keyword.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "keyword-test.kl") 4 | 5 | (example 6 | (my-if (= (+ 2 2) 4) 7 | then "math works" 8 | else "math is broken")) 9 | -------------------------------------------------------------------------------- /examples/fix.golden: -------------------------------------------------------------------------------- 1 | (in (cons "hello" (in (cons "world" (in (nil)))))) : (Fix (ListF String)) 2 | (in (cons "hello" (in (cons "world" (in (nil)))))) : (Fix (ListF String)) 3 | (in (succ (in (succ (in (zero)))))) : (Fix NatF) 4 | # : ∀(α : *) (β : *). ((α → β) → ((Fix (ListF α)) → (Fix (ListF β)))) 5 | (in (cons (in (succ (in (succ (in (zero)))))) 6 | (in (cons (in (succ (in (succ (in (succ (in (zero)))))))) 7 | (in (nil)))))) : (Fix (ListF (Fix NatF))) 8 | -------------------------------------------------------------------------------- /examples/fix.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (datatype (Fix F) 4 | (in (F (Fix F)))) 5 | 6 | (define out 7 | (lambda (x) 8 | (case x 9 | ((in y) y)))) 10 | 11 | (datatype (NatF A) 12 | (zero) 13 | (succ A)) 14 | 15 | (datatype (ListF A L) 16 | (nil) 17 | (cons A L)) 18 | 19 | (define length 20 | (flet (length (xs) 21 | (case (out xs) 22 | [(nil) (in (zero))] 23 | [(cons y ys) (in (succ (length ys)))])) 24 | length)) 25 | 26 | 27 | (define l1 (the (Fix (ListF (String))) (in (cons "hello" (in (cons "world" (in (nil)))))))) 28 | 29 | (example l1) 30 | 31 | (define l1-no-annotation (in (cons "hello" (in (cons "world" (in (nil))))))) 32 | 33 | (example l1-no-annotation) 34 | 35 | 36 | (example (length l1)) 37 | 38 | (define map 39 | (lambda (f) 40 | (flet (map* (xs) 41 | (case (out xs) 42 | [(nil) (in (nil))] 43 | [(cons y ys) (in (cons (f y) (map* ys)))])) 44 | map*))) 45 | 46 | (example map) 47 | 48 | (example ((map length) (in (cons l1 (in (cons (in (cons "Yes" l1)) (in (nil)))))))) 49 | -------------------------------------------------------------------------------- /examples/free-identifier-case-test.golden: -------------------------------------------------------------------------------- 1 | 1 : Integer 2 | 2 : Integer 3 | 3 : Integer 4 | 4 : Integer 5 | 32 : Integer 6 | -------------------------------------------------------------------------------- /examples/free-identifier-case-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "free-identifier-case.kl" 1)) 5 | 6 | (define-macros 7 | ([test 8 | (lambda (stx) 9 | (syntax-case stx 10 | [(list (_ x)) 11 | (free-identifier-case x 12 | [if (pure '1)] 13 | [else (pure '2)] 14 | [define (pure '3)] 15 | [#%app (pure '4)] 16 | [(else y) (pure y)])]))])) 17 | 18 | (define hello 32) 19 | (example (test if)) 20 | (example (test else)) 21 | (example (test define)) 22 | (example (test #%app)) 23 | (example (test hello)) 24 | -------------------------------------------------------------------------------- /examples/free-identifier-case.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/free-identifier-case.golden -------------------------------------------------------------------------------- /examples/free-identifier-case.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "let.kl") 4 | (import (shift "prelude.kl" 1)) 5 | (import (shift "quasiquote.kl" 1)) 6 | 7 | (meta 8 | (define identifier? 9 | (lambda (x) 10 | (syntax-case x 11 | [(ident x) (true)] 12 | [_ (false)])))) 13 | 14 | (define-macros 15 | ([free-identifier-case 16 | (lambda (stx) 17 | (syntax-case stx 18 | [(cons _ body) 19 | (syntax-case body 20 | [(cons scrut cases) 21 | (pure 22 | (quasiquote/loc stx 23 | (let (x ,scrut) (free-identifier-case-aux x ,cases))))])]))] 24 | [free-identifier-case-aux 25 | (lambda (stx) 26 | (syntax-case stx 27 | [(list (_ scrut cases)) 28 | (syntax-case cases 29 | [() (pure '(syntax-error '"Nothing matched"))] 30 | [(cons c cs) 31 | (syntax-case c 32 | [(list (test val)) 33 | (syntax-case test 34 | [(list (e x)) 35 | (>>= (free-identifier=? e 'else) 36 | (lambda (eq) 37 | (if eq 38 | (pure (quasiquote/loc c (let (,x ,scrut) ,val))) 39 | (syntax-error test))))] 40 | [(ident id) 41 | (pure 42 | (quasiquote/loc c 43 | (>>= (free-identifier=? ,scrut ',id) 44 | (lambda (eq) 45 | (if eq 46 | ,val 47 | (free-identifier-case-aux ,scrut ,cs))))))])])])]))])) 48 | 49 | (export free-identifier-case) 50 | -------------------------------------------------------------------------------- /examples/fun-exports-test.golden: -------------------------------------------------------------------------------- 1 | 1 : Integer 2 | 2 : Integer 3 | 3 : Integer 4 | -------------------------------------------------------------------------------- /examples/fun-exports-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | (import (shift "prelude.kl" 1)) 3 | (import (shift "prelude.kl" 2)) 4 | (import "fun-exports.kl") 5 | 6 | (example a) 7 | (meta (example b)) 8 | (meta (meta (example the-a))) 9 | -------------------------------------------------------------------------------- /examples/fun-exports.golden: -------------------------------------------------------------------------------- 1 | 1 : Integer 2 | 2 : Integer 3 | 3 : Integer 4 | 4 : Integer 5 | -------------------------------------------------------------------------------- /examples/fun-exports.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | (import (shift kernel 1)) 3 | (import (shift kernel 2)) 4 | (import (shift kernel 3)) 5 | 6 | 7 | 8 | 9 | (meta (define a 2)) 10 | 11 | (meta (meta (define a 3))) 12 | 13 | (meta (meta (meta (define a 4)))) 14 | 15 | (define a 1) 16 | 17 | (define b a) 18 | (meta (define b a)) 19 | (meta (meta (define b a))) 20 | (meta (meta (meta (define b a)))) 21 | 22 | (example b) 23 | (meta (example b)) 24 | (meta (meta (example b))) 25 | (meta (meta (meta (example b)))) 26 | 27 | (export a) 28 | (export (rename ([a b]) (shift 1 a))) 29 | (export (shift 2 (prefix "the-" a))) 30 | -------------------------------------------------------------------------------- /examples/group.golden: -------------------------------------------------------------------------------- 1 | 1 : Integer 2 | 1 : Integer 3 | 1 : Integer 4 | 10 : Integer 5 | 10 : Integer 6 | 10 : Integer 7 | -------------------------------------------------------------------------------- /examples/group.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | (import (shift kernel 1)) 3 | 4 | (define a 1) 5 | (meta 6 | (define a 10)) 7 | (group 8 | (define b a) 9 | (define c b) 10 | (meta 11 | (define b a) 12 | (define c b))) 13 | 14 | (example a) 15 | (example b) 16 | (example c) 17 | (meta 18 | (example a) 19 | (example b) 20 | (example c)) 21 | -------------------------------------------------------------------------------- /examples/hello.golden: -------------------------------------------------------------------------------- 1 | hello 2 | world 3 | -------------------------------------------------------------------------------- /examples/hello.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | -- do notation is not builtin syntax, it's implemented as a library! 4 | (import "monad.kl") 5 | 6 | -- (-> String (IO Unit)) 7 | (defun putStrLn (str) 8 | (write stdout (string-append str "\n"))) 9 | 10 | -- "run" is like main, except you can have more than one. 11 | (run 12 | -- Klister doesn't have type classes yet, so "do" needs an explicit 13 | -- dictionary argument. 14 | (do io-monad 15 | (putStrLn "hello") 16 | (putStrLn "world"))) 17 | -------------------------------------------------------------------------------- /examples/higher-kinded-patterns.golden: -------------------------------------------------------------------------------- 1 | "OfUnit IO" : String 2 | "OfUnit Maybe" : String 3 | "OfUnit (-> Unit)" : String 4 | "OfUnit (Pair Unit)" : String 5 | "OfUnitUnit (->)" : String 6 | "OfUnitUnit Pair" : String 7 | -------------------------------------------------------------------------------- /examples/higher-kinded-patterns.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "higher-kinded.kl" 1)) 5 | (import (shift "pair-datatype.kl" 1)) 6 | (import "define-syntax-rule.kl") 7 | (import "higher-kinded.kl") 8 | (import "pair-datatype.kl") 9 | 10 | -- Making sure we can pattern-match on unsaturated primitive type constructors, 11 | -- primitive datatypes, and user-defined datatypes. 12 | 13 | (define-macro (type-of) 14 | (>>= (which-problem) 15 | (lambda (problem) 16 | (case problem 17 | [(expression of-unit-t-arrow-string?) 18 | (type-case of-unit-t-arrow-string? 19 | [(-> of-unit-t? string?) 20 | (type-case of-unit-t? 21 | [(OfUnit type) 22 | (type-case type 23 | [(IO) 24 | (pure '(const "OfUnit IO"))] 25 | [(Maybe) 26 | (pure '(const "OfUnit Maybe"))] 27 | [(-> unit?) 28 | (type-case unit? 29 | [(Unit) 30 | (pure '(const "OfUnit (-> Unit)"))] 31 | [(else _) 32 | (pure '(const "OfUnit (-> ?)"))])] 33 | [(Pair unit?) 34 | (type-case unit? 35 | [(Unit) 36 | (pure '(const "OfUnit (Pair Unit)"))] 37 | [(else _) 38 | (pure '(const "OfUnit (Pair ?)"))])] 39 | [(else _) 40 | (pure '(const "OfUnit ?"))])] 41 | [(OfUnitUnit type) 42 | (type-case type 43 | [(->) 44 | (pure '(const "OfUnitUnit (->)"))] 45 | [(Pair) 46 | (pure '(const "OfUnitUnit Pair"))] 47 | [(else _) 48 | (pure '(const "OfUnitUnit ?"))])] 49 | [(else _) 50 | (pure '(const "?"))])])])))) 51 | 52 | (example 53 | ((type-of) 54 | (of-unit (pure-IO unit)))) 55 | (example 56 | ((type-of) 57 | (of-unit (just unit)))) 58 | (example 59 | ((type-of) 60 | (of-unit (the (-> Unit Unit) 61 | id)))) 62 | (example 63 | ((type-of) 64 | (of-unit (pair unit unit)))) 65 | 66 | (example 67 | ((type-of) 68 | (of-unit-unit (the (-> Unit Unit) 69 | id)))) 70 | (example 71 | ((type-of) 72 | (of-unit-unit (pair unit unit)))) 73 | -------------------------------------------------------------------------------- /examples/higher-kinded.golden: -------------------------------------------------------------------------------- 1 | (of-unit #) : (OfUnit IO) 2 | (of-unit #) : (OfUnit (→ Unit)) 3 | (of-unit (just (unit))) : (OfUnit Maybe) 4 | (of-unit (pair (unit) (unit))) : (OfUnit (Pair Unit)) 5 | (of-unit-unit #) : (OfUnitUnit (→)) 6 | (of-unit-unit #) : (OfUnitUnit (→)) 7 | (of-unit-unit (pair (unit) (unit))) : (OfUnitUnit Pair) 8 | -------------------------------------------------------------------------------- /examples/higher-kinded.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "pair-datatype.kl") 4 | 5 | 6 | -- Making sure we can write down unsaturated primitive type constructors, 7 | -- primitive datatypes, and user-defined datatypes. 8 | 9 | (datatype (OfUnit F) 10 | (of-unit (F Unit))) 11 | 12 | (example 13 | (the (OfUnit (IO)) 14 | (of-unit (pure-IO unit)))) 15 | (example 16 | (the (OfUnit (-> Unit)) 17 | (of-unit id))) 18 | (example 19 | (the (OfUnit (Maybe)) 20 | (of-unit (just unit)))) 21 | (example 22 | (the (OfUnit (Pair Unit)) 23 | (of-unit (pair unit unit)))) 24 | 25 | 26 | -- Make sure it also works at kind * -> * -> *. 27 | 28 | (datatype (OfUnitUnit F) 29 | (of-unit-unit 30 | (F Unit Unit))) 31 | 32 | (example 33 | (the (OfUnitUnit ->) 34 | (of-unit-unit id))) 35 | (example 36 | (the (OfUnitUnit (->)) 37 | (of-unit-unit id))) 38 | (example 39 | (the (OfUnitUnit (Pair)) 40 | (of-unit-unit (pair unit unit)))) 41 | 42 | 43 | (export 44 | OfUnit of-unit 45 | OfUnitUnit of-unit-unit) 46 | -------------------------------------------------------------------------------- /examples/hygiene.golden: -------------------------------------------------------------------------------- 1 | #[hygiene.kl:15.19-15.20] : Syntax 2 | #[hygiene.kl:16.37-16.38] : Syntax 3 | #[hygiene.kl:26.57-26.58] : Syntax 4 | 5 : Integer 5 | "defined six" : String 6 | 6 : Integer 7 | -------------------------------------------------------------------------------- /examples/hygiene.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import (shift "list.kl" 1)) 6 | (import "define-syntax-rule.kl") 7 | 8 | 9 | (define fun (lambda (x y) x)) 10 | 11 | (define-macros ([should-not-be-captured (lambda (stx) (pure (quote fun)))])) 12 | 13 | (define fun (lambda (x y) y)) 14 | 15 | (example (fun 'a 'b)) 16 | (example ((should-not-be-captured) 'a 'b)) 17 | 18 | (define-macros 19 | ([should-not-capture 20 | (lambda (stx) 21 | (syntax-case stx 22 | [(list (_ body)) 23 | (pure `(lambda (fun) ,body))] 24 | [_ (syntax-error '"bad syntax" stx)]))])) 25 | 26 | (example ((should-not-capture fun) (lambda (x y) x) 'a 'b)) 27 | 28 | -- In Racket, the following code demonstrates the need for "use-site scopes", 29 | -- as without them, the x introduced by ,misc-id would cause an accidental 30 | -- capture. In this file, this same code demonstrates that Klister doesn't need 31 | -- use-site scopes (because Klister's definition contexts are not recursive; 32 | -- see issue #187). 33 | (define-macros 34 | ([should-be-id 35 | (lambda (stx) 36 | (case (open-syntax stx) 37 | [(list-contents (list _ misc-id)) 38 | (pure `(lambda (x) 39 | (let [,misc-id 'other] 40 | x)))]))])) 41 | (example 42 | ((should-be-id x) 5)) 43 | 44 | -- The following example demonstrates that we can have two (define x ...) 45 | -- declarations with overlapping scopes without any accidental captures. 46 | (define-syntax-rule (define-six misc-id) 47 | (group 48 | (define x "defined six") 49 | (define misc-id 6) 50 | (example x))) 51 | (define-six x) 52 | (example x) 53 | -------------------------------------------------------------------------------- /examples/id-compare.golden: -------------------------------------------------------------------------------- 1 | (true) : Bool 2 | (false) : Bool 3 | -------------------------------------------------------------------------------- /examples/id-compare.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import [shift kernel 1]] 4 | 5 | [define-macros 6 | ([thing [lambda [stx] (syntax-error [quote not-allowed-here] stx)]])] 7 | [define-macros 8 | ([thingp [lambda [stx] 9 | (syntax-case stx 10 | [[list [_ x]] 11 | [>>= [free-identifier=? [quote thing] x] 12 | [lambda [ok] 13 | [case ok 14 | [(true) [pure [quote (true)]]] 15 | [(false) [pure [quote (false)]]]]]]])]])] 16 | 17 | 18 | 19 | [example [thingp thing]] 20 | [example [thingp thingp]] 21 | -------------------------------------------------------------------------------- /examples/implicit-conversion-test.golden: -------------------------------------------------------------------------------- 1 | 42 : Integer 2 | 4 : Integer 3 | "4!" : String 4 | # : (Integer → Integer) 5 | "31!" : String 6 | -------------------------------------------------------------------------------- /examples/implicit-conversion-test.kl: -------------------------------------------------------------------------------- 1 | #lang "implicit-conversion.kl" 2 | 3 | -- using let-implicit 0 times 4 | (example 5 | 42) 6 | 7 | -- using let-implicit 1 time 8 | (example 9 | (let-implicit string-length 10 | (+ 1 "foo"))) 11 | -- => 12 | -- (example 13 | -- (let-implicit string-length 14 | -- (#%app + 15 | -- (#%integer-literal 1) 16 | -- (#%string-literal "foo")))) 17 | -- => 18 | -- (my-example 19 | -- (let-implicit my-string-length 20 | -- (my-app my-+ 21 | -- (my-integer-literal 1) 22 | -- (my-string-literal "foo")))) 23 | -- => 24 | -- (example 25 | -- (run-reader 26 | -- (local (lambda (implicits) 27 | -- (pair string-length implicits)) 28 | -- ((pick-reader-ap-variant) ((pick-reader-ap-variant) (reader-pure +) 29 | -- (reader-pure 1)) 30 | -- (reader-pure "foo"))) 31 | -- (unit))) 32 | -- => 33 | -- (example 34 | -- (run-reader 35 | -- (reader-ap-with (lambda (...) string-length) 36 | -- (reader-ap (reader-pure +) 37 | -- (reader-pure 1)) 38 | -- (reader-pure "foo")) 39 | -- (pair string-length (unit))) 40 | -- => 41 | -- (example 42 | -- (+ 1 (string-length "foo"))) 43 | -- => 44 | -- (example 45 | -- (+ 1 3)) 46 | -- => 47 | -- (example 48 | -- 4) 49 | 50 | -- using let-implicit 2 times 51 | (example 52 | (let-implicit string-length 53 | (let-implicit integer->string 54 | (string-append (+ 1 "foo") "!")))) 55 | 56 | -- lambdas need a type annotation 57 | (example 58 | (lambda ((the Integer x)) 59 | (+ 2 x))) 60 | 61 | -- making a lambda implicit 62 | (example 63 | (let-implicit (lambda ((the String s)) 64 | (* 10 (string-length s))) 65 | (let-implicit integer->string 66 | (string-append (+ 1 "foo") "!")))) 67 | -------------------------------------------------------------------------------- /examples/implicit-conversion.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/implicit-conversion.golden -------------------------------------------------------------------------------- /examples/import-import-renaming.golden: -------------------------------------------------------------------------------- 1 | (true) : Bool 2 | -------------------------------------------------------------------------------- /examples/import-import-renaming.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | (import (rename "bool.kl" (not negb))) 3 | (import "import-renaming.kl") 4 | (example (negb (false))) 5 | -------------------------------------------------------------------------------- /examples/import-list-and-do.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/import-list-and-do.golden -------------------------------------------------------------------------------- /examples/import-list-and-do.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "list.kl") 4 | 5 | (import "lispy-do.kl") 6 | 7 | -------------------------------------------------------------------------------- /examples/import-renaming.golden: -------------------------------------------------------------------------------- 1 | (false) : Bool 2 | -------------------------------------------------------------------------------- /examples/import-renaming.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | (import (rename "bool.kl" (not negb))) 3 | (example (negb (true))) 4 | (export negb) 5 | -------------------------------------------------------------------------------- /examples/import-scoping-m1.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/import-scoping-m1.golden -------------------------------------------------------------------------------- /examples/import-scoping-m1.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -- See "import-scoping.kl" for an explanation. 4 | 5 | (import (shift kernel 1)) 6 | 7 | (define-macros 8 | ([m1 9 | (lambda (stx) 10 | (pure ''1))])) 11 | 12 | (export m1) 13 | -------------------------------------------------------------------------------- /examples/import-scoping-m2.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/import-scoping-m2.golden -------------------------------------------------------------------------------- /examples/import-scoping-m2.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -- See "import-scoping.kl" for an explanation. 4 | 5 | (import (shift kernel 1)) 6 | (import "import-scoping-m1.kl") 7 | 8 | (define-macros 9 | ([m2 10 | (lambda (stx) 11 | (pure '(m1)))])) 12 | 13 | (export m2) 14 | -------------------------------------------------------------------------------- /examples/import-scoping.golden: -------------------------------------------------------------------------------- 1 | #[import-scoping-m1.kl:10.15-10.16]<1> : Syntax 2 | -------------------------------------------------------------------------------- /examples/import-scoping.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -- This tests a tricky case around imports and scoping. 4 | -- 5 | -- * "import-scoping-m1.kl" defines m1. 6 | -- * "import-scoping-m2.kl" defines a macro m2 which produces code referring to m1. 7 | -- * In this module, we import "import-scoping-m2.kl" at two different phases. 8 | -- * We then refer to m2 at phase 0. 9 | -- * Since m2 is a macro, its definition then executes at phase 1. 10 | -- * It expands to code referring to m1. 11 | -- * We now have a reference to m1 at phase 0. 12 | -- 13 | -- With our old approach for imports and scoping, that reference to m1 was 14 | -- ambiguous. The two imports of "import-scoping-m2.kl" each cause a different 15 | -- m1 to be imported, but hidden. It is hidden, because "import-scoping-m2.kl" 16 | -- doesn't re-export m1; but it is nevertheless imported, so that once m2 17 | -- expands to code containing m1, that code has a chance to be well-scoped. 18 | -- 19 | -- If the imports form a diamond, we only import one imported-but-hidden 20 | -- instance of m1, so that the imported macros can cooperate with each other. 21 | -- In this case, however, the two imports are at different phases, so we 22 | -- import two different instances of m1. 23 | -- 24 | -- Previously, we were distinguishing the shifted instance of m1 by shifting 25 | -- all its phase-specific scopes by one phase. Unfortunately, in this case, 26 | -- this is not sufficient, because those phase-specific scopes happen to also 27 | -- be present in the universal scopes shared by the two instances of m1. The 28 | -- solution was add a scope for each (imported module, phase) pair. 29 | 30 | (import (shift "import-scoping-m2.kl" 1)) 31 | (import "import-scoping-m2.kl") 32 | 33 | (example (m2)) 34 | -------------------------------------------------------------------------------- /examples/import.golden: -------------------------------------------------------------------------------- 1 | #[import.kl:7.24-7.27] : Syntax 2 | #[import.kl:8.48-8.50] : Syntax 3 | -------------------------------------------------------------------------------- /examples/import.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import (only "n-ary-app.kl" #%app)] 4 | [import (only "n-ary-app.kl" lambda)] 5 | [import (only "prelude.kl" const)] 6 | 7 | [example (const [quote one] [quote two])] 8 | [example ([lambda (x y z) y] [quote en] [quote to] [quote tre])] 9 | -------------------------------------------------------------------------------- /examples/imports-shifted-macro.golden: -------------------------------------------------------------------------------- 1 | (false) : Bool 2 | -------------------------------------------------------------------------------- /examples/imports-shifted-macro.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import [shift "exports-macro.kl" 1]] 4 | [import [shift (only kernel lambda pure) 1]] 5 | 6 | [define-macros ([m [lambda [stx] [pure [id-m [pure [quote fun]]]]]])] 7 | 8 | [example (m (true))] 9 | -------------------------------------------------------------------------------- /examples/int-ops.golden: -------------------------------------------------------------------------------- 1 | 3 : Integer 2 | 2 : Integer 3 | -1 : Integer 4 | 3 : Integer 5 | -2 : Integer 6 | 2 : Integer 7 | 4 : Integer 8 | -4 : Integer 9 | -4 : Integer 10 | (true) : Bool 11 | (false) : Bool 12 | (false) : Bool 13 | (true) : Bool 14 | (true) : Bool 15 | (false) : Bool 16 | (false) : Bool 17 | (false) : Bool 18 | (true) : Bool 19 | (false) : Bool 20 | (true) : Bool 21 | (true) : Bool 22 | (false) : Bool 23 | (true) : Bool 24 | (false) : Bool 25 | (true) : Bool 26 | (false) : Bool 27 | (true) : Bool 28 | "4" : String 29 | "-5" : String 30 | -------------------------------------------------------------------------------- /examples/int-ops.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (example (+ 1 2)) 4 | (example (* 1 2)) 5 | (example (- 1 2)) 6 | (example (/ 10 3)) 7 | (define minus-two (negate 2)) 8 | (example (minus-two)) 9 | (example (abs minus-two)) 10 | (example (abs 4)) 11 | (example (negate 4)) 12 | (example -4) 13 | 14 | (example (< 1 2)) 15 | (example (< 1 1)) 16 | (example (< 2 1)) 17 | (example (<= 1 2)) 18 | (example (<= 1 1)) 19 | (example (<= 2 1)) 20 | (example (> 1 2)) 21 | (example (> 1 1)) 22 | (example (> 2 1)) 23 | (example (>= 1 2)) 24 | (example (>= 1 1)) 25 | (example (>= 2 1)) 26 | (example (= 1 2)) 27 | (example (= 1 1)) 28 | (example (= 2 1)) 29 | (example (/= 1 2)) 30 | (example (/= 1 1)) 31 | (example (/= 2 1)) 32 | 33 | (example (integer->string 4)) 34 | (example (integer->string (negate 5))) 35 | 36 | -------------------------------------------------------------------------------- /examples/integer-syntax.golden: -------------------------------------------------------------------------------- 1 | 4 : Integer 2 | -------------------------------------------------------------------------------- /examples/integer-syntax.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | (import (shift "prelude.kl" 1)) 3 | (import (shift "quasiquote.kl" 1)) 4 | 5 | (define-macros 6 | ([gotta-be-integer 7 | (lambda (stx) 8 | (syntax-case stx 9 | [(list (_ i)) 10 | (syntax-case i 11 | [(integer int) (pure (integer-syntax (+ int int) i))] 12 | [_ (syntax-error (quasiquote/loc i "bad syntax"))])] 13 | [_ (syntax-error (quasiquote/loc stx "bad syntax"))]))])) 14 | 15 | (example (gotta-be-integer 2)) 16 | 17 | -------------------------------------------------------------------------------- /examples/io.golden: -------------------------------------------------------------------------------- 1 | # : Output-Port 2 | # : (IO Integer) 3 | hello world! 4 | -------------------------------------------------------------------------------- /examples/io.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (example (the Output-Port stdout)) 4 | 5 | (example (bind-IO (pure-IO 5) (lambda (x) (pure-IO (+ x 3))))) 6 | 7 | (run (write stdout "hello world!\n")) 8 | -------------------------------------------------------------------------------- /examples/keyword-test.golden: -------------------------------------------------------------------------------- 1 | "math works" : String 2 | -------------------------------------------------------------------------------- /examples/keyword-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "define-syntax-rule.kl") 4 | (import "keyword.kl") 5 | (import (shift "prelude.kl" 1)) 6 | (import (shift "do.kl" 1)) 7 | (import (shift "quasiquote.kl" 1)) 8 | 9 | (define-keyword my-then) 10 | (define-keyword my-else) 11 | 12 | (define-macro (my-if cond my-then-ish then-part my-else-ish else-part) 13 | (do (my-then? <- (keyword=? my-then-ish my-then)) 14 | (my-else? <- (keyword=? my-else-ish my-else)) 15 | (if my-then? 16 | (if my-else? 17 | (pure `(if ,cond ,then-part ,else-part)) 18 | (syntax-error '(my-if: expected my-else))) 19 | (syntax-error '(my-if: expected my-then))))) 20 | 21 | (example 22 | (my-if (= (+ 2 2) 4) 23 | my-then "math works" 24 | my-else "math is broken")) 25 | 26 | (export my-if my-then my-else) 27 | -------------------------------------------------------------------------------- /examples/keyword.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/keyword.golden -------------------------------------------------------------------------------- /examples/keyword.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import "define-syntax-rule.kl") 5 | 6 | (define-syntax-rule (define-keyword keyword) 7 | (group 8 | (define-variadic-macro (keyword _) 9 | (syntax-error '(Keyword keyword cannot appear on its own))) 10 | (meta 11 | (define keyword 'keyword)))) 12 | 13 | -- I use this synonym because I can never remember whether I should use 14 | -- free-identifier=? or bound-identifier=? 15 | (meta 16 | (defun keyword=? (ident keyword) 17 | (free-identifier=? ident keyword))) 18 | 19 | (export define-keyword) 20 | (export (shift 1 keyword=?)) 21 | -------------------------------------------------------------------------------- /examples/lambda-case-test.golden: -------------------------------------------------------------------------------- 1 | #[lambda-case-test.kl:8.13-8.16] : Syntax 2 | #[lambda-case-test.kl:9.16-9.20] : Syntax 3 | -------------------------------------------------------------------------------- /examples/lambda-case-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "lambda-case.kl") 4 | (import "list.kl") 5 | 6 | (define classify 7 | (lambda-case 8 | [(nil) 'nil] 9 | [(:: a b) 'cons])) 10 | 11 | (example (classify (nil))) 12 | (example (classify (:: 1 (:: 2 (nil))))) 13 | -------------------------------------------------------------------------------- /examples/lambda-case.golden: -------------------------------------------------------------------------------- 1 | "cons" : String 2 | -------------------------------------------------------------------------------- /examples/lambda-case.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import "define-syntax-rule.kl") 6 | (import "list.kl") 7 | 8 | -- In Haskell, the LambdaCase language extension allows us to write 9 | -- 10 | -- \case 11 | -- [] -> "nil" 12 | -- _:_ -> "cons" 13 | -- 14 | -- instead of 15 | -- 16 | -- \x -> case x of 17 | -- [] -> "nil" 18 | -- _:_ -> "cons" 19 | -- 20 | -- Klister supports macros, meaning you can define this kind of syntactic 21 | -- extensions yourself. Here is how to implement lambda-case as a macro. 22 | 23 | -- (lambda-case -- (1) 24 | -- [(nil) "nil"] 25 | -- [(:: _ _) "cons"]) 26 | -- => 27 | -- (lambda (x) -- (2) 28 | -- (case x 29 | -- [(nil) "nil"] 30 | -- [(:: _ _) "cons"])) 31 | (define-variadic-macro (lambda-case stx) 32 | (case (open-syntax stx) -- (3) 33 | [(list-contents (:: _ cases)) 34 | (pure 35 | `(lambda (x) 36 | ,(close-syntax stx stx -- (4) 37 | (list-contents (:: 'case (:: 'x cases))))))])) 38 | 39 | (example -- (5) 40 | (let [f (lambda-case 41 | [(nil) "nil"] 42 | [(:: _ _) "cons"])] 43 | (f (list 1 2 3)))) 44 | 45 | -- A macro is implemented as a function of type (-> Syntax (Macro Syntax)). 46 | -- Macro is a monad, but we don't make use of its effects in this example, so 47 | -- what matters is that we receive a Syntax and produce a Syntax. In the 48 | -- example at (5), we receive (1) and produce (2). 49 | -- 50 | -- Syntax objects will be covered in more details in a different example. For 51 | -- now, it suffices to know that we can split a Syntax into a (List Syntax) 52 | -- by using the open-syntax function and matching on the list-contents 53 | -- constructor, as in (3), and we can combine a (List Syntax) back into a 54 | -- Syntax by wrapping the (List Syntax) in that same list-contents constructor 55 | -- and using the close-syntax function, as in (4). 56 | -- 57 | -- In our running example, splitting (1) results in the list 58 | -- 59 | -- (list 'lambda-case 60 | -- '[(nil) "nil"] 61 | -- '[(:: _ _) "cons"]) 62 | -- 63 | -- So the pattern (:: _ cases) drops 'lambda-case and keeps the list of cases. 64 | -- 65 | -- This list of cases is then used to construct the longer list 66 | -- 67 | -- (list 'case 68 | -- 'x 69 | -- '[(nil) "nil"] 70 | -- '[(:: _ _) "cons"]) 71 | -- 72 | -- Which gets combined into 73 | -- 74 | -- '(case x 75 | -- [(nil) "nil"] 76 | -- [(:: _ _) "cons"]) 77 | -- 78 | -- Which gets spliced into a bigger syntax object in order to produce the 79 | -- desired output, (2). 80 | -- 81 | -- You can see the result of running the example at (5) by running this file: 82 | -- 83 | -- $ cabal run klister -- run examples/lambda-case.kl 84 | -- Example at lambda-case.kl:42.1-97.1: 85 | -- let f = λx. case x of { nil ↦ "nil" ; :: _ _ ↦ "cons" } in 86 | -- (f (:: 1 (:: 2 (:: 3 nil)))) : 87 | -- String ↦ 88 | -- "cons" 89 | -- 90 | -- Or by looking at the golden file generated by our test suite: 91 | -- 92 | -- $ cat examples/lambda-case.golden 93 | -- "cons" : String 94 | 95 | (export lambda-case) 96 | -------------------------------------------------------------------------------- /examples/lang.golden: -------------------------------------------------------------------------------- 1 | #[lang.kl:5.30-5.31]<ø> : Syntax 2 | -------------------------------------------------------------------------------- /examples/lang.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | [define f [lambda (x y z) y]] 4 | 5 | [example (f [quote æ] [quote ø] [quote å])] 6 | -------------------------------------------------------------------------------- /examples/let.golden: -------------------------------------------------------------------------------- 1 | #[let.kl:27.20-27.24] : Syntax 2 | #[let.kl:33.15-33.22]<(five two)> : Syntax 3 | -------------------------------------------------------------------------------- /examples/let.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "quasiquote.kl") 4 | (import (shift "prelude.kl" 1)) 5 | (import (shift "list-syntax.kl" 1)) 6 | (import (shift "quasiquote.kl" 1)) 7 | 8 | (define-macros 9 | -- (let ((x foo) 10 | -- (y bar)) 11 | -- body) 12 | -- => 13 | -- ((lambda (x y) body) 14 | -- foo 15 | -- bar) 16 | ((let (lambda (stx) 17 | (syntax-case stx 18 | ((list (_ args body)) 19 | (pure (cons-list-syntax 20 | `(lambda ,(map car args) ,body) 21 | (map cdr args) 22 | stx)))))))) 23 | 24 | -- examples from Racket's documentation of let 25 | 26 | -- 'five 27 | (example (let ([x 'five]) x)) 28 | 29 | -- ('five 'two) 30 | (example (let ([x 'five]) 31 | (let ([x 'two] 32 | [y x]) 33 | `(,y ,x)))) 34 | 35 | 36 | (export let) 37 | -------------------------------------------------------------------------------- /examples/let1.golden: -------------------------------------------------------------------------------- 1 | (false) : Bool 2 | -------------------------------------------------------------------------------- /examples/let1.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import [shift (only kernel lambda syntax-case cons-list-syntax list-syntax pure) 1]] 4 | [import [shift (only "quasiquote.kl" quasiquote unquote) 1]] 5 | 6 | -- Let for a single variable 7 | 8 | [define-macros 9 | ([let1 10 | [lambda 11 | [stx] 12 | (syntax-case stx 13 | [[list [_ pair body]] 14 | (syntax-case pair 15 | [[list [idt expr]] 16 | [pure `[[lambda [,idt] ,body] ,expr]]])])]])] 17 | 18 | [define id [lambda [x] x]] 19 | [example [let1 [my-id id] [my-id (false)]]] 20 | -------------------------------------------------------------------------------- /examples/lets.golden: -------------------------------------------------------------------------------- 1 | #[lets.kl:3.33-3.36] : Syntax 2 | #[lets.kl:5.40-5.41] : Syntax 3 | #[lets.kl:7.74-7.78]<(a a)> : Syntax 4 | #[lets.kl:9.82-9.86]<(a a)> : Syntax 5 | #[lets.kl:13.29-13.32] : Syntax 6 | 45 : Integer 7 | -------------------------------------------------------------------------------- /examples/lets.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (example (the (Syntax) (let (x 'foo) x))) 4 | 5 | (example (flet (f (x) (case x [(true) 'a] [(false) 'b])) (f (true)))) 6 | 7 | (example (the (Syntax) (flet (f (x) 'a) (list-syntax ((f (true)) (f 4)) 'here)))) 8 | 9 | (example (the (Syntax) (let (f (lambda (x) 'a)) (list-syntax ((f (true)) (f 4)) 'here)))) 10 | 11 | (define id (lambda (x) x)) 12 | 13 | (example (the (Syntax) (id 'foo))) 14 | (example (the (Integer) (id 45))) 15 | -------------------------------------------------------------------------------- /examples/lispy-do.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/lispy-do.golden -------------------------------------------------------------------------------- /examples/lispy-do.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import (shift "let.kl" 1)) 6 | 7 | (define-macros 8 | -- (do (<- x foo) 9 | -- (bar x) 10 | -- (<- y (baz x)) 11 | -- (quux x y)) 12 | -- => 13 | -- (>>= foo (lambda (x) 14 | -- (>>= (bar x) (lambda (_) 15 | -- (>>= (baz x) (lambda (y) 16 | -- (quux x y))))))) 17 | ((<- 18 | (lambda (stx) 19 | (syntax-error (quote "<- used out of context") stx))) 20 | (do (lambda (stx) 21 | (syntax-case stx 22 | ((cons _ all-actions) 23 | (syntax-case all-actions 24 | ((list (last-action)) 25 | (pure last-action)) 26 | ((cons first-action actions) 27 | (let ((otherwise (pure `(>>= ,first-action (lambda (_) 28 | ,(cons-list-syntax 'do actions stx)))))) 29 | (syntax-case first-action 30 | ((list (<-? var action)) 31 | (>>= (free-identifier=? '<- <-?) 32 | (lambda (isArrow) 33 | (if isArrow 34 | (pure `(>>= ,action (lambda (,var) 35 | ,(cons-list-syntax 'do actions stx)))) 36 | otherwise)))) 37 | (_ 38 | otherwise))))))))))) 39 | 40 | (export <- do) 41 | -------------------------------------------------------------------------------- /examples/list-syntax.golden: -------------------------------------------------------------------------------- 1 | #[list-syntax.kl:70.17-70.18]<1> : Syntax 2 | #[list-syntax.kl:71.16-71.23]<(2 3)> : Syntax 3 | #[list-syntax.kl:72.20-72.39]<(x y z)> : Syntax 4 | #[list-syntax.kl:77.18-78.17]<((f x) (f y) (f z))> : Syntax 5 | #[list-syntax.kl:81.18-82.17]<(z y x)> : Syntax 6 | -------------------------------------------------------------------------------- /examples/list-syntax.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "defun.kl") 4 | 5 | 6 | (define car 7 | (lambda (stx) 8 | (syntax-case stx 9 | ((cons a _) 10 | a)))) 11 | 12 | (define cdr 13 | (lambda (stx) 14 | (syntax-case stx 15 | ((cons _ d) 16 | d)))) 17 | 18 | (defun map (f stx) 19 | (syntax-case stx 20 | (() stx) 21 | ((cons a d) 22 | (cons-list-syntax (f a) (map f d) stx)))) 23 | 24 | -- (-> (-> a b b) 25 | -- b 26 | -- (List a) 27 | -- b) 28 | (defun foldr (f b0 as0) 29 | (syntax-case as0 30 | (() b0) 31 | ((cons a as) 32 | (f a (foldr f b0 as))))) 33 | 34 | -- (-> (-> b a b) 35 | -- b 36 | -- (List a) 37 | -- b) 38 | (defun foldl (f b0 as0) 39 | (syntax-case as0 40 | (() b0) 41 | ((cons a as) 42 | (foldl f (f b0 a) as)))) 43 | 44 | -- (-> (-> a b (Macro b)) 45 | -- b 46 | -- (List a) 47 | -- (Macro b)) 48 | (defun foldrM (f b0 as0) 49 | (syntax-case as0 50 | (() 51 | (pure b0)) 52 | ((cons a as1) 53 | (>>= (foldrM f b0 as1) 54 | (lambda (as2) 55 | (f a as2)))))) 56 | 57 | -- (-> (-> b a (Macro b)) 58 | -- b 59 | -- (List a) 60 | -- (Macro b)) 61 | (defun foldlM (f b0 as0) 62 | (syntax-case as0 63 | (() 64 | (pure b0)) 65 | ((cons a1 as) 66 | (>>= (f b0 a1) 67 | (lambda (a2) 68 | (foldlM f a2 as)))))) 69 | 70 | (example (car '(1 2 3))) 71 | (example (cdr '(1 2 3))) 72 | (example (map car '((x 1) (y 2) (z 3)))) 73 | (example (foldr (lambda (x xs) 74 | (cons-list-syntax (list-syntax ('f x) x) 75 | xs 76 | xs)) 77 | '() 78 | '(x y z))) 79 | (example (foldl (lambda (xs x) 80 | (cons-list-syntax x xs xs)) 81 | '() 82 | '(x y z))) 83 | 84 | -- foldrM and foldlM can't be tested here because we'd need to define a macro 85 | -- but foldrM and foldlM are only available at phase 0. 86 | 87 | (export car cdr map foldr foldl foldrM foldlM) 88 | -------------------------------------------------------------------------------- /examples/list-test.golden: -------------------------------------------------------------------------------- 1 | 10 : Integer 2 | (:: 3 (:: 3 (:: 3 (:: 4 (nil))))) : (List Integer) 3 | (:: 1 (:: 2 (:: 3 (nil)))) : (List Integer) 4 | (:: 1 (:: 2 (:: 3 (:: 4 (nil))))) : (List Integer) 5 | (:: 3 (:: 2 (:: 1 (nil)))) : (List Integer) 6 | (:: #[list-test.kl:26.19-26.20] 7 | (:: #[list-test.kl:26.21-26.22] 8 | (:: #[list-test.kl:26.23-26.24] (nil)))) : (List Syntax) 9 | #[list-test.kl:29.34-29.38]<(a b c)> : Syntax 10 | -------------------------------------------------------------------------------- /examples/list-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | -- These examples are here rather than in "list.kl" so that the resulting 4 | -- values are tracked by our test suite, which only covers the "examples" 5 | -- folder, not "stdlib". 6 | 7 | (import "list.kl") 8 | 9 | (example 10 | (foldr + 0 (list 1 2 3 4))) 11 | 12 | (example 13 | (map string-length (list "foo" "bar" "baz" "quux"))) 14 | 15 | (example 16 | (filter (lambda (x) (< x 10)) 17 | (list 1 11 111 2 22 222 3 33 333))) 18 | 19 | (example 20 | (snoc (list 1 2 3) 4)) 21 | 22 | (example 23 | (reverse (list 1 2 3))) 24 | 25 | (example 26 | (syntax->list '(a b c))) 27 | 28 | (example 29 | (list->syntax (list 'a 'b 'c) 'here)) 30 | -------------------------------------------------------------------------------- /examples/macro-body-shift.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/macro-body-shift.golden -------------------------------------------------------------------------------- /examples/macro-body-shift.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | [import [shift "prelude.kl" 1]] 4 | 5 | [define fun [lambda [x] [lambda [y] [lambda [z] y]]]] 6 | 7 | [define-macros ([m [lambda [stx] [pure [quote fun]]]])] 8 | -------------------------------------------------------------------------------- /examples/mcond-test.golden: -------------------------------------------------------------------------------- 1 | 1 : Integer 2 | 2 : Integer 3 | 3 : Integer 4 | 4 : Integer 5 | 4 : Integer 6 | -------------------------------------------------------------------------------- /examples/mcond-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "mcond.kl" 1)) 5 | 6 | (define-macros 7 | ([test 8 | (lambda (stx) 9 | (syntax-case stx 10 | [(list (_ id)) 11 | (mcond 12 | [(free-identifier=? id 'if) (pure '1)] 13 | [(free-identifier=? id 'else) (pure '2)] 14 | [(free-identifier=? id 'lambda) (pure '3)] 15 | [(pure (true)) (pure '4)])]))])) 16 | 17 | (example (test if)) 18 | (example (test else)) 19 | (example (test lambda)) 20 | (example (test define)) 21 | (example (test argh)) 22 | -------------------------------------------------------------------------------- /examples/mcond.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/mcond.golden -------------------------------------------------------------------------------- /examples/mcond.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | 6 | (define-macros 7 | ([mcond 8 | (lambda (stx) 9 | (syntax-case stx 10 | [(cons mc cases) 11 | (syntax-case cases 12 | [() 13 | (pure `(syntax-error ,(replace-loc mc ''"No more cases")))] 14 | [(cons c cs) 15 | (syntax-case c 16 | [(list (condition result)) 17 | (pure 18 | (quasiquote/loc c 19 | (>>= ,condition 20 | (lambda (x) 21 | (if x ,result ,(cons-list-syntax mc cs stx))))))])])]))])) 22 | 23 | (export mcond) 24 | -------------------------------------------------------------------------------- /examples/meta-macro.golden: -------------------------------------------------------------------------------- 1 | #[meta-macro.kl:7.12-7.15] : Syntax 2 | #[meta-macro.kl:31.15-31.18] : Syntax 3 | -------------------------------------------------------------------------------- /examples/meta-macro.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import (shift "let.kl" 1)) 6 | 7 | (define x 'foo) 8 | 9 | (define-macros 10 | ((meta-macro1 (lambda (stx) 11 | (syntax-case stx 12 | ((list (_ macro-name var-name value)) 13 | (let ((body `(define ,var-name ,value))) 14 | (pure `(define-macros 15 | ((,macro-name (lambda (stx) 16 | (pure ',body))))))))))) 17 | (meta-macro2 (lambda (stx) 18 | (syntax-case stx 19 | ((list (_ macro-name)) 20 | (pure `(define-macros 21 | ((,macro-name (lambda (stx) 22 | (syntax-case stx 23 | ((list (_ var-name value)) 24 | (pure (list-syntax ('define var-name value) stx))))))))))))))) 25 | 26 | (meta-macro1 my-macro1 x 'bar) 27 | (my-macro1) 28 | (example x) -- 'foo 29 | 30 | (meta-macro2 my-macro2) 31 | (my-macro2 x 'baz) 32 | (example x) -- 'baz 33 | -------------------------------------------------------------------------------- /examples/monad.golden: -------------------------------------------------------------------------------- 1 | # : ∀(α : *). (α → α) 2 | # : ∀(α : (* → *)) (β : *) (γ : *). ((Functor α β γ) → ((β → γ) → ((α β) → (α γ)))) 3 | (applicative (functor #) # #) : ∀(α : *) (β : *). (Applicative Macro α β) 4 | # : ∀(α : (* → *)) (β : *) (γ : *). ((Applicative α β γ) → (β → (α β))) 5 | # : ∀(α : (* → *)) (β : *) (γ : *). 6 | ((Applicative α β γ) → ((α (β → γ)) → ((α β) → (α γ)))) 7 | (just "applicative notation") : (Maybe String) 8 | (nothing) : (Maybe String) 9 | (just "applicative notation") : (Maybe String) 10 | (nothing) : (Maybe String) 11 | # : ∀(α : (* → *)) (β : *) (γ : *). 12 | ((Monad α β γ) → ((α β) → ((β → (α γ)) → (α γ)))) 13 | (just "hey") : (Maybe String) 14 | (just "hey") : (Maybe String) 15 | -------------------------------------------------------------------------------- /examples/non-examples/circular-1.golden: -------------------------------------------------------------------------------- 1 | Circular imports while importing "examples/non-examples/circular-1.kl" 2 | Context: 3 | "examples/non-examples/circular-2.kl" 4 | "examples/non-examples/circular-1.kl" 5 | -------------------------------------------------------------------------------- /examples/non-examples/circular-1.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | (import "circular-2.kl") 3 | -------------------------------------------------------------------------------- /examples/non-examples/circular-2.golden: -------------------------------------------------------------------------------- 1 | Circular imports while importing "examples/non-examples/circular-2.kl" 2 | Context: 3 | "examples/non-examples/circular-1.kl" 4 | "examples/non-examples/circular-2.kl" 5 | -------------------------------------------------------------------------------- /examples/non-examples/circular-2.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | (import "circular-1.kl") 3 | -------------------------------------------------------------------------------- /examples/non-examples/error.golden: -------------------------------------------------------------------------------- 1 | Error at phase p0: error.kl:3.18-3.34: "It went wrong." 2 | -------------------------------------------------------------------------------- /examples/non-examples/error.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (example (error '"It went wrong.")) 4 | 5 | -------------------------------------------------------------------------------- /examples/non-examples/import-phase.golden: -------------------------------------------------------------------------------- 1 | Unknown: #[import-phase.kl:6.4-6.10] 2 | -------------------------------------------------------------------------------- /examples/non-examples/import-phase.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -- This should fail because the only thing imported at phase 1 is "import". 4 | 5 | [meta 6 | [define m-impl 7 | [lambda [s] 8 | (syntax-case s 9 | [[vec [_ e]] [pure e]])]]] 10 | 11 | [define-macros ([m m-impl])] 12 | 13 | [example [m 1]] 14 | -------------------------------------------------------------------------------- /examples/non-examples/missing-import.golden: -------------------------------------------------------------------------------- 1 | missing-import.kl:3.22-3.27: Not available at phase p0: magic 2 | -------------------------------------------------------------------------------- /examples/non-examples/missing-import.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import (only kernel magic)] 4 | -------------------------------------------------------------------------------- /examples/non-examples/type-errors.golden: -------------------------------------------------------------------------------- 1 | Type mismatch at type-errors.kl:3.36-3.37. Expected Syntax but got Integer 2 | -------------------------------------------------------------------------------- /examples/non-examples/type-errors.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (example ((lambda (x) (syntax-case x [() 'a])) 34)) 4 | 5 | -------------------------------------------------------------------------------- /examples/non-examples/type-errors/not-a-function.golden: -------------------------------------------------------------------------------- 1 | Type mismatch at not-a-function.kl:3.11-3.13. 2 | Expected (Integer → (?1 → ?2)) but got Integer 3 | -------------------------------------------------------------------------------- /examples/non-examples/type-errors/not-a-function.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (example (42 4 2)) 4 | -------------------------------------------------------------------------------- /examples/one-def.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/one-def.golden -------------------------------------------------------------------------------- /examples/one-def.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [define id [lambda [x] x]] 4 | -------------------------------------------------------------------------------- /examples/pair-datatype.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/pair-datatype.golden -------------------------------------------------------------------------------- /examples/pair-datatype.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "lambda-case.kl") 4 | 5 | (datatype (Pair A B) 6 | (pair A B)) 7 | 8 | (define fst 9 | (lambda-case 10 | [(pair x _) x])) 11 | 12 | (define snd 13 | (lambda-case 14 | [(pair _ y) y])) 15 | 16 | (export Pair pair fst snd) 17 | -------------------------------------------------------------------------------- /examples/phase1.golden: -------------------------------------------------------------------------------- 1 | 1 : Integer 2 | -------------------------------------------------------------------------------- /examples/phase1.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import [shift kernel 1]] 4 | 5 | 6 | [meta 7 | [define return 8 | [lambda [e] 9 | [pure e]]] 10 | [define m-impl 11 | [lambda [s] 12 | (syntax-case s 13 | [[list [_ e]] [return e]])]]] 14 | 15 | [define-macros ([m m-impl])] 16 | 17 | [example [m 1]] 18 | -------------------------------------------------------------------------------- /examples/pmatch.golden: -------------------------------------------------------------------------------- 1 | #[pmatch.kl:91.32-91.33] : Syntax 2 | #[pmatch.kl:92.36-92.37] : Syntax 3 | #[pmatch.kl:93.29-93.30] : Syntax 4 | #[pmatch.kl:94.48-94.49] : Syntax 5 | (zero) : Nat 6 | (zero) : Nat 7 | (zero) : Nat 8 | (zero) : Nat 9 | (add1 (zero)) : Nat 10 | (:: (pair #[pmatch.kl:119.34-119.35]<1> 1) 11 | (:: (pair #[pmatch.kl:119.50-119.51]<2> 2) 12 | (:: (pair #[pmatch.kl:119.66-119.67]<3> 3) (nil)))) : (List (Pair Syntax Integer)) 13 | -------------------------------------------------------------------------------- /examples/pmatch.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | (import "defun.kl") 3 | (import "pair-datatype.kl") 4 | (import "list.kl") 5 | 6 | (import (shift "prelude.kl" 1)) 7 | 8 | (import (shift "quasiquote.kl" 1)) 9 | (import (shift "defun.kl" 1)) 10 | (import (shift "lispy-do.kl" 1)) 11 | (import (shift "free-identifier-case.kl" 1)) 12 | (import (shift "temporaries.kl" 1)) 13 | (import (shift "pair-datatype.kl" 1)) 14 | (import (shift "list.kl" 1)) 15 | 16 | (meta 17 | (define identifier? 18 | (lambda (stx) 19 | (syntax-case stx [(ident x) (true)] [_ (false)])))) 20 | 21 | (meta 22 | (datatype (Maybe A) 23 | (nothing) 24 | (just A))) 25 | 26 | (meta 27 | (define else-case 28 | (lambda (stx) 29 | (syntax-case stx 30 | [(list (e x)) 31 | (if (identifier? e) 32 | (free-identifier-case e 33 | [else (pure (just x))] 34 | [(else other) (pure (nothing))]) 35 | (pure (nothing)))] 36 | [(ident e) 37 | (free-identifier-case e 38 | [else (pure (just 'else-x))] 39 | [(else other) (pure (nothing))])] 40 | [_ (pure (nothing))])))) 41 | 42 | (define-macros 43 | ([pmatch 44 | (lambda (stx) 45 | (syntax-case stx 46 | [(cons _ more) 47 | (syntax-case more 48 | [(cons scrut pats) 49 | (pure `(let (x ,scrut) (pmatch-aux ,scrut x ,pats)))])]))] 50 | [pmatch-aux 51 | (lambda (stx) 52 | (syntax-case stx 53 | [(list (_ scrut tgt pats)) 54 | (syntax-case pats 55 | [() (pure `(error ',scrut))] 56 | [(cons c cs) 57 | (syntax-case c 58 | [(list (pat rhs)) 59 | (>>= (else-case pat) 60 | (lambda (e) 61 | (case e 62 | [(just x) (pure `(let (,x ,tgt) ,rhs))] 63 | [(nothing) 64 | (pure `(let (kf (lambda (_) (pmatch-aux ,scrut ,tgt ,cs))) 65 | (ppat ,tgt ,pat ,rhs (kf 'hi))))])))])])]))] 66 | [ppat 67 | (lambda (stx) 68 | (syntax-case stx 69 | [(list (_ tgt pat ks kf)) 70 | (syntax-case pat 71 | [(ident x) 72 | (pure `(let (,x ,tgt) ,ks))] 73 | [(cons what args) 74 | (>>= (make-temporaries (syntax->list args)) 75 | (lambda (temps) 76 | (let (temp-names (map fst temps)) 77 | (flet (combine (stxs) 78 | (case stxs 79 | [(nil) ks] 80 | [(:: id-and-stx rest) 81 | `(ppat ,(fst id-and-stx) ,(snd id-and-stx) ,(combine rest) ,kf)])) 82 | (pure `(case ,tgt 83 | [,(cons-list-syntax what (list->syntax temp-names pat) pat) 84 | ,(combine temps)] 85 | [(else other) ,kf]))))))])]))])) 86 | 87 | 88 | 89 | (datatype (Nat) (zero) (add1 (Nat))) 90 | 91 | (example (pmatch (zero) (else 't))) 92 | (example (pmatch (zero) ((else x) 't))) 93 | (example (pmatch (zero) (x 't))) 94 | (example (pmatch (add1 (zero)) [(add1 (zero)) 't])) 95 | (example (pmatch (add1 (add1 (zero))) 96 | [(add1 (add1 k)) k] 97 | [x x])) 98 | 99 | (define yep-its-often-zero 100 | (lambda (num) 101 | (pmatch num 102 | [(add1 (add1 k)) k] 103 | [(add1 k) k] 104 | [x x]))) 105 | 106 | (example (yep-its-often-zero (add1 (add1 (zero))))) 107 | (example (yep-its-often-zero (add1 (zero)))) 108 | (example (yep-its-often-zero (zero))) 109 | (example (yep-its-often-zero (add1 (add1 (add1 (zero)))))) 110 | 111 | 112 | (defun swap-list (xs) 113 | (pmatch xs 114 | [(:: (pair x y) more) 115 | (:: (pair y x) (swap-list more))] 116 | [(nil) 117 | (nil)])) 118 | 119 | (example (swap-list (:: (pair 1 '1) (:: (pair 2 '2) (:: (pair 3 '3) (nil)))))) 120 | 121 | (export pmatch) 122 | -------------------------------------------------------------------------------- /examples/prelude-test.golden: -------------------------------------------------------------------------------- 1 | #[prelude-test.kl:3.18-3.19] : Syntax 2 | # : ∀(α : *) (β : *). ((α → β) → (α → β)) 3 | # : ∀(α : *). (α → α) 4 | # : ∀(α : *). (α → α) 5 | -------------------------------------------------------------------------------- /examples/prelude-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | [example (const 'a 'b)] 4 | 5 | [example (compose id)] 6 | [example (compose id id)] 7 | [example (compose id id id)] 8 | -------------------------------------------------------------------------------- /examples/primitive-datatypes.golden: -------------------------------------------------------------------------------- 1 | (flip) : ScopeAction 2 | (add) : ScopeAction 3 | (remove) : ScopeAction 4 | (unit) : Unit 5 | (unit) : Unit 6 | (true) : Bool 7 | (false) : Bool 8 | (true) : Bool 9 | -------------------------------------------------------------------------------- /examples/primitive-datatypes.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (example (flip)) 4 | (example (add)) 5 | (example (remove)) 6 | 7 | (example (unit)) 8 | (example (the (Unit) (unit))) 9 | 10 | (example (true)) 11 | (example (false)) 12 | (example (the (Bool) (true))) 13 | 14 | -------------------------------------------------------------------------------- /examples/primitives-documentation.golden: -------------------------------------------------------------------------------- 1 | (pair "open-syntax" #) : (Pair String (Syntax → (Syntax-Contents Syntax))) 2 | (pair "close-syntax" #) : (Pair String (Syntax → (Syntax → ((Syntax-Contents Syntax) → Syntax)))) 3 | (pair "+" #) : (Pair String (Integer → (Integer → Integer))) 4 | (pair "-" #) : (Pair String (Integer → (Integer → Integer))) 5 | (pair "*" #) : (Pair String (Integer → (Integer → Integer))) 6 | (pair "/" #) : (Pair String (Integer → (Integer → Integer))) 7 | (pair "abs" #) : (Pair String (Integer → Integer)) 8 | (pair "negate" #) : (Pair String (Integer → Integer)) 9 | (pair ">" #) : (Pair String (Integer → (Integer → Bool))) 10 | (pair ">=" #) : (Pair String (Integer → (Integer → Bool))) 11 | (pair "<" #) : (Pair String (Integer → (Integer → Bool))) 12 | (pair "<=" #) : (Pair String (Integer → (Integer → Bool))) 13 | (pair "=" #) : (Pair String (Integer → (Integer → Bool))) 14 | (pair "/=" #) : (Pair String (Integer → (Integer → Bool))) 15 | (pair "integer->string" #) : (Pair String (Integer → String)) 16 | (pair "string-append" #) : (Pair String (String → (String → String))) 17 | (pair "substring" #) : (Pair String (Integer → (Integer → (String → (Maybe String))))) 18 | (pair "string-length" #) : (Pair String (String → Integer)) 19 | (pair "string=?" #) : (Pair String (String → (String → Bool))) 20 | (pair "string/=?" #) : (Pair String (String → (String → Bool))) 21 | (pair "string) : (Pair String (String → (String → Bool))) 22 | (pair "string<=?" #) : (Pair String (String → (String → Bool))) 23 | (pair "string>?" #) : (Pair String (String → (String → Bool))) 24 | (pair "string>=?" #) : (Pair String (String → (String → Bool))) 25 | (pair "string-upcase" #) : (Pair String (String → String)) 26 | (pair "string-downcase" #) : (Pair String (String → String)) 27 | (pair "string-titlecase" #) : (Pair String (String → String)) 28 | (pair "string-foldcase" #) : (Pair String (String → String)) 29 | (pair "pure-IO" #) : ∀(α : *). (Pair String (α → (IO α))) 30 | (pair "bind-IO" #) : ∀(α : *) (β : *). (Pair String ((IO α) → ((α → (IO β)) → (IO β)))) 31 | (flip) : ScopeAction 32 | (add) : ScopeAction 33 | (remove) : ScopeAction 34 | (unit) : Unit 35 | (true) : Bool 36 | (false) : Bool 37 | (module) : Problem 38 | (declaration) : Problem 39 | (type) : Problem 40 | (pattern) : Problem 41 | (type-pattern) : Problem 42 | (nothing) : ∀(α : *). (Maybe α) 43 | (nil) : ∀(α : *). (List α) 44 | make-introducer : (Macro (ScopeAction → (Syntax → Syntax))) 45 | which-problem : (Macro Problem) 46 | (pair "id" #) : ∀(α : *). (Pair String (α → α)) 47 | (pair "const" #) : ∀(α : *) (β : *). (Pair String (α → (β → α))) 48 | (pair "compose" #) : ∀(α : *) (β : *) (γ : *). (Pair String ((α → β) → ((γ → α) → (γ → β)))) 49 | (pair "stdout" #) : (Pair String Output-Port) 50 | (pair "write" #) : (Pair String (Output-Port → (String → (IO Unit)))) 51 | -------------------------------------------------------------------------------- /examples/product-type.golden: -------------------------------------------------------------------------------- 1 | #[product-type.kl:12.23-12.24] : Syntax 2 | # : ∀(α : *) (β : *). ((× α β) → α) 3 | -------------------------------------------------------------------------------- /examples/product-type.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (datatype (× A B) 4 | (times A B)) 5 | 6 | (define fst 7 | (lambda (x) 8 | (case x 9 | [(times a _) 10 | a]))) 11 | 12 | (example (fst (times 'a 'b))) 13 | 14 | (example fst) 15 | -------------------------------------------------------------------------------- /examples/quasiquote-syntax-test.golden: -------------------------------------------------------------------------------- 1 | #[quasiquote-syntax-test.kl:6.4-8.29] 2 | <((quasiquote (is quasiquote)) 3 | (unquote (is unquote)) 4 | (unquote-splicing (is unquote-splicing)))> : Syntax 5 | #[quasiquote-syntax-test.kl:11.16-11.23] : Syntax 6 | #[quasiquote-syntax-test.kl:14.11-14.16] : Syntax 7 | #[quasiquote-syntax-test.kl:11.16-11.23] : Syntax 8 | #[quasiquote-syntax-test.kl:17.11-17.18]<(thing)> : Syntax 9 | #[quasiquote-syntax-test.kl:18.11-18.19]<(nothing)> : Syntax 10 | #[quasiquote-syntax-test.kl:20.11-20.45]<(list-syntax (nothing thing) thing)> : Syntax 11 | #[quasiquote-syntax-test.kl:22.11-22.48]<(list-syntax (nothing thing ()) thing)> : Syntax 12 | #[quasiquote-syntax-test.kl:24.11-24.31]<(thing nothing thing)> : Syntax 13 | -------------------------------------------------------------------------------- /examples/quasiquote-syntax-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "quasiquote.kl") 4 | 5 | (define special-characters 6 | '(`(is quasiquote) 7 | ,(is unquote) 8 | ,@(is unquote-splicing))) 9 | (example special-characters) 10 | 11 | (define thing 'nothing) 12 | 13 | (example thing) 14 | (example `thing) 15 | (example `,thing) 16 | 17 | (example `(thing)) 18 | (example `(,thing)) 19 | 20 | (example `(list-syntax (,thing thing) thing)) 21 | 22 | (example `(list-syntax (,thing thing ()) thing)) 23 | 24 | (example `(thing ,thing thing)) 25 | -------------------------------------------------------------------------------- /examples/reader-test.golden: -------------------------------------------------------------------------------- 1 | (:: 10 (:: 20 (:: 30 (:: 40 (:: 50 (:: 60 (nil))))))) : (List Integer) 2 | (:: 70 (:: 80 (:: 90 (:: 100 (nil))))) : (List Integer) 3 | "the string \"foo\" has length 3" : String 4 | -------------------------------------------------------------------------------- /examples/reader-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "list.kl") 4 | (import "monad.kl") 5 | (import "reader.kl") 6 | 7 | 8 | (define once 9 | (reader (lambda (r) r))) 10 | 11 | (define twice 12 | (reader (lambda (r) (* 2 r)))) 13 | 14 | (define thrice 15 | (reader (lambda (r) (* 3 r)))) 16 | 17 | (define four-times 18 | (reader-idiom + twice twice)) 19 | 20 | (define five-times 21 | (reader-idiom + twice thrice)) 22 | 23 | (define six-times 24 | (reader-idiom + thrice thrice)) 25 | 26 | (example 27 | (map (lambda (n-times) 28 | (run-reader n-times 10)) 29 | (list once twice thrice four-times five-times six-times))) 30 | 31 | 32 | (defun n-times (n) 33 | (case (= 0 n) 34 | [(true) 35 | (reader-pure 0)] 36 | [(false) 37 | (reader-idiom + once (n-times (- n 1)))])) 38 | 39 | (define itself-times 40 | (reader-do 41 | (<- r ask) 42 | (n-times r))) 43 | 44 | (example 45 | (map (lambda (n-times) 46 | (run-reader n-times 10)) 47 | (list (n-times 7) (n-times 8) (n-times 9) itself-times))) 48 | 49 | 50 | (define describe 51 | (reader-do 52 | (<- s ask) 53 | (local string-length 54 | (reader-do 55 | (<- n ask) 56 | (return reader-applicative 57 | (string-append "the string \"" 58 | (string-append s 59 | (string-append "\" has length " 60 | (integer->string n))))))))) 61 | 62 | (example 63 | (run-reader describe "foo")) 64 | -------------------------------------------------------------------------------- /examples/reader.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/reader.golden -------------------------------------------------------------------------------- /examples/reader.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "monad.kl") 4 | 5 | 6 | (datatype (Reader R A) 7 | (reader (-> R A))) 8 | 9 | (defun run-reader (reader-a r) 10 | (case reader-a 11 | [(reader r2a) 12 | (r2a r)])) 13 | 14 | (define ask 15 | (reader (lambda (r) 16 | r))) 17 | 18 | (defun local (r2s reader-s-a) 19 | (reader (lambda (r) 20 | (let [s (r2s r)] 21 | (run-reader reader-s-a s))))) 22 | 23 | 24 | (defun reader-map (a2b reader-a) 25 | (reader (lambda (r) 26 | (a2b (run-reader reader-a r))))) 27 | 28 | (defun reader-pure (a) 29 | (reader (lambda (_) a))) 30 | 31 | (defun reader-ap (readerF readerA) 32 | (reader 33 | (lambda (r) 34 | ((run-reader readerF r) 35 | (run-reader readerA r))))) 36 | 37 | (defun reader-bind (reader-a a-to-reader-b) 38 | (reader (lambda (r) 39 | (let [a (run-reader reader-a r)] 40 | (let [reader-b (a-to-reader-b a)] 41 | (let [b (run-reader reader-b r)] 42 | b)))))) 43 | 44 | 45 | (define reader-functor 46 | (functor reader-map)) 47 | 48 | (define reader-applicative 49 | (applicative reader-functor reader-pure reader-ap)) 50 | 51 | (define-idiom reader-idiom reader-applicative) 52 | 53 | (define reader-monad 54 | (monad reader-applicative reader-bind)) 55 | 56 | (define-do reader-do reader-monad) 57 | 58 | 59 | (export 60 | Reader reader run-reader ask local 61 | reader-functor reader-map 62 | reader-applicative reader-idiom reader-pure reader-ap 63 | reader-monad reader-do reader-bind) 64 | -------------------------------------------------------------------------------- /examples/regenerate-golden-files.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | export KLISTERPATH=`pwd`/examples 3 | cabal run klister-tests -- --accept 4 | -------------------------------------------------------------------------------- /examples/rpn-test.golden: -------------------------------------------------------------------------------- 1 | 36 2 | -------------------------------------------------------------------------------- /examples/rpn-test.kl: -------------------------------------------------------------------------------- 1 | #lang "rpn.kl" 2 | 4 3 | 8 4 | + 5 | 3 6 | * 7 | -------------------------------------------------------------------------------- /examples/rpn.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/rpn.golden -------------------------------------------------------------------------------- /examples/rpn.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import "define-syntax-rule.kl") 5 | (import "list.kl") 6 | 7 | -- An example custom #lang, inspired from [1]. 8 | -- 9 | -- [1] https://beautifulracket.com/stacker/ 10 | -- 11 | -- Programs written in this #lang look like this: 12 | -- 13 | -- #lang "rpn.kl" 14 | -- 4 15 | -- 8 16 | -- + 17 | -- 3 18 | -- * 19 | -- 20 | -- This is a stack based language, so the above program pushes 4 and 8 onto the 21 | -- stack, then + pops them and pushes 12 in their place, then 3 is pushed on 22 | -- top, then * pops 12 and 3 and pushes 36. The overall program prints 36. If 23 | -- there was more than one number on the stack at the end of the program, they 24 | -- would all be printed on a separate line, from the bottom to the top of the 25 | -- stack. 26 | -- 27 | -- In order to do so, we take advantage of the fact that the above program gets 28 | -- desugared to the following macro call: 29 | -- 30 | -- (#%module 4 8 + 3 *) 31 | -- 32 | -- We define a custom macro named #%module (well, we define a custom macro 33 | -- named my-module, which we rename to #%module in the export declaration at 34 | -- the end of this file) which rewrites a module in the rpn #lang to a module 35 | -- in the prelude #lang: 36 | -- 37 | -- (prelude.#%module 38 | -- (prelude.run 39 | -- (print-stack 40 | -- (* (3 (+ (8 (4 empty-stack)))))))) 41 | 42 | (define empty-stack 43 | (nil)) 44 | 45 | (defun putStrLn (str) 46 | (write stdout (string-append str "\n"))) 47 | 48 | (defun putIntLn (int) 49 | (putStrLn (integer->string int))) 50 | 51 | (defun print-stack (stack) 52 | (case stack 53 | [(nil) 54 | (pure-IO (unit))] 55 | [(:: x xs) 56 | (bind-IO 57 | (print-stack xs) 58 | (lambda (_) 59 | (putIntLn x)))])) 60 | 61 | (define-macros 62 | ([my-module 63 | (lambda (stx) 64 | -- (go (list '3 '*) 65 | -- '(+ (8 (4 empty-stack)))) 66 | -- => 67 | -- (print-stack 68 | -- (* (3 (+ (8 (4 empty-stack)))))) 69 | (flet [go (inputs compute-stack) 70 | (case inputs 71 | [(nil) 72 | (pure `(#%module 73 | (run 74 | (print-stack ,compute-stack))))] 75 | [(:: x xs) 76 | (go xs `(,x ,compute-stack))])] 77 | (case (open-syntax stx) 78 | -- drop the first argument, which is always #%module 79 | [(list-contents (:: _ xs)) 80 | (go xs 'empty-stack)])))])) 81 | 82 | -- In the expression 83 | -- 84 | -- (print-stack 85 | -- (* (3 (+ (8 (4 empty-stack)))))) 86 | -- 87 | -- the idea is that *, +, and the numbers are intended to be functions which 88 | -- take the stack as input and return the modified stack. 89 | 90 | (defun add (stk) 91 | (case stk 92 | [(:: x1 (:: x2 xs)) 93 | (:: (+ x1 x2) xs)])) 94 | 95 | (defun mul (stk) 96 | (case stk 97 | [(:: x1 (:: x2 xs)) 98 | (:: (* x1 x2) xs)])) 99 | 100 | -- When a number is evaluated, either as a function or as an argument, the 101 | -- #%integer-literal macro is automatically called. Thus, 102 | -- 103 | -- (print-stack 104 | -- (* (3 (+ (8 (4 empty-stack)))))) 105 | -- 106 | -- is automatically expanded to 107 | -- 108 | -- (print-stack 109 | -- (* ((#%integer-literal 3) 110 | -- (+ ((#%integer-literal 8) 111 | -- ((#%integer-literal 4) 112 | -- empty-stack)))))) 113 | -- 114 | -- We can thus define a macro named #%integer-literal which pushes the number 115 | -- onto the stack. We need to delegate to the prelude's #%integer-literal, 116 | -- otherwise including an integer literal in the output will cause 117 | -- my-integer-literal to be called again. 118 | 119 | (define-macro (my-integer-literal n) 120 | (pure `(lambda (stk) 121 | (:: (#%integer-literal ,n) stk)))) 122 | 123 | -- Similarly, "foo" expands to (#%string-literal "foo"), and (f x y) expands to 124 | -- (#%app f x y) when f is _not_ a macro. Our language does not use either 125 | -- syntax, so we do not export macros with those names, and this has the effect 126 | -- of causing an error if a user attempts to use those syntactic forms. 127 | 128 | (export (rename ([my-module #%module] 129 | [add +] 130 | [mul *] 131 | [my-integer-literal #%integer-literal]) 132 | my-module 133 | add 134 | mul 135 | my-integer-literal)) 136 | -------------------------------------------------------------------------------- /examples/small.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/small.golden -------------------------------------------------------------------------------- /examples/small.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -------------------------------------------------------------------------------- /examples/string-syntax.golden: -------------------------------------------------------------------------------- 1 | "hihi" : String 2 | -------------------------------------------------------------------------------- /examples/string-syntax.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | (import (shift "prelude.kl" 1)) 3 | (import (shift "quasiquote.kl" 1)) 4 | 5 | (define-macros 6 | ([gotta-be-string 7 | (lambda (stx) 8 | (syntax-case stx 9 | [(list (_ s)) 10 | (syntax-case s 11 | [(string str) (pure (string-syntax (string-append str str) s))] 12 | [_ (syntax-error (quasiquote/loc s "bad syntax"))])] 13 | [_ (syntax-error (quasiquote/loc stx "bad syntax"))]))])) 14 | 15 | (example (gotta-be-string "hi")) 16 | 17 | -------------------------------------------------------------------------------- /examples/string.golden: -------------------------------------------------------------------------------- 1 | "hello world" : String 2 | "hello world" : String 3 | (true) : Bool 4 | (false) : Bool 5 | (just "cde") : (Maybe String) 6 | (nothing) : (Maybe String) 7 | (just "ab") : (Maybe String) 8 | (nothing) : (Maybe String) 9 | 3 : Integer 10 | 0 : Integer 11 | (false) : Bool 12 | (true) : Bool 13 | (false) : Bool 14 | (true) : Bool 15 | (false) : Bool 16 | (true) : Bool 17 | (true) : Bool 18 | (false) : Bool 19 | (false) : Bool 20 | (true) : Bool 21 | (true) : Bool 22 | (false) : Bool 23 | (false) : Bool 24 | (false) : Bool 25 | (true) : Bool 26 | (false) : Bool 27 | (true) : Bool 28 | (true) : Bool 29 | "ABC!" : String 30 | "STRASSE" : String 31 | "abc!" : String 32 | "stra\223e" : String 33 | "\954\945\959\963" : String 34 | "\963" : String 35 | "Abc Two" : String 36 | "Y2k" : String 37 | "Main Stra\223e" : String 38 | "Stra Sse" : String 39 | "abc!" : String 40 | "strasse" : String 41 | "\954\945\959\963" : String 42 | -------------------------------------------------------------------------------- /examples/string.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (example "hello world") 4 | 5 | (example ((string-append "hello ") "world")) 6 | 7 | (example ((string=? ((string-append "hello") " world")) "hello world")) 8 | 9 | (example ((string=? ((string-append "hello") "world")) "hello world")) 10 | 11 | (example (((substring 2) 3) "abcdefghijklmnop")) 12 | (example (((substring 2) 300) "abcdefghijklmnop")) 13 | (example (((substring 0) 2) "ab")) 14 | (example (((substring 0) 3) "ab")) 15 | 16 | (example (string-length "abc")) 17 | (example (string-length "")) 18 | 19 | 20 | (example ((string=? "a") "b")) 21 | (example ((string=? "a") "a")) 22 | (example ((string=? "b") "a")) 23 | (example ((string/=? "a") "b")) 24 | (example ((string/=? "a") "a")) 25 | (example ((string/=? "b") "a")) 26 | (example ((string? "a") "b")) 33 | (example ((string>? "a") "a")) 34 | (example ((string>? "b") "a")) 35 | (example ((string>=? "a") "b")) 36 | (example ((string>=? "a") "a")) 37 | (example ((string>=? "b") "a")) 38 | 39 | (example (string-upcase "aBC!")) 40 | (example (string-upcase "Straße")) 41 | 42 | (example (string-downcase "aBC!")) 43 | (example (string-downcase "Straße")) 44 | (example (string-downcase "ΚΑΟΣ")) 45 | (example (string-downcase "Σ")) 46 | 47 | (example (string-titlecase "aBC twO")) 48 | (example (string-titlecase "y2k")) 49 | (example (string-titlecase "main straße")) 50 | (example (string-titlecase "stra ße")) 51 | 52 | (example (string-foldcase "aBC!")) 53 | (example (string-foldcase "Straße")) 54 | (example (string-foldcase "ΚΑΟΣ")) 55 | 56 | -------------------------------------------------------------------------------- /examples/syntax-loc.golden: -------------------------------------------------------------------------------- 1 | #[syntax-loc.kl:3.15-3.19] : Syntax 2 | #[syntax-loc.kl:5.16-5.21] : Syntax 3 | -------------------------------------------------------------------------------- /examples/syntax-loc.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (define here 'here) 4 | 5 | (define there 'there) 6 | 7 | (example here) 8 | 9 | (example (replace-loc there here)) 10 | 11 | -------------------------------------------------------------------------------- /examples/syntax.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/syntax.golden -------------------------------------------------------------------------------- /examples/syntax.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "defun.kl") 4 | (import "do.kl") 5 | 6 | -- (replace-identifier 'y 'x '(x y z z y) 7 | -- => 8 | -- (pure '(x x z z x)) 9 | (defun replace-identifier (needle replacement haystack) 10 | (syntax-case haystack 11 | ((ident identifier) 12 | (do (identifier=needle <- (bound-identifier=? identifier needle)) 13 | (if identifier=needle 14 | (pure replacement) 15 | (pure identifier)))) 16 | ((cons a d) 17 | (do (a2 <- (replace-identifier needle replacement a)) 18 | (d2 <- (replace-identifier needle replacement d)) 19 | (pure (cons-list-syntax a2 d2 haystack)))) 20 | (_ 21 | (pure haystack)))) 22 | 23 | -- can't be tested here because we'd need to define a macro but 24 | -- replace-identifier is only available at phase 0. 25 | 26 | (export replace-identifier) 27 | -------------------------------------------------------------------------------- /examples/temporaries-test.golden: -------------------------------------------------------------------------------- 1 | #[temporaries-test.kl:22.24-22.25] : Syntax 2 | -------------------------------------------------------------------------------- /examples/temporaries-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "lispy-do.kl" 1)) 5 | (import (shift "list.kl" 1)) 6 | (import (shift "pair-datatype.kl" 1)) 7 | (import (shift "quasiquote.kl" 1)) 8 | (import (shift "temporaries.kl" 1)) 9 | 10 | (define-macros 11 | ([tester 12 | (lambda (stx) 13 | (do (<- tmps (make-temporaries (:: (unit) (:: (unit) (:: (unit) (nil)))))) 14 | (case tmps 15 | [(:: a as) 16 | (case as 17 | [(:: b bs) 18 | (case bs 19 | [(:: c cs) 20 | (pure (quasiquote/loc stx (lambda (,(fst a) ,(fst b) ,(fst c)) ,(fst b))))])])])))])) 21 | 22 | (example ((tester) 'a 'b 'c)) 23 | -------------------------------------------------------------------------------- /examples/temporaries.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/temporaries.golden -------------------------------------------------------------------------------- /examples/temporaries.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "lispy-do.kl") 4 | (import "list.kl") 5 | (import "pair-datatype.kl") 6 | (import "defun.kl") 7 | 8 | 9 | (define make-temporary 10 | (lambda (x) 11 | (syntax-case x 12 | [(ident id) 13 | (do (<- i (make-introducer)) 14 | (pure (i (add) id)))] 15 | [_ (syntax-error (replace-loc x '"Not an identifier"))]))) 16 | 17 | (defun make-temporaries (vals) 18 | (case vals 19 | [(nil) (pure (nil))] 20 | [(:: v vs) 21 | (do (<- tmp (make-temporary 'x)) 22 | (<- tmps (make-temporaries vs)) 23 | (pure (:: (pair tmp v) tmps)))])) 24 | 25 | (export make-temporary make-temporaries) 26 | 27 | -------------------------------------------------------------------------------- /examples/test-quasiquote.golden: -------------------------------------------------------------------------------- 1 | #[test-quasiquote.kl:6.22-6.29] : Syntax 2 | #[test-quasiquote.kl:9.22-9.27] : Syntax 3 | #[test-quasiquote.kl:6.22-6.29] : Syntax 4 | #[test-quasiquote.kl:12.22-12.29]<(thing)> : Syntax 5 | #[test-quasiquote.kl:13.22-13.39]<(nothing)> : Syntax 6 | #[test-quasiquote.kl:15.22-15.65]<(list-syntax (nothing thing) thing)> : Syntax 7 | #[test-quasiquote.kl:17.22-17.68]<(list-syntax (nothing thing ()) thing)> : Syntax 8 | #[test-quasiquote.kl:19.22-19.51]<(thing nothing thing)> : Syntax 9 | #[test-quasiquote.kl:6.22-6.29]<(thing nothing)> : Syntax 10 | -------------------------------------------------------------------------------- /examples/test-quasiquote.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | [import [shift "prelude.kl" 1]] 4 | [import [shift "defun.kl" 1]] 5 | 6 | [define thing [quote nothing]] 7 | 8 | [example thing] 9 | [example [quasiquote thing]] 10 | [example [quasiquote [unquote thing]]] 11 | 12 | [example [quasiquote [thing]]] 13 | [example [quasiquote [[unquote thing]]]] 14 | 15 | [example [quasiquote [list-syntax [[unquote thing] thing] thing]]] 16 | 17 | [example [quasiquote [list-syntax [[unquote thing] thing ()] thing]]] 18 | 19 | [example [quasiquote (thing [unquote thing] thing)]] 20 | 21 | (example (quasiquote/loc thing (thing ,thing))) 22 | -------------------------------------------------------------------------------- /examples/tiny-types.golden: -------------------------------------------------------------------------------- 1 | (true) : Bool 2 | (false) : Bool 3 | #[tiny-types.kl:5.25-5.28] : Syntax 4 | pure #[tiny-types.kl:6.39-6.42] : (Macro Syntax) 5 | # : (Bool → Bool) 6 | # : (Bool → Syntax) 7 | (free-identifier=? 8 | #[tiny-types.kl:10.40-10.41] 9 | #[tiny-types.kl:10.43-10.44]) 10 | >>= 11 | # : (Macro (Bool → Bool)) 12 | -------------------------------------------------------------------------------- /examples/tiny-types.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (example (the (Bool) (true))) 4 | (example (the (Bool) (false))) 5 | (example (the (Syntax) 'foo)) 6 | (example (the (Macro (Syntax)) (pure 'foo))) 7 | (example (the (-> (Bool) (Bool)) (lambda (x) x))) 8 | (example (the (-> (Bool) (Syntax)) (lambda (x) 'hello))) 9 | (example (the (Macro (-> (Bool) (Bool))) 10 | (>>= (free-identifier=? 'a 'b) 11 | (lambda (eq?) 12 | (case eq? 13 | [(true) (pure (lambda (x) x))] 14 | [(false) (pure (lambda (x) 15 | (case x 16 | [(true) (false)] 17 | [(false) (true)])))]))))) 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /examples/two-defs.golden: -------------------------------------------------------------------------------- 1 | #[two-defs.kl:5.21-5.23] : Syntax 2 | -------------------------------------------------------------------------------- /examples/two-defs.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [define id [lambda [x] x]] 4 | 5 | [define five [quote id]] 6 | 7 | [example [id five]] 8 | -------------------------------------------------------------------------------- /examples/type-eq-test.golden: -------------------------------------------------------------------------------- 1 | (true) : Bool 2 | (false) : Bool 3 | -------------------------------------------------------------------------------- /examples/type-eq-test.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "define-syntax-rule.kl") 4 | (import (shift "prelude.kl" 1)) 5 | (import (shift "lambda-case.kl" 1)) 6 | (import (shift "type-eq.kl" 1)) 7 | 8 | 9 | -- We can't simply write 10 | -- 11 | -- (example (type=? (-> String Integer) 12 | -- (-> Integer String))) 13 | -- 14 | -- because the result is a (Macro Bool), not a Bool. So instead we have to 15 | -- write a macro which observes the inferred type of its arguments and compares 16 | -- those. 17 | (define-macro (type-of=?-helper) 18 | (>>= (which-problem) 19 | (lambda-case 20 | [(expression t1-to-t2-to-Bool) 21 | (type-case t1-to-t2-to-Bool 22 | [(-> t1 t2-to-Bool) 23 | (type-case t2-to-Bool 24 | [(-> t2 Bool) 25 | (>>= (type=? t1 t2) 26 | (lambda-case 27 | [(true) 28 | (pure '(lambda (_ _) true))] 29 | [(false) 30 | (pure '(lambda (_ _) false))]))])])]))) 31 | 32 | (define-syntax-rule (type-of=? e1 e2) 33 | ((type-of=?-helper) e1 e2)) 34 | 35 | -- We can't simply generate 36 | -- 37 | -- (example 38 | -- (type-of=? (the t1 (error 'undefined)) 39 | -- (the t2 (error 'undefined)))) 40 | -- 41 | -- because Klister is a strict language, so those errors would be thrown before 42 | -- (type-of=?-helper) is called. 43 | (define-syntax-rule (type=?-example t1 t2) 44 | (example 45 | (type-of=? (the (-> t1 Unit) (lambda (_) unit)) 46 | (the (-> t2 Unit) (lambda (_) unit))))) 47 | 48 | (type=?-example (-> String Integer) (-> String Integer)) 49 | (type=?-example (-> String Integer) (-> Integer String)) 50 | -------------------------------------------------------------------------------- /examples/type-eq.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/klister/e1368e7d57dfba02ec49f71de4745cc1ecad1c44/examples/type-eq.golden -------------------------------------------------------------------------------- /examples/type-eq.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import "bool.kl") 4 | 5 | -- TODO: support more types. 6 | -- For now, only combinations of String, Integer, Bool, Unit, and functions are 7 | -- supported. 8 | (defun type=? (t1 t2) 9 | (type-case t1 10 | [String 11 | (type-case t2 12 | [String (pure true)] 13 | [(else _) (pure false)])] 14 | [Integer 15 | (type-case t2 16 | [Integer (pure true)] 17 | [(else _) (pure false)])] 18 | [(Bool) 19 | (type-case t2 20 | [(Bool) (pure true)] 21 | [(else _) (pure false)])] 22 | [(Unit) 23 | (type-case t2 24 | [(Unit) (pure true)] 25 | [(else _) (pure false)])] 26 | [(-> t1a t1b) 27 | (type-case t2 28 | [(-> t2a t2b) 29 | (>>= (type=? t1a t2a) 30 | (lambda (eq?a) 31 | (>>= (type=? t1b t2b) 32 | (lambda (eq?b) 33 | (pure (and eq?a eq?b))))))])])) 34 | 35 | (export type=?) -------------------------------------------------------------------------------- /examples/unknown-type.golden: -------------------------------------------------------------------------------- 1 | (nothing) : ∀(α : *). (Maybe α) 2 | (just #[unknown-type.kl:24.33-24.37]) : (Maybe Syntax) 3 | (just #) : ∀(α : *). (Maybe (α → α)) 4 | (pair (just #) (nothing)) : ∀(α : *). (Pair (Maybe (α → α)) (Maybe (α → α))) 5 | -------------------------------------------------------------------------------- /examples/unknown-type.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import "pair-datatype.kl") 6 | 7 | (define-macros 8 | ([gotta-be-maybe 9 | (lambda (stx) 10 | (syntax-case stx 11 | [(list (_ e)) 12 | (pure (quasiquote/loc stx (with-unknown-type (A) (the (Maybe A) ,e))))]))] 13 | [gotta-be-maybes 14 | (lambda (stx) 15 | (syntax-case stx 16 | [(list (_ e1 e2)) 17 | (pure 18 | (quasiquote/loc stx 19 | (with-unknown-type (A) 20 | (pair (the (Maybe A) ,e1) 21 | (the (Maybe A) ,e2)))))]))])) 22 | 23 | (example (gotta-be-maybe (nothing))) 24 | (example (gotta-be-maybe (just 'here))) 25 | (example (gotta-be-maybe (just (lambda (x) x)))) 26 | 27 | 28 | (example (gotta-be-maybes (just (lambda (x) x)) (nothing))) 29 | -------------------------------------------------------------------------------- /examples/which-problem.golden: -------------------------------------------------------------------------------- 1 | (true) : Bool 2 | (true) : Bool 3 | # : (Bool → (Bool → (Bool → (Bool → Unit)))) 4 | # : (Bool → (Bool → (Bool → (Bool → Unit)))) 5 | (both # #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) 6 | (both # #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) 7 | "String" : String 8 | "String -> String" : String 9 | "String -> String -> String" : String 10 | "(String -> String) -> String" : String 11 | -------------------------------------------------------------------------------- /examples/which-problem.kl: -------------------------------------------------------------------------------- 1 | #lang "prelude.kl" 2 | 3 | (import (shift "prelude.kl" 1)) 4 | (import (shift "quasiquote.kl" 1)) 5 | (import "quasiquote.kl") 6 | (import "define-syntax-rule.kl") 7 | 8 | 9 | (define-macros 10 | ([m (lambda (stx) 11 | (>>= (which-problem) 12 | (lambda (prob) 13 | (case prob 14 | [(declaration) (pure '(example (the (m) (m))))] 15 | [(type) (pure 'Bool)] 16 | [(expression t) (pure 'true)] 17 | [(pattern) (pure 'unit)]))))])) 18 | 19 | (m) 20 | 21 | (example (case unit 22 | ((m) true))) 23 | 24 | 25 | -- (the (-> Bool Bool Bool Bool Unit) (mega-const unit)) 26 | -- => 27 | -- (the (-> Bool Bool Bool Bool Unit) (lambda (_ _ _ _) unit)) 28 | (define-macro (mega-const e) 29 | (>>= (which-problem) 30 | (lambda (prob) 31 | (case prob 32 | [(expression t) 33 | (type-case t 34 | [(-> a b) 35 | (pure `(lambda (_) 36 | (mega-const ,e)))] 37 | [(else x) (pure e)])])))) 38 | 39 | (example (the (-> Bool Bool Bool Bool Unit) (mega-const unit))) 40 | 41 | (define-macros 42 | ([llet (lambda (stx) 43 | (syntax-case stx 44 | [(list (_ binding body)) 45 | (syntax-case binding 46 | [(list (name def)) 47 | (pure (quasiquote/loc stx 48 | ((lambda (,name) ,body) ,def)))])]))])) 49 | 50 | (example (llet (x (mega-const unit)) (the (-> Bool Bool Bool Bool Unit) x))) 51 | 52 | 53 | (datatype (Both A) (both A A)) 54 | 55 | (example (both (lambda (x) (lambda (y) (lambda (z) 'hello))) (mega-const 'world))) 56 | (example (both (mega-const 'hello) (lambda (x) (lambda (y) (lambda (z) 'world))))) 57 | 58 | -- Regression test for a bug where matching on String didn't work. 59 | -- 60 | -- Also acts as a regression test for a bug where the pattern (-> a b) 61 | -- was binding the same type to both a and b. 62 | (define-macro (type-name) 63 | (flet (render-type (in-lhs type) 64 | (type-case type 65 | [(-> type1 type2) 66 | (>>= (render-type true type1) 67 | (lambda (string1) 68 | (>>= (render-type false type2) 69 | (lambda (string2) 70 | (let (r (string-append string1 71 | (string-append " -> " string2))) 72 | (case in-lhs 73 | [(true) 74 | (pure (string-append "(" 75 | (string-append r ")")))] 76 | [(false) 77 | (pure r)]))))))] 78 | [String 79 | (pure "String")])) 80 | (>>= (which-problem) 81 | (lambda (prob) 82 | (case prob 83 | [(expression t) 84 | (>>= (render-type false t) 85 | (lambda (string) 86 | (let (syntax (close-syntax '() '() (string-contents string))) 87 | (pure `(mega-const ,syntax)))))]))))) 88 | 89 | (example (the String (type-name))) 90 | (example (the String ((type-name) "foo"))) 91 | (example (the String ((type-name) "foo" "bar"))) 92 | (example (the String ((type-name) (lambda (x) (the String x))))) 93 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1726560853, 9 | "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1729880355, 24 | "narHash": "sha256-RP+OQ6koQQLX5nw0NmcDrzvGL8HDLnyXt/jHhL1jwjM=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "18536bf04cd71abd345f9579158841376fdd0c5a", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "ref": "nixos-unstable", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "A klister flake"; 3 | inputs.nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; 4 | inputs.flake-utils.url = "github:numtide/flake-utils"; 5 | 6 | outputs = { self, nixpkgs, flake-utils }: 7 | flake-utils.lib.eachDefaultSystem (system: 8 | let 9 | pkgs = nixpkgs.legacyPackages.${system}; 10 | 11 | hPkgs = 12 | pkgs.haskell.packages."ghc966"; # need to match Stackage LTS version 13 | # from stack.yaml snapshot 14 | 15 | myDevTools = [ 16 | hPkgs.ghc # GHC compiler in the desired version (will be available on PATH) 17 | hPkgs.ghcid # Continuous terminal Haskell compile checker 18 | hPkgs.ormolu # Haskell formatter 19 | hPkgs.hlint # Haskell codestyle checker 20 | hPkgs.hoogle # Lookup Haskell documentation 21 | hPkgs.haskell-language-server # LSP server for editor 22 | hPkgs.implicit-hie # auto generate LSP hie.yaml file from cabal 23 | hPkgs.retrie # Haskell refactoring tool 24 | # hPkgs.cabal-install 25 | stack-wrapped 26 | pkgs.zlib # External C library needed by some Haskell packages 27 | ]; 28 | 29 | # Wrap Stack to work with our Nix integration. We don't want to modify 30 | # stack.yaml so non-Nix users don't notice anything. 31 | # - no-nix: We don't want Stack's way of integrating Nix. 32 | # --system-ghc # Use the existing GHC on PATH (will come from this Nix file) 33 | # --no-install-ghc # Don't try to install GHC if no matching GHC found on PATH 34 | stack-wrapped = pkgs.symlinkJoin { 35 | name = "stack"; # will be available as the usual `stack` in terminal 36 | paths = [ pkgs.stack ]; 37 | buildInputs = [ pkgs.makeWrapper ]; 38 | postBuild = '' 39 | wrapProgram $out/bin/stack \ 40 | --add-flags "\ 41 | --no-nix \ 42 | --system-ghc \ 43 | --no-install-ghc \ 44 | " 45 | ''; 46 | }; 47 | in { 48 | devShells.default = pkgs.mkShell { 49 | buildInputs = myDevTools; 50 | 51 | # Make external Nix c libraries like zlib known to GHC, like 52 | # pkgs.haskell.lib.buildStackProject does 53 | # https://github.com/NixOS/nixpkgs/blob/d64780ea0e22b5f61cd6012a456869c702a72f20/pkgs/development/haskell-modules/generic-stack-builder.nix#L38 54 | LD_LIBRARY_PATH = pkgs.lib.makeLibraryPath myDevTools; 55 | }; 56 | }); 57 | } 58 | -------------------------------------------------------------------------------- /klister.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: klister 4 | version: 0.1 5 | homepage: https://github.com/gelisam/klister#readme 6 | bug-reports: https://github.com/gelisam/klister/issues 7 | author: David Christiansen , Samuel Gélineau 8 | maintainer: David Christiansen , Samuel Gélineau 9 | license: BSD-3-Clause 10 | license-file: LICENSE 11 | tested-with: GHC==9.2.5, GHC==9.4, GHC==9.6 12 | build-type: Simple 13 | data-files: 14 | stdlib/defun.kl 15 | stdlib/list.kl 16 | stdlib/n-ary-app.kl 17 | stdlib/optional-parens.kl 18 | stdlib/prelude.kl 19 | stdlib/quasiquote.kl 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/gelisam/klister 24 | 25 | Flag KDebug 26 | Description: Enable debug support for klister interpreter 27 | Manual: True 28 | Default: False 29 | 30 | common deps 31 | build-depends: 32 | base >= 4.14.0 && < 5, 33 | bifunctors >= 5.5.5 && < 5.7, 34 | containers >= 0.6 && < 0.7, 35 | unordered-containers >= 0.2.15 && < 3, 36 | hashable, 37 | directory >= 1.3.3 && < 1.4, 38 | exceptions, 39 | extra >= 1.6.18 && < 1.8, 40 | filepath >= 1.4.2 && < 1.5, 41 | lens >= 4.17.1 && < 5.3, 42 | megaparsec >= 7.0.5 && < 9.7, 43 | mtl >= 2.2.2 && < 2.4, 44 | prettyprinter >= 1.2 && < 1.8, 45 | text >= 1.2, 46 | transformers ^>= 0.6 47 | 48 | common flags 49 | if flag(KDebug) 50 | CPP-Options: -DKDEBUG 51 | 52 | library 53 | import: deps 54 | , flags 55 | exposed-modules: 56 | Alpha 57 | Binding 58 | Binding.Info 59 | Control.Lens.IORef 60 | Core 61 | Core.Builder 62 | Datatype 63 | Env 64 | Evaluator 65 | Expander 66 | Expander.DeclScope 67 | Expander.Error 68 | Expander.Monad 69 | Expander.Primitives 70 | Expander.Syntax 71 | Expander.Task 72 | Expander.TC 73 | Kind 74 | KlisterPath 75 | Module 76 | ModuleName 77 | Parser 78 | Parser.Command 79 | Parser.Common 80 | PartialCore 81 | PartialType 82 | Phase 83 | Pretty 84 | Scope 85 | ScopeSet 86 | ShortShow 87 | SplitCore 88 | SplitType 89 | Syntax 90 | Syntax.Syntax 91 | Syntax.Lexical 92 | Syntax.SrcLoc 93 | Type 94 | Type.Context 95 | Unique 96 | Util.Key 97 | Util.Store 98 | Util.Set 99 | Value 100 | World 101 | other-modules: 102 | Paths_klister 103 | hs-source-dirs: 104 | src 105 | ghc-options: -Wall 106 | default-language: Haskell2010 107 | 108 | executable klister 109 | import: deps 110 | main-is: Main.hs 111 | other-modules: 112 | Paths_klister 113 | hs-source-dirs: 114 | repl 115 | ghc-options: -Wall 116 | build-depends: 117 | optparse-applicative >= 0.14 && < 0.19, 118 | klister 119 | default-language: Haskell2010 120 | 121 | test-suite klister-tests 122 | import: deps 123 | , flags 124 | type: exitcode-stdio-1.0 125 | main-is: Test.hs 126 | other-modules: 127 | Golden 128 | MiniTests 129 | Paths_klister 130 | hs-source-dirs: 131 | tests 132 | ghc-options: -Wall 133 | build-depends: 134 | call-stack ^>= 0.4.0, 135 | hedgehog >= 1.2 && < 1.5, 136 | klister, 137 | silently ^>= 1.2, 138 | tasty ^>= 1.4, 139 | tasty-golden ^>= 2.3, 140 | tasty-hedgehog >= 1.4 && < 1.5, 141 | tasty-hunit ^>= 0.10 142 | default-language: Haskell2010 143 | -------------------------------------------------------------------------------- /src/Alpha.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Alpha where 4 | 5 | import Control.Applicative 6 | import Control.Lens 7 | import Control.Monad 8 | import Control.Monad.State 9 | import Data.IntMap.Strict (IntMap) 10 | import Data.Maybe 11 | import Data.Text 12 | 13 | import Unique 14 | 15 | import Util.Key 16 | 17 | 18 | data AlphaState = AlphaState 19 | { _alphaStateEnv1 :: IntMap Int 20 | , _alphaStateEnv2 :: IntMap Int 21 | , _alphaStateNext :: Int 22 | } 23 | makeLenses ''AlphaState 24 | 25 | initialAlphaState :: AlphaState 26 | initialAlphaState = AlphaState 27 | { _alphaStateEnv1 = mempty 28 | , _alphaStateEnv2 = mempty 29 | , _alphaStateNext = 0 30 | } 31 | 32 | 33 | newtype Alpha a = Alpha 34 | { unAlpha :: StateT AlphaState Maybe a } 35 | deriving (Functor, Applicative, Alternative, Monad, MonadFail) 36 | 37 | runAlpha :: Alpha a -> Maybe a 38 | runAlpha = flip evalStateT initialAlphaState 39 | . unAlpha 40 | 41 | nextInt :: Alpha Int 42 | nextInt = Alpha $ do 43 | n <- use alphaStateNext 44 | modifying alphaStateNext (+1) 45 | pure n 46 | 47 | notAlphaEquivalent :: Alpha a 48 | notAlphaEquivalent = Alpha $ lift Nothing 49 | 50 | 51 | class AlphaEq a where 52 | alphaCheck :: a -> a -> Alpha () 53 | 54 | alphaEq :: AlphaEq a 55 | => a -> a -> Bool 56 | alphaEq x y = isJust $ runAlpha $ alphaCheck x y 57 | 58 | instance AlphaEq Unique where 59 | alphaCheck x y = Alpha $ do 60 | maybeM <- use (alphaStateEnv1 . at (getKey x)) 61 | maybeN <- use (alphaStateEnv2 . at (getKey y)) 62 | guard (maybeM == maybeN) 63 | when (isNothing maybeM) $ do 64 | n <- unAlpha nextInt 65 | assign (alphaStateEnv1 . at (getKey x)) (Just n) 66 | assign (alphaStateEnv2 . at (getKey y)) (Just n) 67 | 68 | instance (AlphaEq a, AlphaEq b) => AlphaEq (a, b) where 69 | alphaCheck (x1, y1) 70 | (x2, y2) = do 71 | alphaCheck x1 x2 72 | alphaCheck y1 y2 73 | 74 | instance AlphaEq a => AlphaEq [a] where 75 | alphaCheck [] 76 | [] = do 77 | pure () 78 | alphaCheck (x1:xs1) 79 | (x2:xs2) = do 80 | alphaCheck x1 x2 81 | alphaCheck xs1 xs2 82 | alphaCheck _ _ = notAlphaEquivalent 83 | 84 | instance AlphaEq Text where 85 | alphaCheck x y = guard (x == y) 86 | -------------------------------------------------------------------------------- /src/Binding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | module Binding where 7 | 8 | import Control.Lens 9 | import Data.Data (Data) 10 | import Data.Hashable 11 | import Data.HashMap.Strict (HashMap) 12 | import qualified Data.HashMap.Strict as HM 13 | import ScopeSet 14 | import Data.Text (Text) 15 | import Data.Sequence (Seq) 16 | 17 | import Binding.Info 18 | import Phase 19 | import ShortShow 20 | import Syntax.SrcLoc 21 | import Unique 22 | 23 | import Util.Key 24 | 25 | newtype Binding = Binding Unique 26 | deriving newtype (Eq, Ord, Hashable) 27 | deriving stock Data 28 | 29 | instance HasKey Binding where 30 | getKey (Binding u) = getKey u 31 | fromKey i = Binding $! fromKey i 32 | {-# INLINE getKey #-} 33 | {-# INLINE fromKey #-} 34 | 35 | instance Show Binding where 36 | show (Binding b) = "(Binding " ++ show (hashUnique b) ++ ")" 37 | 38 | instance ShortShow Binding where 39 | shortShow (Binding b) = "b" ++ show (hashUnique b) 40 | 41 | newtype BindingTable = BindingTable { _bindings :: HashMap Text (Seq (ScopeSet, Binding, BindingInfo SrcLoc)) } 42 | deriving (Data, Show) 43 | makeLenses ''BindingTable 44 | 45 | instance Semigroup BindingTable where 46 | b1 <> b2 = BindingTable $ HM.unionWith (<>) (view bindings b1) (view bindings b2) 47 | 48 | instance Monoid BindingTable where 49 | mempty = BindingTable HM.empty 50 | 51 | instance Phased BindingTable where 52 | shift i = over bindings (HM.map (fmap (over _1 (shift i)))) 53 | 54 | type instance Index BindingTable = Text 55 | type instance IxValue BindingTable = Seq (ScopeSet, Binding, BindingInfo SrcLoc) 56 | 57 | instance Ixed BindingTable where 58 | ix x f (BindingTable bs) = BindingTable <$> ix x f bs 59 | 60 | instance At BindingTable where 61 | at x f (BindingTable bs) = BindingTable <$> at x f bs 62 | -------------------------------------------------------------------------------- /src/Binding/Info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | module Binding.Info where 4 | 5 | import Data.Data (Data) 6 | 7 | import ShortShow 8 | 9 | data BindingInfo loc 10 | = BoundLocally loc 11 | | Defined loc 12 | -- TODO add the binding info of the exported name to Imported, to 13 | -- enable go to definition 14 | | Imported loc 15 | deriving (Data, Eq, Functor, Show) 16 | 17 | instance ShortShow loc => ShortShow (BindingInfo loc) where 18 | shortShow (BoundLocally l) = "BoundLocally " ++ shortShow l 19 | shortShow (Defined l) = "Defined " ++ shortShow l 20 | shortShow (Imported l) = "Imported " ++ shortShow l 21 | -------------------------------------------------------------------------------- /src/Control/Lens/IORef.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | 3 | -- Variants of 'view', 'over', and 'set' for pieces of state which are 4 | -- represented using a Reader over an IORef instead of a State. 5 | module Control.Lens.IORef where 6 | 7 | import Control.Lens 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Reader 10 | import Data.IORef 11 | 12 | 13 | viewIORef :: (MonadIO m, MonadReader r m) 14 | => Getting (IORef s) r (IORef s) -- ^ Getter r (IORef s) 15 | -> Getting a s a -- ^ Getter s a 16 | -> m a 17 | viewIORef refGetter leafGetter = do 18 | ref <- view refGetter 19 | s <- liftIO $ readIORef ref 20 | pure (view leafGetter s) 21 | 22 | overIORef :: (MonadIO m, MonadReader r m) 23 | => Getting (IORef s) r (IORef s) -- ^ Getter r (IORef s) 24 | -> ASetter' s a -- ^ Setter s a 25 | -> (a -> a) 26 | -> m () 27 | overIORef refGetter leafSetter f = do 28 | ref <- view refGetter 29 | liftIO $ modifyIORef' ref (over leafSetter f) 30 | 31 | setIORef :: (MonadIO m, MonadReader r m) 32 | => Getting (IORef s) r (IORef s) -- ^ Getter r (IORef s) 33 | -> ASetter' s a -- ^ Setter s a 34 | -> a 35 | -> m () 36 | setIORef refGetter leafSetter a = do 37 | ref <- view refGetter 38 | liftIO $ modifyIORef' ref (set leafSetter a) 39 | -------------------------------------------------------------------------------- /src/Core/Builder.hs: -------------------------------------------------------------------------------- 1 | module Core.Builder where 2 | 3 | import qualified Data.Text as T 4 | 5 | 6 | import Core 7 | import ScopeSet () 8 | import Syntax 9 | import Syntax.SrcLoc 10 | import Unique 11 | 12 | fakeLoc :: SrcLoc 13 | fakeLoc = SrcLoc "" (SrcPos 0 0) (SrcPos 0 0) 14 | 15 | fakeIdent :: Ident 16 | fakeIdent = Stx mempty fakeLoc (T.pack "fake") 17 | 18 | lam :: (IO Core -> IO Core) -> IO Core 19 | lam f = do 20 | v <- Var <$> newUnique 21 | body <- f (pure (Core (CoreVar v))) 22 | return (Core (CoreLam fakeIdent v body)) 23 | 24 | app :: IO Core -> IO Core -> IO Core 25 | app fun arg = Core 26 | <$> (CoreApp <$> fun <*> arg) 27 | 28 | int :: Integer -> IO Core 29 | int i = return $ Core $ CoreInteger $ i 30 | -------------------------------------------------------------------------------- /src/Datatype.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | module Datatype where 7 | 8 | import Control.Lens 9 | import Data.Data (Data) 10 | import Data.String 11 | import Data.Text (Text) 12 | import Data.Hashable 13 | 14 | import Alpha 15 | import Kind 16 | import ModuleName 17 | import ShortShow 18 | import GHC.Generics (Generic) 19 | 20 | newtype DatatypeName = DatatypeName { _datatypeNameText :: Text } 21 | deriving newtype (Eq, IsString, Ord, Show, Hashable) 22 | deriving stock Data 23 | makeLenses ''DatatypeName 24 | 25 | data Datatype 26 | = Datatype 27 | { _datatypeModule :: !ModuleName -- ^ The module that defines the datatype 28 | , _datatypeName :: !DatatypeName -- ^ The unique name for the datatype at this module and phase 29 | } 30 | deriving stock (Data, Eq, Ord, Show, Generic) 31 | makeLenses ''Datatype 32 | 33 | instance Hashable Datatype 34 | 35 | newtype ConstructorName = ConstructorName { _constructorNameText :: Text } 36 | deriving newtype (Eq, IsString, Ord, Show, Hashable) 37 | deriving stock Data 38 | makeLenses ''ConstructorName 39 | 40 | data Constructor 41 | = Constructor 42 | { _constructorModule :: !ModuleName -- ^ The module that defines the constructor 43 | , _constructorName :: !ConstructorName -- ^ The unique name for the constructor at this module and phase 44 | } 45 | deriving (Data, Eq, Ord, Show, Generic) 46 | makeLenses ''Constructor 47 | 48 | instance Hashable Constructor 49 | instance ShortShow Constructor where 50 | shortShow = show 51 | 52 | instance AlphaEq Constructor where 53 | alphaCheck c1 c2 54 | | c1 == c2 = pure () 55 | | otherwise = notAlphaEquivalent 56 | 57 | data DatatypeInfo 58 | = DatatypeInfo 59 | { _datatypeArgKinds :: [Kind] 60 | , _datatypeConstructors :: ![Constructor] 61 | } 62 | deriving Eq 63 | makeLenses ''DatatypeInfo 64 | 65 | data ConstructorInfo t 66 | = ConstructorInfo 67 | { _ctorArguments :: ![t] -- ^ Either a type parameter or a concrete type 68 | , _ctorDatatype :: !Datatype 69 | } 70 | deriving Eq 71 | makeLenses ''ConstructorInfo 72 | -------------------------------------------------------------------------------- /src/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | 6 | module Env (Env, empty, insert, singleton, lookup, lookupIdent, lookupVal, toList, fromList, named) where 7 | 8 | import Prelude hiding (lookup) 9 | 10 | import Control.Lens 11 | import Data.IntMap.Strict (IntMap) 12 | import qualified Data.IntMap.Strict as IM 13 | import Data.Text (Text) 14 | 15 | import Syntax (Ident, Stx(..)) 16 | 17 | import Util.Key 18 | 19 | -- | An environment maps variables of type 'v' to values of type 'a'. 20 | -- 21 | -- More specifically, 'Env' is intended to be used for variables in the core 22 | -- language, such as 'Var' and 'MacroVar', which are represented as unique 23 | -- integers in order to avoid accidental capture. To make error message more 24 | -- readable, 'Env' stores the original 'Ident' in addition to the value. 25 | newtype Env v a = Env (IntMap (Ident, a)) 26 | deriving newtype (Eq, Monoid, Semigroup, Show) 27 | deriving stock Functor 28 | 29 | empty :: Env v a 30 | empty = Env mempty 31 | 32 | toList :: HasKey v => Env v a -> [(v, Ident, a)] 33 | toList (Env env) = [(fromKey x, n, v) | (x, (n, v)) <- IM.toList env] 34 | 35 | fromList :: HasKey v => [(v, Ident, a)] -> Env v a 36 | fromList vars = Env (IM.fromList [(getKey x, (n, v)) | (x, n, v) <- vars]) 37 | 38 | singleton :: HasKey v => v -> Ident -> a -> Env v a 39 | singleton x n v = Env (IM.singleton (getKey x) (n, v)) 40 | 41 | insert :: HasKey v => v -> Ident -> a -> Env v a -> Env v a 42 | insert x n v (Env env) = Env (IM.insert (getKey x) (n, v) env) 43 | 44 | lookup :: HasKey v => v -> Env v a -> Maybe (Ident, a) 45 | lookup x (Env env) = IM.lookup (getKey x) env 46 | 47 | lookupVal :: HasKey v => v -> Env v a -> Maybe a 48 | lookupVal x env = snd <$> lookup x env 49 | 50 | lookupIdent :: HasKey v => v -> Env v a -> Maybe Ident 51 | lookupIdent x env = fst <$> lookup x env 52 | 53 | named :: HasKey v => Text -> Env v a -> [(v, a)] 54 | named n (Env xs) = [(fromKey x, a) | (x, (Stx _ _ n', a)) <- IM.toList xs, n == n'] 55 | 56 | type instance Index (Env v a) = v 57 | type instance IxValue (Env v a) = (Ident, a) 58 | 59 | instance HasKey v => Ixed (Env v a) where 60 | ix var f (Env env) = Env <$> ix (getKey var) f env 61 | {-# INLINE ix #-} 62 | 63 | instance HasKey v => At (Env v a) where 64 | at x f (Env env) = Env <$> at (getKey x) f env 65 | {-# INLINE at #-} 66 | -------------------------------------------------------------------------------- /src/Expander/DeclScope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | module Expander.DeclScope where 4 | 5 | import Unique 6 | import Util.Key 7 | 8 | -- | A 'DeclOutputScopesPtr' gets filled with a 'ScopeSet' consisting of all the 9 | -- scopes introduced by a declaration or a declaration group, so that later code 10 | -- can see the identifiers they bind. 11 | -- 12 | -- Note that 'DeclOutputScopesPtr' gets filled once we know which _names_ get 13 | -- bound, the values to which they are bound may not be fully-expanded yet. 14 | newtype DeclOutputScopesPtr = DeclOutputScopesPtr Unique 15 | deriving newtype (Eq, Ord, HasKey) 16 | 17 | instance Show DeclOutputScopesPtr where 18 | show (DeclOutputScopesPtr u) = "(DeclOutputScopesPtr " ++ show (hashUnique u) ++ ")" 19 | 20 | -------------------------------------------------------------------------------- /src/Kind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | module Kind (Kind(..), KindVar, newKindVar, kFun, KindStore) where 10 | 11 | import Control.Lens 12 | import Data.Data (Data) 13 | 14 | import Unique 15 | 16 | import Util.Store (Store) 17 | import Util.Key 18 | 19 | newtype KindVar = KindVar Unique 20 | deriving newtype (Eq, Ord, HasKey) 21 | deriving stock Data 22 | 23 | 24 | instance Show KindVar where 25 | show (KindVar i) = "(KindVar " ++ show (hashUnique i) ++ ")" 26 | 27 | data Kind 28 | = KStar 29 | | KFun Kind Kind 30 | | KMetaVar KindVar 31 | deriving (Data, Eq, Show) 32 | makePrisms ''Kind 33 | 34 | 35 | newKindVar :: IO KindVar 36 | newKindVar = KindVar <$> newUnique 37 | 38 | 39 | kFun :: [Kind] -> Kind -> Kind 40 | kFun args result = foldr KFun result args 41 | 42 | newtype KindStore = KindStore (Store KindVar Kind) 43 | deriving newtype (Monoid, Semigroup, Show) 44 | 45 | type instance Index KindStore = KindVar 46 | type instance IxValue KindStore = Kind 47 | 48 | instance Ixed KindStore where 49 | ix var f (KindStore env) = KindStore <$> ix var f env 50 | 51 | instance At KindStore where 52 | at x f (KindStore env) = KindStore <$> at x f env 53 | 54 | -------------------------------------------------------------------------------- /src/ModuleName.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module ModuleName ( 5 | -- * Module names 6 | ModuleName(..) 7 | , KernelName 8 | , kernelName 9 | , moduleNameFromPath 10 | , moduleNameToPath 11 | , moduleNameText 12 | , relativizeModuleName 13 | ) where 14 | 15 | import Data.Data (Data) 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import System.Directory 19 | import System.FilePath 20 | import Data.Hashable 21 | import GHC.Generics (Generic) 22 | 23 | import ShortShow 24 | 25 | newtype KernelName = Kernel () 26 | deriving (Data, Eq, Ord, Show, Generic) 27 | 28 | instance Hashable KernelName 29 | 30 | kernelName :: KernelName 31 | kernelName = Kernel () 32 | 33 | data ModuleName = ModuleName FilePath | KernelName KernelName 34 | deriving (Data, Eq, Ord, Show, Generic) 35 | 36 | instance Hashable ModuleName 37 | 38 | instance ShortShow ModuleName where 39 | shortShow (ModuleName x) = x 40 | shortShow (KernelName _k) = "kernel" 41 | 42 | moduleNameFromPath :: FilePath -> IO ModuleName 43 | moduleNameFromPath file = ModuleName <$> canonicalizePath file 44 | 45 | moduleNameToPath :: ModuleName -> Either FilePath KernelName 46 | moduleNameToPath (ModuleName file) = Left file 47 | moduleNameToPath (KernelName _) = Right (Kernel ()) 48 | 49 | moduleNameText :: ModuleName -> Text 50 | moduleNameText (ModuleName f) = T.pack (show f) 51 | moduleNameText (KernelName _) = T.pack "kernel" 52 | 53 | -- | Given a path, relativize the @ModuleName@ with respect to the path. 54 | -- 55 | -- > relativizeModuleName "a/b/c/klister" "a/b/c/klister/examples/do.kl" = "examples/do.kl" 56 | -- 57 | relativizeModuleName :: FilePath -> ModuleName -> ModuleName 58 | relativizeModuleName l (ModuleName r) = ModuleName (makeRelative l r) 59 | relativizeModuleName _ k@KernelName{} = k 60 | -------------------------------------------------------------------------------- /src/Parser/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | module Parser.Command (Command(..), readCommand) where 5 | 6 | import Control.Lens 7 | import Data.Functor 8 | import Data.Text (Text) 9 | import qualified Data.Text as T 10 | 11 | import Text.Megaparsec 12 | import Text.Megaparsec.Char 13 | 14 | import Parser.Common 15 | 16 | data Command = CommandQuit | CommandWorld 17 | deriving (Eq, Ord, Show, Read) 18 | makePrisms ''Command 19 | 20 | readCommand :: FilePath -> Text -> Either Text Command 21 | readCommand filename fileContents = 22 | case parse (char ':' *> command <* eof) filename fileContents of 23 | Left err -> Left $ T.pack $ errorBundlePretty err 24 | Right ok -> Right ok 25 | 26 | command :: Parser Command 27 | command = (literal "q" $> CommandQuit) <|> (literal "w" $> CommandWorld) 28 | -------------------------------------------------------------------------------- /src/Parser/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ViewPatterns #-} 2 | module Parser.Common (Parser, eatWhitespace, literal) where 3 | 4 | import Data.Text (Text) 5 | import Data.Void 6 | 7 | import Text.Megaparsec 8 | import Text.Megaparsec.Char 9 | import qualified Text.Megaparsec.Char.Lexer as L 10 | 11 | 12 | type Parser = Parsec Void Text 13 | 14 | eatWhitespace :: Parser () 15 | eatWhitespace = L.space space1 lineComment blockComment 16 | where 17 | lineComment = L.skipLineComment "--" 18 | blockComment = L.skipBlockComment "{-" "-}" 19 | 20 | literal :: Text -> Parser () 21 | literal x = L.symbol eatWhitespace x *> pure () 22 | -------------------------------------------------------------------------------- /src/PartialCore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module PartialCore where 3 | 4 | import Control.Lens 5 | 6 | import Core 7 | 8 | newtype PartialPattern = 9 | PartialPattern { unPartialPattern :: Maybe (ConstructorPatternF PartialPattern) } 10 | deriving (Eq, Show) 11 | 12 | newtype PartialCore = PartialCore 13 | { unPartialCore :: 14 | Maybe (CoreF (Maybe TypePattern) PartialPattern PartialCore) 15 | } 16 | deriving (Eq, Show) 17 | makePrisms ''PartialCore 18 | 19 | nonPartial :: Core -> PartialCore 20 | nonPartial = 21 | PartialCore . Just . mapCoreF Just nonPartialPattern nonPartial . unCore 22 | where 23 | nonPartialPattern pat = PartialPattern $ Just $ nonPartialPattern <$> unConstructorPattern pat 24 | 25 | runPartialCore :: PartialCore -> Maybe Core 26 | runPartialCore (PartialCore Nothing) = Nothing 27 | runPartialCore (PartialCore (Just c)) = Core <$> traverseCoreF id runPartialPattern runPartialCore c 28 | 29 | runPartialPattern :: PartialPattern -> Maybe ConstructorPattern 30 | runPartialPattern (PartialPattern Nothing) = Nothing 31 | runPartialPattern (PartialPattern (Just p)) = ConstructorPattern <$> traverse runPartialPattern p 32 | -------------------------------------------------------------------------------- /src/PartialType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module PartialType where 3 | 4 | import Control.Lens 5 | 6 | import Type 7 | 8 | newtype PartialType = PartialType 9 | { unPartialType :: Maybe (TyF PartialType) } 10 | deriving (Eq, Show) 11 | makePrisms ''PartialType 12 | 13 | nonPartialType :: Ty -> PartialType 14 | nonPartialType = PartialType . Just . fmap nonPartialType . unTy 15 | 16 | runPartialType :: PartialType -> Maybe Ty 17 | runPartialType (PartialType Nothing) = Nothing 18 | runPartialType (PartialType (Just t)) = 19 | traverse runPartialType t >>= pure . Ty 20 | -------------------------------------------------------------------------------- /src/Phase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module Phase (Phase(..), runtime, prior, Phased(..)) where 7 | 8 | import Control.Lens 9 | import Data.Data (Data) 10 | import Data.Sequence (Seq) 11 | import Numeric.Natural 12 | 13 | import ShortShow 14 | 15 | import Util.Key 16 | 17 | newtype Phase = Phase { phaseNum :: Natural } 18 | deriving newtype (Eq, Ord, Show, Num) 19 | deriving stock Data 20 | makePrisms ''Phase 21 | 22 | instance HasKey Phase where 23 | getKey (Phase n) = fromInteger $ toInteger n 24 | fromKey i = Phase $! fromIntegral i 25 | {-# INLINE getKey #-} 26 | {-# INLINE fromKey #-} 27 | 28 | instance ShortShow Phase where 29 | shortShow (Phase i) = "p" ++ show i 30 | 31 | runtime :: Phase 32 | runtime = Phase 0 33 | 34 | prior :: Phase -> Phase 35 | prior (Phase i) = Phase (i + 1) 36 | 37 | class Phased a where 38 | shift :: Natural -> a -> a 39 | 40 | instance Phased Phase where 41 | shift j (Phase i) = Phase (i + j) 42 | 43 | instance Phased a => Phased [a] where 44 | shift i = fmap (shift i) 45 | 46 | instance Phased a => Phased (Seq a) where 47 | shift i = fmap (shift i) 48 | -------------------------------------------------------------------------------- /src/Scope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | 7 | module Scope where 8 | 9 | import Data.Data (Data) 10 | import Control.Lens 11 | 12 | #ifdef KDEBUG 13 | import Data.Text (Text) 14 | #else 15 | import Util.Key 16 | #endif 17 | 18 | 19 | -- Int should be enough for now - consider bumping to something like int64 20 | #ifndef KDEBUG 21 | newtype Scope = Scope { scopeNum :: Int} 22 | deriving newtype (Eq, Ord, Show, HasKey) 23 | deriving stock Data 24 | #else 25 | -- For a debug build Scope keeps a blob of text for debugging the expander 26 | -- output. This will have an impact of the performance of the interpreter so it 27 | -- won't be useful for performance issues 28 | data Scope = Scope { scopeNum :: Int, scopePurpose :: Text } 29 | deriving (Data, Eq, Ord, Show) 30 | #endif 31 | makeLenses ''Scope 32 | -------------------------------------------------------------------------------- /src/ShortShow.hs: -------------------------------------------------------------------------------- 1 | module ShortShow where 2 | 3 | import Data.Text 4 | import qualified Data.List as List 5 | 6 | import Unique 7 | 8 | 9 | class ShortShow a where 10 | shortShow :: a -> String 11 | 12 | instance ShortShow Text where 13 | shortShow = show 14 | 15 | instance ShortShow Unique where 16 | shortShow = show . hashUnique 17 | 18 | instance (ShortShow a, ShortShow b) => ShortShow (a, b) where 19 | shortShow (x, y) 20 | = "(" 21 | ++ shortShow x 22 | ++ ", " 23 | ++ shortShow y 24 | ++ ")" 25 | instance (ShortShow a, ShortShow b, ShortShow c) => ShortShow (a, b, c) where 26 | shortShow (x, y, z) 27 | = "(" 28 | ++ shortShow x 29 | ++ ", " 30 | ++ shortShow y 31 | ++ ", " 32 | ++ shortShow z 33 | ++ ")" 34 | 35 | instance ShortShow a => ShortShow [a] where 36 | shortShow xs 37 | = "[" 38 | ++ List.intercalate ", " (fmap shortShow xs) 39 | ++ "]" 40 | -------------------------------------------------------------------------------- /src/SplitType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | module SplitType where 5 | 6 | import Control.Lens hiding (children) 7 | import Control.Monad.Writer 8 | 9 | import PartialType 10 | import Type 11 | import Unique 12 | 13 | import Util.Store (Store) 14 | import qualified Util.Store as S 15 | import Util.Key 16 | 17 | newtype SplitTypePtr = SplitTypePtr Unique 18 | deriving newtype (Eq, Ord, HasKey) 19 | 20 | instance Show SplitTypePtr where 21 | show (SplitTypePtr i) = "(SplitTypePtr " ++ show (hashUnique i) ++ ")" 22 | 23 | newSplitTypePtr :: IO SplitTypePtr 24 | newSplitTypePtr = SplitTypePtr <$> newUnique 25 | 26 | data SplitType = SplitType 27 | { _splitTypeRoot :: SplitTypePtr 28 | , _splitTypeDescendants :: Store SplitTypePtr (TyF SplitTypePtr) 29 | } 30 | makeLenses ''SplitType 31 | 32 | unsplitType :: SplitType -> PartialType 33 | unsplitType t = PartialType $ go (view splitTypeRoot t) 34 | where 35 | go :: SplitTypePtr -> Maybe (TyF PartialType) 36 | go ptr = do 37 | this <- view (splitTypeDescendants . at ptr) t 38 | return (fmap (PartialType . go) this) 39 | 40 | splitType :: PartialType -> IO SplitType 41 | splitType partialType = do 42 | root <- newSplitTypePtr 43 | ((), childMap) <- runWriterT $ go root (unPartialType partialType) 44 | return $ SplitType root childMap 45 | where 46 | go :: 47 | SplitTypePtr -> Maybe (TyF PartialType) -> 48 | WriterT (Store SplitTypePtr (TyF SplitTypePtr)) IO () 49 | go _ Nothing = pure () 50 | go place (Just t) = do 51 | children <- flip traverse t $ \p -> do 52 | here <- liftIO newSplitTypePtr 53 | go here (unPartialType p) 54 | pure here 55 | tell $ S.singleton place children 56 | 57 | newtype SchemePtr = SchemePtr Unique deriving newtype (Eq, Ord, HasKey) 58 | 59 | newSchemePtr :: IO SchemePtr 60 | newSchemePtr = SchemePtr <$> newUnique 61 | 62 | instance Show SchemePtr where 63 | show (SchemePtr ptr) = "(SchemePtr " ++ show (hashUnique ptr) ++ ")" 64 | -------------------------------------------------------------------------------- /src/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Syntax 3 | Description : User-facing syntax of Klister 4 | 5 | 'Syntax' is the user-facing syntax for Klister. It can come from parsing Klister 6 | code or from the expansion of user macros. It is transformed into Klister\'s 7 | core language by the expander. 8 | -} 9 | 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | 14 | module Syntax 15 | ( addScope 16 | , removeScope 17 | , flipScope 18 | , flipScope' 19 | , addScope' 20 | , removeScope' 21 | , addScopes 22 | , stxLoc 23 | , syntaxE 24 | , syntaxText 25 | , module Syntax.Syntax 26 | )where 27 | 28 | import Data.Text (Text) 29 | import qualified Data.Text as T 30 | 31 | import Phase 32 | import Scope 33 | import ScopeSet 34 | import Syntax.SrcLoc 35 | import Syntax.Syntax 36 | 37 | 38 | addScope :: HasScopes a => Phase -> Scope -> a -> a 39 | addScope p = adjustScope (ScopeSet.insertAtPhase p) 40 | 41 | removeScope :: HasScopes a => Phase -> Scope -> a -> a 42 | removeScope p = adjustScope (ScopeSet.deleteAtPhase p) 43 | 44 | flipScope :: HasScopes a => Phase -> Scope -> a -> a 45 | flipScope p = adjustScope go 46 | where 47 | go sc scs 48 | | ScopeSet.member p sc scs = ScopeSet.deleteAtPhase p sc scs 49 | | otherwise = ScopeSet.insertAtPhase p sc scs 50 | 51 | flipScope' :: HasScopes a => Scope -> a -> a 52 | flipScope' = adjustScope ScopeSet.flipUniversally 53 | 54 | addScope' :: HasScopes a => Scope -> a -> a 55 | addScope' = adjustScope ScopeSet.insertUniversally 56 | 57 | removeScope' :: HasScopes a => Scope -> a -> a 58 | removeScope' = adjustScope ScopeSet.deleteUniversally 59 | 60 | addScopes :: HasScopes p => ScopeSet -> p -> p 61 | addScopes = addScopes' 62 | 63 | stxLoc :: Syntax -> SrcLoc 64 | stxLoc (Syntax (Stx _ srcloc _)) = srcloc 65 | 66 | syntaxE :: Syntax -> ExprF Syntax 67 | syntaxE (Syntax (Stx _ _ e)) = e 68 | 69 | syntaxText :: Syntax -> Text 70 | syntaxText (Syntax (Stx _ _ e)) = go e 71 | where 72 | go (Id x) = x 73 | go (String str) = T.pack $ show str 74 | go (Integer s) = T.pack (show s) 75 | go (List xs) = "(" <> T.intercalate " " (map syntaxText xs) <> ")" 76 | -------------------------------------------------------------------------------- /src/Syntax/Lexical.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Syntax.Lexical where 3 | 4 | import Control.Lens 5 | 6 | import Syntax.SrcLoc 7 | 8 | 9 | data Located a = Located 10 | { _locatedSrcLoc :: !SrcLoc 11 | , _locatedValue :: a 12 | } 13 | makeLenses ''Located 14 | -------------------------------------------------------------------------------- /src/Syntax/SrcLoc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Syntax.SrcLoc where 4 | 5 | import Control.Monad 6 | import Control.Lens 7 | import Data.Data (Data) 8 | 9 | import Alpha 10 | import ShortShow 11 | 12 | data SrcPos = SrcPos 13 | { _srcPosLine :: !Int 14 | , _srcPosCol :: !Int 15 | } 16 | deriving (Data, Eq, Show) 17 | makeLenses ''SrcPos 18 | 19 | instance ShortShow SrcPos where 20 | shortShow (SrcPos l c) = show l ++ "." ++ show c 21 | 22 | data SrcLoc = SrcLoc 23 | { _srcLocFilePath :: !FilePath 24 | , _srcLocStart :: !SrcPos 25 | , _srcLocEnd :: !SrcPos 26 | } 27 | deriving (Data, Eq, Show) 28 | makeLenses ''SrcLoc 29 | 30 | instance AlphaEq SrcLoc where 31 | alphaCheck x y = guard (x == y) 32 | 33 | instance ShortShow SrcLoc where 34 | shortShow (SrcLoc fn beg end) = 35 | reverse (take 10 (reverse fn)) ++ ":" ++ 36 | shortShow beg ++ "-" ++ 37 | shortShow end 38 | -------------------------------------------------------------------------------- /src/Syntax/Syntax.hs: -------------------------------------------------------------------------------- 1 | -- | Internal module for Syntax component. Holds core data types, classes and 2 | -- smart constructors. 3 | 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE CPP #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | 12 | module Syntax.Syntax where 13 | 14 | import Control.Lens hiding (List) 15 | import Data.Data (Data) 16 | import Data.Text (Text) 17 | 18 | import Alpha 19 | import ModuleName 20 | import Phase 21 | import Scope 22 | import ScopeSet 23 | import ShortShow 24 | import Syntax.SrcLoc 25 | 26 | import qualified Util.Set as Set 27 | import qualified Util.Store as St 28 | 29 | 30 | data Stx a = Stx 31 | { _stxScopeSet :: ScopeSet 32 | , _stxSrcLoc :: !SrcLoc 33 | , _stxValue :: a 34 | } 35 | deriving (Data, Eq, Functor, Show) 36 | makeLenses ''Stx 37 | 38 | data ExprF a 39 | = Id Text 40 | | String Text 41 | | Integer Integer 42 | | List [a] 43 | deriving (Data, Eq, Functor, Show) 44 | makePrisms ''ExprF 45 | 46 | 47 | newtype Syntax = Syntax { _unSyntax :: (Stx (ExprF Syntax)) } 48 | deriving (Data, Eq, Show) 49 | makeLenses ''Syntax 50 | 51 | type Ident = Stx Text 52 | 53 | data ParsedModule a = ParsedModule 54 | { _moduleSource :: ModuleName 55 | , _moduleLanguage :: a 56 | , _moduleContents :: a 57 | } 58 | deriving (Eq, Show) 59 | makeLenses ''ParsedModule 60 | 61 | class HasScopes a where 62 | getScopes :: a -> ScopeSet 63 | adjustScope :: (Scope -> ScopeSet -> ScopeSet) -> Scope -> a -> a 64 | mapScopes :: (ScopeSet -> ScopeSet) -> a -> a 65 | 66 | instance HasScopes (Stx Text) where 67 | getScopes (Stx scs _ _) = scs 68 | adjustScope f sc (Stx scs srcloc x) = Stx (f sc scs) srcloc x 69 | mapScopes f (Stx scs srcloc x) = Stx (f scs) srcloc x 70 | 71 | instance HasScopes Syntax where 72 | getScopes (Syntax (Stx scs _ _)) = scs 73 | adjustScope f sc = mapScopes (f sc) 74 | mapScopes f (Syntax (Stx scs srcloc e)) = 75 | Syntax $ 76 | Stx (f scs) srcloc $ 77 | mapRec e 78 | where 79 | mapRec (Id x) = Id x 80 | mapRec (String str) = String str 81 | mapRec (Integer i) = Integer i 82 | mapRec (List xs) = List $ map (\stx -> mapScopes f stx) xs 83 | 84 | instance Phased (Stx Text) where 85 | shift i = mapScopes (shift i) 86 | 87 | instance Phased Syntax where 88 | shift i = mapScopes (shift i) 89 | 90 | instance AlphaEq a => AlphaEq (Stx a) where 91 | alphaCheck (Stx scopeSet1 srcLoc1 x1) 92 | (Stx scopeSet2 srcLoc2 x2) = do 93 | alphaCheck scopeSet1 scopeSet2 94 | alphaCheck srcLoc1 srcLoc2 95 | alphaCheck x1 x2 96 | 97 | instance AlphaEq a => AlphaEq (ExprF a) where 98 | alphaCheck (Id x1) 99 | (Id x2) = do 100 | alphaCheck x1 x2 101 | alphaCheck (List xs1) 102 | (List xs2) = do 103 | alphaCheck xs1 xs2 104 | alphaCheck _ _ = notAlphaEquivalent 105 | 106 | instance AlphaEq Syntax where 107 | alphaCheck (Syntax x1) 108 | (Syntax x2) = do 109 | alphaCheck x1 x2 110 | 111 | 112 | instance ShortShow a => ShortShow (Stx a) where 113 | shortShow (Stx _ _ x) = shortShow x 114 | 115 | instance ShortShow a => ShortShow (ExprF a) where 116 | shortShow (Id x) = shortShow x 117 | shortShow (String s) = show s 118 | shortShow (List xs) = shortShow xs 119 | shortShow (Integer s) = show s 120 | 121 | instance ShortShow Syntax where 122 | shortShow (Syntax x) = shortShow x 123 | 124 | addScopes' :: HasScopes p => ScopeSet -> p -> p 125 | #ifndef KDEBUG 126 | addScopes' scopeSet = mapScopes (over phaseScopes newSpecificScopes 127 | . over universalScopes newUniversalScopes) 128 | where 129 | newUniversalScopes = Set.union (view _1 (contents scopeSet)) 130 | newSpecificScopes = St.unionWith (<>) (view _2 (contents scopeSet)) 131 | #else 132 | addScopes' scopeSet 133 | = addSpecificScopes 134 | . addUniversalScopes 135 | where 136 | addUniversalScopes :: HasScopes a => a -> a 137 | addUniversalScopes a0 = 138 | foldlOf (to ScopeSet.contents . _1 . folded) 139 | (flip addScope') 140 | a0 141 | scopeSet 142 | 143 | addSpecificScopes :: HasScopes a => a -> a 144 | addSpecificScopes a0 = 145 | ifoldlOf (to ScopeSet.contents .> _2 .> ifolded <. folded) 146 | (\p a sc -> addScope p sc a) 147 | a0 148 | scopeSet 149 | #endif 150 | -------------------------------------------------------------------------------- /src/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveFoldable #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | module Type where 13 | 14 | import Control.Lens 15 | import Control.Monad 16 | import Data.Foldable 17 | import Data.Data (Data) 18 | import Numeric.Natural 19 | 20 | import Alpha 21 | import Datatype 22 | import Kind 23 | import ShortShow 24 | import Unique 25 | 26 | import Util.Key 27 | import Util.Store 28 | 29 | newtype MetaPtr = MetaPtr Unique 30 | deriving newtype (Eq, Ord, HasKey) 31 | deriving stock Data 32 | 33 | newMetaPtr :: IO MetaPtr 34 | newMetaPtr = MetaPtr <$> newUnique 35 | 36 | instance Show MetaPtr where 37 | show (MetaPtr i) = "(MetaPtr " ++ show (hashUnique i) ++ ")" 38 | 39 | data TypeConstructor 40 | = TSyntax 41 | | TInteger 42 | | TString 43 | | TOutputPort 44 | | TFun 45 | | TMacro 46 | | TIO 47 | | TType 48 | | TDatatype Datatype 49 | | TSchemaVar Natural 50 | | TMetaVar MetaPtr 51 | deriving (Data, Eq, Show) 52 | makePrisms ''TypeConstructor 53 | 54 | data TyF t = TyF 55 | { outermostCtor :: TypeConstructor 56 | , typeArgs :: [t] 57 | } 58 | deriving (Data, Eq, Foldable, Functor, Show, Traversable) 59 | makeLenses ''TyF 60 | 61 | data VarLinkage t = NoLink | Link (TyF t) 62 | deriving (Functor, Show) 63 | makePrisms ''VarLinkage 64 | 65 | newtype BindingLevel = BindingLevel Natural 66 | deriving (Eq, Ord, Show) 67 | makePrisms ''BindingLevel 68 | 69 | data TVar t = TVar 70 | { _varLinkage :: !(VarLinkage t) 71 | , _varLevel :: !BindingLevel 72 | , _varKind :: !Kind 73 | } 74 | deriving (Functor, Show) 75 | makeLenses ''TVar 76 | 77 | newtype TypeStore t = TypeStore (Store MetaPtr (TVar t)) 78 | deriving (Functor, Monoid, Semigroup, Show) 79 | 80 | type instance Index (TypeStore t) = MetaPtr 81 | type instance IxValue (TypeStore t) = TVar t 82 | 83 | instance Ixed (TypeStore t) where 84 | ix var f (TypeStore env) = TypeStore <$> ix var f env 85 | 86 | instance At (TypeStore t) where 87 | at x f (TypeStore env) = TypeStore <$> at x f env 88 | 89 | data Scheme t = Scheme [Kind] t 90 | deriving (Data, Eq, Show) 91 | makeLenses ''Scheme 92 | 93 | newtype Ty = Ty 94 | { unTy :: TyF Ty } 95 | deriving (Data, Eq, Show) 96 | makePrisms ''Ty 97 | 98 | instance AlphaEq a => AlphaEq (TyF a) where 99 | alphaCheck (TyF ctor1 args1) (TyF ctor2 args2) = do 100 | guard (ctor1 == ctor2) 101 | guard (length args1 == length args2) 102 | for_ (zip args1 args2) (uncurry alphaCheck) 103 | 104 | instance ShortShow a => ShortShow (TyF a) where 105 | shortShow t = show (fmap shortShow t) 106 | 107 | 108 | class TyLike a arg | a -> arg where 109 | tSyntax :: a 110 | tInteger :: a 111 | tString :: a 112 | tOutputPort :: a 113 | tFun1 :: arg -> arg -> a 114 | tMacro :: arg -> a 115 | tIO :: arg -> a 116 | tType :: a 117 | tDatatype :: Datatype -> [arg] -> a 118 | tSchemaVar :: Natural -> [arg] -> a 119 | tMetaVar :: MetaPtr -> a 120 | 121 | instance TyLike (TyF a) a where 122 | tSyntax = TyF TSyntax [] 123 | tInteger = TyF TInteger [] 124 | tString = TyF TString [] 125 | tOutputPort = TyF TOutputPort [] 126 | tFun1 t1 t2 = TyF TFun [t1, t2] 127 | tMacro t = TyF TMacro [t] 128 | tIO t = TyF TIO [t] 129 | tType = TyF TType [] 130 | tDatatype x ts = TyF (TDatatype x) ts 131 | tSchemaVar x ts = TyF (TSchemaVar x) ts 132 | tMetaVar x = TyF (TMetaVar x) [] 133 | 134 | instance TyLike Ty Ty where 135 | tSyntax = Ty $ tSyntax 136 | tInteger = Ty $ tInteger 137 | tString = Ty $ tString 138 | tOutputPort = Ty $ tOutputPort 139 | tFun1 t1 t2 = Ty $ tFun1 t1 t2 140 | tMacro t = Ty $ tMacro t 141 | tIO t = Ty $ tIO t 142 | tType = Ty $ tType 143 | tDatatype x ts = Ty $ tDatatype x ts 144 | tSchemaVar x ts = Ty $ tSchemaVar x ts 145 | tMetaVar x = Ty $ tMetaVar x 146 | 147 | tFun :: [Ty] -> Ty -> Ty 148 | tFun args result = foldr tFun1 result args 149 | -------------------------------------------------------------------------------- /src/Type/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Type.Context where 4 | 5 | import Control.Lens 6 | 7 | import Env 8 | import Phase 9 | 10 | import Util.Store (Store) 11 | import qualified Util.Store as St 12 | 13 | newtype TypeContext v t = TypeContext (Store Phase (Env v t)) 14 | deriving Show 15 | 16 | instance Ord v => Semigroup (TypeContext v t) where 17 | TypeContext γ1 <> TypeContext γ2 = TypeContext (St.unionWith (<>) γ1 γ2) 18 | 19 | instance Ord v => Monoid (TypeContext v t) where 20 | mempty = TypeContext mempty 21 | 22 | type instance Index (TypeContext v a) = Phase 23 | type instance IxValue (TypeContext v a) = Env v a 24 | 25 | instance Ord v => Ixed (TypeContext v a) where 26 | ix var f (TypeContext env) = TypeContext <$> ix var f env 27 | 28 | instance Ord v => At (TypeContext v a) where 29 | at x f (TypeContext env) = TypeContext <$> at x f env 30 | 31 | instance Phased (TypeContext v t) where 32 | shift i (TypeContext γ) = TypeContext (St.mapKeys (shift i) γ) 33 | -------------------------------------------------------------------------------- /src/Unique.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | -- | A drop-in replacement for Data.Unique which has a Data instance. 6 | module Unique (Unique, newUnique, hashUnique) where 7 | 8 | import Data.Data (Data) 9 | import Data.IORef 10 | import System.IO.Unsafe 11 | import Data.Hashable 12 | 13 | import Util.Key 14 | 15 | 16 | newtype Unique = Unique Int 17 | deriving newtype (Eq, Ord, Hashable) 18 | deriving stock Data 19 | 20 | uniqSource :: IORef Int 21 | uniqSource = unsafePerformIO (newIORef 0) 22 | {-# NOINLINE uniqSource #-} 23 | 24 | -- | Creates a new object of type 'Unique'. The value returned will 25 | -- not compare equal to any other value of type 'Unique' returned by 26 | -- previous calls to 'newUnique'. There is no limit on the number of 27 | -- times 'newUnique' may be called. 28 | newUnique :: IO Unique 29 | newUnique = do 30 | r <- atomicModifyIORef' uniqSource $ \x -> let !z = x+1 in (z,z) 31 | return (Unique r) 32 | 33 | hashUnique :: Unique -> Int 34 | hashUnique (Unique x) = x 35 | 36 | instance HasKey Unique where 37 | getKey u = hashUnique u 38 | fromKey i = Unique $! i 39 | -------------------------------------------------------------------------------- /src/Util/Key.hs: -------------------------------------------------------------------------------- 1 | -- | Tiny module to wrap operations for IntMaps 2 | 3 | module Util.Key 4 | (HasKey(..) 5 | ) where 6 | 7 | class HasKey a where 8 | getKey :: a -> Int 9 | fromKey :: Int -> a 10 | 11 | instance HasKey Int where 12 | getKey = id 13 | fromKey = id 14 | -------------------------------------------------------------------------------- /src/Util/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RoleAnnotations #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | 15 | -- | wrapper over IntSet for our purposes 16 | 17 | module Util.Set 18 | ( 19 | #ifndef KDEBUG 20 | member 21 | , singleton 22 | , empty 23 | , size 24 | , isSubsetOf 25 | , insert 26 | , delete 27 | , toList 28 | , fromList 29 | , Set 30 | , union 31 | #else 32 | module Data.Set 33 | #endif 34 | ) 35 | where 36 | 37 | import Prelude hiding (lookup) 38 | import Control.Lens 39 | import Data.Data (Data) 40 | import Data.Functor 41 | import Data.IntSet (IntSet) 42 | import qualified Data.IntSet as IS 43 | import Control.Monad (guard) 44 | import Util.Key 45 | 46 | #ifdef KDEBUG 47 | import Data.Set 48 | #endif 49 | 50 | newtype Set key = Set { unSet :: IntSet} 51 | deriving newtype (Eq, Ord, Show, Semigroup, Monoid) 52 | deriving stock Data 53 | type role Set nominal 54 | 55 | type instance IxValue (Set p) = () 56 | type instance Index (Set p) = p 57 | 58 | instance HasKey p => Ixed (Set p) where 59 | ix k f m = if member k m 60 | then f () $> m 61 | else pure m 62 | 63 | instance HasKey p => At (Set p) where 64 | {-# INLINE at #-} 65 | at k f s = fmap choose (f (guard member_)) 66 | where 67 | member_ = member k s 68 | 69 | (inserted, deleted) 70 | | member_ = (s, delete k s) 71 | | otherwise = (insert k s, s) 72 | 73 | choose (Just ~()) = inserted 74 | choose Nothing = deleted 75 | 76 | member :: HasKey e => e -> Set e -> Bool 77 | member e s = IS.member (getKey e) (unSet s) 78 | 79 | empty :: Set e 80 | empty = Set IS.empty 81 | 82 | size :: Set e -> Int 83 | size = IS.size . unSet 84 | 85 | singleton :: HasKey e => e -> Set e 86 | singleton = Set . IS.singleton . getKey 87 | 88 | insert :: HasKey e => e -> Set e -> Set e 89 | insert e s = Set $! IS.insert (getKey e) (unSet s) 90 | 91 | delete :: HasKey e => e -> Set e -> Set e 92 | delete e s = Set $! IS.delete (getKey e) (unSet s) 93 | 94 | isSubsetOf :: Set e -> Set e -> Bool 95 | isSubsetOf l r = IS.isSubsetOf (unSet l) (unSet r) 96 | 97 | toList :: HasKey p => Set p -> [p] 98 | toList = map fromKey . IS.toList . unSet 99 | 100 | fromList :: HasKey p => [p] -> Set p 101 | fromList = Set . IS.fromList . map getKey 102 | 103 | union :: Set p -> Set p -> Set p 104 | union l r = Set $! IS.union (unSet l) (unSet r) 105 | -------------------------------------------------------------------------------- /src/Util/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RoleAnnotations #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | 14 | -- | wrapper over IntMap for our purposes 15 | 16 | module Util.Store 17 | ( empty 18 | , lookup 19 | , singleton 20 | , insert 21 | , toList 22 | , fromList 23 | , Store 24 | , unionWith 25 | , mapKeys 26 | , mapMaybeWithKey 27 | , size 28 | ) 29 | where 30 | 31 | import Prelude hiding (lookup) 32 | import Control.Lens 33 | import Data.Data (Data) 34 | import Data.IntMap.Strict (IntMap) 35 | import qualified Data.IntMap.Strict as IM 36 | import Control.Arrow (first) 37 | 38 | import Util.Key 39 | import Phase 40 | 41 | newtype Store p v = Store { unStore :: IntMap v} 42 | deriving newtype (Eq, Ord, Show, Semigroup, Monoid, Functor, Foldable) 43 | deriving stock Data 44 | type role Store nominal _ 45 | 46 | instance Traversable (Store p) where 47 | traverse f s = Store <$> traverse f (unStore s) 48 | 49 | instance FoldableWithIndex Phase (Store p) where 50 | ifoldMap f s = IM.foldMapWithKey (f . Phase . fromIntegral . toInteger) (unStore s) 51 | {-# INLINE ifoldMap #-} 52 | ifoldr f acc s = IM.foldrWithKey (f . Phase . fromIntegral . toInteger) acc (unStore s) 53 | {-# INLINE ifoldr #-} 54 | ifoldl' f acc s = IM.foldlWithKey' (\e k ac -> f (fromIntegral k) e ac) acc (unStore s) 55 | {-# INLINE ifoldl' #-} 56 | 57 | type instance IxValue (Store p v) = v 58 | type instance Index (Store p v) = p 59 | 60 | instance HasKey p => Ixed (Store p v) where 61 | ix k f m = case lookup k m of 62 | Just v -> f v <&> \new_v -> insert k new_v m 63 | Nothing -> pure m 64 | 65 | instance HasKey p => At (Store p v) where 66 | at k f s = alterF f k s 67 | {-# INLINE at #-} 68 | 69 | instance (c ~ d) => Each (Store c a) (Store d b) a b where 70 | each = traversed 71 | 72 | empty :: Store p v 73 | empty = Store IM.empty 74 | 75 | lookup :: HasKey p => p -> Store p v -> Maybe v 76 | lookup ptr graph = getKey ptr `IM.lookup` unStore graph 77 | 78 | singleton :: HasKey p => p -> v -> Store p v 79 | singleton ptr val = Store $! IM.singleton (getKey ptr) val 80 | 81 | insert :: HasKey p => p -> v -> Store p v -> Store p v 82 | insert k v str = Store $! IM.insert (getKey k) v (unStore str) 83 | 84 | toList :: HasKey p => Store p v -> [(p,v)] 85 | toList str = map (first fromKey) $ IM.toList (unStore str) 86 | 87 | fromList :: HasKey p => [(p,v)] -> Store p v 88 | fromList ps = Store $! IM.fromList $ map (first getKey) ps 89 | 90 | alterF :: ( Functor f, HasKey p) 91 | => (Maybe v -> f (Maybe v)) -> p -> Store p v -> f (Store p v) 92 | alterF f k s = Store <$> IM.alterF f (getKey k) (unStore s) 93 | 94 | unionWith :: (v -> v -> v) -> Store p v -> Store p v -> Store p v 95 | unionWith f l r = Store $! IM.unionWith f (unStore l) (unStore r) 96 | 97 | mapMaybeWithKey :: HasKey p => (p -> a -> Maybe b) -> Store p a -> Store p b 98 | mapMaybeWithKey f s = Store $! IM.mapMaybeWithKey (f . fromKey) (unStore s) 99 | 100 | mapKeys :: HasKey p => (p -> p) -> Store p v -> Store p v 101 | mapKeys f s = Store $! IM.mapKeys (getKey . f . fromKey) (unStore s) 102 | 103 | size :: Store p v -> Int 104 | size = IM.size . unStore -------------------------------------------------------------------------------- /src/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Value where 4 | 5 | import Control.Lens 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | import System.IO (Handle) 9 | 10 | import Core 11 | import Datatype 12 | import Env 13 | import ModuleName 14 | import Syntax 15 | import Syntax.SrcLoc 16 | import Type 17 | 18 | type VEnv = Env Var Value 19 | type TEnv = Env MacroVar Value 20 | 21 | data MacroAction 22 | = MacroActionPure Value 23 | | MacroActionBind MacroAction Closure 24 | | MacroActionSyntaxError (SyntaxError Syntax) 25 | | MacroActionIdentEq HowEq Value Value 26 | | MacroActionLog Syntax 27 | | MacroActionIntroducer 28 | | MacroActionWhichProblem 29 | | MacroActionTypeCase VEnv SrcLoc Ty [(TypePattern, Core)] 30 | 31 | instance Show MacroAction where 32 | show _ = "MacroAction..." 33 | 34 | 35 | data Value 36 | = ValueClosure Closure 37 | | ValueSyntax Syntax 38 | | ValueMacroAction MacroAction 39 | | ValueIOAction (IO Value) 40 | | ValueOutputPort Handle 41 | | ValueInteger Integer 42 | | ValueCtor Constructor [Value] 43 | | ValueType Ty 44 | | ValueString Text 45 | 46 | instance Show Value where 47 | show _ = "Value..." 48 | 49 | primitiveCtor :: Text -> [Value] -> Value 50 | primitiveCtor name args = 51 | let ctor = Constructor (KernelName kernelName) (ConstructorName name) 52 | in ValueCtor ctor args 53 | 54 | valueText :: Value -> Text 55 | valueText (ValueClosure _) = "#" 56 | valueText (ValueSyntax stx) = "'" <> syntaxText stx 57 | valueText (ValueMacroAction _) = "#" 58 | valueText (ValueIOAction _) = "#" 59 | valueText (ValueOutputPort _) = "#" 60 | valueText (ValueInteger s) = "#!" <> T.pack (show s) 61 | valueText (ValueCtor c args) = 62 | "(" <> view (constructorName . constructorNameText) c <> " " <> 63 | T.intercalate " " (map valueText args) <> ")" 64 | valueText (ValueType ptr) = "#t<" <> T.pack (show ptr) <> ">" 65 | valueText (ValueString str) = T.pack (show str) 66 | 67 | -- | Find a simple description that is suitable for inclusion in error messages. 68 | describeVal :: Value -> Text 69 | describeVal (ValueClosure _) = "function" 70 | describeVal (ValueSyntax _) = "syntax" 71 | describeVal (ValueMacroAction _) = "macro action" 72 | describeVal (ValueIOAction _) = "IO action" 73 | describeVal (ValueOutputPort _) = "output port" 74 | describeVal (ValueInteger _) = "integer" 75 | describeVal (ValueCtor c _args) = 76 | view (constructorName . constructorNameText) c 77 | describeVal (ValueType _) = "type" 78 | describeVal (ValueString _) = "string" 79 | 80 | data FOClosure = FOClosure 81 | { _closureEnv :: VEnv 82 | , _closureIdent :: Ident 83 | , _closureVar :: Var 84 | , _closureBody :: Core 85 | } 86 | 87 | data Closure = FO FOClosure | HO (Value -> Value) 88 | 89 | instance Show Closure where 90 | show _ = "Closure {...}" 91 | 92 | makePrisms ''MacroAction 93 | makePrisms ''Value 94 | makeLenses ''Closure 95 | makeLenses ''FOClosure 96 | -------------------------------------------------------------------------------- /src/World.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module World where 5 | 6 | import Control.Lens 7 | import Data.HashMap.Strict (HashMap) 8 | import qualified Data.HashMap.Strict as HM 9 | import Data.Sequence as Seq 10 | import Util.Set (Set) 11 | import Data.Maybe (fromMaybe) 12 | 13 | import Core (MacroVar, Var) 14 | import Datatype 15 | import Env 16 | import Evaluator (EvalResult) 17 | import Module 18 | import ModuleName 19 | import Phase 20 | import SplitType 21 | import Type 22 | import Type.Context 23 | 24 | import Util.Store 25 | 26 | data World a = World 27 | { _worldEnvironments :: !(Store Phase (Env Var a)) 28 | , _worldTypeContexts :: !(TypeContext Var SchemePtr) 29 | , _worldTransformerEnvironments :: !(Store Phase (Env MacroVar a)) 30 | , _worldModules :: !(HashMap ModuleName CompleteModule) 31 | , _worldVisited :: !(HashMap ModuleName (Set Phase)) 32 | , _worldExports :: !(HashMap ModuleName Exports) 33 | , _worldEvaluated :: !(HashMap ModuleName (Seq EvalResult)) 34 | , _worldDatatypes :: !(Store Phase (HashMap Datatype DatatypeInfo)) 35 | , _worldConstructors :: !(Store Phase (HashMap Constructor (ConstructorInfo Ty))) 36 | , _worldLocation :: FilePath 37 | } 38 | makeLenses ''World 39 | 40 | phaseEnv :: Phase -> World a -> Env Var a 41 | phaseEnv p = fromMaybe Env.empty . view (worldEnvironments . at p) 42 | 43 | initialWorld :: FilePath -> World a 44 | initialWorld fp = 45 | World { _worldEnvironments = mempty 46 | , _worldTypeContexts = mempty 47 | , _worldTransformerEnvironments = mempty 48 | , _worldModules = HM.empty 49 | , _worldVisited = HM.empty 50 | , _worldExports = HM.empty 51 | , _worldEvaluated = HM.empty 52 | , _worldDatatypes = mempty 53 | , _worldConstructors = mempty 54 | , _worldLocation = fp 55 | } 56 | 57 | addExpandedModule :: CompleteModule -> World a -> World a 58 | addExpandedModule m = 59 | over (worldModules . at (getName m)) 60 | \case 61 | Nothing -> Just m 62 | Just m' -> Just m' 63 | where 64 | getName :: CompleteModule -> ModuleName 65 | getName (Expanded em _) = view moduleName em 66 | getName (KernelModule _) = KernelName kernelName 67 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.39 2 | packages: 3 | - . 4 | extra-deps: 5 | 6 | # mark nix as disable. Nix users can use cabal and the nix flake 7 | nix: 8 | enable: false 9 | -------------------------------------------------------------------------------- /stdlib/defun.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | (import (rename "n-ary-app.kl" (flet nflet))) 3 | (import (shift kernel 1)) 4 | (import (shift "n-ary-app.kl" 1)) 5 | 6 | (define-macros 7 | -- (defun f (args...) 8 | -- body which references f) 9 | -- => 10 | -- (define f 11 | -- (flet f (args...) 12 | -- body which references f)) 13 | ([defun 14 | (lambda (stx) 15 | (case (open-syntax stx) 16 | [(list-contents (:: _ (:: f (:: args (:: body (nil)))))) 17 | (pure (close-syntax stx stx 18 | (list-contents 19 | (:: 'define 20 | (:: f 21 | (:: (close-syntax stx stx 22 | (list-contents 23 | (:: 'nflet 24 | (:: (close-syntax stx stx 25 | (list-contents (:: f (:: args (:: body (nil)))))) 26 | (:: f (nil)))))) 27 | (nil)))))))] 28 | [_ (syntax-error '"bad syntax" stx)]))])) 29 | 30 | (export defun) 31 | 32 | -------------------------------------------------------------------------------- /stdlib/list.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (import (shift kernel 1)) 4 | (import (shift "n-ary-app.kl" 1)) 5 | (import (shift "quasiquote.kl" 1)) 6 | 7 | (import "n-ary-app.kl") 8 | (import "defun.kl") 9 | 10 | (defun foldr (f base lst) 11 | (case lst 12 | [(:: x xs) 13 | (f x (foldr f base xs))] 14 | [(nil) 15 | base])) 16 | 17 | (defun map (f lst) 18 | (foldr 19 | (lambda (elem accum) (:: (f elem) accum)) 20 | (nil) 21 | lst)) 22 | 23 | (defun filter (predicate lst) 24 | (foldr 25 | (lambda (elem accum) 26 | (if (predicate elem) 27 | (:: elem accum) 28 | accum)) 29 | (nil) 30 | lst)) 31 | 32 | (defun snoc (xs x) 33 | (case xs 34 | [(nil) (:: x (nil))] 35 | [(:: y ys) (:: y (snoc ys x))])) 36 | 37 | (defun reverse (xs) 38 | (case xs 39 | [(nil) (nil)] 40 | [(:: x xs) (snoc (reverse xs) x)])) 41 | 42 | (defun syntax->list (stx) 43 | (syntax-case stx 44 | [() (nil)] 45 | [(cons x xs) (:: x (syntax->list xs))])) 46 | 47 | (defun list->syntax (xs0 stx) 48 | (case xs0 49 | [(nil) 50 | (empty-list-syntax stx)] 51 | [(:: x xs) 52 | (cons-list-syntax x 53 | (list->syntax xs stx) 54 | stx)])) 55 | 56 | 57 | (define-macros 58 | ([list 59 | (lambda (stx) 60 | (syntax-case stx 61 | [(cons _ more) 62 | (syntax-case more 63 | [() 64 | (pure (replace-loc more '(nil)))] 65 | [(cons x xs) 66 | (pure (quasiquote/loc more (:: ,x ,(cons-list-syntax 'list xs xs))))])]))])) 67 | 68 | (export List nil :: foldr map filter snoc reverse syntax->list list->syntax list) 69 | -------------------------------------------------------------------------------- /stdlib/n-ary-app.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -- N-ary function abstraction and application 4 | 5 | [import [shift kernel 1]] 6 | 7 | (define-macros 8 | ([if 9 | (lambda (stx) 10 | (syntax-case stx 11 | [(list (_ c t f)) 12 | (pure 13 | (list-syntax 14 | ('case c 15 | (list-syntax ['(true) t] t) 16 | (list-syntax ['(false) f] f)) 17 | stx))]))])) 18 | 19 | [define-macros 20 | -- (my-app f foo bar baz) => (((f foo) bar) baz) 21 | ([my-app 22 | [lambda [stx] 23 | (syntax-case stx 24 | [[cons _ fun-and-args] 25 | (syntax-case fun-and-args 26 | [[cons fun args] 27 | (syntax-case args 28 | [() [pure fun]] 29 | [[cons arg0 more-args] 30 | [pure 31 | [cons-list-syntax 32 | 'my-app 33 | [cons-list-syntax 34 | [list-syntax ['#%app fun arg0] stx] 35 | more-args 36 | stx] 37 | stx]]])])])]] 38 | -- (my-lam (x y z) body 39 | -- => 40 | -- (lambda (x) 41 | -- (lambda (y) 42 | -- (lambda (z) 43 | -- body))) 44 | [my-lam 45 | [lambda [stx] 46 | (syntax-case stx 47 | [[list [_ args body]] 48 | (syntax-case args 49 | [() [pure body]] 50 | [[cons arg0 more-args] 51 | [pure [list-syntax ['lambda 52 | [list-syntax [arg0] arg0] 53 | [list-syntax ['my-lam more-args body] stx]] 54 | stx]]] 55 | [[list [arg]] 56 | [pure [list-syntax ['lambda args body] stx]]])])]])] 57 | 58 | [define-macros 59 | -- (f foo bar baz) => (my-app foo bar baz) 60 | ([#%app 61 | [lambda [stx] 62 | (syntax-case stx 63 | [[cons _ args] 64 | [pure [cons-list-syntax 'my-app args stx]]])]])] 65 | 66 | [define-macros 67 | -- (lambda (x y z) ...) => (my-lam (x y z) ...) 68 | ([lambda 69 | [lambda [stx] 70 | (syntax-case stx 71 | [[list [_ args body]] 72 | [pure [list-syntax ['my-lam args body] stx]]])]])] 73 | 74 | (define-macros 75 | -- (my-flet [name (arg more-args ...) 76 | -- def] 77 | -- body) 78 | -- => 79 | -- (flet [name (arg) 80 | -- (lambda (more-args ...) def)] 81 | -- body) 82 | ([my-flet 83 | (lambda (stx) 84 | (syntax-case stx 85 | [(list (_ fun body)) 86 | (syntax-case fun 87 | [(list (name args def)) 88 | (syntax-case args 89 | [(cons arg more-args) 90 | (pure (list-syntax 91 | ('flet 92 | (list-syntax (name 93 | (list-syntax (arg) stx) 94 | (list-syntax ('lambda more-args def) stx)) 95 | stx) 96 | body) 97 | stx))])])]))])) 98 | 99 | (define-macros 100 | -- (my-arrow foo bar baz) => (-> foo (-> bar baz)) 101 | ([my-arrow (lambda (stx) 102 | (syntax-case stx 103 | [(cons _ args) 104 | (syntax-case args 105 | [(list (arg1 arg2)) 106 | (pure (list-syntax ('-> arg1 arg2) 107 | stx))] 108 | [(list (arg1)) 109 | (pure (list-syntax ('-> arg1) 110 | stx))] 111 | [(cons arg1 args) 112 | (pure (list-syntax ('-> arg1 113 | (cons-list-syntax 'my-arrow args stx)) 114 | stx))] 115 | [() 116 | (pure '(->))])] 117 | [_ 118 | (pure '(->))]))])) 119 | 120 | (export (rename ([my-arrow ->]) my-arrow)) 121 | (export (rename ([my-flet flet]) my-flet)) 122 | (export if #%app lambda) 123 | -------------------------------------------------------------------------------- /stdlib/optional-parens.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | -- Allow e.g. unit instead of (unit) 4 | 5 | [import [shift kernel 1]] 6 | 7 | (meta 8 | (define optional-parens 9 | (lambda (symbol) 10 | (lambda (stx) 11 | (case (open-syntax stx) 12 | [(identifier-contents x) 13 | (pure (((close-syntax stx) stx) (list-contents (:: symbol (nil)))))] 14 | [(list-contents (:: _ args)) 15 | (pure (((close-syntax stx) stx) (list-contents (:: symbol args))))]))))) 16 | 17 | -- TODO: wrap 'datatype' so that parentheses are also optional for 18 | -- the nullary types and constructors it creates 19 | (define-macros 20 | ([my-Syntax (optional-parens 'Syntax)] 21 | [my-Integer (optional-parens 'Integer)] 22 | [my-Macro (optional-parens 'Macro)] 23 | [my-Type (optional-parens 'Type)] 24 | [my-String (optional-parens 'String)] 25 | [my-IO (optional-parens 'IO)] 26 | [my-ScopeAction (optional-parens 'ScopeAction)] 27 | [my-flip (optional-parens 'flip)] 28 | [my-add (optional-parens 'add)] 29 | [my-remove (optional-parens 'remove)] 30 | [my-Unit (optional-parens 'Unit)] 31 | [my-unit (optional-parens 'unit)] 32 | [my-Bool (optional-parens 'Bool)] 33 | [my-true (optional-parens 'true)] 34 | [my-false (optional-parens 'false)] 35 | [my-Problem (optional-parens 'Problem)] 36 | [my-module (optional-parens 'module)] 37 | [my-declaration (optional-parens 'declaration)] 38 | [my-type (optional-parens 'type)] 39 | [my-pattern (optional-parens 'pattern)] 40 | [my-type-pattern (optional-parens 'type-pattern)] 41 | [my-Maybe (optional-parens 'Maybe)] 42 | [my-nothing (optional-parens 'nothing)] 43 | [my-List (optional-parens 'List)] 44 | [my-nil (optional-parens 'nil)] 45 | [my-Syntax-Contents (optional-parens 'Syntax-Contents)] 46 | [my-Output-Port (optional-parens 'Output-Port)])) 47 | 48 | (export (rename ([my-Syntax Syntax] 49 | [my-Integer Integer] 50 | [my-Macro Macro] 51 | [my-Type Type] 52 | [my-String String] 53 | [my-IO IO] 54 | [my-ScopeAction ScopeAction] [my-flip flip] [my-add add] [my-remove remove] 55 | [my-Unit Unit] [my-unit unit] 56 | [my-Bool Bool] [my-true true] [my-false false] 57 | [my-Problem Problem] [my-module module] [my-declaration declaration] [my-type type] [my-pattern pattern] [my-type-pattern type-pattern] 58 | [my-Maybe Maybe] [my-nothing nothing] 59 | [my-List List] [my-nil nil] 60 | [my-Syntax-Contents Syntax-Contents] 61 | [my-Output-Port Output-Port]) 62 | my-Syntax 63 | my-Integer 64 | my-Macro 65 | my-Type 66 | my-String 67 | my-IO 68 | my-ScopeAction my-flip my-add my-remove 69 | my-Unit my-unit 70 | my-Bool my-true my-false 71 | my-Maybe my-nothing 72 | my-List my-nil 73 | my-Syntax-Contents 74 | my-Output-Port)) 75 | -------------------------------------------------------------------------------- /stdlib/prelude.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | (import "defun.kl") 4 | (import "n-ary-app.kl") 5 | (import "optional-parens.kl") 6 | (import "quasiquote.kl") 7 | 8 | (defun id (x) x) 9 | (define const (lambda (x y) x)) 10 | (define compose (lambda (f g x) (f (g x)))) 11 | 12 | -- When adding an export to this file, please remember to add a corresponding 13 | -- entry to "examples/primitives-documentation.kl", so that we at least have 14 | -- its type signature as a bare minimum form of documentation. 15 | (export -- primitive module macros 16 | #%module 17 | 18 | -- primitive declaration macros 19 | define 20 | datatype 21 | define-macros 22 | example 23 | run 24 | import 25 | export 26 | meta 27 | group 28 | 29 | -- primitive types 30 | Syntax open-syntax close-syntax 31 | -> 32 | Integer + - * / abs negate > >= < <= = /= integer->string 33 | Macro 34 | Type 35 | String string-append substring string-length 36 | string=? string/=? string? string>=? 37 | string-upcase string-downcase string-titlecase string-foldcase 38 | IO pure-IO bind-IO 39 | 40 | -- primitive datatypes 41 | ScopeAction flip add remove 42 | Unit unit 43 | Bool true false 44 | Problem module declaration type expression pattern type-pattern 45 | Maybe nothing just 46 | List nil :: 47 | Syntax-Contents list-contents integer-contents string-contents identifier-contents 48 | 49 | -- primitive expression macros 50 | error 51 | the 52 | let 53 | flet 54 | lambda 55 | #%app 56 | #%integer-literal 57 | #%string-literal 58 | pure 59 | >>= 60 | syntax-error 61 | bound-identifier=? 62 | free-identifier=? 63 | quote 64 | ident-syntax 65 | empty-list-syntax 66 | cons-list-syntax 67 | list-syntax 68 | integer-syntax 69 | string-syntax 70 | replace-loc 71 | syntax-case 72 | let-syntax 73 | log 74 | make-introducer 75 | which-problem 76 | case 77 | type-case 78 | 79 | -- primitive patterns 80 | else 81 | 82 | -- primitive universal macros 83 | with-unknown-type 84 | 85 | -- non-primitive declaration macros 86 | defun 87 | 88 | -- non-primitive expression macros 89 | unquote 90 | quasiquote 91 | quasiquote/loc 92 | 93 | -- non-primitive expressions 94 | if 95 | id 96 | const 97 | compose 98 | 99 | -- IO primitives 100 | Output-Port 101 | stdout 102 | write) 103 | -------------------------------------------------------------------------------- /stdlib/quasiquote.kl: -------------------------------------------------------------------------------- 1 | #lang kernel 2 | 3 | [import [shift kernel 1]] 4 | [import [shift "n-ary-app.kl" 1]] 5 | [import [shift "defun.kl" 1]] 6 | 7 | (meta 8 | (defun map-syntax (f stx) 9 | (syntax-case stx 10 | [() stx] 11 | [(cons a d) 12 | (cons-list-syntax (f a) (map-syntax f d) stx)] 13 | [_ stx]))) 14 | 15 | [define-macros 16 | ([unquote 17 | [lambda (stx) 18 | (syntax-error [quote "unquote used out of context"] stx)]] 19 | [quasiquote 20 | [lambda (stx) 21 | (syntax-case stx 22 | [[list [_ e]] 23 | (syntax-case e 24 | [[ident x] 25 | [pure [list-syntax [[quote quote] x] 26 | x]]] 27 | [[integer int] 28 | [pure [list-syntax [[quote quote] (integer-syntax int e)] 29 | e]]] 30 | [[string str] 31 | [pure [list-syntax [[quote quote] (string-syntax str e)] 32 | e]]] 33 | [() 34 | [pure 35 | [list-syntax [[quote empty-list-syntax] 36 | [list-syntax [[quote quote] 37 | e] 38 | 'here]] 39 | e]]] 40 | [[cons x y] 41 | (syntax-case x 42 | [[ident i] 43 | [>>= [free-identifier=? i [quote unquote]] 44 | [lambda [unquote?] 45 | [if unquote? 46 | (syntax-case y 47 | [[list [v]] [pure v]] 48 | [_ (syntax-error '"wrong number of arguments to unquote" e)]) 49 | [pure 50 | (list-syntax ('list-syntax 51 | (map-syntax (lambda (s) 52 | (list-syntax ('quasiquote s) 53 | s)) 54 | e) 55 | (list-syntax ('quote e) 'foo)) 56 | e)]]]]] 57 | [_ [pure 58 | (list-syntax ('list-syntax 59 | (map-syntax (lambda (s) 60 | (list-syntax ('quasiquote s) s)) 61 | e) 62 | (list-syntax ('quote e) 'foo)) 63 | e)]])])] 64 | [_ (syntax-error [list-syntax [[quote "bad syntax"] stx] stx] stx)])]])] 65 | 66 | (define-macros 67 | ([quasiquote/loc 68 | (lambda (stx) 69 | (syntax-case stx 70 | [(list (_ loc q)) 71 | (pure (list-syntax ('replace-loc loc (list-syntax ('quasiquote q) stx)) stx))]))])) 72 | 73 | (export unquote quasiquote quasiquote/loc) 74 | -------------------------------------------------------------------------------- /tests/Golden.hs: -------------------------------------------------------------------------------- 1 | -- make sure we don't accidentally change the result of any of the examples in 2 | -- the 'examples' folder. 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | 8 | module Golden where 9 | 10 | import Control.Lens hiding (argument) 11 | import Control.Monad.Catch (bracket) 12 | import Control.Monad 13 | import Control.Monad.IO.Class 14 | import Control.Monad.Trans.Writer (WriterT, execWriterT, tell) 15 | import Data.Foldable (for_) 16 | import Data.Text.Lazy (Text) 17 | import qualified Data.Text.Lazy as T 18 | import System.FilePath (replaceExtension, takeBaseName) 19 | import Test.Tasty (TestTree, testGroup) 20 | import Test.Tasty.Golden (findByExtension, goldenVsStringDiff) 21 | import qualified Data.HashMap.Strict as HM 22 | import qualified Data.Text.Lazy as Text 23 | import qualified Data.Text.Lazy.Encoding as TE 24 | import System.IO (Handle, openFile, hClose, IOMode(WriteMode)) 25 | import System.IO.Silently (hCapture_) 26 | import System.Directory 27 | 28 | import Evaluator 29 | import Expander 30 | import Expander.Monad 31 | import ModuleName 32 | import Pretty 33 | import World 34 | 35 | 36 | mkGoldenTests :: IO TestTree 37 | mkGoldenTests = do 38 | klisterFiles <- findByExtension [".kl"] "examples" 39 | return $ testGroup "Golden tests" 40 | [ let actual = execWriterT $ runExamples file 41 | in goldenVsStringDiff testName diffCmd goldenFile (TE.encodeUtf8 <$> actual) 42 | | file <- klisterFiles 43 | , let testName = takeBaseName file 44 | , let goldenFile = replaceExtension file ".golden" 45 | ] 46 | 47 | diffCmd :: FilePath -> FilePath -> [String] 48 | diffCmd goldenFile actualFile = ["diff", "-u", goldenFile, actualFile] 49 | 50 | runExamples :: FilePath -> WriterT Text IO () 51 | runExamples file = do 52 | -- We want to capture whatever the test writes to Klister's stdout without 53 | -- accidentally capturing what the test harness writes to Haskell's stdout. 54 | -- Here we create a Handle which is distinct from Haskell's stdout. Below, we 55 | -- use 'hCapture_' to replace it with a handle to which we can actually 56 | -- write, not /dev/null. 57 | bracket (liftIO $ openFile "/dev/null" WriteMode) 58 | (liftIO . hClose) 59 | $ \magicHandle -> do 60 | expandFile magicHandle file >>= \case 61 | 62 | -- if we had an error or an expected failure then report it. Tasty-golden 63 | -- will track the failure 64 | Left err -> prettyTellLn err 65 | 66 | -- a normal test so all good 67 | Right (moduleName, result) -> 68 | case HM.lookup moduleName (view worldEvaluated (view expanderWorld result)) of 69 | Nothing -> fail "Internal error: module not evaluated" 70 | Just results -> do 71 | -- Show just the results of evaluation in the module the user 72 | -- asked to run 73 | for_ results $ 74 | \case 75 | (ExampleResult _ _ _ tp val) -> do 76 | prettyTell val 77 | tell " : " 78 | prettyTellLn tp 79 | (IOResult io) -> do 80 | output <- liftIO $ hCapture_ [magicHandle] io 81 | tell (T.pack output) 82 | 83 | expandFile :: Handle -> FilePath -> WriterT Text IO (Either ExpansionErr (ModuleName, ExpanderState)) 84 | expandFile magicHandle file = do 85 | moduleName <- liftIO $ moduleNameFromPath file 86 | ctx <- liftIO $ getCurrentDirectory >>= mkInitContext moduleName 87 | void $ liftIO $ execExpand ctx (initializeKernel magicHandle) 88 | liftIO $ fmap (moduleName,) <$> execExpand ctx (visit moduleName >> getState) 89 | 90 | prettyTell :: Pretty ann a 91 | => a -> WriterT Text IO () 92 | prettyTell = tell . Text.fromStrict . pretty 93 | 94 | prettyTellLn :: Pretty ann a 95 | => a -> WriterT Text IO () 96 | prettyTellLn = tell . (<> "\n") . Text.fromStrict . pretty 97 | -------------------------------------------------------------------------------- /tests/MiniTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Tiny module to hold mini-test strings. Some mini-test strings are split 4 | -- strings which conflict with the CPP pragma. See 5 | -- https://downloads.haskell.org/ghc/latest/docs/users_guide/phases.html#cpp-and-string-gaps 6 | 7 | module MiniTests where 8 | 9 | import Data.Text 10 | 11 | trivialUserMacro :: Text 12 | trivialUserMacro = "[let-syntax \n\ 13 | \ [m [lambda [_] \n\ 14 | \ [pure [quote [lambda [x] x]]]]] \n\ 15 | \ m]" 16 | 17 | letMacro :: Text 18 | letMacro = "[let-syntax \n\ 19 | \ [let1 [lambda [stx] \n\ 20 | \ (syntax-case stx \n\ 21 | \ [[list [_ binder body]] \n\ 22 | \ (syntax-case binder \n\ 23 | \ [[list [x e]] \n\ 24 | \ {- [[lambda [x] body] e] -} \n\ 25 | \ [pure [list-syntax \n\ 26 | \ [[list-syntax \n\ 27 | \ [[ident-syntax 'lambda stx] \n\ 28 | \ [list-syntax [x] stx] \n\ 29 | \ body] \n\ 30 | \ stx] \n\ 31 | \ e] \n\ 32 | \ stx]]])])]] \n\ 33 | \ [let1 [x [lambda [x] x]] \n\ 34 | \ x]]" 35 | 36 | unboundVarLet :: Text 37 | unboundVarLet = "[let-syntax \ 38 | \ [m [lambda [_] \ 39 | \ [pure [quote [lambda [x] x]]]]] \ 40 | \ anyRandomWord]" 41 | --------------------------------------------------------------------------------