├── .github └── workflows │ └── main.yml ├── .gitignore ├── .hlint.yaml ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── app └── Main.hs ├── benchmarks └── parser │ └── Main.hs ├── builtin └── Builtin.vix ├── fourmolu.yaml ├── package.yaml ├── rts ├── Sixten.Builtin.c ├── Sixten.Builtin.ll ├── main.ll ├── memory.c └── memory.h ├── src ├── Boxity.hs ├── Builtin.hs ├── ClosureConversion.hs ├── ClosureConverted │ ├── Context.hs │ ├── Domain.hs │ ├── Evaluation.hs │ ├── Readback.hs │ ├── Representation.hs │ ├── Syntax.hs │ └── TypeOf.hs ├── Command │ ├── BenchmarkProjectGenerator.hs │ ├── Check.hs │ ├── Compile.hs │ ├── Run.hs │ └── Watch.hs ├── Compiler.hs ├── Core │ ├── Binding.hs │ ├── Bindings.hs │ ├── Domain.hs │ ├── Domain │ │ ├── Pattern.hs │ │ ├── Showable.hs │ │ └── Telescope.hs │ ├── Evaluation.hs │ ├── Pretty.hs │ ├── Readback.hs │ ├── Syntax.hs │ ├── TypeOf.hs │ └── Zonking.hs ├── Data │ ├── IntSeq.hs │ ├── OrderedHashMap.hs │ ├── OrderedHashSet.hs │ └── Tsil.hs ├── Driver.hs ├── Elaboration.hs ├── Elaboration.hs-boot ├── Elaboration │ ├── Clauses.hs │ ├── Context.hs │ ├── Context │ │ └── Type.hs │ ├── Depth.hs │ ├── Equation.hs │ ├── Matching.hs │ ├── Matching │ │ └── SuggestedName.hs │ ├── Meta.hs │ ├── MetaInlining.hs │ ├── Postponed.hs │ ├── Unification.hs │ ├── Unification.hs-boot │ └── ZonkPostponedChecks.hs ├── Environment.hs ├── Error.hs ├── Error │ ├── Hydrated.hs │ └── Parsing.hs ├── Extra.hs ├── FileSystem.hs ├── Flexibility.hs ├── Index.hs ├── Index │ ├── Map.hs │ └── Seq.hs ├── Inlining.hs ├── LambdaLifted │ └── Syntax.hs ├── LambdaLifting.hs ├── LanguageServer.hs ├── LanguageServer │ ├── CodeLens.hs │ ├── Completion.hs │ ├── CursorAction.hs │ ├── DocumentHighlights.hs │ ├── GoToDefinition.hs │ ├── Hover.hs │ ├── LineColumns.hs │ └── References.hs ├── Lexer.hs ├── Literal.hs ├── Low │ ├── PassBy.hs │ ├── Pretty.hs │ ├── Representation.hs │ └── Syntax.hs ├── LowToLLVM.hs ├── Lower.hs ├── Meta.hs ├── Module.hs ├── Monad.hs ├── Name.hs ├── Occurrences.hs ├── Occurrences │ └── Intervals.hs ├── Orphans.hs ├── Parser.hs ├── Plicity.hs ├── Position.hs ├── Postponement.hs ├── Project.hs ├── Query.hs ├── Query │ └── Mapped.hs ├── ReferenceCounting.hs ├── Resolution.hs ├── Rules.hs ├── Scope.hs ├── Span.hs ├── Surface │ └── Syntax.hs ├── Telescope.hs ├── UTF16.hs ├── UTF8.hs └── Var.hs ├── stack.yaml └── tests ├── Main.hs ├── compilation ├── boxed-data.vix ├── const.vix ├── factorial.vix ├── fibonacci.vix ├── identity.vix ├── list-generation.vix ├── maybe.vix ├── printint.vix ├── triangular-number.vix └── unboxed-data.vix ├── multis └── imports │ ├── Alias.vix │ ├── Cyclic1.vix │ ├── Cyclic2.vix │ ├── ImportExposing.vix │ ├── Lib.vix │ ├── LibExposingAll.vix │ ├── SelfImport.vix │ └── Simple.vix ├── singles ├── parsing │ ├── ExposingNone.vix │ ├── ModuleHeader.vix │ ├── app.vix │ ├── boxity.vix │ ├── case.vix │ ├── clauses.vix │ ├── data-adt.vix │ ├── data-multi-param.vix │ ├── data-multi.vix │ ├── data.vix │ ├── empty.vix │ ├── error.vix │ ├── fun.vix │ ├── implicit-apps.vix │ ├── implicit-data-param.vix │ ├── implicit-lams.vix │ ├── implicit-pi.vix │ ├── int-literals.vix │ ├── lambda-patterns.vix │ ├── lambda.vix │ ├── let-clauses.vix │ ├── let-mutually-recursive.vix │ ├── let-recursive.vix │ ├── let.vix │ ├── only-comments.vix │ ├── pi.vix │ ├── pis.vix │ ├── type-annotation.vix │ ├── unicode.vix │ └── wildcard.vix ├── resolution │ ├── ModuleFileMismatch.vix │ ├── QualifiedLocalModule.vix │ ├── duplicate-name.vix │ ├── duplicate-name2.vix │ ├── import-not-found.vix │ ├── not-in-scope.vix │ └── type-after-def.vix └── type-checking │ ├── OhNo.vix │ ├── absurd-conversion.vix │ ├── agda-1079.vix │ ├── agda-1387.vix │ ├── agda-2099.vix │ ├── ambiguous-constructor-in-pattern.vix │ ├── ambiguous-name.vix │ ├── any.vix │ ├── app-lambda.vix │ ├── array-append-tuple.vix │ ├── array-append.vix │ ├── case-coverage-propagation.vix │ ├── case-empty.vix │ ├── case-equality.vix │ ├── case-inversion.vix │ ├── case-list-map.vix │ ├── case-non-exhaustive.vix │ ├── case-non-linear-pattern-scrutinee.vix │ ├── case-non-pattern-scrutinee.vix │ ├── case-of-global.vix │ ├── case-of-meta.vix │ ├── case-overlap.vix │ ├── case-pattern-scrutinee.vix │ ├── case-plicity-mismatch.vix │ ├── case-use-scrutinee.vix │ ├── check-applied-case.vix │ ├── clauses-list-map.vix │ ├── clauses-list-zipwith.vix │ ├── clauses-mismatch.vix │ ├── constructor-overloading.vix │ ├── data-constructor-return.vix │ ├── data-list.vix │ ├── data-maybe.vix │ ├── data-overloading.vix │ ├── data-pair.vix │ ├── data-recursive.vix │ ├── evaluate-applied-case.vix │ ├── fcif.vix │ ├── global-equality-recursive.vix │ ├── global-equality.vix │ ├── global-equality2.vix │ ├── gluing.vix │ ├── id250-implicit.vix │ ├── id250.vix │ ├── implicit-aliased-lams.vix │ ├── implicit-apps.vix │ ├── implicit-constructor-args.vix │ ├── implicit-constructor-fields.vix │ ├── implicit-data-param.vix │ ├── implicit-lams.vix │ ├── implicit-map.vix │ ├── impredicative-polymorphism-error.vix │ ├── impredicative-polymorphism.vix │ ├── inductive-families │ ├── fin-add.vix │ ├── fin.vix │ ├── forced.vix │ ├── impossible.vix │ ├── propositional-equality.vix │ ├── vector-append.vix │ └── vector.vix │ ├── let-mutually-recursive-stress.vix │ ├── let-mutually-recursive.vix │ ├── let-recursive.vix │ ├── local-gluing.vix │ ├── matching-circularity.vix │ ├── mismatch.vix │ ├── mutually-recursive-definitions.vix │ ├── occurs-check.vix │ ├── occurs-check2.vix │ ├── pair-stress.vix │ ├── polymorphic-variable-inference.vix │ ├── propagation.vix │ ├── record.vix │ ├── record2.vix │ ├── singleton.vix │ ├── type-evaluation.vix │ ├── unsolved-meta.vix │ └── vector-stress.vix └── todo ├── circular.vix ├── parse-recovery.vix └── typeless-clauses.vix /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: [push] 4 | 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | 9 | steps: 10 | - uses: actions/checkout@v1 11 | 12 | - name: Cache .stack 13 | uses: actions/cache@v1 14 | with: 15 | path: ~/.stack 16 | key: ${{ runner.OS }}-stack-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} 17 | restore-keys: | 18 | ${{ runner.OS }}-stack- 19 | 20 | - name: Install LLVM and Clang 21 | uses: KyleMayes/install-llvm-action@v1 22 | with: 23 | version: "17.0" 24 | 25 | - name: Add ~/.local/bin to PATH 26 | run: echo "$HOME/.local/bin" >> $GITHUB_PATH 27 | 28 | - name: Setup Stack 29 | run: stack setup 30 | 31 | - name: Build dependencies 32 | run: stack test --dependencies-only --fast 33 | 34 | - name: Build 35 | run: stack test --no-run-tests --fast 36 | 37 | - name: Run tests 38 | run: stack test --fast 39 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | sixty.cabal 2 | .stack-work 3 | tags 4 | stack.yaml.lock 5 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: Use hierarchical imports} 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Olle Fredriksson (c) 2019-2024 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Olle Fredriksson nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | RELEASE ?= 0 2 | STACK := stack 3 | STACK_BENCH := $(STACK) build --bench --test --no-run-tests 4 | STACK_TEST := $(STACK) build --bench --test --no-run-benchmarks 5 | ifneq ($(RELEASE), 1) 6 | STACK_TEST += --fast 7 | endif 8 | STACK_BUILD := $(STACK_TEST) --no-run-tests 9 | STACK_INSTALL := $(STACK_BUILD) --copy-bins 10 | HASKELL_SOURCE_DIRECTORIES = $$(yq -r '.. | .["source-dirs"]? | select(. != null)' package.yaml) 11 | HASKELL_SOURCE_FILES = $$(find $(HASKELL_SOURCE_DIRECTORIES) -name "*.hs*") 12 | 13 | .PHONY: install 14 | install: 15 | $(STACK_INSTALL) 16 | 17 | .PHONY: test 18 | test: 19 | $(STACK_TEST) 20 | 21 | .PHONY: watch-test 22 | watch-test: 23 | $(STACK) exec --package ghcid -- ghcid \ 24 | --command="stack ghci sixty:lib sixty:test:test-sixty --test --ghci-options=-fno-break-on-exception --ghci-options=-fno-break-on-error --ghci-options=-v1 --ghci-options=-ferror-spans --ghci-options=-j" \ 25 | --test="Main.main" 26 | 27 | .PHONY: install-profile 28 | install-profile: 29 | $(STACK_INSTALL) --profile 30 | 31 | .PHONY: profile-tests 32 | profile-tests: 33 | $(STACK_TEST) --profile 34 | $(STACK) exec --package ghc-prof-flamegraph -- ghc-prof-flamegraph test-sixty.prof 35 | 36 | .PHONY: profile-bench 37 | bench: 38 | $(STACK_BENCH) 39 | 40 | .PHONY: profile-bench 41 | profile-bench: 42 | $(STACK_BENCH) --profile 43 | $(STACK) exec --package ghc-prof-flamegraph -- ghc-prof-flamegraph benchmark-parser.prof 44 | 45 | .PHONY: ddump-simpl 46 | ddump-simpl: 47 | $(STACK_BUILD) --ghc-options='-ddump-simpl -ddump-to-file' 48 | 49 | .PHONY: ghcid 50 | ghcid: 51 | $(STACK) exec --package ghcid -- ghcid 52 | 53 | .PHONY: lint 54 | lint: hlint weeder 55 | 56 | .PHONY: hlint 57 | hlint: 58 | $(STACK) exec --package hlint -- hlint . 59 | 60 | .PHONY: weeder 61 | weeder: 62 | $(STACK) exec --package weeder -- weeder 63 | 64 | .PHONY: format 65 | format: 66 | stack exec --package fourmolu -- fourmolu --mode inplace $(HASKELL_SOURCE_FILES) 67 | 68 | .PHONY: check-format 69 | check-format: 70 | stack exec --package fourmolu -- fourmolu --mode check $(HASKELL_SOURCE_FILES) 71 | 72 | .PHONY: debug 73 | debug: 74 | llvm-as out/program.ll -o out/program.bc 75 | gdb --quiet -ex "b initCloneLookups" -ex "r" --args lli -jit-kind=mcjit out/program.bc 76 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sixty ![](https://github.com/ollef/sixty/workflows/Tests/badge.svg) 2 | 3 | A type checker for a dependent type theory using normalisation by evaluation, 4 | with an eye on performance. 5 | Might go into [Sixten](https://github.com/ollef/sixten) one day. 6 | 7 | ## Roadmap 8 | 9 | - [x] Surface syntax 10 | - [x] Core syntax 11 | - [x] Safe and fast phantom typed De Bruijn indices 12 | - [x] Evaluation 13 | - [x] Inlining of globals 14 | - [x] Readback 15 | - [x] Parsing 16 | - [x] Indentation-sensitivity 17 | - [x] Pretty printing 18 | - [x] Scope-aware name printing 19 | - [x] Unification and meta variables 20 | - [x] Pruning 21 | - [x] The "same meta variable" intersection rule 22 | - [x] Solution inlining 23 | - [x] Elaboration of meta variable solutions to local definitions 24 | - [x] Case expression inversion 25 | - [x] Basic type checking 26 | - [x] Elaboration postponement ("impredicative polymorphism" inference) 27 | - [x] Lazily written solutions 28 | - [x] Approximate polymorphic variable inference 29 | - [x] Query architecture 30 | - [x] Parallel type checking 31 | - [x] Simple modules 32 | - [x] Top-level definitions 33 | - [x] Name resolution 34 | - [x] Imports 35 | - [x] Tests 36 | - [x] Error tests 37 | - [x] Multi-module tests 38 | - [x] Position-independent implicit arguments 39 | - [x] Errors 40 | - [x] Source location tracking 41 | - [x] Meta variable locations 42 | - [x] Error recovery during 43 | - [x] Parsing 44 | - [x] Elaboration 45 | - [x] Unification 46 | - [ ] Print the context and let-bound variables (including metas) 47 | - [x] Data 48 | - [x] Elaboration of data definitions 49 | - [x] Constructors 50 | - [x] Type-based overloading 51 | - [x] ADT-style data definitions 52 | - [x] Pattern matching elaboration 53 | - [x] Case expressions 54 | - [x] Exhaustiveness check 55 | - [x] Redundant pattern check 56 | - [x] Clause elaboration 57 | - [x] Pattern lambdas 58 | - [x] Smart case 59 | - [x] Inductive families 60 | - [x] Glued evaluation 61 | - [x] Let definitions by clauses 62 | - [x] Mutually recursive lets 63 | - [x] Command-line parser 64 | - [x] Language server 65 | - [x] Diagnostics 66 | - [x] Hover 67 | - [ ] Print the context and let-bound variables (including metas) 68 | - [x] Jump to definition 69 | - [x] Multi file projects 70 | - [x] Reverse dependency tracking 71 | - [x] Completion 72 | - [x] Type-based refinement completion snippets 73 | - [x] Find references 74 | - [x] Renaming 75 | - [x] Code lenses 76 | - [ ] Language server tests 77 | - [x] File watcher 78 | - [ ] Cached builds 79 | - [ ] Per-module caches 80 | - [ ] Backend 81 | - [x] Typed lambda lifting 82 | - [ ] Recursive let bindings 83 | - [x] Typed closure conversion 84 | - [ ] Code generation 85 | - [x] Basics 86 | - [ ] Closures 87 | - [x] Precise, moving garbage collector 88 | - [x] Cheney's two-space algorithm 89 | - [ ] Generational GC 90 | - [ ] Extern code 91 | - [ ] Prevent CBV-incompatible circular values 92 | - [ ] Literals 93 | - [x] Numbers 94 | - [ ] Strings 95 | - [ ] Records 96 | - [ ] Binary/mixfix operators 97 | - [ ] REPL 98 | - [ ] Integrate into Sixten 99 | 100 | ## Inspiration 101 | 102 | * András Kovács' [smalltt](https://github.com/AndrasKovacs/smalltt) and [work on Dhall](https://discourse.dhall-lang.org/t/nbe-type-checking-conversion-checking/55) 103 | * Thierry Coquand's [semantic type checking](http://www.cse.chalmers.se/~coquand/type.ps) 104 | * Danny Gratzer's [nbe-for-mltt](https://github.com/jozefg/nbe-for-mltt) 105 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/parser/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import qualified Data.Text as Text 7 | import qualified Gauge 8 | import qualified Lexer 9 | import qualified Parser 10 | import Prettyprinter 11 | import Protolude 12 | import System.Directory 13 | import System.FilePath 14 | 15 | main :: IO () 16 | main = do 17 | singlesDirectory <- canonicalizePath "tests/singles" 18 | multisDirectory <- canonicalizePath "tests/multis" 19 | singleFiles <- listDirectoryRecursive isSourceFile singlesDirectory 20 | multiFiles <- listDirectoriesWithFilesMatching isSourceFile multisDirectory 21 | let files = 22 | singleFiles <> concatMap snd multiFiles 23 | -- ["lol.vix"] 24 | Gauge.defaultMain 25 | [ Gauge.BenchGroup 26 | file 27 | [ -- Gauge.bench "read file" $ Gauge.nfAppIO readFile file 28 | -- , Gauge.env (readFile file) $ Gauge.bench "lex" . Gauge.nf Lexer.lexText 29 | -- , Gauge.env (Lexer.lexText <$> readFile file) $ Gauge.bench "parse" . Gauge.whnf (Parser.parseTokens Parser.module_) 30 | -- , 31 | Gauge.env (readFile file) $ Gauge.bench "parse and lex" . Gauge.whnf (Parser.parseTokens Parser.module_ . Lexer.lexText) 32 | ] 33 | | file <- files 34 | ] 35 | texts <- mapM readFile files 36 | putText $ "Lines: " <> show (length $ mconcat $ Text.lines <$> texts) 37 | where 38 | isSourceFile = 39 | (== ".vix") . takeExtension 40 | 41 | listDirectoryRecursive :: (FilePath -> Bool) -> FilePath -> IO [FilePath] 42 | listDirectoryRecursive p dir = do 43 | files <- listDirectory dir 44 | concat 45 | <$> forM files \file -> do 46 | let path = dir file 47 | isDir <- doesDirectoryExist path 48 | if isDir 49 | then listDirectoryRecursive p path 50 | else pure [path | p path] 51 | 52 | listDirectoriesWithFilesMatching 53 | :: (FilePath -> Bool) 54 | -> FilePath 55 | -> IO [(FilePath, [FilePath])] 56 | listDirectoriesWithFilesMatching p dir = do 57 | files <- listDirectory dir 58 | let paths = (dir ) <$> files 59 | if any p paths 60 | then do 61 | recursiveFiles <- listDirectoryRecursive p dir 62 | pure [(dir, recursiveFiles)] 63 | else 64 | concat 65 | <$> forM paths \path -> do 66 | isDir <- doesDirectoryExist path 67 | if isDir 68 | then listDirectoriesWithFilesMatching p path 69 | else pure [] 70 | -------------------------------------------------------------------------------- /builtin/Builtin.vix: -------------------------------------------------------------------------------- 1 | module Sixten.Builtin exposing (Type, Int, addInt, mulInt, subInt, printInt) 2 | 3 | Type : Type 4 | 5 | Int : Type 6 | 7 | unknown : (A : Type) -> A 8 | 9 | data Equals forall (A : Type). (a b : A) where 10 | Refl : Equals a b 11 | 12 | data Unit = Unit 13 | 14 | printInt : Int -> Unit 15 | addInt : Int -> Int -> Int 16 | mulInt : Int -> Int -> Int 17 | subInt : Int -> Int -> Int 18 | 19 | EmptyRepresentation : Type 20 | PointerRepresentation : Type 21 | 22 | maxRepresentation : Type -> Type -> Type 23 | addRepresentation : Type -> Type -> Type 24 | 25 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | record-brace-space: true 3 | indent-wheres: true 4 | respectful: false 5 | haddock-style: single-line 6 | comma-style: leading 7 | import-export-comma-style: leading 8 | function-arrows: leading 9 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: sixty 2 | version: 0.1.0.0 3 | #synopsis: 4 | #description: 5 | homepage: https://github.com/ollef/sixty#readme 6 | license: BSD3 7 | author: Olle Fredriksson 8 | maintainer: fredriksson.olle@gmail.com 9 | copyright: 2019-2024 Olle Fredriksson 10 | category: Language, Compiler 11 | extra-source-files: 12 | - README.md 13 | data-files: 14 | - builtin/Builtin.vix 15 | - rts/Sixten.Builtin.c 16 | - rts/Sixten.Builtin.ll 17 | - rts/main.ll 18 | - rts/memory.c 19 | - rts/memory.h 20 | 21 | ghc-options: 22 | - -Wall 23 | - -Wcompat 24 | - -Widentities 25 | - -Wincomplete-record-updates 26 | - -Wincomplete-uni-patterns 27 | - -Wmissing-home-modules 28 | - -Wpartial-fields 29 | - -Wredundant-constraints 30 | - -Wtabs 31 | - -Wunused-packages 32 | - -funbox-strict-fields 33 | 34 | default-extensions: 35 | - NoImplicitPrelude 36 | 37 | dependencies: 38 | - base >= 4.7 && < 5 39 | - protolude 40 | 41 | library: 42 | source-dirs: src 43 | dependencies: 44 | - aeson 45 | - aeson-casing 46 | - ansi-terminal 47 | - bytestring 48 | - co-log-core 49 | - constraints 50 | - constraints-extras 51 | - containers 52 | - data-default 53 | - dependent-hashmap 54 | - dependent-sum 55 | - dependent-sum-template 56 | - directory 57 | - enummapset 58 | - filepath 59 | - fingertree 60 | - fsnotify 61 | - lens 62 | - lsp 63 | - lifted-async 64 | - lifted-base 65 | - monad-control 66 | - parsers 67 | - prettyprinter 68 | - process 69 | - random 70 | - rock 71 | - stm 72 | - template-haskell 73 | - temporary 74 | - text 75 | - text-rope 76 | - time 77 | - transformers 78 | - transformers-base 79 | - unboxed-ref 80 | - unordered-containers 81 | 82 | executables: 83 | sixty: 84 | source-dirs: app 85 | main: Main.hs 86 | dependencies: 87 | - optparse-applicative 88 | - sixty 89 | - text 90 | ghc-options: -threaded -rtsopts "-with-rtsopts=-N -H -A50m" 91 | 92 | tests: 93 | test-sixty: 94 | main: Main.hs 95 | source-dirs: tests 96 | dependencies: 97 | - directory 98 | - filepath 99 | - prettyprinter 100 | - process 101 | - rock 102 | - sixty 103 | - tasty 104 | - tasty-hunit 105 | - text 106 | - unordered-containers 107 | ghc-options: -threaded -rtsopts "-with-rtsopts=-N -H -A50m" 108 | 109 | benchmarks: 110 | benchmark-parser: 111 | main: Main.hs 112 | source-dirs: benchmarks/parser 113 | dependencies: 114 | - directory 115 | - filepath 116 | - prettyprinter 117 | - sixty 118 | - text 119 | - gauge 120 | ghc-options: -threaded -rtsopts "-with-rtsopts=-N -H -A50m" 121 | -------------------------------------------------------------------------------- /rts/Sixten.Builtin.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | void print_int(int64_t i) { 5 | printf("%" PRId64 "\n", i); 6 | } 7 | -------------------------------------------------------------------------------- /rts/Sixten.Builtin.ll: -------------------------------------------------------------------------------- 1 | 2 | declare void @print_int(i64 %i) 3 | declare void @exit(i32) 4 | 5 | @Sixten.Builtin.Int = unnamed_addr constant i64 8 6 | @Sixten.Builtin.Type = unnamed_addr constant i64 8 7 | @Sixten.Builtin.EmptyRepresentation = unnamed_addr constant i64 0 8 | @Sixten.Builtin.WordRepresentation = unnamed_addr constant i64 8 9 | 10 | define external fastcc i64 @Sixten.Builtin.unknown({ptr, ptr} %destination, i64 %a) { 11 | call void @exit(i32 7411) 12 | unreachable 13 | } 14 | 15 | define external fastcc i64 @Sixten.Builtin.addRepresentation(i64 %a, i64 %b) { 16 | %result = add i64 %a, %b 17 | ret i64 %result 18 | } 19 | 20 | define external fastcc i64 @Sixten.Builtin.maxRepresentation(i64 %a, i64 %b) { 21 | %a_lt_b = icmp ult i64 %a, %b 22 | %result = select i1 %a_lt_b, i64 %b, i64 %a 23 | ret i64 %result 24 | } 25 | 26 | define external fastcc void @Sixten.Builtin.printInt(i64 %i) { 27 | call void @print_int(i64 %i) 28 | ret void 29 | } 30 | 31 | define external fastcc i64 @Sixten.Builtin.addInt(i64 %a, i64 %b) { 32 | %result = add i64 %a, %b 33 | ret i64 %result 34 | } 35 | 36 | define external fastcc i64 @Sixten.Builtin.mulInt(i64 %a, i64 %b) { 37 | %result = mul i64 %a, %b 38 | ret i64 %result 39 | } 40 | 41 | define external fastcc i64 @Sixten.Builtin.subInt(i64 %a, i64 %b) { 42 | %result = sub i64 %a, %b 43 | ret i64 %result 44 | } 45 | -------------------------------------------------------------------------------- /rts/main.ll: -------------------------------------------------------------------------------- 1 | declare fastcc void @.$module_init() 2 | 3 | define i32 @main() { 4 | call fastcc void @.$module_init() 5 | ret i32 0 6 | } 7 | 8 | -------------------------------------------------------------------------------- /rts/memory.c: -------------------------------------------------------------------------------- 1 | #include "memory.h" 2 | 3 | #include 4 | #include 5 | 6 | static const uintptr_t TAG_BITS = 16; 7 | static const uintptr_t TAG_MASK = ((uintptr_t)1 << TAG_BITS) - 1; 8 | 9 | struct header { 10 | uint32_t reference_count; 11 | uint32_t pointers; 12 | }; 13 | 14 | uintptr_t sixten_heap_allocate(uint64_t tag, uint32_t pointers, uint32_t non_pointer_bytes) { 15 | uintptr_t bytes = (uintptr_t)pointers * sizeof(void*) + (uintptr_t)non_pointer_bytes; 16 | uint8_t* pointer = 0; 17 | 18 | if (bytes > 0) { 19 | pointer = calloc(sizeof(struct header) + bytes, 1); 20 | struct header* header = (struct header*)pointer; 21 | *header = (struct header) { 22 | .pointers = pointers, 23 | .reference_count = 1, 24 | }; 25 | pointer += sizeof(struct header); 26 | } 27 | 28 | return (uintptr_t)pointer << TAG_BITS | (uintptr_t)(tag & TAG_MASK); 29 | } 30 | 31 | static uint8_t* heap_object_pointer(uintptr_t heap_object) { 32 | return (uint8_t*)((intptr_t)heap_object >> TAG_BITS); 33 | } 34 | 35 | struct sixten_reference sixten_heap_payload(uintptr_t heap_object) { 36 | uint8_t* pointer = heap_object_pointer(heap_object); 37 | 38 | if (pointer == 0) { 39 | return (struct sixten_reference) { 40 | .pointers = 0, 41 | .non_pointers = 0, 42 | }; 43 | } 44 | 45 | struct header* header = (struct header*)(pointer - sizeof(struct header)); 46 | 47 | return (struct sixten_reference) { 48 | .pointers = (uintptr_t*)pointer, 49 | .non_pointers = pointer + header->pointers * sizeof(void*), 50 | }; 51 | } 52 | 53 | uint64_t sixten_heap_tag(uintptr_t heap_object) { 54 | return (uint64_t)(heap_object & TAG_MASK); 55 | } 56 | 57 | void sixten_copy( 58 | struct sixten_reference dst, 59 | struct sixten_reference src, 60 | uint32_t pointers, 61 | uint32_t non_pointer_bytes 62 | ) { 63 | memcpy(dst.pointers, src.pointers, sizeof(void*) * pointers); 64 | memcpy(dst.non_pointers, src.non_pointers, non_pointer_bytes); 65 | } 66 | 67 | void sixten_increase_reference_count(uintptr_t heap_object) { 68 | uint8_t* pointer = heap_object_pointer(heap_object); 69 | if (pointer == 0) { 70 | return; 71 | } 72 | 73 | struct header* header = (struct header*)(pointer - sizeof(struct header)); 74 | ++header->reference_count; 75 | } 76 | 77 | void sixten_increase_reference_counts(uintptr_t* data, uint32_t count) { 78 | for (uint32_t i = 0; i < count; ++i) { 79 | sixten_increase_reference_count(data[i]); 80 | } 81 | } 82 | 83 | void sixten_decrease_reference_count(uintptr_t heap_object) { 84 | uint8_t* pointer = heap_object_pointer(heap_object); 85 | if (pointer == 0) { 86 | return; 87 | } 88 | 89 | struct header* header = (struct header*)(pointer - sizeof(struct header)); 90 | --header->reference_count; 91 | if (header->reference_count == 0) { 92 | sixten_decrease_reference_counts((uintptr_t*)pointer, header->pointers); 93 | free(header); 94 | } 95 | } 96 | 97 | void sixten_decrease_reference_counts(uintptr_t* data, uint32_t count) { 98 | for (uint32_t i = 0; i < count; ++i) { 99 | sixten_decrease_reference_count(data[i]); 100 | } 101 | } 102 | -------------------------------------------------------------------------------- /rts/memory.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | 3 | #include 4 | 5 | struct sixten_reference { 6 | uintptr_t* pointers; 7 | uint8_t* non_pointers; 8 | }; 9 | 10 | uintptr_t sixten_heap_allocate(uint64_t tag, uint32_t pointers, uint32_t non_pointer_bytes); 11 | struct sixten_reference sixten_heap_payload(uintptr_t heap_object); 12 | uint64_t sixten_heap_tag(uintptr_t heap_object); 13 | void sixten_copy( 14 | struct sixten_reference dst, 15 | struct sixten_reference src, 16 | uint32_t pointers, 17 | uint32_t non_pointer_bytes 18 | ); 19 | void sixten_increase_reference_count(uintptr_t heap_object); 20 | void sixten_increase_reference_counts(uintptr_t* data, uint32_t count); 21 | void sixten_decrease_reference_count(uintptr_t heap_object); 22 | void sixten_decrease_reference_counts(uintptr_t* data, uint32_t count); 23 | -------------------------------------------------------------------------------- /src/Boxity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Boxity where 6 | 7 | import Prettyprinter 8 | import Protolude 9 | 10 | data Boxity 11 | = Unboxed 12 | | Boxed 13 | deriving (Eq, Ord, Show, Generic, Hashable) 14 | 15 | instance Pretty Boxity where 16 | pretty boxity = 17 | case boxity of 18 | Unboxed -> 19 | "unboxed" 20 | Boxed -> 21 | "boxed" 22 | 23 | prettyAnnotation :: Boxity -> Doc ann -> Doc ann 24 | prettyAnnotation boxity = 25 | case boxity of 26 | Unboxed -> 27 | identity 28 | Boxed -> 29 | ("boxed" <+>) 30 | -------------------------------------------------------------------------------- /src/Builtin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | 4 | module Builtin where 5 | 6 | import qualified Core.Domain as Domain 7 | import qualified Core.Syntax as Syntax 8 | import qualified Data.Sequence as Seq 9 | import qualified Data.Tsil as Tsil 10 | import qualified Name 11 | import Plicity 12 | 13 | pattern Module :: Name.Module 14 | pattern Module = 15 | "Sixten.Builtin" 16 | 17 | pattern TypeName :: Name.Qualified 18 | pattern TypeName = 19 | "Sixten.Builtin.Type" 20 | 21 | pattern Type :: Domain.Value 22 | pattern Type = 23 | Domain.Neutral (Domain.Global TypeName) Domain.Empty 24 | 25 | type_ :: Syntax.Term v 26 | type_ = 27 | Syntax.Global TypeName 28 | 29 | pattern UnknownName :: Name.Qualified 30 | pattern UnknownName = 31 | "Sixten.Builtin.unknown" 32 | 33 | pattern Unknown :: Domain.Type -> Domain.Value 34 | pattern Unknown type_ = 35 | Domain.Neutral (Domain.Global UnknownName) (Domain.Apps (Seq.Empty Seq.:|> (Explicit, type_))) 36 | 37 | pattern UnitName :: Name.Qualified 38 | pattern UnitName = 39 | "Sixten.Builtin.Unit" 40 | 41 | unknown :: Syntax.Type v -> Syntax.Term v 42 | unknown = 43 | Syntax.App (Syntax.Global Builtin.UnknownName) Explicit 44 | 45 | pattern EqualsName :: Name.Qualified 46 | pattern EqualsName = 47 | "Sixten.Builtin.Equals" 48 | 49 | pattern Equals 50 | :: Domain.Type 51 | -> Domain.Value 52 | -> Domain.Value 53 | -> Domain.Value 54 | pattern Equals k a b = 55 | Domain.Neutral 56 | (Domain.Global EqualsName) 57 | (Domain.Apps (Seq.Empty Seq.:|> (Implicit, k) Seq.:|> (Explicit, a) Seq.:|> (Explicit, b))) 58 | 59 | equals 60 | :: Syntax.Type v 61 | -> Syntax.Term v 62 | -> Syntax.Term v 63 | -> Syntax.Term v 64 | equals k a b = 65 | Syntax.apps 66 | (Syntax.Global EqualsName) 67 | [(Implicit, k), (Explicit, a), (Explicit, b)] 68 | 69 | pattern ReflName :: Name.QualifiedConstructor 70 | pattern ReflName = 71 | Name.QualifiedConstructor EqualsName "Refl" 72 | 73 | pattern Refl 74 | :: Domain.Type 75 | -> Domain.Value 76 | -> Domain.Value 77 | -> Domain.Value 78 | pattern Refl k a b = 79 | Domain.Con 80 | ReflName 81 | (Tsil.Empty Tsil.:> (Implicit, k) Tsil.:> (Implicit, a) Tsil.:> (Implicit, b)) 82 | 83 | pattern IntName :: Name.Qualified 84 | pattern IntName = 85 | "Sixten.Builtin.Int" 86 | 87 | pattern Int :: Domain.Value 88 | pattern Int = 89 | Domain.Neutral (Domain.Global IntName) Domain.Empty 90 | 91 | int :: Syntax.Term v 92 | int = 93 | Syntax.Global IntName 94 | 95 | pattern EmptyRepresentationName :: Name.Qualified 96 | pattern EmptyRepresentationName = 97 | "Sixten.Builtin.EmptyRepresentation" 98 | 99 | pattern PointerRepresentationName :: Name.Qualified 100 | pattern PointerRepresentationName = 101 | "Sixten.Builtin.PointerRepresentation" 102 | 103 | pattern AddRepresentationName :: Name.Qualified 104 | pattern AddRepresentationName = 105 | "Sixten.Builtin.addRepresentation" 106 | 107 | pattern MaxRepresentationName :: Name.Qualified 108 | pattern MaxRepresentationName = 109 | "Sixten.Builtin.maxRepresentation" 110 | -------------------------------------------------------------------------------- /src/ClosureConverted/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module ClosureConverted.Context where 6 | 7 | import qualified ClosureConverted.Domain as Domain 8 | import Data.EnumMap (EnumMap) 9 | import qualified Data.EnumMap as EnumMap 10 | import qualified Data.Kind 11 | import Environment (Environment (Environment)) 12 | import qualified Environment 13 | import Index (Index) 14 | import qualified Index 15 | import qualified Index.Map 16 | import qualified Index.Map as Index 17 | import Monad 18 | import Protolude hiding (empty) 19 | import Var (Var) 20 | 21 | data Context (v :: Data.Kind.Type) = Context 22 | { indices :: Index.Map v Var 23 | , types :: EnumMap Var Domain.Type 24 | , glueableBefore :: !(Index (Index.Succ v)) 25 | } 26 | 27 | empty :: Context Index.Zero 28 | empty = 29 | Context 30 | { indices = Index.Map.Empty 31 | , types = mempty 32 | , glueableBefore = Index.Zero 33 | } 34 | 35 | lookupIndexVar :: Index v -> Context v -> Var 36 | lookupIndexVar index context = 37 | Index.Map.index (indices context) index 38 | 39 | lookupVarType :: Var -> Context v -> Domain.Type 40 | lookupVarType var context = 41 | fromMaybe (panic $ "ClosureConverted.Context.lookupVarType " <> show var) $ 42 | EnumMap.lookup var $ 43 | types context 44 | 45 | toEnvironment 46 | :: Context v 47 | -> Domain.Environment v 48 | toEnvironment context = 49 | Environment 50 | { indices = indices context 51 | , values = mempty 52 | , glueableBefore = glueableBefore context 53 | } 54 | 55 | extend 56 | :: Context v 57 | -> Domain.Type 58 | -> M (Context (Index.Succ v), Var) 59 | extend context type_ = do 60 | var <- freshVar 61 | pure 62 | ( context 63 | { indices = indices context Index.Map.:> var 64 | , types = EnumMap.insert var type_ (types context) 65 | , glueableBefore = Index.Succ $ glueableBefore context 66 | } 67 | , var 68 | ) 69 | -------------------------------------------------------------------------------- /src/ClosureConverted/Domain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module ClosureConverted.Domain where 4 | 5 | import qualified ClosureConverted.Syntax as Syntax 6 | import Data.Tsil (Tsil) 7 | import qualified Data.Tsil as Tsil 8 | import qualified Environment 9 | import Index (Scope) 10 | import qualified Index 11 | import Literal (Literal) 12 | import Monad 13 | import Name (Name) 14 | import qualified Name 15 | import Protolude hiding (Type, evaluate) 16 | import Telescope (Telescope) 17 | import Var (Var) 18 | 19 | data Value 20 | = Neutral !Head Spine 21 | | Con !Name.QualifiedConstructor [Value] [Value] 22 | | Lit !Literal 23 | | Glued !Head Spine !Value 24 | | Lazy !(Lazy Value) 25 | | Pi !Name !Type !Closure 26 | | Function !(Telescope Name Syntax.Type Syntax.Type Index.Zero) 27 | 28 | data Head 29 | = Var !Var 30 | | Global !Name.Lifted 31 | deriving (Show) 32 | 33 | type Type = Value 34 | 35 | data Branches where 36 | Branches :: Type -> Environment v -> Syntax.Branches v -> Maybe (Syntax.Term v) -> Branches 37 | 38 | data Closure where 39 | Closure :: Environment v -> Scope Syntax.Term v -> Closure 40 | 41 | type Environment = Environment.Environment Value 42 | 43 | var :: Var -> Value 44 | var v = 45 | Neutral (Var v) mempty 46 | 47 | global :: Name.Lifted -> Value 48 | global g = 49 | Neutral (Global g) mempty 50 | 51 | ------------------------------------------------------------------------------- 52 | 53 | -- * Elimination spines 54 | 55 | type Spine = Tsil Elimination 56 | 57 | data Elimination 58 | = App !Value 59 | | Case !Branches 60 | 61 | data GroupedElimination 62 | = GroupedApps [Value] 63 | | GroupedCase !Branches 64 | 65 | groupSpine :: Spine -> [GroupedElimination] 66 | groupSpine = 67 | go Tsil.Empty . toList 68 | where 69 | go args (App arg : spine) = 70 | go (args Tsil.:> arg) spine 71 | go Tsil.Empty (Case branches : spine) = 72 | GroupedCase branches : go Tsil.Empty spine 73 | go args (Case branches : spine) = 74 | GroupedApps (toList args) : GroupedCase branches : go Tsil.Empty spine 75 | go Tsil.Empty [] = 76 | [] 77 | go args [] = 78 | [GroupedApps $ toList args] 79 | -------------------------------------------------------------------------------- /src/ClosureConverted/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module ClosureConverted.Syntax where 7 | 8 | import Boxity 9 | import Data.OrderedHashMap (OrderedHashMap) 10 | import Index (Index, Scope) 11 | import qualified Index 12 | import Literal (Literal) 13 | import Name (Name) 14 | import qualified Name 15 | import Protolude hiding (IntMap, Type) 16 | import Telescope (Telescope) 17 | import Unsafe.Coerce 18 | 19 | {- 20 | General idea: 21 | 22 | xs |- t : T 23 | ------------------------- 24 | \|- \xs. t : Function xs T 25 | 26 | f : Function xs T 27 | ts : xs[ts/xs] 28 | ----------------- 29 | f ts : T[ts/xs] 30 | 31 | f : Function (xs ++ ys) T 32 | ts : xs[ts/xs] 33 | -------------------------------------- 34 | Closure f ts : ys[ts/xs] -> T[ts/xs] 35 | 36 | cl : (xs ++ ys) -> T 37 | ts : xs[ts/xs] 38 | ------------------------------------------ 39 | ApplyClosure cl ts : ys[ts/xs] -> T[ts/xs] 40 | -} 41 | 42 | data Term v 43 | = Var !(Index v) 44 | | Global !Name.Lifted 45 | | -- | Saturated constructor application 46 | Con 47 | !Name.QualifiedConstructor 48 | [Term v] 49 | -- ^ Type parameters 50 | [Term v] 51 | -- ^ Constructor arguments 52 | | Lit !Literal 53 | | Let !Name !(Term v) !(Type v) !(Scope Term v) 54 | | -- | The type of a top-level function definition 55 | Function !(Telescope Name Type Type Index.Zero) 56 | | -- | Saturated application of a top-level function 57 | Apply !Name.Lifted [Term v] 58 | | Pi !Name !(Type v) !(Scope Type v) 59 | | Closure !Name.Lifted [Term v] 60 | | ApplyClosure !(Term v) [Term v] 61 | | Case !(Term v) !(Type v) (Branches v) !(Maybe (Term v)) 62 | deriving (Eq, Show, Generic, Hashable) 63 | 64 | type Type = Term 65 | 66 | data Branches v 67 | = ConstructorBranches !Name.Qualified (ConstructorBranches v) 68 | | LiteralBranches (LiteralBranches v) 69 | deriving (Eq, Show, Generic, Hashable) 70 | 71 | type ConstructorBranches v = 72 | OrderedHashMap Name.Constructor (Telescope Name Type Term v) 73 | 74 | type LiteralBranches v = 75 | OrderedHashMap Literal (Term v) 76 | 77 | data Definition 78 | = TypeDeclaration !(Type Index.Zero) 79 | | ConstantDefinition !(Term Index.Zero) 80 | | FunctionDefinition !(Telescope Name Type Term Index.Zero) 81 | | DataDefinition !Boxity (ConstructorDefinitions Index.Zero) 82 | | ParameterisedDataDefinition !Boxity !(Telescope Name Type ConstructorDefinitions Index.Zero) 83 | deriving (Eq, Show, Generic, Hashable) 84 | 85 | newtype ConstructorDefinitions v 86 | = ConstructorDefinitions (OrderedHashMap Name.Constructor (Type v)) 87 | deriving (Show, Generic) 88 | deriving newtype (Eq, Hashable) 89 | 90 | fromZero :: Term Index.Zero -> Term v 91 | fromZero = 92 | unsafeCoerce 93 | -------------------------------------------------------------------------------- /src/Command/BenchmarkProjectGenerator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | module Command.BenchmarkProjectGenerator where 7 | 8 | import Data.List ((!!)) 9 | import qualified Data.Text as Text 10 | import Protolude hiding (functionName, moduleName, (<.>)) 11 | import System.Directory 12 | import System.FilePath 13 | import System.Random 14 | 15 | data Options = Options 16 | { outputDirectory :: FilePath 17 | , moduleCount :: !Int 18 | , importCount :: !Int 19 | , functionCount :: !Int 20 | } 21 | 22 | generate :: Options -> IO () 23 | generate Options {..} = do 24 | createDirectoryIfMissing True $ outputDirectory "src" 25 | forM_ [1 .. moduleCount] \moduleNumber -> do 26 | let moduleName num = 27 | "Module" <> show num 28 | 29 | functionName num = 30 | "f" <> show num 31 | 32 | importedModules <- 33 | replicateM (min (moduleNumber - 1) importCount) $ 34 | randomRIO (1, moduleNumber - 1) 35 | 36 | functions <- forM [1 .. functionCount] \functionNumber -> do 37 | def <- 38 | if not (null importedModules) 39 | then do 40 | module1 <- (importedModules !!) <$> randomRIO (0, length importedModules - 1) 41 | module2 <- (importedModules !!) <$> randomRIO (0, length importedModules - 1) 42 | function1 <- randomRIO (1, functionCount) 43 | function2 <- randomRIO (1, functionCount) 44 | pure $ 45 | moduleName module1 46 | <> "." 47 | <> functionName function1 48 | <> " -> " 49 | <> moduleName module2 50 | <> "." 51 | <> functionName function2 52 | else pure "Type" 53 | pure (functionNumber, def) 54 | 55 | writeFile (outputDirectory "src" moduleName moduleNumber <.> "vix") $ 56 | Text.unlines 57 | [ "module " <> moduleName moduleNumber <> " exposing (..)" 58 | , "" 59 | , Text.unlines 60 | [ "import " <> moduleName importedModule 61 | | importedModule <- importedModules 62 | ] 63 | , Text.unlines 64 | [ Text.unlines 65 | [ functionName functionNumber <> " : Type" 66 | , functionName functionNumber <> " = " <> def 67 | ] 68 | | (functionNumber, def) <- functions 69 | ] 70 | ] 71 | 72 | writeFile (outputDirectory "sixten.json") "{ \"source-directories\": [ \"src\" ] }" 73 | -------------------------------------------------------------------------------- /src/Command/Check.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Command.Check where 6 | 7 | import Control.Concurrent.Async.Lifted.Safe 8 | import qualified Core.Pretty as Pretty 9 | import qualified Core.Syntax as Syntax 10 | import qualified Data.HashSet as HashSet 11 | import qualified Data.Text as Text 12 | import Data.Time.Clock 13 | import qualified Driver 14 | import qualified Error.Hydrated 15 | import qualified Name 16 | import Prettyprinter 17 | import Prettyprinter.Render.Text (putDoc) 18 | import qualified Project 19 | import Protolude hiding (wait, withAsync) 20 | import qualified Query 21 | import Rock 22 | 23 | check :: [FilePath] -> Bool -> IO () 24 | check argumentFiles printElaborated = do 25 | startTime <- getCurrentTime 26 | (sourceDirectories, filePaths) <- Project.filesFromArguments argumentFiles 27 | ((), errs) <- 28 | Driver.runTask 29 | sourceDirectories 30 | filePaths 31 | Error.Hydrated.pretty 32 | if printElaborated 33 | then withAsync (void Driver.checkAll) \checkedAll -> do 34 | inputFiles <- fetch Query.InputFiles 35 | forM_ inputFiles \filePath -> do 36 | (module_, _, defs) <- fetch $ Query.ParsedFile filePath 37 | let names = 38 | HashSet.fromList $ 39 | Name.Qualified module_ . fst . snd <$> defs 40 | emptyPrettyEnv <- Pretty.emptyM module_ 41 | liftIO $ putDoc $ "module" <+> pretty module_ <> line <> line 42 | forM_ names \name -> do 43 | type_ <- fetch $ Query.ElaboratedType name 44 | liftIO $ putDoc $ Pretty.prettyDefinition emptyPrettyEnv name (Syntax.TypeDeclaration type_) <> line 45 | (definition, _) <- fetch $ Query.ElaboratedDefinition name 46 | liftIO do 47 | case definition of 48 | Syntax.TypeDeclaration {} -> pure () 49 | _ -> putDoc $ Pretty.prettyDefinition emptyPrettyEnv name definition <> line 50 | putDoc line 51 | wait checkedAll 52 | else void Driver.checkAll 53 | endTime <- getCurrentTime 54 | forM_ errs \err -> 55 | putDoc $ err <> line 56 | let errorCount = 57 | length errs 58 | putText $ 59 | Text.unwords 60 | [ "Found" 61 | , show errorCount 62 | , case errorCount of 63 | 1 -> "error" 64 | _ -> "errors" 65 | , "in" 66 | , show (diffUTCTime endTime startTime) <> "." 67 | ] 68 | unless 69 | (null errs) 70 | exitFailure 71 | -------------------------------------------------------------------------------- /src/Command/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | module Command.Compile where 8 | 9 | import qualified Compiler 10 | import qualified Data.Text as Text 11 | import Data.Time.Clock 12 | import qualified Driver 13 | import qualified Error.Hydrated 14 | import Prettyprinter 15 | import qualified Project 16 | import Protolude hiding (moduleName, wait, withAsync) 17 | import System.Directory 18 | import System.IO 19 | import System.IO.Temp 20 | 21 | data Options = Options 22 | { argumentFiles :: [FilePath] 23 | , maybeAssemblyDir :: Maybe FilePath 24 | , maybeOutputFile :: Maybe FilePath 25 | , maybeOptimisationLevel :: Maybe FilePath 26 | , printLowered :: Bool 27 | } 28 | 29 | compile :: Options -> IO () 30 | compile = 31 | withCompiledExecutable $ const $ pure () 32 | 33 | withCompiledExecutable :: (FilePath -> IO ()) -> Options -> IO () 34 | withCompiledExecutable k Options {..} = do 35 | startTime <- getCurrentTime 36 | (sourceDirectories, filePaths) <- Project.filesFromArguments argumentFiles 37 | withAssemblyDirectory maybeAssemblyDir \assemblyDir -> 38 | withOutputFile maybeOutputFile \outputFile -> do 39 | ((), errs) <- 40 | Driver.runTask sourceDirectories filePaths Error.Hydrated.pretty $ 41 | Compiler.compile assemblyDir (isJust maybeAssemblyDir) outputFile maybeOptimisationLevel printLowered 42 | endTime <- getCurrentTime 43 | let errorCount = 44 | length errs 45 | putText $ 46 | Text.unwords 47 | [ "Found" 48 | , show errorCount 49 | , case errorCount of 50 | 1 -> "error" 51 | _ -> "errors" 52 | , "in" 53 | , show (diffUTCTime endTime startTime) <> "." 54 | ] 55 | unless 56 | (null errs) 57 | exitFailure 58 | k outputFile 59 | 60 | withOutputFile :: Maybe FilePath -> (FilePath -> IO a) -> IO a 61 | withOutputFile maybeOutputFile_ k' = 62 | case maybeOutputFile_ of 63 | Nothing -> 64 | withTempFile "." "temp.exe" \outputFile outputFileHandle -> do 65 | hClose outputFileHandle 66 | k' outputFile 67 | Just o -> do 68 | o' <- makeAbsolute o 69 | k' o' 70 | 71 | withAssemblyDirectory :: Maybe FilePath -> (FilePath -> IO a) -> IO a 72 | withAssemblyDirectory maybeAssemblyDir_ k = 73 | case maybeAssemblyDir_ of 74 | Nothing -> 75 | withSystemTempDirectory "sixten" k 76 | Just dir -> do 77 | createDirectoryIfMissing True dir 78 | k dir 79 | -------------------------------------------------------------------------------- /src/Command/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | 3 | module Command.Run where 4 | 5 | import qualified Command.Compile 6 | import Protolude 7 | import System.Process 8 | 9 | run :: Command.Compile.Options -> IO () 10 | run = 11 | Command.Compile.withCompiledExecutable (`callProcess` []) 12 | -------------------------------------------------------------------------------- /src/Command/Watch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE OverloadedRecordDot #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Command.Watch where 6 | 7 | import qualified Data.HashSet as HashSet 8 | import qualified Data.Text as Text 9 | import Data.Time.Clock 10 | import qualified Driver 11 | import qualified Error.Hydrated 12 | import qualified FileSystem 13 | import Prettyprinter (Doc) 14 | import qualified Prettyprinter as Doc 15 | import Prettyprinter.Render.Text (putDoc) 16 | import Protolude hiding (check) 17 | import qualified System.Console.ANSI 18 | import qualified System.FSNotify as FSNotify 19 | 20 | watch :: [FilePath] -> IO () 21 | watch argumentFiles = do 22 | watcher <- FileSystem.watcherFromArguments argumentFiles 23 | signalChangeVar <- newEmptyMVar 24 | fileStateVar <- newMVar mempty 25 | FSNotify.withManager \manager -> do 26 | stopListening <- FileSystem.runWatcher watcher manager \projectFiles -> do 27 | modifyMVar_ fileStateVar \projectFiles' -> 28 | pure 29 | projectFiles 30 | { FileSystem.changedFiles = 31 | projectFiles.changedFiles <> projectFiles'.changedFiles 32 | } 33 | void $ tryPutMVar signalChangeVar () 34 | 35 | (`finally` stopListening) do 36 | driverState <- Driver.initialState 37 | forever do 38 | projectFiles <- waitForChanges signalChangeVar fileStateVar driverState 39 | checkAndPrintErrors driverState projectFiles 40 | 41 | waitForChanges 42 | :: MVar () 43 | -> MVar FileSystem.ProjectFiles 44 | -> Driver.State (Doc ann) 45 | -> IO FileSystem.ProjectFiles 46 | waitForChanges signalChangeVar fileStateVar driverState = do 47 | projectFiles <- 48 | modifyMVar fileStateVar \projectFiles -> 49 | pure (projectFiles {FileSystem.changedFiles = mempty}, projectFiles) 50 | 51 | if HashSet.null projectFiles.changedFiles 52 | then do 53 | takeMVar signalChangeVar 54 | waitForChanges signalChangeVar fileStateVar driverState 55 | else pure projectFiles 56 | 57 | checkAndPrintErrors 58 | :: Driver.State (Doc ann) 59 | -> FileSystem.ProjectFiles 60 | -> IO () 61 | checkAndPrintErrors driverState projectFiles = do 62 | startTime <- getCurrentTime 63 | (_, errs) <- 64 | Driver.runIncrementalTask 65 | driverState 66 | projectFiles.changedFiles 67 | (HashSet.fromList projectFiles.sourceDirectories) 68 | (fmap Right projectFiles.fileContents) 69 | Error.Hydrated.pretty 70 | Driver.Prune 71 | Driver.checkAll 72 | endTime <- getCurrentTime 73 | 74 | System.Console.ANSI.clearScreen 75 | forM_ errs \err -> 76 | putDoc $ err <> Doc.line 77 | let errorCount = 78 | length errs 79 | putText $ 80 | Text.unwords 81 | [ "Found" 82 | , show errorCount 83 | , case errorCount of 84 | 1 -> "error" 85 | _ -> "errors" 86 | , "in" 87 | , show (diffUTCTime endTime startTime) <> "." 88 | ] 89 | -------------------------------------------------------------------------------- /src/Core/Binding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Core.Binding where 5 | 6 | import Data.String 7 | import Name (Name (Name)) 8 | import qualified Name 9 | import Protolude 10 | import qualified Span 11 | import qualified Surface.Syntax as Surface 12 | 13 | data Binding 14 | = Spanned !Span.Relative !Name 15 | | Unspanned !Name 16 | deriving (Eq, Show, Generic, Hashable) 17 | 18 | toName :: Binding -> Name 19 | toName bindings = 20 | case bindings of 21 | Spanned _ name -> 22 | name 23 | Unspanned name -> 24 | name 25 | 26 | fromSurface :: Surface.SpannedName -> Binding 27 | fromSurface (Surface.SpannedName span (Name.Surface name)) = 28 | Spanned span $ Name name 29 | 30 | spans :: Binding -> [Span.Relative] 31 | spans binding = 32 | case binding of 33 | Spanned span _ -> 34 | [span] 35 | Unspanned _ -> 36 | [] 37 | 38 | instance IsString Binding where 39 | fromString = 40 | Unspanned . fromString 41 | -------------------------------------------------------------------------------- /src/Core/Bindings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | module Core.Bindings where 6 | 7 | import qualified Data.List.NonEmpty as NonEmpty 8 | import Data.String 9 | import Name (Name) 10 | import Protolude 11 | import qualified Span 12 | 13 | data Bindings 14 | = Spanned (NonEmpty (Span.Relative, Name)) 15 | | Unspanned !Name 16 | deriving (Eq, Show, Generic, Hashable) 17 | 18 | toName :: Bindings -> Name 19 | toName bindings = 20 | case bindings of 21 | Spanned ((_, name) NonEmpty.:| _) -> 22 | name 23 | Unspanned name -> 24 | name 25 | 26 | fromName :: [Span.Relative] -> Name -> Bindings 27 | fromName spans_ name = 28 | case spans_ of 29 | [] -> 30 | Unspanned name 31 | span : spans' -> 32 | Spanned $ (span, name) NonEmpty.:| ((,name) <$> spans') 33 | 34 | spans :: Bindings -> [Span.Relative] 35 | spans binding = 36 | case binding of 37 | Spanned spannedNames -> 38 | toList $ fst <$> spannedNames 39 | Unspanned _ -> 40 | [] 41 | 42 | instance IsString Bindings where 43 | fromString = 44 | Unspanned . fromString 45 | -------------------------------------------------------------------------------- /src/Core/Domain/Pattern.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Core.Domain.Pattern where 4 | 5 | import Literal (Literal) 6 | import qualified Name 7 | import Plicity 8 | import Protolude 9 | 10 | data Pattern 11 | = Wildcard 12 | | Con !Name.QualifiedConstructor [(Plicity, Pattern)] 13 | | Lit !Literal 14 | deriving (Eq, Show, Generic) 15 | -------------------------------------------------------------------------------- /src/Core/Domain/Showable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | 5 | module Core.Domain.Showable where 6 | 7 | import Core.Binding (Binding) 8 | import Core.Bindings (Bindings) 9 | import qualified Core.Domain as Domain 10 | import qualified Core.Syntax as Syntax 11 | import Data.Tsil (Tsil) 12 | import qualified Environment 13 | import Index (Scope) 14 | import Literal (Literal) 15 | import Monad 16 | import qualified Name 17 | import Plicity 18 | import Protolude hiding (IntMap, Type, force, to) 19 | 20 | data Value 21 | = Neutral !Domain.Head Spine 22 | | Stuck !Domain.Head (Seq (Plicity, Value)) Value Spine 23 | | Con !Name.QualifiedConstructor (Tsil (Plicity, Value)) 24 | | Lit !Literal 25 | | Glued !Domain.Head Spine !Value 26 | | Lazy !Value 27 | | Lam !Bindings !Type !Plicity !Closure 28 | | Pi !Binding !Type !Plicity !Closure 29 | | Fun !Type !Plicity !Type 30 | deriving (Show) 31 | 32 | type Type = Value 33 | 34 | type Spine = Tsil Elimination 35 | 36 | data Elimination 37 | = App Plicity Value 38 | | Case !Branches 39 | deriving (Show) 40 | 41 | type Environment = Environment.Environment Value 42 | 43 | data Closure where 44 | Closure :: Environment v -> Scope Syntax.Term v -> Closure 45 | 46 | deriving instance Show Closure 47 | 48 | data Branches where 49 | Branches :: Type -> Environment v -> Syntax.Branches v -> Maybe (Syntax.Term v) -> Branches 50 | 51 | deriving instance Show Branches 52 | 53 | to :: Domain.Value -> M Value 54 | to value = 55 | case value of 56 | Domain.Neutral hd spine -> 57 | Neutral hd <$> Domain.mapM eliminationTo spine 58 | Domain.Stuck hd args value' spine -> 59 | Stuck hd <$> mapM (mapM to) args <*> to value' <*> Domain.mapM eliminationTo spine 60 | Domain.Con con args -> 61 | Con con <$> mapM (mapM to) args 62 | Domain.Lit lit -> 63 | pure $ Lit lit 64 | Domain.Glued hd spine value' -> 65 | Glued hd <$> Domain.mapM eliminationTo spine <*> to value' 66 | Domain.Lazy lazyValue -> 67 | Core.Domain.Showable.Lazy <$> lazyTo lazyValue 68 | Domain.Lam bindings type_ plicity closure -> 69 | Lam bindings <$> to type_ <*> pure plicity <*> closureTo closure 70 | Domain.Pi binding type_ plicity closure -> 71 | Pi binding <$> to type_ <*> pure plicity <*> closureTo closure 72 | Domain.Fun domain plicity target -> 73 | Fun <$> to domain <*> pure plicity <*> to target 74 | 75 | eliminationTo :: Domain.Elimination -> M Elimination 76 | eliminationTo elimination = 77 | case elimination of 78 | Domain.App plicity arg -> 79 | App plicity <$> to arg 80 | Domain.Case branches -> 81 | Case <$> branchesTo branches 82 | 83 | lazyTo :: Lazy Domain.Value -> M Value 84 | lazyTo = 85 | to <=< force 86 | 87 | closureTo :: Domain.Closure -> M Closure 88 | closureTo (Domain.Closure env term) = 89 | flip Closure term <$> environmentTo env 90 | 91 | branchesTo :: Domain.Branches -> M Branches 92 | branchesTo (Domain.Branches type_ env branches defaultBranch) = do 93 | type' <- to type_ 94 | env' <- environmentTo env 95 | pure $ Branches type' env' branches defaultBranch 96 | 97 | environmentTo :: Domain.Environment v -> M (Environment v) 98 | environmentTo env = do 99 | values' <- mapM to $ Environment.values env 100 | pure 101 | Environment.Environment 102 | { indices = Environment.indices env 103 | , values = values' 104 | , glueableBefore = Environment.glueableBefore env 105 | } 106 | -------------------------------------------------------------------------------- /src/Core/Domain/Telescope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Core.Domain.Telescope where 4 | 5 | import Core.Binding (Binding) 6 | import qualified Core.Domain as Domain 7 | import Monad 8 | import Plicity 9 | import Protolude 10 | 11 | data Telescope base 12 | = Empty !base 13 | | Extend !Binding !Domain.Type !Plicity (Domain.Value -> M (Telescope base)) 14 | 15 | apply :: Telescope k -> [(Plicity, Domain.Value)] -> M (Telescope k) 16 | apply tele args = 17 | case (tele, args) of 18 | (_, []) -> 19 | pure tele 20 | (Extend _ _ plicity1 teleFun, (plicity2, arg) : args') 21 | | plicity1 == plicity2 -> do 22 | tele' <- teleFun arg 23 | apply tele' args' 24 | _ -> 25 | panic "Core.Domain.Telescope.apply" 26 | -------------------------------------------------------------------------------- /src/Data/IntSeq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | module Data.IntSeq where 8 | 9 | import Data.EnumMap (EnumMap) 10 | import qualified Data.EnumMap as EnumMap 11 | import qualified Data.Sequence as Seq 12 | import Data.Tsil (Tsil) 13 | import qualified Data.Tsil as Tsil 14 | import Protolude hiding (seq, splitAt, unsnoc) 15 | import Prelude (Show (showsPrec), showParen, showString, shows) 16 | 17 | data IntSeq a = IntSeq !(Seq a) (EnumMap a Int) 18 | 19 | instance Semigroup (IntSeq a) where 20 | IntSeq seq1 indices1 <> IntSeq seq2 indices2 = 21 | IntSeq (seq1 <> seq2) (indices1 <> map (+ Seq.length seq1) indices2) 22 | 23 | instance (Show a) => Show (IntSeq a) where 24 | showsPrec p xs = 25 | showParen (p > 10) $ 26 | showString "fromList " . shows (toList xs) 27 | 28 | instance Monoid (IntSeq a) where 29 | mempty = 30 | IntSeq mempty mempty 31 | 32 | instance Foldable IntSeq where 33 | foldMap f (IntSeq seq _) = 34 | foldMap f seq 35 | 36 | pattern Empty :: (Enum a) => IntSeq a 37 | pattern Empty <- 38 | IntSeq Seq.Empty _ 39 | where 40 | Empty = mempty 41 | 42 | pattern (:>) :: (Enum a) => IntSeq a -> a -> IntSeq a 43 | pattern as :> a <- 44 | (unsnoc -> Just (as, a)) 45 | where 46 | IntSeq seq indices :> a = IntSeq (seq Seq.:|> a) (EnumMap.insert a (Seq.length seq) indices) 47 | 48 | unsnoc :: (Enum a) => IntSeq a -> Maybe (IntSeq a, a) 49 | unsnoc (IntSeq seq indices) = 50 | case seq of 51 | seq' Seq.:|> a -> 52 | Just (IntSeq seq' $ EnumMap.delete a indices, a) 53 | _ -> Nothing 54 | 55 | {-# COMPLETE Empty, (:>) #-} 56 | 57 | length :: IntSeq a -> Int 58 | length (IntSeq seq _) = 59 | Seq.length seq 60 | 61 | singleton :: (Enum a) => a -> IntSeq a 62 | singleton a = 63 | Empty :> a 64 | 65 | member :: (Enum a) => a -> IntSeq a -> Bool 66 | member a (IntSeq _ indices) = 67 | EnumMap.member a indices 68 | 69 | elemIndex :: (Enum a) => a -> IntSeq a -> Maybe Int 70 | elemIndex a (IntSeq _ indices) = 71 | EnumMap.lookup a indices 72 | 73 | index :: IntSeq a -> Int -> a 74 | index (IntSeq seq _) = 75 | Seq.index seq 76 | 77 | splitAt :: Int -> IntSeq a -> (IntSeq a, IntSeq a) 78 | splitAt i (IntSeq seq indices) = 79 | (IntSeq seq1 indices1, IntSeq seq2 indices2) 80 | where 81 | (seq1, seq2) = Seq.splitAt i seq 82 | (indices1, indices2) = EnumMap.mapEither (\j -> if j < i then Left j else Right $ j - i) indices 83 | 84 | insertAt :: (Enum a) => Int -> a -> IntSeq a -> IntSeq a 85 | insertAt i a (IntSeq seq indices) = 86 | IntSeq (Seq.insertAt i a seq) (EnumMap.insert a i indices') 87 | where 88 | indices' = map (\j -> if j < i then j else j + 1) indices 89 | 90 | delete :: (Enum a) => a -> IntSeq a -> IntSeq a 91 | delete a as = 92 | case elemIndex a as of 93 | Nothing -> 94 | as 95 | Just i -> 96 | deleteAt i as 97 | 98 | deleteAt :: Int -> IntSeq a -> IntSeq a 99 | deleteAt i (IntSeq seq indices) = 100 | IntSeq (Seq.deleteAt i seq) indices' 101 | where 102 | indices' = 103 | EnumMap.mapMaybe 104 | ( \j -> 105 | case compare j i of 106 | LT -> 107 | Just j 108 | EQ -> 109 | Nothing 110 | GT -> 111 | Just $ j - 1 112 | ) 113 | indices 114 | 115 | fromTsil :: (Enum a) => Tsil a -> IntSeq a 116 | fromTsil tsil = 117 | case tsil of 118 | Tsil.Empty -> 119 | mempty 120 | as Tsil.:> a -> 121 | fromTsil as :> a 122 | 123 | toTsil :: IntSeq a -> Tsil a 124 | toTsil (IntSeq seq _) = 125 | go seq 126 | where 127 | go as = 128 | case as of 129 | Seq.Empty -> 130 | Tsil.Empty 131 | as' Seq.:|> a -> 132 | go as' Tsil.:> a 133 | 134 | toSeq :: IntSeq a -> Seq a 135 | toSeq (IntSeq seq _) = seq 136 | 137 | fromSeq :: (Enum a) => Seq a -> IntSeq a 138 | fromSeq seq = IntSeq seq $ EnumMap.fromList $ zip (toList seq) [0 ..] 139 | -------------------------------------------------------------------------------- /src/Data/OrderedHashMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | 4 | module Data.OrderedHashMap where 5 | 6 | import Data.HashMap.Lazy (HashMap) 7 | import qualified Data.HashMap.Lazy as HashMap 8 | import Protolude hiding (get, put, toList) 9 | import Prelude (Show (showsPrec), showParen, showString, shows) 10 | 11 | newtype OrderedHashMap k v = OrderedHashMap {toMap :: HashMap k (Ordered v)} 12 | deriving (Functor) 13 | 14 | instance (Eq k, Eq v) => Eq (OrderedHashMap k v) where 15 | (==) = 16 | (==) `on` toList 17 | 18 | instance (Ord k, Ord v) => Ord (OrderedHashMap k v) where 19 | compare = 20 | compare `on` toList 21 | 22 | instance (Show k, Show v) => Show (OrderedHashMap k v) where 23 | showsPrec p xs = 24 | showParen (p > 10) $ 25 | showString "fromList " . shows (toList xs) 26 | 27 | instance Foldable (OrderedHashMap k) where 28 | foldMap f (OrderedHashMap h) = 29 | foldMap (\(Ordered _ v) -> f v) $ 30 | sortOn (\(Ordered n _) -> n) $ 31 | HashMap.elems h 32 | 33 | instance (Hashable k, Hashable v) => Hashable (OrderedHashMap k v) where 34 | hashWithSalt s = 35 | hashWithSalt s . toList 36 | 37 | null :: OrderedHashMap k v -> Bool 38 | null (OrderedHashMap h) = 39 | HashMap.null h 40 | 41 | size :: OrderedHashMap k v -> Int 42 | size (OrderedHashMap h) = 43 | HashMap.size h 44 | 45 | lookup :: (Hashable k) => k -> OrderedHashMap k v -> Maybe v 46 | lookup k (OrderedHashMap h) = 47 | (\(Ordered _ v) -> v) <$> HashMap.lookup k h 48 | 49 | lookupDefault :: (Hashable k) => v -> k -> OrderedHashMap k v -> v 50 | lookupDefault def k (OrderedHashMap h) = 51 | (\(Ordered _ v) -> v) $ HashMap.lookupDefault (Ordered 0 def) k h 52 | 53 | mapMUnordered :: (Applicative f) => (a -> f b) -> OrderedHashMap k a -> f (OrderedHashMap k b) 54 | mapMUnordered f (OrderedHashMap h) = 55 | OrderedHashMap <$> traverse (traverse f) h 56 | 57 | mapMUnordered_ :: (Applicative f) => (a -> f ()) -> OrderedHashMap k a -> f () 58 | mapMUnordered_ f (OrderedHashMap h) = 59 | traverse_ (traverse_ f) h 60 | 61 | forMUnordered :: (Applicative f) => OrderedHashMap k a -> (a -> f b) -> f (OrderedHashMap k b) 62 | forMUnordered = 63 | flip mapMUnordered 64 | 65 | data Ordered v = Ordered !Int v 66 | deriving (Functor, Foldable, Traversable) 67 | 68 | keys :: OrderedHashMap k v -> [k] 69 | keys = 70 | map fst . toList 71 | 72 | elems :: OrderedHashMap k v -> [v] 73 | elems = 74 | map snd . toList 75 | 76 | toList :: OrderedHashMap k v -> [(k, v)] 77 | toList (OrderedHashMap h) = 78 | map (\(k, Ordered _ v) -> (k, v)) $ 79 | sortOn (\(_, Ordered n _) -> n) $ 80 | HashMap.toList h 81 | 82 | fromList 83 | :: (Hashable k) 84 | => [(k, v)] 85 | -> OrderedHashMap k v 86 | fromList = 87 | OrderedHashMap 88 | . HashMap.fromList 89 | . zipWith (\n (k, v) -> (k, Ordered n v)) [0 ..] 90 | 91 | fromListWith 92 | :: (Hashable k) 93 | => (v -> v -> v) 94 | -> [(k, v)] 95 | -> OrderedHashMap k v 96 | fromListWith f = 97 | OrderedHashMap 98 | . HashMap.fromListWith (\(Ordered i v1) (Ordered _ v2) -> Ordered i $ f v1 v2) 99 | . zipWith (\n (k, v) -> (k, Ordered n v)) [0 ..] 100 | 101 | intersectionWith 102 | :: (Hashable k) 103 | => (v1 -> v2 -> v3) 104 | -> OrderedHashMap k v1 105 | -> OrderedHashMap k v2 106 | -> OrderedHashMap k v3 107 | intersectionWith f (OrderedHashMap h1) (OrderedHashMap h2) = 108 | OrderedHashMap $ 109 | HashMap.intersectionWith 110 | (\(Ordered i v1) (Ordered _ v2) -> Ordered i $ f v1 v2) 111 | h1 112 | h2 113 | 114 | difference :: (Hashable k) => OrderedHashMap k v -> OrderedHashMap k w -> OrderedHashMap k v 115 | difference (OrderedHashMap h1) (OrderedHashMap h2) = 116 | OrderedHashMap $ 117 | HashMap.difference h1 h2 118 | 119 | differenceFromMap :: (Hashable k) => OrderedHashMap k v -> HashMap k w -> OrderedHashMap k v 120 | differenceFromMap (OrderedHashMap h1) h2 = 121 | OrderedHashMap $ 122 | HashMap.difference h1 h2 123 | -------------------------------------------------------------------------------- /src/Data/OrderedHashSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | module Data.OrderedHashSet where 5 | 6 | import Data.OrderedHashMap (OrderedHashMap) 7 | import qualified Data.OrderedHashMap as OrderedHashMap 8 | import Protolude hiding (toList) 9 | import Prelude (Show (showsPrec), showParen, showString, shows) 10 | 11 | newtype OrderedHashSet a = OrderedHashSet (OrderedHashMap a ()) 12 | deriving (Eq, Ord, Hashable) 13 | 14 | instance (Show a) => Show (OrderedHashSet a) where 15 | showsPrec p xs = 16 | showParen (p > 10) $ 17 | showString "fromList " . shows (toList xs) 18 | 19 | instance Foldable OrderedHashSet where 20 | foldMap f = 21 | foldMap f . toList 22 | 23 | null :: OrderedHashSet a -> Bool 24 | null (OrderedHashSet s) = 25 | OrderedHashMap.null s 26 | 27 | size :: OrderedHashSet a -> Int 28 | size (OrderedHashSet s) = 29 | OrderedHashMap.size s 30 | 31 | member :: (Hashable a) => a -> OrderedHashSet a -> Bool 32 | member a (OrderedHashSet s) = 33 | isJust $ OrderedHashMap.lookup a s 34 | 35 | toList :: OrderedHashSet a -> [a] 36 | toList (OrderedHashSet s) = 37 | fst <$> OrderedHashMap.toList s 38 | 39 | fromList :: (Hashable a) => [a] -> OrderedHashSet a 40 | fromList as = 41 | OrderedHashSet $ OrderedHashMap.fromList $ (,()) <$> as 42 | -------------------------------------------------------------------------------- /src/Data/Tsil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Data.Tsil where 7 | 8 | import qualified Data.Sequence as Seq 9 | import GHC.Exts 10 | import Protolude 11 | import qualified Prelude 12 | 13 | data Tsil a 14 | = Empty 15 | | Tsil a :> a 16 | deriving (Eq, Functor, Ord, Traversable, Generic, Hashable) 17 | 18 | instance (Show a) => Show (Tsil a) where 19 | show = show . Protolude.toList 20 | 21 | instance Semigroup (Tsil a) where 22 | xs <> Empty = xs 23 | xs <> (ys :> y) = (xs <> ys) :> y 24 | 25 | instance Monoid (Tsil a) where 26 | mempty = Empty 27 | mappend = (<>) 28 | 29 | instance Applicative Tsil where 30 | pure = (Empty :>) 31 | (<*>) = ap 32 | 33 | instance Alternative Tsil where 34 | empty = Empty 35 | (<|>) = mappend 36 | 37 | instance Monad Tsil where 38 | return = pure 39 | Empty >>= _ = Empty 40 | xs :> x >>= f = (xs >>= f) <> f x 41 | 42 | instance IsList (Tsil a) where 43 | type Item (Tsil a) = a 44 | fromList = go Empty 45 | where 46 | go acc [] = acc 47 | go acc (a : as) = go (acc :> a) as 48 | toList = Protolude.toList 49 | 50 | instance Foldable Tsil where 51 | foldMap _ Empty = mempty 52 | foldMap f (xs :> x) = foldMap f xs `mappend` f x 53 | toList = go [] 54 | where 55 | go acc Empty = acc 56 | go acc (xs :> x) = go (x : acc) xs 57 | 58 | toReverseList :: Tsil a -> [a] 59 | toReverseList Empty = [] 60 | toReverseList (as :> a) = a : toReverseList as 61 | 62 | null :: Tsil a -> Bool 63 | null Empty = True 64 | null (_ :> _) = False 65 | 66 | lookup :: (Eq a) => a -> Tsil (a, b) -> Maybe b 67 | lookup _ Empty = Nothing 68 | lookup a (as :> (a', b)) 69 | | a == a' = Just b 70 | | otherwise = Data.Tsil.lookup a as 71 | 72 | filter :: (a -> Bool) -> Tsil a -> Tsil a 73 | filter _ Empty = Empty 74 | filter f (xs :> x) 75 | | f x = Data.Tsil.filter f xs :> x 76 | | otherwise = Data.Tsil.filter f xs 77 | 78 | partition :: (a -> Bool) -> Tsil a -> (Tsil a, Tsil a) 79 | partition _ Empty = mempty 80 | partition p (xs :> x) 81 | | p x = first (:> x) $ partition p xs 82 | | otherwise = second (:> x) $ partition p xs 83 | 84 | span :: (a -> Bool) -> Tsil a -> (Tsil a, Tsil a) 85 | span _ Empty = (Empty, Empty) 86 | span p as@(as' :> a) 87 | | p a = second (:> a) $ span p as' 88 | | otherwise = (as, Empty) 89 | 90 | zip :: Tsil a -> Tsil b -> Tsil (a, b) 91 | zip = Data.Tsil.zipWith (,) 92 | 93 | zipWith :: (a -> b -> c) -> Tsil a -> Tsil b -> Tsil c 94 | zipWith _ Empty _ = Empty 95 | zipWith _ _ Empty = Empty 96 | zipWith f (as :> a) (bs :> b) = Data.Tsil.zipWith f as bs :> f a b 97 | 98 | zipWithM :: (Monad m) => (a -> b -> m c) -> Tsil a -> Tsil b -> m (Tsil c) 99 | zipWithM f as bs = sequenceA (Data.Tsil.zipWith f as bs) 100 | 101 | zipWithM_ :: (Monad m) => (a -> b -> m c) -> Tsil a -> Tsil b -> m () 102 | zipWithM_ f as bs = sequenceA_ (Data.Tsil.zipWith f as bs) 103 | 104 | unzip :: Tsil (a, b) -> (Tsil a, Tsil b) 105 | unzip Empty = (Empty, Empty) 106 | unzip (as :> (a, b)) = (as' :> a, bs' :> b) 107 | where 108 | (as', bs') = Data.Tsil.unzip as 109 | 110 | toSeq :: Tsil a -> Seq a 111 | toSeq Empty = Seq.Empty 112 | toSeq (as :> a) = toSeq as Seq.:|> a 113 | 114 | fromSeq :: Seq a -> Tsil a 115 | fromSeq Seq.Empty = Empty 116 | fromSeq (as Seq.:|> a) = fromSeq as :> a 117 | -------------------------------------------------------------------------------- /src/Elaboration.hs-boot: -------------------------------------------------------------------------------- 1 | module Elaboration where 2 | 3 | import qualified Core.Domain as Domain 4 | import qualified Core.Syntax as Syntax 5 | import Data.HashSet (HashSet) 6 | import Elaboration.Context (Context) 7 | import Literal (Literal) 8 | import qualified Meta 9 | import Monad 10 | import Name (Name) 11 | import qualified Name 12 | import Plicity 13 | import qualified Postponement 14 | import Prettyprinter (Doc) 15 | import Protolude 16 | import qualified Surface.Syntax as Surface 17 | 18 | check 19 | :: Context v 20 | -> Surface.Term 21 | -> Domain.Type 22 | -> M (Syntax.Term v) 23 | inferLiteral :: Literal -> Domain.Type 24 | evaluate 25 | :: Context v 26 | -> Syntax.Term v 27 | -> M Domain.Value 28 | readback 29 | :: Context v 30 | -> Domain.Value 31 | -> M (Syntax.Term v) 32 | getExpectedTypeName 33 | :: Context v 34 | -> Domain.Type 35 | -> M (Maybe (Either Meta.Index Name.Qualified)) 36 | 37 | data ResolvedConstructor 38 | = Ambiguous (HashSet Name.QualifiedConstructor) (HashSet Name.Qualified) 39 | | ResolvedConstructor !Name.QualifiedConstructor 40 | | ResolvedData !Name.Qualified 41 | 42 | resolveConstructor 43 | :: HashSet Name.QualifiedConstructor 44 | -> HashSet Name.Qualified 45 | -> M (Maybe (Either Meta.Index Name.Qualified)) 46 | -> M (Either Meta.Index ResolvedConstructor) 47 | inferenceFailed 48 | :: Context v 49 | -> M (Syntax.Term v, Domain.Type) 50 | 51 | data InsertUntil 52 | = UntilTheEnd 53 | | UntilExplicit 54 | | UntilImplicit (Name -> Bool) 55 | 56 | insertMetas 57 | :: Context v 58 | -> InsertUntil 59 | -> Domain.Type 60 | -> M ([(Plicity, Domain.Value)], Domain.Type) 61 | prettyValue :: Context v -> Domain.Value -> M (Doc ann) 62 | postpone 63 | :: Context v 64 | -> Domain.Type 65 | -> Meta.Index 66 | -> (Postponement.CanPostpone -> M (Syntax.Term v)) 67 | -> M (Syntax.Term v) 68 | -------------------------------------------------------------------------------- /src/Elaboration/Context/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | 3 | module Elaboration.Context.Type where 4 | 5 | import qualified Core.Domain as Domain 6 | import Data.EnumMap (EnumMap) 7 | import Data.HashMap.Lazy (HashMap) 8 | import Data.HashSet (HashSet) 9 | import Data.IORef.Lifted 10 | import Data.IntSeq (IntSeq) 11 | import qualified Data.Kind 12 | import Data.Tsil (Tsil) 13 | import qualified Elaboration.Meta as Meta 14 | import qualified Elaboration.Postponed as Postponed 15 | import Error (Error) 16 | import qualified Error 17 | import qualified Index.Map as Index 18 | import Literal (Literal) 19 | import Monad 20 | import Name (Name) 21 | import qualified Name 22 | import Protolude hiding (catch, check, force, moduleName, state) 23 | import qualified Scope 24 | import qualified Span 25 | import Var 26 | 27 | data Context (v :: Data.Kind.Type) = Context 28 | { definitionKind :: !Scope.DefinitionKind 29 | , definitionName :: !Name.Qualified 30 | , definitionType :: Maybe Domain.Type 31 | , span :: !Span.Relative 32 | , indices :: Index.Map v Var 33 | , surfaceNames :: HashMap Name.Surface (Domain.Value, Domain.Type) 34 | , varNames :: EnumMap Var Name 35 | , types :: EnumMap Var Domain.Type 36 | , boundVars :: IntSeq Var 37 | , metas :: !(IORef (Meta.State M)) 38 | , postponed :: !(IORef Postponed.Checks) 39 | , values :: EnumMap Var Domain.Value 40 | , equal :: HashMap Domain.Head [(Domain.Spine, Domain.Value)] 41 | , notEqual :: HashMap Domain.Head [(Domain.Spine, HashSet Name.QualifiedConstructor, HashSet Literal)] 42 | , coverageChecks :: !(IORef (Tsil CoverageCheck)) 43 | , errors :: !(IORef (Tsil Error)) 44 | } 45 | 46 | type CoveredConstructors = EnumMap Var (HashSet Name.QualifiedConstructor) 47 | 48 | type CoveredLiterals = EnumMap Var (HashSet Literal) 49 | 50 | data CoverageCheck = CoverageCheck 51 | { allClauses :: Set Span.Relative 52 | , usedClauses :: IORef (Set Span.Relative) 53 | , matchKind :: !Error.MatchKind 54 | } 55 | -------------------------------------------------------------------------------- /src/Elaboration/Depth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | 3 | module Elaboration.Depth where 4 | 5 | import qualified Core.Domain as Domain 6 | import Monad 7 | import Protolude 8 | import qualified Query 9 | import qualified Query.Mapped as Mapped 10 | import Rock 11 | 12 | -- | Try to find out which of two heads might refer to the other so we can 13 | -- unfold glued values that are defined later first (see "depth" in 14 | -- https://arxiv.org/pdf/1505.04324.pdf). 15 | compareHeadDepths :: Domain.Head -> Domain.Head -> M Ordering 16 | compareHeadDepths head1 head2 = 17 | case (head1, head2) of 18 | (Domain.Global global1, Domain.Global global2) -> do 19 | global1DependsOn2 <- fetch $ Query.TransitiveDependencies global2 $ Mapped.Query global1 20 | global2DependsOn1 <- fetch $ Query.TransitiveDependencies global1 $ Mapped.Query global2 21 | pure case (global1DependsOn2, global2DependsOn1) of 22 | (Just _, Nothing) -> GT 23 | (Nothing, Just _) -> LT 24 | _ -> EQ 25 | (_, Domain.Global _) -> pure GT 26 | (Domain.Global _, _) -> pure LT 27 | (Domain.Var v1, Domain.Var v2) -> pure $ compare v1 v2 28 | _ -> pure EQ 29 | -------------------------------------------------------------------------------- /src/Elaboration/Matching/SuggestedName.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedRecordDot #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Elaboration.Matching.SuggestedName where 5 | 6 | import Core.Bindings (Bindings) 7 | import qualified Core.Bindings as Bindings 8 | import qualified Data.HashMap.Lazy as HashMap 9 | import qualified Data.HashSet as HashSet 10 | import qualified Data.List.NonEmpty as NonEmpty 11 | import Elaboration.Context (Context) 12 | import qualified Elaboration.Context as Context 13 | import Monad 14 | import Name (Name (Name)) 15 | import qualified Name 16 | import Protolude 17 | import qualified Query 18 | import Rock 19 | import qualified Scope 20 | import qualified Span 21 | import qualified Surface.Syntax as Surface 22 | 23 | nextExplicit 24 | :: Context v 25 | -> [[Surface.PlicitPattern]] 26 | -> M (Bindings, [[Surface.PlicitPattern]]) 27 | nextExplicit context clauses = do 28 | spannedNames <- 29 | concatMapM (concatMapM $ explicitNames context) $ maybeToList . headMay <$> clauses 30 | pure 31 | ( maybe "x" Bindings.Spanned $ NonEmpty.nonEmpty spannedNames 32 | , shiftExplicit <$> clauses 33 | ) 34 | 35 | explicitNames :: Context v -> Surface.PlicitPattern -> M [(Span.Relative, Name)] 36 | explicitNames context pattern_ = 37 | case pattern_ of 38 | Surface.ExplicitPattern pattern' -> 39 | patternNames context pattern' 40 | _ -> 41 | pure [] 42 | 43 | shiftExplicit :: [Surface.PlicitPattern] -> [Surface.PlicitPattern] 44 | shiftExplicit patterns = 45 | case patterns of 46 | Surface.ExplicitPattern _ : patterns' -> 47 | patterns' 48 | Surface.ImplicitPattern _ _ : patterns' -> 49 | shiftExplicit patterns' 50 | [] -> 51 | [] 52 | 53 | nextImplicit 54 | :: Context v 55 | -> Name 56 | -> [[Surface.PlicitPattern]] 57 | -> M (Bindings, [[Surface.PlicitPattern]]) 58 | nextImplicit context piName clauses = do 59 | spannedNames <- 60 | concatMapM (concatMapM $ implicitNames context piName) $ maybeToList . headMay <$> clauses 61 | pure 62 | ( maybe (Bindings.Unspanned piName) Bindings.Spanned $ NonEmpty.nonEmpty spannedNames 63 | , shiftImplicit piName <$> clauses 64 | ) 65 | 66 | implicitNames :: Context v -> Name -> Surface.PlicitPattern -> M [(Span.Relative, Name)] 67 | implicitNames context piName pattern_ = 68 | case pattern_ of 69 | Surface.ImplicitPattern _ namedPats 70 | | Just p <- HashMap.lookup piName namedPats -> 71 | patternNames context p.pattern_ 72 | _ -> 73 | pure [] 74 | 75 | shiftImplicit :: Name -> [Surface.PlicitPattern] -> [Surface.PlicitPattern] 76 | shiftImplicit name patterns = 77 | case patterns of 78 | Surface.ImplicitPattern patSpan namedPats : patterns' -> 79 | let namedPats' = 80 | HashMap.delete name namedPats 81 | in if HashMap.null namedPats' 82 | then patterns' 83 | else Surface.ImplicitPattern patSpan namedPats' : patterns' 84 | _ -> 85 | patterns 86 | 87 | patternNames :: Context v -> Surface.Pattern -> M [(Span.Relative, Name)] 88 | patternNames context pattern_ = 89 | case pattern_ of 90 | Surface.Pattern span (Surface.ConOrVar (Surface.SpannedName _ surfaceName@(Name.Surface nameText)) []) -> do 91 | maybeScopeEntry <- fetch $ Query.ResolvedName (Context.moduleName context) surfaceName 92 | if HashSet.null $ foldMap Scope.entryConstructors maybeScopeEntry 93 | then pure [(span, Name nameText)] 94 | else pure [] 95 | _ -> 96 | pure [] 97 | 98 | patternBinding :: Context v -> Surface.Pattern -> Name -> M Bindings 99 | patternBinding context pattern_ fallbackName = do 100 | spannedNames <- patternNames context pattern_ 101 | pure $ 102 | maybe (Bindings.Unspanned fallbackName) Bindings.Spanned $ 103 | NonEmpty.nonEmpty spannedNames 104 | -------------------------------------------------------------------------------- /src/Elaboration/Postponed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Elaboration.Postponed where 5 | 6 | import qualified Core.Syntax as Syntax 7 | import Data.EnumMap (EnumMap) 8 | import qualified Data.EnumMap as EnumMap 9 | import Monad 10 | import qualified Postponement 11 | import Protolude hiding (check) 12 | 13 | data Check where 14 | Unchecked :: (Postponement.CanPostpone -> M (Syntax.Term v)) -> Check 15 | Checking :: Check 16 | Checked :: Syntax.Term v -> Check 17 | 18 | data Checks = Checks 19 | { checks :: !(EnumMap Postponement.Index Check) 20 | , nextIndex :: !Postponement.Index 21 | } 22 | 23 | empty :: Checks 24 | empty = 25 | Checks 26 | { checks = mempty 27 | , nextIndex = 0 28 | } 29 | 30 | lookup :: Postponement.Index -> Checks -> Check 31 | lookup index p = 32 | checks p EnumMap.! index 33 | 34 | insert :: (Postponement.CanPostpone -> M (Syntax.Term v)) -> Checks -> (Checks, Postponement.Index) 35 | insert check p = 36 | (Checks (EnumMap.insert (nextIndex p) (Unchecked check) (checks p)) (nextIndex p + 1), nextIndex p) 37 | 38 | update :: Postponement.Index -> Check -> Checks -> Checks 39 | update index newCheck p = 40 | p {checks = EnumMap.insert index newCheck $ checks p} 41 | 42 | adjustF :: (Functor f) => (Check -> f Check) -> Postponement.Index -> Checks -> f Checks 43 | adjustF adjust index p = 44 | (\checks' -> p {checks = checks'}) <$> EnumMap.alterF alter index (checks p) 45 | where 46 | alter maybeCheck = 47 | case maybeCheck of 48 | Nothing -> 49 | panic "Elaboration.Postponement.adjustF: adjusting non-existent index" 50 | Just check -> 51 | Just <$> adjust check 52 | -------------------------------------------------------------------------------- /src/Elaboration/Unification.hs-boot: -------------------------------------------------------------------------------- 1 | module Elaboration.Unification where 2 | 3 | import qualified Core.Domain as Domain 4 | import Elaboration.Context.Type 5 | import Monad 6 | import Protolude 7 | 8 | equalSpines :: Context v -> Domain.Spine -> Domain.Spine -> M Bool 9 | -------------------------------------------------------------------------------- /src/Elaboration/ZonkPostponedChecks.hs: -------------------------------------------------------------------------------- 1 | module Elaboration.ZonkPostponedChecks where 2 | 3 | import qualified Core.Syntax as Syntax 4 | import qualified Elaboration.Postponed as Postponed 5 | import Protolude hiding (IntMap) 6 | import Telescope (Telescope) 7 | import qualified Telescope 8 | 9 | zonkDefinition :: Postponed.Checks -> Syntax.Definition -> Syntax.Definition 10 | zonkDefinition postponed def = 11 | case def of 12 | Syntax.TypeDeclaration type_ -> 13 | Syntax.TypeDeclaration $ zonkTerm postponed type_ 14 | Syntax.ConstantDefinition term -> 15 | Syntax.ConstantDefinition $ zonkTerm postponed term 16 | Syntax.DataDefinition boxity tele -> 17 | Syntax.DataDefinition boxity $ zonkDataDefinition postponed tele 18 | 19 | zonkDataDefinition 20 | :: Postponed.Checks 21 | -> Telescope binding Syntax.Type Syntax.ConstructorDefinitions v 22 | -> Telescope binding Syntax.Type Syntax.ConstructorDefinitions v 23 | zonkDataDefinition postponed tele = 24 | case tele of 25 | Telescope.Empty (Syntax.ConstructorDefinitions constructorDefinitions) -> 26 | Telescope.Empty $ Syntax.ConstructorDefinitions $ zonkTerm postponed <$> constructorDefinitions 27 | Telescope.Extend binding type_ plicity tele' -> 28 | Telescope.Extend binding (zonkTerm postponed type_) plicity (zonkDataDefinition postponed tele') 29 | 30 | zonkTerm :: Postponed.Checks -> Syntax.Term v -> Syntax.Term v 31 | zonkTerm postponed term = 32 | case term of 33 | Syntax.Var _ -> 34 | term 35 | Syntax.Global _ -> 36 | term 37 | Syntax.Con _ -> 38 | term 39 | Syntax.Lit _ -> 40 | term 41 | Syntax.Meta _ -> 42 | term 43 | Syntax.PostponedCheck index term' -> 44 | case Postponed.lookup index postponed of 45 | Postponed.Unchecked {} -> 46 | zonkTerm postponed term' 47 | Postponed.Checking -> 48 | zonkTerm postponed term' 49 | Postponed.Checked term'' -> 50 | zonkTerm postponed $ Syntax.coerce term'' 51 | Syntax.Lets lets -> 52 | Syntax.Lets $ zonkLets postponed lets 53 | Syntax.Pi binding domain plicity targetScope -> 54 | Syntax.Pi binding (zonkTerm postponed domain) plicity (zonkTerm postponed targetScope) 55 | Syntax.Fun domain plicity target -> 56 | Syntax.Fun (zonkTerm postponed domain) plicity (zonkTerm postponed target) 57 | Syntax.Lam binding type_ plicity bodyScope -> 58 | Syntax.Lam binding (zonkTerm postponed type_) plicity (zonkTerm postponed bodyScope) 59 | Syntax.App fun plicity arg -> 60 | Syntax.App (zonkTerm postponed fun) plicity (zonkTerm postponed arg) 61 | Syntax.Case scrutinee type_ branches defaultBranch -> 62 | Syntax.Case 63 | (zonkTerm postponed scrutinee) 64 | (zonkTerm postponed type_) 65 | (zonkBranches postponed branches) 66 | (zonkTerm postponed <$> defaultBranch) 67 | Syntax.Spanned span term' -> 68 | Syntax.Spanned span $ zonkTerm postponed term' 69 | 70 | zonkLets :: Postponed.Checks -> Syntax.Lets v -> Syntax.Lets v 71 | zonkLets postponed lets = 72 | case lets of 73 | Syntax.LetType binding type_ lets' -> 74 | Syntax.LetType binding (zonkTerm postponed type_) (zonkLets postponed lets') 75 | Syntax.Let binding index term lets' -> 76 | Syntax.Let binding index (zonkTerm postponed term) (zonkLets postponed lets') 77 | Syntax.In term -> 78 | Syntax.In $ zonkTerm postponed term 79 | 80 | zonkBranches :: Postponed.Checks -> Syntax.Branches v -> Syntax.Branches v 81 | zonkBranches postponed branches = 82 | case branches of 83 | Syntax.ConstructorBranches constructorTypeName constructorBranches -> 84 | Syntax.ConstructorBranches constructorTypeName $ map (zonkTelescope postponed) <$> constructorBranches 85 | Syntax.LiteralBranches literalBranches -> 86 | Syntax.LiteralBranches $ map (zonkTerm postponed) <$> literalBranches 87 | 88 | zonkTelescope 89 | :: Postponed.Checks 90 | -> Telescope bindings Syntax.Type Syntax.Term v 91 | -> Telescope bindings Syntax.Type Syntax.Term v 92 | zonkTelescope postponed tele = 93 | case tele of 94 | Telescope.Empty branch -> 95 | Telescope.Empty $ zonkTerm postponed branch 96 | Telescope.Extend bindings type_ plicity tele' -> 97 | Telescope.Extend bindings (zonkTerm postponed type_) plicity (zonkTelescope postponed tele') 98 | -------------------------------------------------------------------------------- /src/Environment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | 3 | module Environment where 4 | 5 | import Data.EnumMap (EnumMap) 6 | import qualified Data.EnumMap as EnumMap 7 | import Data.Kind 8 | import Index (Index) 9 | import qualified Index 10 | import qualified Index.Map 11 | import qualified Index.Map as Index 12 | import Monad 13 | import Protolude 14 | import Var (Var) 15 | 16 | data Environment value (v :: Data.Kind.Type) = Environment 17 | { indices :: Index.Map v Var 18 | , values :: EnumMap Var value 19 | , glueableBefore :: !(Index (Index.Succ v)) 20 | } 21 | deriving (Show) 22 | 23 | empty :: Environment value Index.Zero 24 | empty = 25 | Environment 26 | { indices = Index.Map.Empty 27 | , values = mempty 28 | , glueableBefore = Index.Zero 29 | } 30 | 31 | extend 32 | :: Environment value v 33 | -> M (Environment value (Index.Succ v), Var) 34 | extend env = do 35 | var <- freshVar 36 | pure (extendVar env var, var) 37 | 38 | extendVar 39 | :: Environment value v 40 | -> Var 41 | -> Environment value (Index.Succ v) 42 | extendVar env v = 43 | env 44 | { indices = indices env Index.Map.:> v 45 | , glueableBefore = Index.Succ $ glueableBefore env 46 | } 47 | 48 | extendValue 49 | :: Environment value v 50 | -> value 51 | -> M (Environment value (Index.Succ v), Var) 52 | extendValue env value = do 53 | var <- freshVar 54 | pure 55 | ( env 56 | { indices = indices env Index.Map.:> var 57 | , values = EnumMap.insert var value (values env) 58 | , glueableBefore = Index.Succ $ glueableBefore env 59 | } 60 | , var 61 | ) 62 | 63 | define :: Environment value v -> Var -> value -> Environment value v 64 | define env var value = 65 | env {values = EnumMap.insert var value (values env)} 66 | 67 | lookupVarIndex :: Var -> Environment value v -> Maybe (Index v) 68 | lookupVarIndex var context = 69 | Index.Map.elemIndex var (indices context) 70 | 71 | lookupIndexVar :: Index v -> Environment value v -> Var 72 | lookupIndexVar index env = 73 | Index.Map.index (indices env) index 74 | 75 | lookupIndexValue :: Index v -> Environment value v -> Maybe value 76 | lookupIndexValue index env = 77 | lookupVarValue (lookupIndexVar index env) env 78 | 79 | lookupVarValue :: Var -> Environment value v -> Maybe value 80 | lookupVarValue v env = 81 | EnumMap.lookup v $ values env 82 | -------------------------------------------------------------------------------- /src/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Error where 6 | 7 | import Core.Domain.Pattern (Pattern) 8 | import qualified Core.Syntax as Syntax 9 | import Data.HashSet (HashSet) 10 | import Data.Tsil (Tsil) 11 | import qualified Error.Parsing as Error 12 | import qualified Meta 13 | import qualified Module 14 | import Name (Name) 15 | import qualified Name 16 | import Plicity 17 | import Prettyprinter 18 | import Protolude 19 | import qualified Scope 20 | import qualified Span 21 | 22 | data Error 23 | = Parse FilePath !Error.Parsing 24 | | DuplicateName !Scope.DefinitionKind !Name.Qualified !Span.Absolute 25 | | ImportNotFound !Name.Module !Module.Import 26 | | MultipleFilesWithModuleName !Name.Module FilePath FilePath 27 | | ModuleFileNameMismatch !Name.Module !Name.Module !Span.Absolute FilePath 28 | | Elaboration !Scope.DefinitionKind !Name.Qualified !Error.Spanned 29 | deriving (Eq, Show, Generic) 30 | 31 | data Elaboration 32 | = NotInScope !Name.Surface 33 | | Ambiguous !Name.Surface (HashSet Name.QualifiedConstructor) (HashSet Name.Qualified) 34 | | DuplicateLetName !Name.Surface !Span.Relative 35 | | UndefinedLetName !Name.Surface 36 | | TypeMismatch (Tsil (PrettyableTerm, PrettyableTerm)) 37 | | OccursCheck (Tsil (PrettyableTerm, PrettyableTerm)) 38 | | UnsolvedMetaVariable !Meta.Index !PrettyableTerm 39 | | NonExhaustivePatterns ![[(Plicity, PrettyablePattern)]] 40 | | RedundantMatch !MatchKind 41 | | IndeterminateIndexUnification !MatchKind 42 | | PlicityMismatch !FieldOrArgument !PlicityMismatch 43 | | UnableToInferImplicitLambda 44 | | ImplicitApplicationMismatch (HashSet Name) !PrettyableTerm !PrettyableTerm 45 | deriving (Eq, Show, Generic, Exception) 46 | 47 | data PlicityMismatch 48 | = Mismatch !Plicity !Plicity 49 | | Missing !Plicity 50 | | Extra 51 | deriving (Eq, Show, Generic) 52 | 53 | data FieldOrArgument 54 | = Field 55 | | Argument 56 | deriving (Eq, Show, Generic) 57 | 58 | instance Pretty FieldOrArgument where 59 | pretty fieldOrArg = 60 | case fieldOrArg of 61 | Field -> 62 | "field" 63 | Argument -> 64 | "argument" 65 | 66 | data MatchKind 67 | = Clause 68 | | Branch 69 | | Lambda 70 | deriving (Eq, Show, Generic) 71 | 72 | instance Pretty MatchKind where 73 | pretty clauseOrPat = 74 | case clauseOrPat of 75 | Clause -> 76 | "clause" 77 | Branch -> 78 | "branch" 79 | Lambda -> 80 | "lambda" 81 | 82 | data Spanned 83 | = Spanned !Span.Relative !Error.Elaboration 84 | deriving (Eq, Show, Generic) 85 | 86 | data V 87 | 88 | data PrettyableTerm = PrettyableTerm Name.Module [Name] (Syntax.Term V) 89 | deriving (Eq, Show, Generic) 90 | 91 | data PrettyablePattern = PrettyablePattern Name.Module [Name] Pattern 92 | deriving (Eq, Show, Generic) 93 | -------------------------------------------------------------------------------- /src/Error/Parsing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Error.Parsing where 5 | 6 | import qualified Position 7 | import Protolude 8 | 9 | data Parsing = Parsing 10 | { reason :: !(Maybe Text) 11 | , expected :: [Text] 12 | , position :: Either EOF Position.Absolute 13 | } 14 | deriving (Eq, Ord, Show, Generic, Hashable) 15 | 16 | data EOF = EOF 17 | deriving (Eq, Ord, Show, Generic, Hashable) 18 | -------------------------------------------------------------------------------- /src/Extra.hs: -------------------------------------------------------------------------------- 1 | module Extra where 2 | 3 | import Data.Graph 4 | import qualified Data.HashSet as HashSet 5 | import Protolude 6 | 7 | unique :: (Hashable a, Foldable f) => f a -> Bool 8 | unique = go mempty . toList 9 | where 10 | go seen as = 11 | case as of 12 | [] -> 13 | True 14 | a : as' 15 | | a `HashSet.member` seen -> 16 | False 17 | | otherwise -> 18 | go (HashSet.insert a seen) as' 19 | 20 | topoSortWith 21 | :: (Foldable t, Ord name) 22 | => (a -> name) 23 | -> (a -> [name]) 24 | -> t a 25 | -> [SCC a] 26 | topoSortWith name deps as = 27 | stronglyConnComp [(a, name a, deps a) | a <- toList as] 28 | 29 | last :: [a] -> Maybe a 30 | last = 31 | go Nothing 32 | where 33 | go result as = 34 | case as of 35 | [] -> 36 | result 37 | a : as' -> 38 | go (Just a) as' 39 | 40 | {-# INLINE defaultHashWithSalt #-} 41 | defaultHashWithSalt :: (Hashable a) => Int -> a -> Int 42 | defaultHashWithSalt salt x = 43 | salt `combine` hash x 44 | where 45 | {-# INLINE combine #-} 46 | combine :: Int -> Int -> Int 47 | combine h1 h2 = 48 | (h1 * 16777619) `xor` h2 49 | -------------------------------------------------------------------------------- /src/Flexibility.hs: -------------------------------------------------------------------------------- 1 | module Flexibility where 2 | 3 | import Protolude 4 | 5 | data Flexibility 6 | = Rigid 7 | | Flexible 8 | deriving (Eq, Ord, Show) 9 | -------------------------------------------------------------------------------- /src/Index.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module Index where 6 | 7 | import Protolude hiding (pred) 8 | 9 | ------------------------------------------------------------------------------- 10 | -- Indices 11 | 12 | newtype Index v = Index Int 13 | deriving (Eq, Ord, Show, Hashable) 14 | 15 | ------------------------------------------------------------------------------- 16 | -- Phantom types 17 | 18 | type Scope f v = f (Succ v) 19 | 20 | data Zero 21 | 22 | data Succ v 23 | 24 | pattern Zero :: Index (Succ v) 25 | pattern Zero = Index 0 26 | 27 | pattern Succ :: Index v -> Index (Succ v) 28 | pattern Succ i <- 29 | (pred -> Just i) 30 | where 31 | Succ (Index v) = Index $ v + 1 32 | 33 | pred :: Index (Succ v) -> Maybe (Index v) 34 | pred (Index 0) = Nothing 35 | pred (Index n) = Just $ Index $ n - 1 36 | 37 | {-# COMPLETE Zero, Succ #-} 38 | -------------------------------------------------------------------------------- /src/Index/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | module Index.Map where 7 | 8 | import Data.IntSeq (IntSeq) 9 | import qualified Data.IntSeq as IntSeq 10 | import Index (Index (Index)) 11 | import qualified Index 12 | import Protolude hiding (Map) 13 | 14 | newtype Map v a = Map (IntSeq a) 15 | deriving (Show, Foldable) 16 | 17 | pattern Empty :: (Enum a) => Map Index.Zero a 18 | pattern Empty = Map IntSeq.Empty 19 | 20 | pattern (:>) :: (Enum a) => Map v a -> a -> Map (Index.Succ v) a 21 | pattern as :> a <- 22 | Map ((Map -> as) IntSeq.:> a) 23 | where 24 | Map m :> a = Map $ m IntSeq.:> a 25 | 26 | {-# COMPLETE Empty, (:>) #-} 27 | 28 | length :: Map v a -> Index (Index.Succ v) 29 | length (Map m) = Index $ IntSeq.length m 30 | 31 | elemIndex :: (Enum a) => a -> Map v a -> Maybe (Index v) 32 | elemIndex a (Map m) = 33 | (\i -> Index $ IntSeq.length m - i - 1) <$> IntSeq.elemIndex a m 34 | 35 | index :: Map v a -> Index v -> a 36 | index (Map m) (Index i) = 37 | IntSeq.index m (IntSeq.length m - i - 1) 38 | -------------------------------------------------------------------------------- /src/Index/Seq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | module Index.Seq where 7 | 8 | import qualified Data.Sequence as Seq 9 | import Index (Index (Index)) 10 | import qualified Index 11 | import Protolude hiding (Seq) 12 | 13 | newtype Seq v a = Seq {toSeq :: Seq.Seq a} 14 | deriving (Show, Foldable) 15 | 16 | pattern Empty :: Seq Index.Zero a 17 | pattern Empty <- Seq (Seq.null -> True) 18 | where 19 | Empty = Seq mempty 20 | 21 | pattern (:>) :: Seq v a -> a -> Seq (Index.Succ v) a 22 | pattern as :> a <- 23 | Seq ((Seq -> as) Seq.:|> a) 24 | where 25 | Seq m :> a = Seq $ m Seq.:|> a 26 | 27 | {-# COMPLETE Empty, (:>) #-} 28 | 29 | length :: Seq v a -> Index (Index.Succ v) 30 | length (Seq m) = Index $ Seq.length m 31 | 32 | index :: Seq v a -> Index v -> a 33 | index (Seq m) (Index i) = 34 | Seq.index m (Seq.length m - i - 1) 35 | -------------------------------------------------------------------------------- /src/LambdaLifted/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | 7 | module LambdaLifted.Syntax where 8 | 9 | import Boxity 10 | import Data.OrderedHashMap (OrderedHashMap) 11 | import Index (Index, Scope) 12 | import qualified Index 13 | import Literal (Literal) 14 | import Name (Name) 15 | import qualified Name 16 | import Plicity 17 | import Protolude hiding (IntMap, Type) 18 | import Telescope (Telescope) 19 | import qualified Telescope 20 | 21 | data Term v 22 | = Var !(Index v) 23 | | Global !Name.Lifted 24 | | Con 25 | !Name.QualifiedConstructor 26 | [Term v] 27 | -- ^ Type parameters 28 | [Term v] 29 | -- ^ Constructor arguments 30 | | Lit !Literal 31 | | Let !Name !(Term v) !(Type v) !(Scope Term v) 32 | | Pi !Name !(Type v) !(Scope Type v) 33 | | App !(Term v) !(Term v) 34 | | Case !(Term v) !(Type v) (Branches v) !(Maybe (Term v)) 35 | deriving (Eq, Show, Generic, Hashable) 36 | 37 | type Type = Term 38 | 39 | pisView :: (forall v'. Term v' -> term v') -> Term v -> Telescope Name term term v 40 | pisView f type_ = 41 | case type_ of 42 | Var {} -> Telescope.Empty $ f type_ 43 | Global {} -> Telescope.Empty $ f type_ 44 | Con {} -> Telescope.Empty $ f type_ 45 | Lit {} -> Telescope.Empty $ f type_ 46 | Let {} -> Telescope.Empty $ f type_ 47 | Pi name type' scope -> Telescope.Extend name (f type') Explicit $ pisView f scope 48 | App {} -> Telescope.Empty $ f type_ 49 | Case {} -> Telescope.Empty $ f type_ 50 | 51 | data Branches v 52 | = ConstructorBranches !Name.Qualified (OrderedHashMap Name.Constructor (Telescope Name Type Term v)) 53 | | LiteralBranches (OrderedHashMap Literal (Term v)) 54 | deriving (Eq, Show, Generic, Hashable) 55 | 56 | data Definition 57 | = TypeDeclaration !(Type Index.Zero) 58 | | ConstantDefinition !(Telescope Name Type Term Index.Zero) 59 | | DataDefinition !Boxity !(Telescope Name Type ConstructorDefinitions Index.Zero) 60 | deriving (Eq, Show, Generic, Hashable) 61 | 62 | newtype ConstructorDefinitions v 63 | = ConstructorDefinitions (OrderedHashMap Name.Constructor (Type v)) 64 | deriving (Show, Generic) 65 | deriving newtype (Eq, Hashable) 66 | -------------------------------------------------------------------------------- /src/LanguageServer/CodeLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | 3 | module LanguageServer.CodeLens where 4 | 5 | import qualified Data.Text.Unsafe as Text 6 | import qualified Elaboration.Context as Context 7 | import qualified Error.Hydrated as Error 8 | import qualified LanguageServer.LineColumns as LineColumns 9 | import Monad 10 | import Name (Name (Name)) 11 | import qualified Name 12 | import qualified Position 13 | import Prettyprinter (Doc) 14 | import Protolude hiding (IntMap, evaluate, moduleName) 15 | import Query (Query) 16 | import qualified Query 17 | import Rock 18 | import qualified Scope 19 | import qualified Span 20 | import qualified Surface.Syntax as Surface 21 | import qualified UTF16 22 | 23 | codeLens :: FilePath -> Task Query [(UTF16.LineColumns, Doc ann)] 24 | codeLens filePath = runM do 25 | (moduleName, _, defs) <- fetch $ Query.ParsedFile filePath 26 | 27 | toLineColumns <- LineColumns.fromAbsolute moduleName 28 | let previousDefs = Nothing : fmap Just defs 29 | concat 30 | <$> forM (zip previousDefs defs) \(previousDef, (pos, (name@(Name nameText), def))) -> do 31 | let qualifiedName = 32 | Name.Qualified moduleName name 33 | 34 | go = do 35 | context <- Context.empty Scope.Definition qualifiedName 36 | type_ <- fetch $ Query.ElaboratedType qualifiedName 37 | prettyType <- Error.prettyPrettyableTerm 0 =<< Context.toPrettyableTerm context type_ 38 | pure 39 | [ 40 | ( toLineColumns $ Span.Absolute pos $ pos + Position.Absolute (Text.lengthWord8 nameText) 41 | , prettyType 42 | ) 43 | ] 44 | 45 | case (previousDef, def) of 46 | (Just (_, (previousName, Surface.TypeDeclaration {})), _) 47 | | previousName == name -> 48 | pure [] 49 | (_, Surface.TypeDeclaration {}) -> 50 | pure [] 51 | (_, Surface.ConstantDefinition {}) -> 52 | go 53 | (_, Surface.DataDefinition {}) -> 54 | go 55 | -------------------------------------------------------------------------------- /src/LanguageServer/DocumentHighlights.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module LanguageServer.DocumentHighlights where 5 | 6 | import Data.HashMap.Lazy as HashMap 7 | import qualified Data.Text.Utf16.Rope as Rope 8 | import qualified LanguageServer.LineColumns as LineColumns 9 | import qualified Name 10 | import qualified Occurrences.Intervals as Intervals 11 | import qualified Position 12 | import Protolude hiding (moduleName) 13 | import Query (Query) 14 | import qualified Query 15 | import Rock 16 | import qualified Span 17 | import qualified UTF16 18 | 19 | highlights 20 | :: FilePath 21 | -> UTF16.LineColumn 22 | -> Task Query [UTF16.LineColumns] 23 | highlights filePath (UTF16.LineColumn line column) = do 24 | (moduleName, _, _) <- fetch $ Query.ParsedFile filePath 25 | spans <- fetch $ Query.ModuleSpanMap moduleName 26 | contents <- fetch $ Query.FileRope filePath 27 | let pos = 28 | Position.Absolute 29 | case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of 30 | Nothing -> 0 31 | Just (rope, _) -> fromIntegral $ Rope.utf8Length rope 32 | 33 | toLineColumns <- LineColumns.fromAbsolute moduleName 34 | 35 | let itemSpans item = 36 | concat 37 | <$> forM (HashMap.toList spans) \((definitionKind, name), Span.Absolute defPos _) -> do 38 | occurrenceIntervals <- 39 | fetch $ 40 | Query.Occurrences definitionKind $ 41 | Name.Qualified moduleName name 42 | pure $ toLineColumns . Span.absoluteFrom defPos <$> Intervals.itemSpans item occurrenceIntervals 43 | 44 | concat 45 | <$> forM (HashMap.toList spans) \((definitionKind, name), span@(Span.Absolute defPos _)) -> 46 | if span `Span.contains` pos 47 | then do 48 | occurrenceIntervals <- 49 | fetch $ 50 | Query.Occurrences definitionKind $ 51 | Name.Qualified moduleName name 52 | let relativePos = 53 | Position.relativeTo defPos pos 54 | 55 | items = 56 | Intervals.intersect relativePos occurrenceIntervals 57 | 58 | concat 59 | <$> forM items \item -> 60 | case item of 61 | Intervals.Var var -> 62 | pure $ toLineColumns . Span.absoluteFrom defPos <$> Intervals.varSpans var relativePos occurrenceIntervals 63 | Intervals.Global _ -> 64 | itemSpans item 65 | Intervals.Con _ -> 66 | itemSpans item 67 | Intervals.Lit _ -> 68 | itemSpans item 69 | else pure [] 70 | -------------------------------------------------------------------------------- /src/LanguageServer/Hover.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module LanguageServer.Hover where 6 | 7 | import qualified Core.TypeOf as TypeOf 8 | import qualified Elaboration 9 | import qualified Elaboration.Context as Context 10 | import qualified Error.Hydrated as Error 11 | import qualified LanguageServer.CursorAction as CursorAction 12 | import Prettyprinter (Doc, (<+>)) 13 | import Protolude hiding (evaluate, moduleName) 14 | import Query (Query) 15 | import Rock 16 | import qualified UTF16 17 | 18 | hover :: FilePath -> UTF16.LineColumn -> Task Query (Maybe (UTF16.LineColumns, Doc ann)) 19 | hover filePath pos = 20 | CursorAction.cursorAction filePath pos \item lineColumn -> 21 | case item of 22 | CursorAction.Term _ context _ term -> do 23 | value <- lift $ Elaboration.evaluate context term 24 | type_ <- lift $ TypeOf.typeOf context value 25 | type' <- lift $ Elaboration.readback context type_ 26 | prettyTerm <- Error.prettyPrettyableTerm 0 =<< lift (Context.toPrettyableTerm context term) 27 | prettyType <- Error.prettyPrettyableTerm 0 =<< lift (Context.toPrettyableTerm context type') 28 | pure 29 | ( lineColumn 30 | , prettyTerm <+> ":" <+> prettyType 31 | ) 32 | CursorAction.Import _ -> 33 | empty 34 | -------------------------------------------------------------------------------- /src/LanguageServer/LineColumns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module LanguageServer.LineColumns where 4 | 5 | import qualified Data.Text.Utf16.Rope as Rope 6 | import qualified Name 7 | import qualified Position 8 | import Protolude hiding (moduleName) 9 | import Query (Query) 10 | import qualified Query 11 | import Rock 12 | import qualified Scope 13 | import qualified Span 14 | import UTF16 15 | 16 | fromDefinitionName :: (MonadFetch Query m) => Scope.DefinitionKind -> Name.Qualified -> m (Maybe (Span.Relative -> UTF16.LineColumns)) 17 | fromDefinitionName definitionKind name@(Name.Qualified moduleName _) = do 18 | (_, maybeAbsolutePosition) <- fetch $ Query.DefinitionPosition definitionKind name 19 | toLineColumns <- fromAbsolute moduleName 20 | pure $ fmap ((toLineColumns .) . Span.absoluteFrom) maybeAbsolutePosition 21 | 22 | fromAbsolute :: (MonadFetch Query m) => Name.Module -> m (Span.Absolute -> UTF16.LineColumns) 23 | fromAbsolute moduleName = do 24 | maybeFilePath <- fetch $ Query.ModuleFile moduleName 25 | case maybeFilePath of 26 | Nothing -> 27 | pure $ const $ UTF16.LineColumns (UTF16.LineColumn 0 0) (UTF16.LineColumn 0 0) 28 | Just filePath -> do 29 | rope <- fetch $ Query.FileRope filePath 30 | let toLineColumn (Position.Absolute i) = 31 | case Rope.utf8SplitAt (fromIntegral i) rope of 32 | Nothing -> UTF16.LineColumn 0 0 33 | Just (rope', _) -> 34 | let Rope.Position row column = Rope.lengthAsPosition rope' 35 | in UTF16.LineColumn (fromIntegral row) (fromIntegral column) 36 | 37 | toLineColumns (Span.Absolute start end) = 38 | UTF16.LineColumns (toLineColumn start) (toLineColumn end) 39 | 40 | return toLineColumns 41 | -------------------------------------------------------------------------------- /src/LanguageServer/References.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedRecordDot #-} 4 | 5 | module LanguageServer.References where 6 | 7 | import qualified Builtin 8 | import Data.HashMap.Lazy as HashMap 9 | import qualified Data.HashSet as HashSet 10 | import qualified Data.Text.Utf16.Rope as Rope 11 | import qualified LanguageServer.LineColumns as LineColumns 12 | import qualified Module 13 | import qualified Name 14 | import qualified Occurrences.Intervals as Intervals 15 | import qualified Position 16 | import Protolude hiding (moduleName) 17 | import Query (Query) 18 | import qualified Query 19 | import Rock 20 | import qualified Span 21 | import qualified UTF16 22 | 23 | references 24 | :: FilePath 25 | -> UTF16.LineColumn 26 | -> Task Query [(Intervals.Item, [(FilePath, UTF16.LineColumns)])] 27 | references filePath (UTF16.LineColumn line column) = do 28 | (originalModuleName, _, _) <- fetch $ Query.ParsedFile filePath 29 | let itemSpans definingModule item = do 30 | let mightUseDefiningModule moduleName header = 31 | moduleName == definingModule 32 | || any ((==) definingModule . (.module_)) header.imports 33 | inputFiles <- fetch Query.InputFiles 34 | concat 35 | <$> forM (HashSet.toList inputFiles) \inputFile -> do 36 | (moduleName, header, _) <- fetch $ Query.ParsedFile inputFile 37 | if mightUseDefiningModule moduleName header 38 | then do 39 | spans <- fetch $ Query.ModuleSpanMap moduleName 40 | toLineColumns <- LineColumns.fromAbsolute moduleName 41 | concat 42 | <$> forM (HashMap.toList spans) \((definitionKind, name), Span.Absolute defPos _) -> do 43 | occurrenceIntervals <- 44 | fetch $ 45 | Query.Occurrences definitionKind $ 46 | Name.Qualified moduleName name 47 | pure $ (,) inputFile . toLineColumns . Span.absoluteFrom defPos <$> Intervals.itemSpans item occurrenceIntervals 48 | else pure mempty 49 | 50 | contents <- fetch $ Query.FileRope filePath 51 | let pos = 52 | Position.Absolute 53 | case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of 54 | Nothing -> 0 55 | Just (rope, _) -> fromIntegral $ Rope.utf8Length rope 56 | toLineColumns <- LineColumns.fromAbsolute originalModuleName 57 | spans <- fetch $ Query.ModuleSpanMap originalModuleName 58 | concat 59 | <$> forM (HashMap.toList spans) \((definitionKind, name), span@(Span.Absolute defPos _)) -> 60 | if span `Span.contains` pos 61 | then do 62 | occurrenceIntervals <- 63 | fetch $ 64 | Query.Occurrences definitionKind $ 65 | Name.Qualified originalModuleName name 66 | let relativePos = 67 | Position.relativeTo defPos pos 68 | 69 | items = 70 | Intervals.intersect relativePos occurrenceIntervals 71 | 72 | forM items \item -> 73 | (,) item 74 | <$> case item of 75 | Intervals.Var var -> 76 | pure $ (,) filePath . toLineColumns . Span.absoluteFrom defPos <$> Intervals.varSpans var relativePos occurrenceIntervals 77 | Intervals.Global (Name.Qualified definingModule _) -> 78 | itemSpans definingModule item 79 | Intervals.Con (Name.QualifiedConstructor (Name.Qualified definingModule _) _) -> 80 | itemSpans definingModule item 81 | Intervals.Lit _ -> 82 | itemSpans Builtin.Module item 83 | else pure [] 84 | -------------------------------------------------------------------------------- /src/Literal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | module Literal where 5 | 6 | import Prettyprinter 7 | import Protolude 8 | 9 | newtype Literal 10 | = Integer Integer 11 | deriving (Eq, Generic, Show, Hashable) 12 | 13 | instance Pretty Literal where 14 | pretty literal = 15 | case literal of 16 | Literal.Integer int -> 17 | pretty int 18 | -------------------------------------------------------------------------------- /src/Low/PassBy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Low.PassBy where 7 | 8 | import Low.Representation (Representation) 9 | import Prettyprinter 10 | import Protolude hiding (repr) 11 | 12 | data PassBy 13 | = Value !Representation 14 | | Reference 15 | deriving (Eq, Show, Generic, Hashable) 16 | 17 | instance Pretty PassBy where 18 | pretty = \case 19 | Value repr -> pretty repr 20 | Reference -> "ref" 21 | -------------------------------------------------------------------------------- /src/Low/Representation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedRecordDot #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | 8 | module Low.Representation where 9 | 10 | import Prettyprinter 11 | import Protolude hiding (repr) 12 | 13 | data Representation = Representation 14 | { pointers :: !Word32 15 | , nonPointerBytes :: !Word32 16 | } 17 | deriving (Eq, Show, Generic, Hashable) 18 | 19 | instance Semigroup Representation where 20 | repr1 <> repr2 = 21 | Representation 22 | { pointers = repr1.pointers + repr2.pointers 23 | , nonPointerBytes = repr1.nonPointerBytes + repr2.nonPointerBytes 24 | } 25 | 26 | instance Monoid Representation where 27 | mempty = Empty 28 | 29 | instance Pretty Representation where 30 | pretty = \case 31 | Representation {pointers = 0, nonPointerBytes = 0} -> "empty" 32 | Representation {pointers = 0, nonPointerBytes = np} -> "b" <> pretty np 33 | Representation {pointers = p, nonPointerBytes = 0} -> "p" <> pretty p 34 | Representation {pointers = p, nonPointerBytes = np} -> "p" <> pretty p <> "b" <> pretty np 35 | 36 | pattern Empty :: Representation 37 | pattern Empty = Representation {pointers = 0, nonPointerBytes = 0} 38 | 39 | leastUpperBound :: Representation -> Representation -> Representation 40 | leastUpperBound repr1 repr2 = 41 | Representation 42 | { pointers = max repr1.pointers repr2.pointers 43 | , nonPointerBytes = 44 | max repr1.nonPointerBytes repr2.nonPointerBytes 45 | } 46 | 47 | wordBytes :: (Num a) => a 48 | wordBytes = 8 49 | 50 | wordBits :: (Num a) => a 51 | wordBits = wordBytes * 8 52 | 53 | int :: Representation 54 | int = Representation {pointers = 0, nonPointerBytes = wordBytes} 55 | 56 | type_ :: Representation 57 | type_ = Representation {pointers = 0, nonPointerBytes = wordBytes} 58 | 59 | pointer :: Representation 60 | pointer = Representation {pointers = 1, nonPointerBytes = 0} 61 | 62 | rawFunctionPointer :: Representation 63 | rawFunctionPointer = Representation {pointers = 0, nonPointerBytes = wordBytes} 64 | 65 | shouldPassByReference :: Representation -> Bool 66 | shouldPassByReference repr = 67 | repr.pointers * wordBytes + repr.nonPointerBytes > 2 * wordBytes 68 | -------------------------------------------------------------------------------- /src/Low/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module Low.Syntax where 6 | 7 | import Index (Index, Scope) 8 | import qualified Index 9 | import Literal (Literal) 10 | import Low.PassBy (PassBy) 11 | import Low.Representation (Representation) 12 | import Name (Name) 13 | import qualified Name 14 | import Protolude 15 | 16 | data Term v 17 | = Operand !(Operand v) 18 | | Let !PassBy !Name !(LetOperation v) !(Scope Term v) 19 | | Seq !(SeqOperation v) !(Term v) 20 | deriving (Eq, Show, Generic, Hashable) 21 | 22 | data LetOperation v 23 | = Case !(Operand v) [Branch v] (Maybe (Term v)) 24 | | Call !Name.Lowered [Operand v] 25 | | StackAllocate !(Operand v) 26 | | HeapAllocate !Name.QualifiedConstructor !(Operand v) 27 | | HeapPayload !(Operand v) 28 | | PointerTag !(Operand v) 29 | | Offset !(Operand v) !(Operand v) 30 | | Load !(Operand v) !Representation 31 | deriving (Eq, Show, Generic, Hashable) 32 | 33 | data SeqOperation v 34 | = Store !(Operand v) !(Operand v) !Representation 35 | | Copy !(Operand v) !(Operand v) !(Operand v) 36 | | IncreaseReferenceCount !(Operand v) !Representation 37 | | IncreaseReferenceCounts !(Operand v) !(Operand v) 38 | | DecreaseReferenceCount !(Operand v) !Representation 39 | deriving (Eq, Show, Generic, Hashable) 40 | 41 | data Operand v 42 | = Var !(Index v) 43 | | Global !Representation !Name.Lowered 44 | | Literal !Literal 45 | | Representation !Representation 46 | | Tag !Name.QualifiedConstructor 47 | | Undefined !Representation 48 | deriving (Eq, Show, Generic, Hashable) 49 | 50 | data Branch v 51 | = ConstructorBranch !Name.QualifiedConstructor !(Term v) 52 | | LiteralBranch !Literal !(Term v) 53 | deriving (Eq, Show, Generic, Hashable) 54 | 55 | branchTerm :: Branch v -> Term v 56 | branchTerm = \case 57 | ConstructorBranch _ t -> t 58 | LiteralBranch _ t -> t 59 | 60 | data Function v 61 | = Body !PassBy !(Term v) 62 | | Parameter !Name !PassBy !(Scope Function v) 63 | deriving (Eq, Show, Generic, Hashable) 64 | 65 | type Type = Term 66 | 67 | data Definition 68 | = ConstantDefinition !Representation 69 | | FunctionDefinition !(Function Index.Zero) 70 | deriving (Eq, Show, Generic, Hashable) 71 | 72 | data Signature 73 | = ConstantSignature !Representation 74 | | FunctionSignature [PassBy] !PassBy 75 | deriving (Eq, Show, Generic, Hashable) 76 | -------------------------------------------------------------------------------- /src/Meta.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Meta where 6 | 7 | import Orphans () 8 | import Prettyprinter 9 | import Protolude hiding (IntMap) 10 | 11 | newtype Index = Index Int 12 | deriving (Eq, Ord, Show) 13 | deriving newtype (Enum, Hashable, Num) 14 | 15 | instance Pretty Index where 16 | pretty (Index i) = 17 | "?" <> pretty i 18 | -------------------------------------------------------------------------------- /src/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | 5 | module Module where 6 | 7 | import Data.HashSet (HashSet) 8 | import qualified Name 9 | import Orphans () 10 | import Protolude 11 | import qualified Span 12 | 13 | data Header = Header 14 | { exposedNames :: !ExposedNames 15 | , imports :: [Import] 16 | } 17 | deriving (Eq, Show, Generic, Hashable) 18 | 19 | instance Semigroup Header where 20 | Header exposed1 imports1 <> Header exposed2 imports2 = 21 | Header (exposed1 <> exposed2) (imports1 <> imports2) 22 | 23 | instance Monoid Header where 24 | mempty = 25 | Header 26 | { exposedNames = mempty 27 | , imports = mempty 28 | } 29 | 30 | data ExposedNames 31 | = Exposed (HashSet Name.Surface) 32 | | AllExposed 33 | deriving (Eq, Show, Generic, Hashable) 34 | 35 | instance Semigroup ExposedNames where 36 | Exposed names1 <> Exposed names2 = 37 | Exposed $ names1 <> names2 38 | AllExposed <> _ = 39 | AllExposed 40 | _ <> AllExposed = 41 | AllExposed 42 | 43 | instance Monoid ExposedNames where 44 | mempty = 45 | Exposed mempty 46 | 47 | data Import = Import 48 | { span :: !Span.Absolute 49 | , module_ :: !Name.Module 50 | , alias :: !(Span.Absolute, Name.Surface) 51 | , importedNames :: !ExposedNames 52 | } 53 | deriving (Eq, Show, Generic, Hashable) 54 | -------------------------------------------------------------------------------- /src/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Monad where 5 | 6 | import Control.Monad.Trans.Control 7 | import Data.IORef.Unboxed (IORefU) 8 | import qualified Data.IORef.Unboxed as IORef.Unboxed 9 | import Protolude hiding (State, try) 10 | import Query (Query) 11 | import Rock 12 | import System.IO.Unsafe (unsafeDupablePerformIO) 13 | import Var 14 | 15 | type M = ReaderT State (Task Query) 16 | 17 | newtype State = State 18 | { nextVar :: IORefU Int 19 | } 20 | 21 | data Lazy a = Lazy a 22 | 23 | {-# INLINE force #-} 24 | force :: Lazy a -> M a 25 | force (Lazy a) = 26 | liftIO $ evaluate a 27 | 28 | {-# ANN module "HLint: ignore Use newtype instead of data" #-} 29 | 30 | {-# NOINLINE lazy #-} 31 | lazy :: M a -> M (Lazy a) 32 | lazy m = 33 | liftBaseWith \runInIO -> 34 | pure $ Lazy $ unsafeDupablePerformIO $ runInIO m 35 | 36 | freshVar :: M Var 37 | freshVar = do 38 | ref <- asks nextVar 39 | i <- liftIO $ IORef.Unboxed.atomicAddCounter_ ref 1 40 | pure $ Var i 41 | 42 | runM :: M a -> Task Query a 43 | runM r = do 44 | nextVarVar <- liftIO $ IORef.Unboxed.newCounter 0 45 | runReaderT 46 | r 47 | State 48 | { nextVar = nextVarVar 49 | } 50 | 51 | allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool 52 | allM _ [] = return True 53 | allM p (x : xs) = do 54 | b <- p x 55 | if b 56 | then allM p xs 57 | else return False 58 | 59 | anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool 60 | anyM _ [] = return False 61 | anyM p (x : xs) = do 62 | b <- p x 63 | if b 64 | then return True 65 | else anyM p xs 66 | -------------------------------------------------------------------------------- /src/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE NoFieldSelectors #-} 7 | 8 | module Name where 9 | 10 | import Data.String 11 | import qualified Data.Text as Text 12 | import Extra 13 | import Prettyprinter 14 | import Protolude hiding (Constructor) 15 | 16 | newtype Surface = Surface Text 17 | deriving stock (Eq, Ord, Show) 18 | deriving newtype (IsString, Semigroup, Hashable) 19 | 20 | newtype Name = Name Text 21 | deriving stock (Eq, Ord, Show) 22 | deriving newtype (IsString, Hashable) 23 | 24 | newtype Constructor = Constructor Text 25 | deriving stock (Eq, Ord, Show) 26 | deriving newtype (IsString, Hashable) 27 | 28 | newtype Module = Module Text 29 | deriving stock (Eq, Ord, Show) 30 | deriving newtype (IsString, Hashable) 31 | 32 | data Qualified = Qualified 33 | { moduleName :: !Module 34 | , name :: !Name 35 | } 36 | deriving (Eq, Ord, Show, Generic) 37 | 38 | data QualifiedConstructor = QualifiedConstructor 39 | { typeName :: !Qualified 40 | , constructorName :: !Constructor 41 | } 42 | deriving (Eq, Ord, Show, Generic) 43 | 44 | data Lifted = Lifted !Qualified !Int 45 | deriving (Eq, Ord, Show, Generic) 46 | 47 | data Lowered = Lowered !Lifted !LoweredKind 48 | deriving (Eq, Ord, Show, Generic) 49 | 50 | data LoweredKind = Original | Init | Inited 51 | deriving (Eq, Ord, Show, Generic, Hashable) 52 | 53 | unqualifyConstructor :: QualifiedConstructor -> Constructor 54 | unqualifyConstructor (QualifiedConstructor _ c) = c 55 | 56 | ------------------------------------------------------------------------------- 57 | 58 | instance IsString Qualified where 59 | fromString s = 60 | let t = 61 | fromString s 62 | 63 | (moduleDot, name) = 64 | Text.breakOnEnd "." t 65 | in case Text.stripSuffix "." moduleDot of 66 | Nothing -> 67 | Qualified (Module mempty) (Name t) 68 | Just module_ -> 69 | Qualified (Module module_) (Name name) 70 | 71 | instance Pretty Surface where 72 | pretty (Surface t) = 73 | pretty t 74 | 75 | instance Pretty Name where 76 | pretty (Name t) = 77 | pretty t 78 | 79 | instance Pretty Constructor where 80 | pretty (Constructor c) = 81 | pretty c 82 | 83 | instance Pretty Module where 84 | pretty (Module t) = 85 | pretty t 86 | 87 | instance Pretty Qualified where 88 | pretty (Qualified (Module module_) name) 89 | | Text.null module_ = 90 | pretty name 91 | | otherwise = 92 | pretty module_ <> "." <> pretty name 93 | 94 | instance Hashable Qualified where 95 | hashWithSalt = 96 | defaultHashWithSalt 97 | 98 | hash (Qualified m n) = 99 | hash m `hashWithSalt` n 100 | 101 | instance Pretty QualifiedConstructor where 102 | pretty (QualifiedConstructor n c) = 103 | pretty n <> "." <> pretty c 104 | 105 | instance Hashable QualifiedConstructor where 106 | hashWithSalt = 107 | defaultHashWithSalt 108 | 109 | hash (QualifiedConstructor m n) = 110 | hash m `hashWithSalt` n 111 | 112 | instance Pretty Lifted where 113 | pretty (Lifted name 0) = 114 | pretty name 115 | pretty (Lifted name n) = 116 | pretty name <> "$" <> pretty n 117 | 118 | instance Hashable Lifted where 119 | hashWithSalt = 120 | defaultHashWithSalt 121 | 122 | hash (Lifted m n) = 123 | hash m `hashWithSalt` n 124 | 125 | instance Pretty Lowered where 126 | pretty (Lowered name loweredKind) = 127 | case loweredKind of 128 | Original -> pretty name 129 | Init -> pretty name <> "$init" 130 | Inited -> pretty name <> "$inited" 131 | 132 | instance Hashable Lowered where 133 | hashWithSalt = 134 | defaultHashWithSalt 135 | 136 | hash (Lowered m n) = 137 | hash m `hashWithSalt` n 138 | -------------------------------------------------------------------------------- /src/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# OPTIONS_GHC -Wno-orphans #-} 6 | 7 | module Orphans where 8 | 9 | import Data.EnumMap (EnumMap) 10 | import qualified Data.EnumMap as EnumMap 11 | import Data.EnumSet (EnumSet) 12 | import qualified Data.EnumSet as EnumSet 13 | import Data.IntervalMap.FingerTree (IntervalMap) 14 | import qualified Data.IntervalMap.FingerTree as IntervalMap 15 | import Data.Text.Utf16.Rope (Rope) 16 | import qualified Data.Text.Utf16.Rope as Rope 17 | import Protolude hiding (IntSet, get, put) 18 | 19 | instance (Enum k, Hashable k, Hashable v) => Hashable (EnumMap k v) where 20 | hashWithSalt s = hashWithSalt s . EnumMap.toList 21 | 22 | instance (Enum k, Hashable k) => Hashable (EnumSet k) where 23 | hashWithSalt s = hashWithSalt s . EnumSet.toList 24 | 25 | instance (Hashable k) => Hashable (IntervalMap.Interval k) where 26 | hashWithSalt s (IntervalMap.Interval a b) = 27 | hashWithSalt s (a, b) 28 | 29 | instance (Hashable k, Ord k, Hashable v) => Hashable (IntervalMap k v) where 30 | hashWithSalt s m = 31 | hashWithSalt s $ 32 | (`IntervalMap.intersections` m) 33 | <$> IntervalMap.bounds m 34 | 35 | instance Hashable Rope where 36 | hashWithSalt s = hashWithSalt s . Rope.toText 37 | -------------------------------------------------------------------------------- /src/Plicity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Plicity where 6 | 7 | import Prettyprinter 8 | import Protolude 9 | 10 | data Plicity 11 | = Implicit 12 | | Explicit 13 | | Constraint 14 | deriving (Eq, Ord, Show, Generic, Hashable) 15 | 16 | instance Pretty Plicity where 17 | pretty plicity = 18 | case plicity of 19 | Implicit -> 20 | "implicit" 21 | Explicit -> 22 | "explicit" 23 | Constraint -> 24 | "constraint" 25 | 26 | isImplicitish :: Plicity -> Bool 27 | isImplicitish plicity = 28 | case plicity of 29 | Implicit -> 30 | True 31 | Explicit -> 32 | False 33 | Constraint -> 34 | True 35 | 36 | prettyAnnotation :: Plicity -> Doc ann 37 | prettyAnnotation plicity = 38 | case plicity of 39 | Implicit -> 40 | "@" 41 | Explicit -> 42 | "" 43 | Constraint -> 44 | "!" 45 | 46 | implicitise :: Plicity -> Plicity 47 | implicitise plicity = 48 | case plicity of 49 | Explicit -> 50 | Implicit 51 | Implicit -> 52 | Implicit 53 | Constraint -> 54 | Constraint 55 | -------------------------------------------------------------------------------- /src/Position.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module Position where 7 | 8 | import Protolude 9 | 10 | newtype Absolute = Absolute Int 11 | deriving stock (Eq, Ord, Show) 12 | deriving newtype (Num, Hashable, NFData) 13 | 14 | newtype Relative = Relative Int 15 | deriving stock (Eq, Ord, Show) 16 | deriving newtype (Num, Hashable) 17 | 18 | relativeTo :: Absolute -> Absolute -> Relative 19 | relativeTo (Absolute base) (Absolute pos) = 20 | Relative (pos - base) 21 | 22 | add :: Absolute -> Relative -> Absolute 23 | add (Absolute base) (Relative rel) = Absolute $ base + rel 24 | 25 | data LineColumn = LineColumn !Int !Int 26 | deriving (Eq, Ord, Show, Generic, NFData) 27 | 28 | addLine :: LineColumn -> LineColumn 29 | addLine (LineColumn line _) = 30 | LineColumn (line + 1) 0 31 | 32 | addColumns :: LineColumn -> Int -> LineColumn 33 | addColumns (LineColumn line column) delta = 34 | LineColumn line $ column + delta 35 | -------------------------------------------------------------------------------- /src/Postponement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Postponement where 6 | 7 | import Orphans () 8 | import Prettyprinter 9 | import Protolude hiding (IntMap) 10 | 11 | newtype Index = Index Int 12 | deriving (Eq, Ord, Show) 13 | deriving newtype (Enum, Hashable, Num) 14 | 15 | instance Pretty Index where 16 | pretty (Index i) = 17 | "?" <> pretty i 18 | 19 | data CanPostpone 20 | = Can'tPostpone 21 | | CanPostpone 22 | deriving (Show) 23 | -------------------------------------------------------------------------------- /src/Project.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE OverloadedRecordDot #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE NoFieldSelectors #-} 5 | 6 | module Project where 7 | 8 | import Control.Monad.Trans.Maybe 9 | import qualified Data.Aeson as Aeson 10 | import qualified Data.Aeson.Casing as Aeson 11 | import qualified Data.Aeson.TH as Aeson 12 | import Data.HashSet (HashSet) 13 | import qualified Data.HashSet as HashSet 14 | import Protolude 15 | import qualified System.Directory as Directory 16 | import qualified System.FilePath as FilePath 17 | 18 | newtype Project = Project 19 | { sourceDirectories :: [FilePath] 20 | } 21 | deriving (Show) 22 | 23 | Aeson.deriveJSON Aeson.defaultOptions {Aeson.fieldLabelModifier = Aeson.trainCase} ''Project 24 | 25 | filesFromArguments :: [FilePath] -> IO (HashSet FilePath, HashSet FilePath) 26 | filesFromArguments files = do 27 | files' <- mapM Directory.canonicalizePath files 28 | case files' of 29 | [] -> do 30 | workingDirectory <- Directory.getCurrentDirectory 31 | filesFromProjectInDirectory workingDirectory 32 | _ -> 33 | mconcat 34 | <$> forM files' \file -> do 35 | isDir <- Directory.doesDirectoryExist file 36 | isFile <- Directory.doesFileExist file 37 | case () of 38 | _ 39 | | isDir -> do 40 | projectFiles <- filesFromProjectInDirectory file 41 | if projectFiles == mempty 42 | then (,) (HashSet.singleton file) <$> listDirectoryRecursive isSourcePath file 43 | else pure projectFiles 44 | | isFile 45 | , isProjectPath file -> 46 | listProjectFile file 47 | | isFile 48 | , isSourcePath file -> 49 | pure (HashSet.singleton $ FilePath.takeDirectory file, HashSet.singleton file) 50 | | otherwise -> 51 | -- TODO report error 52 | pure mempty 53 | 54 | filesFromProjectInDirectory :: FilePath -> IO (HashSet FilePath, HashSet FilePath) 55 | filesFromProjectInDirectory directory = do 56 | maybeProjectFile <- findProjectFile directory 57 | case maybeProjectFile of 58 | Nothing -> 59 | -- TODO report error 60 | pure mempty 61 | Just file -> 62 | listProjectFile file 63 | 64 | findProjectFile :: FilePath -> IO (Maybe FilePath) 65 | findProjectFile directory = do 66 | let candidateDirectories = 67 | map FilePath.joinPath $ 68 | reverse $ 69 | drop 1 $ 70 | inits $ 71 | FilePath.splitDirectories directory 72 | runMaybeT $ 73 | asum $ 74 | foreach candidateDirectories \candidateDirectory -> do 75 | let file = 76 | candidateDirectory FilePath. "sixten.json" 77 | fileExists <- liftIO $ Directory.doesFileExist file 78 | guard fileExists 79 | pure file 80 | 81 | listProjectFile :: FilePath -> IO (HashSet FilePath, HashSet FilePath) 82 | listProjectFile file = do 83 | maybeProject <- Aeson.decodeFileStrict file 84 | case maybeProject of 85 | Nothing -> 86 | -- TODO report error 87 | pure mempty 88 | Just project -> 89 | listProject file project 90 | 91 | listProject :: FilePath -> Project -> IO (HashSet FilePath, HashSet FilePath) 92 | listProject file project = do 93 | sourceDirectories <- mapM (Directory.canonicalizePath . (FilePath.takeDirectory file FilePath.)) project.sourceDirectories 94 | fmap ((,) (HashSet.fromList sourceDirectories) . mconcat) $ 95 | forM sourceDirectories $ 96 | listDirectoryRecursive isSourcePath 97 | 98 | listDirectoryRecursive :: (FilePath -> Bool) -> FilePath -> IO (HashSet FilePath) 99 | listDirectoryRecursive p dir = do 100 | files <- Directory.listDirectory dir 101 | mconcat 102 | <$> forM files \file -> do 103 | let path = dir FilePath. file 104 | isDir <- Directory.doesDirectoryExist path 105 | if isDir 106 | then listDirectoryRecursive p path 107 | else pure $ HashSet.fromList [path | p path] 108 | 109 | isSourcePath :: FilePath -> Bool 110 | isSourcePath = 111 | (== ".vix") . FilePath.takeExtension 112 | 113 | isProjectPath :: FilePath -> Bool 114 | isProjectPath = 115 | (== ".json") . FilePath.takeExtension 116 | -------------------------------------------------------------------------------- /src/Query/Mapped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | module Query.Mapped where 11 | 12 | import Data.Constraint 13 | import Data.Constraint.Extras 14 | import Data.GADT.Compare 15 | import Data.HashMap.Lazy (HashMap) 16 | import qualified Data.HashMap.Lazy as HashMap 17 | import Orphans () 18 | import Protolude 19 | import Rock 20 | 21 | data Query key result a where 22 | Map :: Query key result (HashMap key result) 23 | Query :: key -> Query key result (Maybe result) 24 | 25 | deriving instance (Show key, Show result) => Show (Query key result a) 26 | 27 | deriving instance (Eq key, Eq result) => Eq (Query key result a) 28 | 29 | instance (Hashable key, Hashable result) => Hashable (Query key result a) where 30 | hashWithSalt salt query = 31 | case query of 32 | Map -> 33 | hashWithSalt salt (0 :: Int) 34 | Query key -> 35 | hashWithSalt salt (1 :: Int, key) 36 | 37 | rule 38 | :: (Hashable key) 39 | => (forall a'. Query key result a' -> query a') 40 | -> Query key result a 41 | -> Task query (HashMap key result) 42 | -> Task query a 43 | rule inject query fetchMap = 44 | case query of 45 | Map -> 46 | fetchMap 47 | Query key -> do 48 | m <- fetch $ inject Map 49 | pure $ HashMap.lookup key m 50 | 51 | instance (Eq key) => GEq (Query key result) where 52 | geq Map Map = Just Refl 53 | geq (Query k1) (Query k2) 54 | | k1 == k2 = Just Refl 55 | geq _ _ = Nothing 56 | 57 | instance (Ord key) => GCompare (Query key result) where 58 | gcompare Map Map = GEQ 59 | gcompare Map _ = GLT 60 | gcompare _ Map = GGT 61 | gcompare (Query k1) (Query k2) = 62 | case compare k1 k2 of 63 | LT -> GLT 64 | EQ -> GEQ 65 | GT -> GGT 66 | 67 | instance (c (Maybe result), c (HashMap key result)) => Has c (Query key result) where 68 | argDict query = 69 | case query of 70 | Map -> Dict 71 | Query {} -> Dict 72 | -------------------------------------------------------------------------------- /src/Scope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Scope where 5 | 6 | import Data.HashMap.Lazy (HashMap) 7 | import qualified Data.HashMap.Lazy as HashMap 8 | import Data.HashSet (HashSet) 9 | import qualified Data.HashSet as HashSet 10 | import qualified Name 11 | import Orphans () 12 | import Protolude 13 | 14 | data DefinitionKind = Type | Definition 15 | deriving (Eq, Ord, Show, Generic, Hashable) 16 | 17 | data Entry 18 | = Name !Name.Qualified 19 | | -- | Only data 20 | Constructors (HashSet Name.QualifiedConstructor) (HashSet Name.Qualified) 21 | | Ambiguous (HashSet Name.QualifiedConstructor) (HashSet Name.Qualified) 22 | deriving (Eq, Show, Generic, Hashable) 23 | 24 | entryConstructors :: Entry -> HashSet Name.QualifiedConstructor 25 | entryConstructors entry = 26 | case entry of 27 | Name _ -> 28 | mempty 29 | Constructors cs _ -> 30 | cs 31 | Ambiguous cs _ -> 32 | cs 33 | 34 | type Scope = 35 | HashMap Name.Surface Entry 36 | 37 | instance Semigroup Entry where 38 | Name name1 <> Name name2 39 | | name1 == name2 = 40 | Name name1 41 | | otherwise = 42 | Ambiguous mempty $ HashSet.fromList [name1, name2] 43 | Constructors constrs1 data1 <> Constructors constrs2 data2 = 44 | Constructors (constrs1 <> constrs2) (data1 <> data2) 45 | entry@(Constructors _ data_) <> Name name 46 | | name `HashSet.member` data_ = 47 | entry 48 | Name name <> entry@(Constructors _ data_) 49 | | name `HashSet.member` data_ = 50 | entry 51 | Name name <> entry = 52 | Ambiguous mempty (HashSet.singleton name) <> entry 53 | entry <> Name name = 54 | entry <> Ambiguous mempty (HashSet.singleton name) 55 | Constructors constrs data_ <> entry = 56 | Ambiguous constrs data_ <> entry 57 | entry <> Constructors constrs data_ = 58 | entry <> Ambiguous constrs data_ 59 | Ambiguous constrs1 names1 <> Ambiguous constrs2 names2 = 60 | Ambiguous (constrs1 <> constrs2) (names1 <> names2) 61 | 62 | aliases 63 | :: Scope 64 | -> (HashMap Name.QualifiedConstructor (HashSet Name.Surface), HashMap Name.Qualified (HashSet Name.Surface)) 65 | aliases scope = 66 | bimap (HashMap.fromListWith (<>)) (HashMap.fromListWith (<>)) $ 67 | partitionEithers $ 68 | concat 69 | [ case entry of 70 | Name name -> 71 | [Right (name, HashSet.singleton surfaceName)] 72 | Constructors constrs dataNames -> 73 | [ Left (constr, HashSet.singleton surfaceName) 74 | | constr <- HashSet.toList constrs 75 | ] 76 | <> [ Right (name, HashSet.singleton surfaceName) 77 | | name <- HashSet.toList dataNames 78 | ] 79 | Ambiguous constrs names -> 80 | [ Left (constr, HashSet.singleton surfaceName) 81 | | constr <- HashSet.toList constrs 82 | ] 83 | <> [ Right (name, HashSet.singleton surfaceName) 84 | | name <- HashSet.toList names 85 | ] 86 | | (surfaceName, entry) <- HashMap.toList scope 87 | ] 88 | -------------------------------------------------------------------------------- /src/Span.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Span where 5 | 6 | import qualified Position 7 | import Protolude 8 | 9 | data Absolute = Absolute !Position.Absolute !Position.Absolute 10 | deriving (Eq, Ord, Show, Generic, Hashable, NFData) 11 | 12 | data Relative = Relative !Position.Relative !Position.Relative 13 | deriving (Eq, Ord, Show, Generic, Hashable) 14 | 15 | relativeTo :: Position.Absolute -> Span.Absolute -> Span.Relative 16 | relativeTo base (Span.Absolute start end) = 17 | Span.Relative (Position.relativeTo base start) (Position.relativeTo base end) 18 | 19 | absoluteFrom :: Position.Absolute -> Span.Relative -> Span.Absolute 20 | absoluteFrom base (Span.Relative start end) = 21 | Span.Absolute (Position.add base start) (Position.add base end) 22 | 23 | add :: Relative -> Relative -> Relative 24 | add (Span.Relative start _) (Span.Relative _ end) = 25 | Span.Relative start end 26 | 27 | contains :: Absolute -> Position.Absolute -> Bool 28 | contains (Absolute start end) pos = 29 | start <= pos && pos < end 30 | 31 | relativeContains :: Relative -> Position.Relative -> Bool 32 | relativeContains (Relative start end) pos = 33 | start <= pos && pos < end 34 | 35 | data LineColumn = LineColumns !Position.LineColumn !Position.LineColumn 36 | deriving (Show, Generic) 37 | -------------------------------------------------------------------------------- /src/Telescope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | 7 | module Telescope where 8 | 9 | import Index (Scope) 10 | import qualified Index 11 | import Plicity 12 | import Protolude 13 | import Unsafe.Coerce 14 | 15 | data Telescope name type_ base v 16 | = Empty !(base v) 17 | | Extend !name !(type_ v) !Plicity !(Scope (Telescope name type_ base) v) 18 | deriving (Generic) 19 | 20 | deriving instance 21 | (Eq n, forall v'. Eq (t v'), forall v'. Eq (k v')) 22 | => Eq (Telescope n t k v) 23 | 24 | deriving instance 25 | (Show n, (forall v'. Show (t v')), (forall v'. Show (k v'))) 26 | => Show (Telescope n t k v) 27 | 28 | deriving instance 29 | (Hashable n, (forall v'. Hashable (t v')), (forall v'. Hashable (k v'))) 30 | => Hashable (Telescope n t k v) 31 | 32 | under :: Telescope n t k v -> (forall v'. k v' -> result) -> result 33 | under tele f = 34 | case tele of 35 | Empty k -> f k 36 | Extend _ _ _ tele' -> under tele' f 37 | 38 | hoist :: (forall v'. t v' -> t' v') -> (forall v'. k v' -> k' v') -> Telescope n t k v -> Telescope n t' k' v 39 | hoist f g tele = 40 | case tele of 41 | Empty k -> 42 | Empty $ g k 43 | Extend name t plicity scope -> 44 | Extend name (f t) plicity $ hoist f g scope 45 | 46 | hoistA :: (Applicative f) => (forall v'. t v' -> f (t' v')) -> (forall v'. k v' -> f (k' v')) -> Telescope n t k v -> f (Telescope n t' k' v) 47 | hoistA f g tele = 48 | case tele of 49 | Empty k -> 50 | Empty <$> g k 51 | Extend name t plicity scope -> 52 | Extend name <$> f t <*> pure plicity <*> hoistA f g scope 53 | 54 | fold 55 | :: (forall v'. n -> t v' -> Plicity -> Scope k v' -> k v') 56 | -> Telescope n t k v 57 | -> k v 58 | fold f = 59 | Telescope.foldr f identity 60 | 61 | foldr 62 | :: (forall v'. n -> t v' -> Plicity -> Scope result v' -> result v') 63 | -> (forall v'. k v' -> result v') 64 | -> Telescope n t k v 65 | -> result v 66 | foldr f g tele = 67 | case tele of 68 | Empty k -> 69 | g k 70 | Extend name t plicity scope -> 71 | f name t plicity $ Telescope.foldr f g scope 72 | 73 | foldMap 74 | :: (Monoid result) 75 | => (forall v'. type_ v' -> result) 76 | -> (forall v'. base v' -> result) 77 | -> Telescope name type_ base v 78 | -> result 79 | foldMap f g tele = 80 | case tele of 81 | Empty k -> 82 | g k 83 | Extend _ t _ scope -> 84 | f t <> Telescope.foldMap f g scope 85 | 86 | fromZero :: Telescope n t k Index.Zero -> Telescope n t k v 87 | fromZero = unsafeCoerce 88 | 89 | length :: Telescope n t k v -> Int 90 | length tele = 91 | case tele of 92 | Empty _ -> 93 | 0 94 | Extend _ _ _ tele' -> 95 | 1 + Telescope.length tele' 96 | -------------------------------------------------------------------------------- /src/UTF16.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | module UTF16 where 7 | 8 | import qualified Data.Text as Text 9 | import qualified Data.Text.Unsafe as Text 10 | import qualified Data.Text.Utf16.Lines as Utf16.Lines 11 | import qualified Position 12 | import Prettyprinter (Pretty (pretty)) 13 | import Protolude hiding (length) 14 | import qualified Span 15 | 16 | newtype CodeUnits = CodeUnits {toInt :: Int} 17 | deriving (Eq, Ord, Show, Generic, NFData, Num) 18 | 19 | length :: Text -> CodeUnits 20 | length = CodeUnits . fromIntegral . Utf16.Lines.length . Utf16.Lines.fromText 21 | 22 | data LineColumn = LineColumn !Int !CodeUnits 23 | deriving (Eq, Ord, Show, Generic) 24 | 25 | data LineColumns = LineColumns !LineColumn !LineColumn 26 | deriving (Show, Generic) 27 | 28 | lineColumn :: Position.Absolute -> Text -> (LineColumn, Text) 29 | lineColumn (Position.Absolute index) text = 30 | let prefix = Text.takeWord8 index text 31 | suffix = Text.dropWord8 index text 32 | linePrefix = Text.takeWhileEnd (/= '\n') prefix 33 | linePrefixLength = Text.lengthWord8 linePrefix 34 | linePrefixLength16 = length linePrefix 35 | lineSuffixLength = Text.lengthWord8 $ Text.takeWhile (/= '\n') suffix 36 | lineStart = index - linePrefixLength 37 | lineLength = linePrefixLength + lineSuffixLength 38 | line = Text.takeWord8 lineLength $ Text.dropWord8 lineStart text 39 | in ( LineColumn 40 | (Text.count "\n" prefix) 41 | linePrefixLength16 42 | , line 43 | ) 44 | 45 | lineColumns :: Span.Absolute -> Text -> (LineColumns, Text) 46 | lineColumns (Span.Absolute start end) text = 47 | let (startLineColumn, lineText) = 48 | lineColumn start text 49 | in ( LineColumns 50 | startLineColumn 51 | (fst $ lineColumn end text) 52 | , lineText 53 | ) 54 | 55 | -- | Gives a summary (fileName:row:column) of the location 56 | instance Pretty LineColumns where 57 | pretty 58 | ( LineColumns 59 | start@(LineColumn ((+ 1) -> startLine) (CodeUnits ((+ 1) -> startColumn))) 60 | end@(LineColumn ((+ 1) -> endLine) (CodeUnits ((+ 1) -> endColumn))) 61 | ) 62 | | start == end = 63 | pretty startLine <> ":" <> pretty startColumn 64 | | startLine == endLine = 65 | pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endColumn 66 | | otherwise = 67 | pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endLine <> ":" <> pretty endColumn 68 | -------------------------------------------------------------------------------- /src/UTF8.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module UTF8 where 5 | 6 | import qualified Data.Char as Char 7 | import qualified Data.Text.Internal.Encoding.Utf8 as Utf8 8 | import qualified Language.Haskell.TH.Lib as TH 9 | import Language.Haskell.TH.Quote 10 | import Protolude 11 | 12 | unit1 :: QuasiQuoter 13 | unit1 = 14 | QuasiQuoter 15 | { quoteExp = \case 16 | [c] 17 | | word8 <- fromIntegral $ Char.ord c 18 | , Utf8.validate1 word8 -> 19 | TH.litE $ TH.integerL $ fromIntegral word8 20 | _ -> 21 | panic "UTF8.unit1 needs a single char" 22 | , quotePat = \case 23 | [c] 24 | | word8 <- fromIntegral $ Char.ord c 25 | , Utf8.validate1 word8 -> 26 | TH.litP $ TH.integerL $ fromIntegral word8 27 | _ -> 28 | panic "UTF8.unit1 needs a single char" 29 | , quoteType = panic "UTF8.unit1 quoteType" 30 | , quoteDec = panic "UTF8.unit1 quoteDec" 31 | } 32 | -------------------------------------------------------------------------------- /src/Var.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Var where 4 | 5 | import Protolude 6 | 7 | newtype Var = Var Int 8 | deriving (Eq, Enum, Ord, Show, Hashable) 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.22 2 | packages: 3 | - . 4 | extra-deps: 5 | - dependent-hashmap-0.1.0.1 6 | - rock-0.3.1.2 7 | - git: https://github.com/ollef/text-rope.git 8 | commit: 22ccfdd795cfec5014acc3923b781a783afbdb06 9 | - git: https://github.com/fpco/ghc-prof-flamegraph.git 10 | commit: 8edd3b4806adeb25a4d55bed51c3afcc8e7a8e14 11 | -------------------------------------------------------------------------------- /tests/compilation/boxed-data.vix: -------------------------------------------------------------------------------- 1 | boxed 2 | data Pointer a = Pointer a 3 | 4 | add600 : Pointer Int -> Pointer Int 5 | add600 (Pointer n) = Pointer (addInt 600 n) 6 | 7 | deref : forall a. Pointer a -> a 8 | deref (Pointer a) = a 9 | 10 | data Tuple a b = Tuple a b 11 | 12 | addTuplePtr : Pointer (Tuple Int Int) -> Int 13 | addTuplePtr (Pointer (Tuple a b)) = addInt a b 14 | 15 | test1 = printInt (deref (Pointer 609)) -- prints 609 16 | test2 = printInt (deref (add600 (Pointer 10))) -- prints 610 17 | test3 = printInt (addTuplePtr (Pointer (Tuple 13 14))) -- prints 27 18 | -------------------------------------------------------------------------------- /tests/compilation/const.vix: -------------------------------------------------------------------------------- 1 | const : forall a b. a -> b -> a 2 | const a _ = a 3 | 4 | singleUse = printInt (const 610 1) -- prints 610 5 | nestedUse = printInt (const 611 (const 2 3)) -- prints 611 6 | -------------------------------------------------------------------------------- /tests/compilation/factorial.vix: -------------------------------------------------------------------------------- 1 | factorial : Int -> Int 2 | factorial 0 = 1 3 | factorial n = mulInt n (factorial (subInt n 1)) 4 | 5 | test = printInt (factorial 10) -- prints 3628800 6 | -------------------------------------------------------------------------------- /tests/compilation/fibonacci.vix: -------------------------------------------------------------------------------- 1 | fibonacci : Int -> Int 2 | fibonacci 0 = 0 3 | fibonacci 1 = 1 4 | fibonacci n = addInt (fibonacci (subInt n 1)) (fibonacci (subInt n 2)) 5 | 6 | test = printInt (fibonacci 20) -- prints 6765 7 | -------------------------------------------------------------------------------- /tests/compilation/identity.vix: -------------------------------------------------------------------------------- 1 | id : forall a. a -> a 2 | id x = x 3 | 4 | id2 : forall a. a -> a 5 | id2 x = id x 6 | 7 | id3 : forall a. a -> a 8 | id3 x = 9 | let result = id2 x 10 | in result 11 | 12 | intId : Int -> Int 13 | intId x = x 14 | 15 | useId = printInt (id 610) -- prints 610 16 | 17 | useId2 = printInt (id2 611) -- prints 611 18 | 19 | useId3 = printInt (id3 612) -- prints 612 20 | 21 | useIntId = printInt (intId 613) -- prints 613 22 | -------------------------------------------------------------------------------- /tests/compilation/list-generation.vix: -------------------------------------------------------------------------------- 1 | boxed 2 | data List a = Nil | Cons a (List a) 3 | 4 | data Tuple a b = Tuple a b 5 | 6 | generate : Int -> List Int 7 | generate 0 = Nil 8 | generate n = Cons n (generate (subInt n 1)) 9 | 10 | sum : List Int -> Int 11 | sum Nil = 0 12 | sum (Cons n ns) = addInt n (sum ns) 13 | 14 | zip : forall a b. List a -> List b -> List (Tuple a b) 15 | zip Nil _ = Nil 16 | zip _ Nil = Nil 17 | zip (Cons a as) (Cons b bs) = Cons (Tuple a b) (zip as bs) 18 | 19 | fsts : forall a b. List (Tuple a b) -> List a 20 | fsts Nil = Nil 21 | fsts (Cons (Tuple a b) rest) = Cons a (fsts rest) 22 | 23 | snds : forall a b. List (Tuple a b) -> List b 24 | snds Nil = Nil 25 | snds (Cons (Tuple a b) rest) = Cons b (snds rest) 26 | 27 | idList : forall a. List a -> List a 28 | idList Nil = Nil 29 | idList (Cons a as) = Cons a (idList as) 30 | 31 | addTuples : List (Tuple Int Int) -> List Int 32 | addTuples Nil = Nil 33 | addTuples (Cons (Tuple m n) tuples) = Cons (addInt m n) (addTuples tuples) 34 | 35 | list = generate 100 36 | 37 | listList = zip list list 38 | 39 | test1 = printInt (sum list) -- prints 5050 40 | test2 = printInt (sum (idList list)) -- prints 5050 41 | test3 = printInt (sum (fsts listList)) -- prints 5050 42 | test4 = printInt (sum (snds listList)) -- prints 5050 43 | test5 = printInt (sum (addTuples listList)) -- prints 10100 44 | -------------------------------------------------------------------------------- /tests/compilation/maybe.vix: -------------------------------------------------------------------------------- 1 | data Maybe a = Nothing | Just a 2 | 3 | withDefault : forall a. a -> Maybe a -> a 4 | withDefault default Nothing = default 5 | withDefault _ (Just a) = a 6 | 7 | test1 = printInt (withDefault 610 Nothing) -- prints 610 8 | test2 = printInt (withDefault 0 (Just 611)) -- prints 611 9 | -------------------------------------------------------------------------------- /tests/compilation/printint.vix: -------------------------------------------------------------------------------- 1 | test = printInt 610 -- prints 610 2 | -------------------------------------------------------------------------------- /tests/compilation/triangular-number.vix: -------------------------------------------------------------------------------- 1 | triangular : Int -> Int 2 | triangular 0 = 0 3 | triangular n = addInt n (triangular (subInt n 1)) 4 | 5 | test1 = printInt (triangular 10) -- prints 55 6 | test2 = printInt (triangular 100) -- prints 5050 7 | -------------------------------------------------------------------------------- /tests/compilation/unboxed-data.vix: -------------------------------------------------------------------------------- 1 | data Empty where 2 | data Unit = Unit 3 | data Either a b = Left a | Right b 4 | data Tuple a b = Tuple a b 5 | 6 | identity : forall a. a -> a 7 | 8 | fromRightWithDefault : forall a b. b -> Either a b -> b 9 | fromRightWithDefault default (Left _) = default 10 | fromRightWithDefault _ (Right b) = b 11 | 12 | fromLeftWithDefault : forall a b. a -> Either a b -> a 13 | fromLeftWithDefault _ (Left a) = a 14 | fromLeftWithDefault default (Right _) = default 15 | 16 | first : forall a b. Tuple a b -> a 17 | first (Tuple a b) = a 18 | 19 | second : forall a b. Tuple a b -> b 20 | second (Tuple a b) = b 21 | 22 | absurd : forall a. Empty -> a 23 | absurd e = case e of 24 | 25 | testData1 : Either Unit (Either Unit Unit) 26 | testData1 = Right (Right Unit) 27 | 28 | testFunction1 : forall a. Either a (Either a a) -> a 29 | testFunction1 (Left a) = a 30 | testFunction1 (Right (Left a)) = a 31 | testFunction1 (Right (Right a)) = a 32 | 33 | test1 = case testFunction1 testData1 of 34 | Unit -> printInt 610 -- prints 610 35 | 36 | testData2 : Either Unit Unit 37 | testData2 = Left Unit 38 | 39 | testFunction2 : Either Unit Unit -> Unit 40 | testFunction2 (Left a) = a 41 | testFunction2 (Right a) = a 42 | 43 | test2 = case testFunction2 testData2 of 44 | Unit -> printInt 611 -- prints 611 45 | 46 | testData3 : Either Unit (Either Unit Unit) 47 | testData3 = Right (Left Unit) 48 | 49 | testFunction3 : Either Unit (Either Unit Unit) -> Unit 50 | testFunction3 (Left a) = a 51 | testFunction3 (Right (Left a)) = a 52 | testFunction3 (Right (Right a)) = a 53 | 54 | test3 = case testFunction3 testData3 of 55 | Unit -> printInt 612 -- prints 612 56 | 57 | testData4 : Either Int (Tuple Unit Int) 58 | testData4 = Right (Tuple Unit 613) 59 | 60 | testFunction4 : Either Int (Tuple Unit Int) -> Int 61 | testFunction4 (Left a) = a 62 | testFunction4 (Right (Tuple Unit a)) = a 63 | 64 | test4 = printInt (testFunction4 testData4) -- prints 613 65 | 66 | testData5 : Either Unit (Tuple Int Int) 67 | testData5 = Right (Tuple 613 614) 68 | 69 | testFunction5 : Either Unit (Tuple Int Int) -> Int 70 | testFunction5 (Left Unit) = 0 71 | testFunction5 (Right (Tuple 613 a)) = a 72 | testFunction5 (Right (Tuple _ _)) = 0 73 | 74 | test5 = printInt (testFunction5 testData5) -- prints 614 75 | 76 | testData6 : Tuple (Either Unit Unit) (Either Int Int) 77 | testData6 = Tuple (Left Unit) (Right 615) 78 | 79 | testFunction6 : Tuple (Either Unit Unit) (Either Int Int) -> Int 80 | testFunction6 (Tuple (Left Unit) (Left _)) = 0 81 | testFunction6 (Tuple (Left Unit) (Right n)) = n 82 | testFunction6 (Tuple (Right Unit) (Left _)) = 0 83 | testFunction6 (Tuple (Right Unit) (Right _)) = 0 84 | 85 | test6 = printInt (testFunction6 testData6) -- prints 615 86 | 87 | testData7 : Tuple (Either Int (Tuple Int Int)) (Either Unit Int) 88 | testData7 = Tuple (Right (Tuple 1 2)) (Right 3) 89 | 90 | test7 = printInt (first (fromRightWithDefault (Tuple 0 0) (first testData7))) -- prints 1 91 | test8 = printInt (second (fromRightWithDefault (Tuple 0 0) (first testData7))) -- prints 2 92 | test9 = printInt (fromRightWithDefault 0 (second testData7)) -- prints 3 93 | -------------------------------------------------------------------------------- /tests/multis/imports/Alias.vix: -------------------------------------------------------------------------------- 1 | module Alias exposing (..) 2 | 3 | import Lib as Alias 4 | 5 | unqualifieda : Type 6 | unqualifieda = a -- not in scope error expected 7 | liba : Type 8 | liba = Lib.a -- not in scope error expected 9 | aliasa = Alias.a 10 | aliasb = Alias.b 11 | aliasc = Alias.c 12 | aliasd : Type 13 | aliasd = Alias.d -- not in scope error expected 14 | -------------------------------------------------------------------------------- /tests/multis/imports/Cyclic1.vix: -------------------------------------------------------------------------------- 1 | module Cyclic1 exposing (..) 2 | 3 | import Cyclic2 4 | 5 | x : Int 6 | x = Cyclic2.x 7 | 8 | y : Int 9 | y = 611 10 | -------------------------------------------------------------------------------- /tests/multis/imports/Cyclic2.vix: -------------------------------------------------------------------------------- 1 | module Cyclic2 exposing (..) 2 | 3 | import Cyclic1 4 | 5 | x : Int 6 | x = 610 7 | 8 | y : Int 9 | y = Cyclic1.y 10 | -------------------------------------------------------------------------------- /tests/multis/imports/ImportExposing.vix: -------------------------------------------------------------------------------- 1 | module ImportExposing exposing (..) 2 | 3 | import Lib exposing (b, c) 4 | import LibExposingAll exposing (..) 5 | 6 | aa = a 7 | bb : Type 8 | bb = b -- ambiguous name error expected 9 | cc : Type 10 | cc = c -- ambiguous name error expected 11 | dd : Type 12 | dd = d -- not in scope error expected 13 | 14 | liba = Lib.a 15 | -------------------------------------------------------------------------------- /tests/multis/imports/Lib.vix: -------------------------------------------------------------------------------- 1 | module Lib exposing (a, b, c) 2 | 3 | a = Type 4 | b = Type 5 | c = Type 6 | d = Type 7 | -------------------------------------------------------------------------------- /tests/multis/imports/LibExposingAll.vix: -------------------------------------------------------------------------------- 1 | module LibExposingAll exposing (..) 2 | 3 | a = Type 4 | b = Type 5 | c = Type 6 | -------------------------------------------------------------------------------- /tests/multis/imports/SelfImport.vix: -------------------------------------------------------------------------------- 1 | module SelfImport exposing (x) 2 | 3 | import SelfImport as SI 4 | 5 | y = SI.x 6 | 7 | x = 610 8 | -------------------------------------------------------------------------------- /tests/multis/imports/Simple.vix: -------------------------------------------------------------------------------- 1 | module Simple exposing (..) 2 | 3 | import Lib 4 | import LibExposingAll 5 | 6 | unqualifieda : Type 7 | unqualifieda = a -- not in scope error expected 8 | unqualifiedd : Type 9 | unqualifiedd = d -- not in scope error expected 10 | 11 | liba = Lib.a 12 | libb = Lib.b 13 | libc = Lib.c 14 | libd : Type 15 | libd = Lib.d -- not in scope error expected 16 | 17 | aa : Type 18 | aa = LibExposingAll.a 19 | bb : Type 20 | bb = LibExposingAll.b 21 | cc : Type 22 | cc = LibExposingAll.c 23 | dd : Type 24 | dd = LibExposingAll.d -- not in scope error expected 25 | -------------------------------------------------------------------------------- /tests/singles/parsing/ExposingNone.vix: -------------------------------------------------------------------------------- 1 | module ExposingNone exposing () 2 | -------------------------------------------------------------------------------- /tests/singles/parsing/ModuleHeader.vix: -------------------------------------------------------------------------------- 1 | -- Test that a module header doesn't have to be on the first line 2 | module ModuleHeader exposing (..) 3 | -------------------------------------------------------------------------------- /tests/singles/parsing/app.vix: -------------------------------------------------------------------------------- 1 | f : Type -> Type -> Type 2 | 3 | g = f Type Type 4 | h = f (f Type Type) (f Type Type) 5 | -------------------------------------------------------------------------------- /tests/singles/parsing/boxity.vix: -------------------------------------------------------------------------------- 1 | boxed 2 | data Nat = Z | S Nat 3 | 4 | boxed data Nat2 = Z | S Nat2 5 | 6 | data Nat3 = Z | S Nat3 7 | -------------------------------------------------------------------------------- /tests/singles/parsing/case.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | f : forall a. List a -> List a 6 | f = 7 | \xs. case xs of 8 | Nil -> 9 | Nil 10 | Cons y ys -> 11 | Cons y ys 12 | -------------------------------------------------------------------------------- /tests/singles/parsing/clauses.vix: -------------------------------------------------------------------------------- 1 | data Maybe a where 2 | Nothing : Maybe a 3 | Just : a -> Maybe a 4 | 5 | fromMaybe : forall A. A -> Maybe A -> A 6 | fromMaybe @{A} (a : A) Nothing = a 7 | fromMaybe @{A} _ (Just (a : A)) = a 8 | -------------------------------------------------------------------------------- /tests/singles/parsing/data-adt.vix: -------------------------------------------------------------------------------- 1 | data Bool 2 | = False 3 | | True 4 | 5 | data List a 6 | = Nil 7 | | Cons a (List a) 8 | 9 | data Bool = 10 | 11 | catchTheParseError -- parse error expected 12 | = False 13 | -------------------------------------------------------------------------------- /tests/singles/parsing/data-multi-param.vix: -------------------------------------------------------------------------------- 1 | data Tuple (a b : Type) where 2 | MkTuple : a -> b -> Tuple a b 3 | 4 | data Either (a b : Type) where 5 | Left : a -> Either a b 6 | Right : b -> Either a b 7 | -------------------------------------------------------------------------------- /tests/singles/parsing/data-multi.vix: -------------------------------------------------------------------------------- 1 | data Bool where 2 | False True : Bool 3 | -------------------------------------------------------------------------------- /tests/singles/parsing/data.vix: -------------------------------------------------------------------------------- 1 | Maybe : Type -> Type 2 | 3 | data Maybe a where 4 | Nothing : Maybe a 5 | Just : Maybe a 6 | -------------------------------------------------------------------------------- /tests/singles/parsing/empty.vix: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ollef/sixty/2c78e57ab290ba67fa876222c4cd5ad6aa845abb/tests/singles/parsing/empty.vix -------------------------------------------------------------------------------- /tests/singles/parsing/error.vix: -------------------------------------------------------------------------------- 1 | f 2 | 3 | g : Type -- parse error expected 4 | g = Type 5 | -------------------------------------------------------------------------------- /tests/singles/parsing/fun.vix: -------------------------------------------------------------------------------- 1 | f : Type -> Type 2 | -------------------------------------------------------------------------------- /tests/singles/parsing/implicit-apps.vix: -------------------------------------------------------------------------------- 1 | f : forall X Y. X -> Y -> X 2 | f = \@{X, Y} x y. x 3 | 4 | g = f @{Y = Type} Type 5 | 6 | h Y = f @{Y} Type 7 | -------------------------------------------------------------------------------- /tests/singles/parsing/implicit-data-param.vix: -------------------------------------------------------------------------------- 1 | data Test forall (a : Type). (b : a) where 2 | MkTest : Test @{a} b 3 | -------------------------------------------------------------------------------- /tests/singles/parsing/implicit-lams.vix: -------------------------------------------------------------------------------- 1 | f : forall X Y. X -> Y -> X 2 | f = \@{X, Y} x y. x 3 | -------------------------------------------------------------------------------- /tests/singles/parsing/implicit-pi.vix: -------------------------------------------------------------------------------- 1 | withType : forall (y : Type). Type 2 | withTypes : forall (x y : Type). Type 3 | withoutType : forall x. x 4 | mixed : forall x (y : x). Type 5 | -------------------------------------------------------------------------------- /tests/singles/parsing/int-literals.vix: -------------------------------------------------------------------------------- 1 | 2 | term : Int 3 | term = 123 4 | 5 | data Bool = False | True 6 | 7 | is123or231 : Int -> Bool 8 | is123or231 123 = True 9 | is123or231 231 = True 10 | is123or231 _ = False 11 | -------------------------------------------------------------------------------- /tests/singles/parsing/lambda-patterns.vix: -------------------------------------------------------------------------------- 1 | data Unit where 2 | MkUnit : Unit 3 | 4 | f : forall (a b : Unit). Unit -> Unit 5 | f = \@{a = MkUnit, b = MkUnit} MkUnit. MkUnit 6 | -------------------------------------------------------------------------------- /tests/singles/parsing/lambda.vix: -------------------------------------------------------------------------------- 1 | f : Type -> Type -> Type 2 | f = \x y. x 3 | 4 | g : Type -> Type 5 | g = \x. x 6 | -------------------------------------------------------------------------------- /tests/singles/parsing/let-clauses.vix: -------------------------------------------------------------------------------- 1 | data Nat = Z | S Nat 2 | 3 | g : Nat 4 | g = 5 | let 6 | pred : Nat -> Nat 7 | pred Z = Z 8 | pred (S n) = n 9 | 10 | succ : Nat -> Nat 11 | succ n = S n 12 | 13 | x = Z 14 | in 15 | pred x 16 | -------------------------------------------------------------------------------- /tests/singles/parsing/let-mutually-recursive.vix: -------------------------------------------------------------------------------- 1 | g : Type 2 | g = 3 | let 4 | x : Type 5 | y : Type 6 | x = y 7 | y = x 8 | in 9 | x 10 | -------------------------------------------------------------------------------- /tests/singles/parsing/let-recursive.vix: -------------------------------------------------------------------------------- 1 | g : Type 2 | g = 3 | let 4 | x : Type 5 | x = x 6 | in 7 | x 8 | -------------------------------------------------------------------------------- /tests/singles/parsing/let.vix: -------------------------------------------------------------------------------- 1 | g : Type 2 | g = 3 | let x = Type 4 | in 5 | x 6 | -------------------------------------------------------------------------------- /tests/singles/parsing/only-comments.vix: -------------------------------------------------------------------------------- 1 | -- aaaaaaaa 2 | -- bbbbbbbb 3 | -------------------------------------------------------------------------------- /tests/singles/parsing/pi.vix: -------------------------------------------------------------------------------- 1 | f : (x : Type) -> Type 2 | g : (x y : Type) -> Type 3 | -------------------------------------------------------------------------------- /tests/singles/parsing/pis.vix: -------------------------------------------------------------------------------- 1 | Nat : Type 2 | 3 | f : (x y : Type)(z w : Nat) -> Type 4 | -------------------------------------------------------------------------------- /tests/singles/parsing/type-annotation.vix: -------------------------------------------------------------------------------- 1 | f : Type 2 | -------------------------------------------------------------------------------- /tests/singles/parsing/unicode.vix: -------------------------------------------------------------------------------- 1 | β : Type 2 | β = Type 3 | 4 | lol : β 5 | lol = Type 6 | 7 | ࢄ : Type 8 | ࢄ = Type 9 | 10 | 𒀂 : Type 11 | 𒀂 = Type 12 | -------------------------------------------------------------------------------- /tests/singles/parsing/wildcard.vix: -------------------------------------------------------------------------------- 1 | id : (A : Type) -> A -> A 2 | id = \A a. a 3 | 4 | id2 : (A : Type) -> A -> A 5 | id2 = \A. id _ 6 | -------------------------------------------------------------------------------- /tests/singles/resolution/ModuleFileMismatch.vix: -------------------------------------------------------------------------------- 1 | module SomeOtherName exposing (..) -- module file name mismatch error expected 2 | -------------------------------------------------------------------------------- /tests/singles/resolution/QualifiedLocalModule.vix: -------------------------------------------------------------------------------- 1 | module QualifiedLocalModule exposing (..) 2 | 3 | def = Type 4 | 5 | useDefQualified = QualifiedLocalModule.def 6 | 7 | decl : Type 8 | 9 | useDeclQualified1 = QualifiedLocalModule.decl 10 | 11 | decl = Type 12 | 13 | useDeclQualified2 = QualifiedLocalModule.decl 14 | 15 | declDef : Type 16 | declDef = Type 17 | 18 | useDeclDefQualified = QualifiedLocalModule.declDef 19 | 20 | data Data = Constr 21 | 22 | useDataQualified = QualifiedLocalModule.Data 23 | 24 | useConstrQualified = QualifiedLocalModule.Constr 25 | 26 | DeclData : Type 27 | 28 | useDeclDataQualified1 = QualifiedLocalModule.DeclData 29 | 30 | data DeclData = DeclConstr 31 | 32 | useDeclDataQualified2 = QualifiedLocalModule.DeclData 33 | 34 | useDeclConstrQualified2 = QualifiedLocalModule.DeclConstr 35 | -------------------------------------------------------------------------------- /tests/singles/resolution/duplicate-name.vix: -------------------------------------------------------------------------------- 1 | g = Type 2 | f = Type 3 | h = Type 4 | f = g -- duplicate name error expected 5 | -------------------------------------------------------------------------------- /tests/singles/resolution/duplicate-name2.vix: -------------------------------------------------------------------------------- 1 | data Unit = MkUnit 2 | 3 | g : Unit -> Unit 4 | g MkUnit = MkUnit 5 | 6 | Unit = Type -- duplicate name error expected 7 | -------------------------------------------------------------------------------- /tests/singles/resolution/import-not-found.vix: -------------------------------------------------------------------------------- 1 | import NonExistentModule -- import not found error expected 2 | 3 | f : Type 4 | -------------------------------------------------------------------------------- /tests/singles/resolution/not-in-scope.vix: -------------------------------------------------------------------------------- 1 | f : Type 2 | f = x -- not in scope error expected 3 | -------------------------------------------------------------------------------- /tests/singles/resolution/type-after-def.vix: -------------------------------------------------------------------------------- 1 | f = Type 2 | f : Type 3 | 4 | data D = MkD 5 | D : Type 6 | -------------------------------------------------------------------------------- /tests/singles/type-checking/OhNo.vix: -------------------------------------------------------------------------------- 1 | data Void where 2 | 3 | Not a = a -> Void 4 | 5 | data Bad = Bad (Not Bad) 6 | 7 | hmmm : Bad -> Not Bad 8 | hmmm (Bad n) = n 9 | 10 | why : Not Bad 11 | why bad = hmmm bad bad 12 | 13 | bad : Bad 14 | bad = Bad why 15 | 16 | ohno : Void 17 | ohno = why bad 18 | -------------------------------------------------------------------------------- /tests/singles/type-checking/absurd-conversion.vix: -------------------------------------------------------------------------------- 1 | data Empty where 2 | 3 | data Bool = False | True 4 | 5 | absurd : Empty -> Bool 6 | absurd e = case e of 7 | 8 | data Equals forall A. (a b : A) where 9 | Refl : Equals a a 10 | 11 | trans : forall A (a b c : A). Equals a b -> Equals b c -> Equals a c 12 | trans Refl Refl = Refl 13 | 14 | sym : forall A (a b : A). Equals a b -> Equals b a 15 | sym Refl = Refl 16 | 17 | lol1 : (e : Empty) -> Equals (absurd e) True 18 | lol1 e = Refl 19 | 20 | lol2 : (e : Empty) -> Equals (absurd e) False 21 | lol2 e = Refl 22 | 23 | lol3 : Empty -> Equals True False 24 | lol3 e = Refl -- type mismatch error expected 25 | 26 | lol4 : Empty -> Equals True False 27 | lol4 e = case e of 28 | 29 | lol5 : Empty -> Equals True False 30 | lol5 e = trans (sym (lol1 e)) (lol2 e) 31 | -------------------------------------------------------------------------------- /tests/singles/type-checking/agda-1079.vix: -------------------------------------------------------------------------------- 1 | Nat : Type 2 | Dec : Type -> Type 3 | True : forall A. Dec A -> Type 4 | fromWitness : forall P (Q : Dec P). P -> True Q 5 | T : Nat -> Type 6 | 7 | Coprime = forall i. T i 8 | 9 | coprime : Dec Coprime 10 | 11 | bla : Coprime -> True coprime 12 | bla = \c. fromWitness c 13 | -------------------------------------------------------------------------------- /tests/singles/type-checking/agda-1387.vix: -------------------------------------------------------------------------------- 1 | 2 | Bool : Type 3 | Bool = (B : _) -> B -> B -> B 4 | true : Bool 5 | true = \_ t f. t 6 | false : Bool 7 | false = \_ t f. f 8 | 9 | Eq : forall A. A -> A -> Type 10 | Eq = \@{A} x y. (P : A -> Type) -> P x -> P y 11 | 12 | refl : forall A x. Eq @{A} x x 13 | refl = \_ px. px 14 | 15 | T : Bool -> Type 16 | T = \b. b _ (forall A. A -> A) Type 17 | 18 | g : (b : Bool) -> Eq b true -> T b -> Bool 19 | f : (b : Bool) -> T b -> Eq b true -> Bool 20 | 21 | works : Bool 22 | works = g _ refl (\x. x) 23 | 24 | test : Bool 25 | test = f _ (\x. x) refl 26 | -------------------------------------------------------------------------------- /tests/singles/type-checking/agda-2099.vix: -------------------------------------------------------------------------------- 1 | id : forall A. A -> A 2 | id = \x. x 3 | 4 | test : forall A. A -> forall B. B -> A 5 | test = id (\x y. x) 6 | -------------------------------------------------------------------------------- /tests/singles/type-checking/ambiguous-constructor-in-pattern.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | data List2 a where 6 | Nil : List2 a 7 | Cons : a -> List a -> List2 a 8 | 9 | test x = -- unsolved meta error expected 10 | case x of 11 | Nil -> 610 -- ambiguous name error expected 12 | -------------------------------------------------------------------------------- /tests/singles/type-checking/ambiguous-name.vix: -------------------------------------------------------------------------------- 1 | Maybe : Type 2 | 3 | data Maybe where 4 | Nothing : Maybe 5 | 6 | Maybe2 : Type 7 | 8 | data Maybe2 where 9 | Nothing : Maybe2 10 | 11 | f : Type 12 | f = Nothing -- ambiguous name error expected 13 | -------------------------------------------------------------------------------- /tests/singles/type-checking/any.vix: -------------------------------------------------------------------------------- 1 | data Any where 2 | Any : (A : Type) -> A -> Any 3 | 4 | anyType : Any -> Type 5 | anyType (Any T _) = T 6 | 7 | anyValue : (any : Any) -> anyType any 8 | anyValue (Any _ V) = V 9 | -------------------------------------------------------------------------------- /tests/singles/type-checking/app-lambda.vix: -------------------------------------------------------------------------------- 1 | f : (Type -> Type) -> Type -> Type 2 | f = \x y. x y 3 | 4 | g : Type -> Type 5 | g = f (\x. x) 6 | -------------------------------------------------------------------------------- /tests/singles/type-checking/array-append-tuple.vix: -------------------------------------------------------------------------------- 1 | data Nat = Z | S Nat 2 | 3 | add : Nat -> Nat -> Nat 4 | add Z n = n 5 | add (S m) n = S (add m n) 6 | data Unit = Unit 7 | data Tuple A B = Tuple A B 8 | 9 | Vector : Nat -> Type -> Type 10 | Vector Z T = Unit 11 | Vector (S n) T = Tuple T (Vector n T) 12 | 13 | boxed 14 | data Array T where 15 | Array : forall n. Vector n T -> Array T 16 | 17 | map_vector : forall A B n. (A -> B) -> Vector n A -> Vector n B 18 | map_vector @{n = Z} f Unit = Unit 19 | map_vector @{n = S n} f (Tuple a as) = Tuple (f a) (map_vector @{n} f as) 20 | 21 | append_vector : forall A m n. Vector m A -> Vector n A -> Vector (add m n) A 22 | append_vector @{m = Z} Unit ys = ys 23 | append_vector @{m = S m} (Tuple x xs) ys = Tuple x (append_vector xs ys) 24 | 25 | map_array : forall A B. (A -> B) -> Array A -> Array B 26 | map_array f (Array v) = Array (map_vector f v) 27 | 28 | append_array : forall A. Array A -> Array A -> Array A 29 | append_array (Array xs) (Array ys) = Array (append_vector xs ys) 30 | 31 | data Bool = False | True 32 | 33 | filter_length : forall n A. (A -> Bool) -> Vector n A -> Nat 34 | filter_length @{n = Z} p Unit = Z 35 | filter_length @{n = S n} p (Tuple a as) = 36 | case p a of 37 | False -> filter_length @{n} p as 38 | True -> S (filter_length @{n} p as) 39 | 40 | filter_vector : forall n A. (p : A -> Bool)(v : Vector n A) -> Vector (filter_length p v) A 41 | filter_vector @{n = Z} p Unit = Unit 42 | filter_vector @{n = S n} p (Tuple a as) = 43 | case p a of 44 | False -> filter_vector p as 45 | True -> Tuple a (filter_vector p as) 46 | 47 | filter_array : forall A. (A -> Bool) -> Array A -> Array A 48 | filter_array p (Array v) = Array (filter_vector p v) 49 | -------------------------------------------------------------------------------- /tests/singles/type-checking/array-append.vix: -------------------------------------------------------------------------------- 1 | data Nat = Z | S Nat 2 | 3 | data Bool = False | True 4 | 5 | add : Nat -> Nat -> Nat 6 | add Z n = n 7 | add (S m) n = S (add m n) 8 | 9 | data Vector n A where 10 | Nil : Vector Z A 11 | Cons : forall n. A -> Vector n A -> Vector (S n) A 12 | 13 | append_vector : forall m n A. Vector m A -> Vector n A -> Vector (add m n) A 14 | append_vector Nil ys = ys 15 | append_vector (Cons x xs) ys = Cons x (append_vector xs ys) 16 | 17 | data Array A where 18 | Array : forall n. Vector n A -> Array A 19 | 20 | append_array : forall A. Array A -> Array A -> Array A 21 | append_array (Array xs) (Array ys) = Array (append_vector xs ys) 22 | 23 | filter_length : forall A n. (A -> Bool) -> Vector n A -> Nat 24 | filter_length p Nil = Z 25 | filter_length p (Cons x xs) = case p x of 26 | False -> filter_length p xs 27 | True -> S (filter_length p xs) 28 | 29 | filter_vector : forall A n. (p : A -> Bool)(xs : Vector n A) -> Vector (filter_length p xs) A 30 | filter_vector p Nil = Nil 31 | filter_vector p (Cons x xs) = case p x of 32 | False -> filter_vector p xs 33 | True -> Cons x (filter_vector p xs) 34 | 35 | filter_array : forall A. (A -> Bool) -> Array A -> Array A 36 | filter_array p (Array xs) = Array (filter_vector p xs) 37 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-coverage-propagation.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | f : forall a. List a -> List a 6 | f as = 7 | case as of 8 | Nil -> Nil 9 | _ -> 10 | case as of 11 | Nil -> as -- redundant match error expected 12 | Cons x xs -> 13 | as 14 | 15 | f' : forall a. List a -> List a 16 | f' as = 17 | case as of 18 | Nil -> 19 | case as of 20 | Nil -> as 21 | Cons x xs -> as -- redundant match error expected 22 | _ -> 23 | as 24 | 25 | g : forall a. List a -> List a 26 | g as = 27 | case as of 28 | Nil -> Nil 29 | _ -> 30 | case as of 31 | Cons x xs -> 32 | as 33 | 34 | g' : forall a. List a -> List a 35 | g' as = 36 | case as of 37 | Nil -> 38 | case as of 39 | Nil -> as 40 | _ -> 41 | as 42 | 43 | h : Int -> Int 44 | h n = 45 | case n of 46 | 0 -> 0 47 | _ -> 48 | case n of 49 | 0 -> 0 -- redundant match error expected 50 | 1 -> 1 51 | _ -> n 52 | 53 | h' : Int -> Int 54 | h' n = 55 | case n of 56 | 0 -> 57 | case n of 58 | 0 -> 0 59 | _ -> n -- redundant match error expected 60 | _ -> n 61 | 62 | i : Int -> Int 63 | i n = 64 | case n of 65 | 0 -> 0 66 | _ -> 67 | case n of 68 | 1 -> 1 69 | _ -> n 70 | 71 | i' : Int -> Int 72 | i' n = 73 | case n of 74 | 0 -> 75 | case n of 76 | _ -> n 77 | _ -> n 78 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-empty.vix: -------------------------------------------------------------------------------- 1 | data Empty where 2 | 3 | absurd : Empty -> forall a. a 4 | absurd = \empty. 5 | case empty of 6 | 7 | data Unit where 8 | MkUnit : Unit 9 | 10 | absurd' : Unit -> forall a. a 11 | absurd' = \unit. 12 | case unit of -- non-exhaustive patterns error expected 13 | 14 | data Nested where 15 | MkNested : Empty -> Nested 16 | 17 | nestedAbsurd : Nested -> forall a. a 18 | nestedAbsurd = \nested. 19 | case nested of 20 | 21 | nestedAbsurd' : Nested -> forall a. a 22 | nestedAbsurd' = \nested. 23 | case nested of 24 | MkNested empty -> 25 | case empty of 26 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-equality.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | isZero : Int -> Bool 4 | isZero x = case x of 5 | 0 -> True 6 | 1 -> False 7 | _ -> False 8 | 9 | isZero' : Int -> Bool 10 | isZero' x = case x of 11 | 0 -> True 12 | 1 -> False 13 | 2 -> False 14 | _ -> False 15 | 16 | isZero'' : Int -> Bool 17 | isZero'' x = case x of 18 | 0 -> True 19 | 1 -> False 20 | 2 -> False 21 | 3 -> True 22 | _ -> False 23 | 24 | data Equals forall T. (A B : T) where 25 | Refl : Equals A A 26 | 27 | isZeroIsIsZero' : Equals isZero isZero' 28 | isZeroIsIsZero' = Refl 29 | 30 | isZeroIsIsZero'' : Equals isZero isZero'' 31 | isZeroIsIsZero'' = Refl -- type mismatch error expected 32 | 33 | isZero'IsIsZero'' : Equals isZero' isZero'' 34 | isZero'IsIsZero'' = Refl -- type mismatch error expected 35 | 36 | data Maybe a = Nothing | Just a 37 | 38 | isNothing : Maybe Int -> Bool 39 | isNothing Nothing = True 40 | isNothing (Just _) = False 41 | 42 | isNothing' : Maybe Int -> Bool 43 | isNothing' Nothing = True 44 | isNothing' (Just 0) = False 45 | isNothing' (Just _) = False 46 | 47 | isNothing'' : Maybe Int -> Bool 48 | isNothing'' Nothing = True 49 | isNothing'' (Just 0) = True 50 | isNothing'' (Just _) = False 51 | 52 | isNothingIsIsNothing' : Equals isNothing isNothing' 53 | isNothingIsIsNothing' = Refl 54 | 55 | isNothingIsIsNothing'' : Equals isNothing isNothing'' 56 | isNothingIsIsNothing'' = Refl -- type mismatch error expected 57 | 58 | isNothing'IsIsNothing'' : Equals isNothing' isNothing'' 59 | isNothing'IsIsNothing'' = Refl -- type mismatch error expected 60 | 61 | data Three = A | B | C 62 | 63 | isA : Three -> Bool 64 | isA A = True 65 | isA B = False 66 | isA C = False 67 | 68 | isA' : Three -> Bool 69 | isA' A = True 70 | isA' _ = False 71 | 72 | isA'' : Three -> Bool 73 | isA'' A = True 74 | isA'' B = False 75 | isA'' _ = True 76 | 77 | isAIsIsA' : Equals isA isA' 78 | isAIsIsA' = Refl 79 | 80 | isAIsIsA'' : Equals isA isA'' 81 | isAIsIsA'' = Refl -- type mismatch error expected 82 | 83 | isA'IsIsA'' : Equals isA' isA'' 84 | isA'IsIsA'' = Refl -- type mismatch error expected 85 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-inversion.vix: -------------------------------------------------------------------------------- 1 | data Tuple a b = MkTuple a b 2 | 3 | data Unit = MkUnit 4 | 5 | data Nat = Z | S Nat 6 | 7 | data Equals forall (T : Type). (a b : T) where 8 | Refl : Equals a a 9 | 10 | Vector : Nat -> Type -> Type 11 | Vector Z _ = Unit 12 | Vector (S n) A = Tuple A (Vector n A) 13 | 14 | the : (A : Type) -> A -> A 15 | the A a = a 16 | 17 | test = the (Equals (Vector _ Unit) (Tuple _ (Tuple _ Unit))) Refl 18 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-list-map.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | map : forall a b. (a -> b) -> List a -> List b 6 | map = \f as. 7 | case as of 8 | Nil -> 9 | Nil 10 | 11 | Cons a as' -> 12 | Cons (f a) (map f as') 13 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-non-exhaustive.vix: -------------------------------------------------------------------------------- 1 | data List a = Nil | Cons a (List a) | Lol 2 | 3 | clauses1 : forall a. List a -> List a 4 | clauses1 Nil = Nil -- non-exhaustive patterns error expected 5 | 6 | clauses2 : forall a. List a -> List a 7 | clauses2 Nil = Nil -- non-exhaustive patterns error expected 8 | clauses2 (Cons _ _) = Nil 9 | 10 | clauses3 : forall a. List a -> List a 11 | clauses3 Nil = Nil 12 | clauses3 (Cons _ _) = Nil 13 | clauses3 Lol = Nil 14 | 15 | cases1 : forall a. List a -> List a 16 | cases1 x = case x of 17 | Nil -> Nil -- non-exhaustive patterns error expected 18 | 19 | cases2 : forall a. List a -> List a 20 | cases2 x = case x of 21 | Nil -> Nil -- non-exhaustive patterns error expected 22 | Cons _ _ -> Nil 23 | 24 | cases3 : forall a. List a -> List a 25 | cases3 x = case x of 26 | Nil -> Nil 27 | Cons _ _ -> Nil 28 | Lol -> Nil 29 | 30 | multiClauses1 : forall a. List a -> List a -> List a 31 | multiClauses1 Nil Nil = Nil -- non-exhaustive patterns error expected, non-exhaustive patterns error expected 32 | 33 | multiClauses2 : forall a. List a -> List a -> List a 34 | multiClauses2 Nil Nil = Nil -- non-exhaustive patterns error expected, non-exhaustive patterns error expected 35 | multiClauses2 (Cons _ _) (Cons _ _) = Nil -- non-exhaustive patterns error expected 36 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-non-linear-pattern-scrutinee.vix: -------------------------------------------------------------------------------- 1 | data Tuple a b = MkTuple a b 2 | 3 | data Nat = Z | S Nat 4 | 5 | test : Nat -> Nat 6 | test x = 7 | case MkTuple x x of 8 | MkTuple Z Z -> S Z 9 | MkTuple (S n) (S ~n) -> S (S Z) 10 | MkTuple (S n) Z -> Z -- redundant match error expected 11 | MkTuple Z (S n) -> Z -- redundant match error expected 12 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-non-pattern-scrutinee.vix: -------------------------------------------------------------------------------- 1 | 2 | data Tuple a b where 3 | MkTuple : a -> b -> Tuple a b 4 | 5 | data Nat where 6 | Z : Nat 7 | S : Nat -> Nat 8 | 9 | data Vector n a where 10 | Nil : Vector Z a 11 | Cons : forall m. a -> Vector m a -> Vector (S m) a 12 | 13 | data Bool = False | True 14 | 15 | zipWithCase : forall a b c n. (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c 16 | 17 | nonPatternScrutinee : forall a b c n. (a -> b -> c) -> Vector n a -> Vector n b -> Bool 18 | nonPatternScrutinee f as bs = 19 | case zipWithCase f as bs of 20 | Nil -> True 21 | Cons _ _ -> True 22 | 23 | data List a = Nil | Cons a (List a) 24 | 25 | localScrutinee : forall a. (a -> List Type) -> a -> List a 26 | localScrutinee f a = 27 | case f a of 28 | Nil -> Nil 29 | Cons _ _ -> Cons a Nil 30 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-of-global.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | not : Bool -> Bool 4 | not False = True 5 | not True = False 6 | 7 | f : Bool -> Bool 8 | f b = case not b of 9 | False -> True 10 | True -> True 11 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-of-meta.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | f : Bool 4 | f = 5 | let x : Bool 6 | x = _ -- unsolved meta error expected 7 | in 8 | case x of -- indeterminate index unification error expected 9 | False -> True -- redundant match error expected 10 | True -> False -- redundant match error expected 11 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-overlap.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | f : forall a. List a -> List a 6 | f = \as. 7 | case as of 8 | Nil -> 9 | as 10 | 11 | Nil -> -- redundant match error expected 12 | as 13 | 14 | Cons x xs -> 15 | as 16 | 17 | Cons x xs -> -- redundant match error expected 18 | as 19 | 20 | g : forall a. List a -> List a 21 | g = \as. 22 | case as of 23 | Nil -> 24 | as 25 | 26 | _ -> 27 | as 28 | 29 | Cons x xs -> -- redundant match error expected 30 | as 31 | 32 | h : forall a. List a -> List a 33 | h = \as. 34 | case as of 35 | Nil -> 36 | as 37 | 38 | Cons x xs -> 39 | as 40 | 41 | _ -> -- redundant match error expected 42 | as 43 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-pattern-scrutinee.vix: -------------------------------------------------------------------------------- 1 | data Tuple a b where 2 | MkTuple : a -> b -> Tuple a b 3 | 4 | data Nat where 5 | Z : Nat 6 | S : Nat -> Nat 7 | 8 | data Vector n a where 9 | Nil : Vector Z a 10 | Cons : forall m. a -> Vector m a -> Vector (S m) a 11 | 12 | zipWithCase : forall a b c n. (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c 13 | zipWithCase f as bs = 14 | case MkTuple as bs of 15 | MkTuple (Cons a as') (Cons b bs') -> Cons (f a b) (zipWithCase f as' bs') 16 | MkTuple Nil Nil -> Nil 17 | 18 | zipWithTuple : forall a b c n. (a -> b -> c) -> Tuple (Vector n a) (Vector n b) -> Vector n c 19 | zipWithTuple f (MkTuple Nil Nil) = Nil 20 | zipWithTuple f (MkTuple (Cons a as') (Cons b bs')) = Cons (f a b) (zipWithTuple f (MkTuple as' bs')) 21 | 22 | data List a = Nil | Cons a (List a) 23 | 24 | zipWithListCase : forall a b c. (a -> b -> c) -> List a -> List b -> List c 25 | zipWithListCase f as bs = 26 | case MkTuple as bs of 27 | MkTuple (Cons a as') (Cons b bs') -> case as of 28 | Cons _ _ -> Cons (f a b) (zipWithListCase f as' bs') 29 | -- as is a Cons cell, so no Nil case 30 | MkTuple _ _ -> Nil 31 | 32 | zipWithListCaseLet : forall a b c. (a -> b -> c) -> List a -> List b -> List c 33 | zipWithListCaseLet f as bs = 34 | let x = MkTuple as bs in 35 | case x of 36 | MkTuple (Cons a as') (Cons b bs') -> case as of 37 | Cons _ _ -> Cons (f a b) (zipWithListCase f as' bs') 38 | -- as is a Cons cell, so no Nil case 39 | MkTuple _ _ -> Nil 40 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-plicity-mismatch.vix: -------------------------------------------------------------------------------- 1 | data D where 2 | MkD : Type -> D 3 | 4 | f : D -> Type 5 | f = \d. 6 | case d of 7 | MkD d d -> -- plicity mismatch error expected 8 | Type 9 | 10 | g : D -> Type 11 | g = \d. 12 | case d of 13 | MkD -> -- plicity mismatch error expected 14 | Type 15 | 16 | h : D -> Type 17 | h = \d. 18 | case d of 19 | MkD d' -> 20 | Type 21 | -------------------------------------------------------------------------------- /tests/singles/type-checking/case-use-scrutinee.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | useScrutinee : forall a. List a -> List a 6 | useScrutinee = \as. 7 | case as of 8 | Nil -> 9 | as 10 | 11 | Cons a as' -> 12 | as 13 | -------------------------------------------------------------------------------- /tests/singles/type-checking/check-applied-case.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | data List a = Nil | Cons a (List a) 4 | 5 | data Maybe a = Nothing | Just a 6 | 7 | the : (T : Type) -> T -> T 8 | the _ t = t 9 | 10 | myType : Bool -> Type -> Type 11 | myType b t = 12 | (the (Type -> Type) (case b of 13 | False -> List 14 | True -> Maybe)) 15 | t 16 | 17 | test : myType True Type -> Maybe Type 18 | test x = x 19 | -------------------------------------------------------------------------------- /tests/singles/type-checking/clauses-list-map.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | map : forall a b. (a -> b) -> List a -> List b 6 | map f Nil = Nil 7 | map f (Cons a as') = Cons (f a) (map f as') 8 | -------------------------------------------------------------------------------- /tests/singles/type-checking/clauses-list-zipwith.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | zipWith : forall a b c. (a -> b -> c) -> List a -> List b -> List c 6 | zipWith f Nil Nil = Nil 7 | zipWith f (Cons a as) (Cons b bs) = Cons (f a b) (zipWith f as bs) 8 | zipWith f _ _ = Nil 9 | -------------------------------------------------------------------------------- /tests/singles/type-checking/clauses-mismatch.vix: -------------------------------------------------------------------------------- 1 | data Bool where 2 | False : Bool 3 | True : Bool 4 | 5 | test : Bool -> Type -> Type 6 | test False x = Type 7 | test True = Type -- plicity mismatch error expected 8 | -------------------------------------------------------------------------------- /tests/singles/type-checking/constructor-overloading.vix: -------------------------------------------------------------------------------- 1 | Maybe : Type 2 | 3 | data Maybe where 4 | Nothing : Maybe 5 | 6 | Maybe2 : Type 7 | 8 | data Maybe2 where 9 | Nothing : Maybe2 10 | 11 | f : Maybe 12 | f = Nothing 13 | 14 | g : Maybe2 15 | g = Nothing 16 | -------------------------------------------------------------------------------- /tests/singles/type-checking/data-constructor-return.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | data Maybe a where 6 | Nothing : Maybe a 7 | Just : a -> List a -- type mismatch error expected 8 | -------------------------------------------------------------------------------- /tests/singles/type-checking/data-list.vix: -------------------------------------------------------------------------------- 1 | List : Type -> Type 2 | 3 | data List a where 4 | Nil : List a 5 | Cons : a -> List a -> List a 6 | 7 | t1 = Type 8 | t2 = Type 9 | 10 | example = 11 | Cons t1 (Cons t2 Nil) 12 | -------------------------------------------------------------------------------- /tests/singles/type-checking/data-maybe.vix: -------------------------------------------------------------------------------- 1 | Maybe : Type -> Type 2 | 3 | data Maybe a where 4 | Nothing : Maybe a 5 | Just : a -> Maybe a 6 | 7 | test : (a : Type) -> a -> Maybe a 8 | test = \a. Just 9 | 10 | test2 : (a : Type) -> a -> Maybe a 11 | test2 = \a x. Just x 12 | -------------------------------------------------------------------------------- /tests/singles/type-checking/data-overloading.vix: -------------------------------------------------------------------------------- 1 | data Unit = Unit 2 | 3 | u : Unit 4 | u = Unit 5 | 6 | u' = -- unsolved meta error expected 7 | Unit -- ambiguous name error expected 8 | 9 | Maybe2 : Type -> Type 10 | 11 | data Maybe a = Maybe a | Nothing 12 | 13 | data Maybe2 a = Maybe2 a | Nothing 14 | 15 | f : Maybe Unit 16 | f = Nothing 17 | 18 | f' : Type 19 | f' = Maybe Unit 20 | 21 | g : Maybe2 Unit 22 | g = Nothing 23 | 24 | g' : Type 25 | g' = Maybe2 Unit 26 | 27 | h = -- unsolved meta error expected 28 | Nothing -- ambiguous name error expected 29 | 30 | fun : Unit -> Unit 31 | fun Unit = Unit 32 | 33 | f'un : Maybe Unit -> Maybe2 Unit 34 | f'un (Maybe Unit) = Maybe2 Unit 35 | f'un Nothing = Nothing 36 | 37 | g'un : Maybe2 Unit -> Maybe Unit 38 | g'un (Maybe2 Unit) = Maybe Unit 39 | g'un Nothing = Nothing 40 | -------------------------------------------------------------------------------- /tests/singles/type-checking/data-pair.vix: -------------------------------------------------------------------------------- 1 | Pair : Type -> Type -> Type 2 | 3 | data Pair a b where 4 | MkPair : a -> b -> Pair a b 5 | 6 | test : Pair Type Type 7 | test = MkPair Type Type 8 | -------------------------------------------------------------------------------- /tests/singles/type-checking/data-recursive.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | list : List Type 6 | list = Cons Type (Cons Type Nil) 7 | 8 | data DependentParams (a : Type)(b : a) where 9 | Con : DependentParams a b 10 | 11 | dependentParams : DependentParams Type Type 12 | dependentParams = Con 13 | -------------------------------------------------------------------------------- /tests/singles/type-checking/evaluate-applied-case.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | data List a = Nil | Cons a (List a) 4 | 5 | data Maybe a = Nothing | Just a 6 | 7 | myType : Bool -> Type -> Type 8 | myType b = case b of 9 | False -> List 10 | True -> Maybe 11 | 12 | test : myType True Type -> Maybe Type 13 | test x = x 14 | -------------------------------------------------------------------------------- /tests/singles/type-checking/fcif.vix: -------------------------------------------------------------------------------- 1 | -- Adapted from https://github.com/AndrasKovacs/implicit-fun-elaboration/blob/3e2d6165ffe9d559badac3f86cf93071ca757730/src/benchmarks.fcif 2 | 3 | data Nat = Zero | Succ Nat 4 | data List a = Nil | Cons a (List a) 5 | data Pair a b = Pair a b 6 | data Bool = False | True 7 | 8 | length : forall A. List A -> Nat 9 | length Nil = Zero 10 | length (Cons _ as) = Succ (length as) 11 | 12 | head : forall a. List a -> a 13 | 14 | tail : forall a. List a -> List a 15 | tail Nil = Nil 16 | tail (Cons _ as) = as 17 | 18 | map : forall a b. (a -> b) -> List a -> List b 19 | map f Nil = Nil 20 | map f (Cons x xs) = Cons (f x) (map f xs) 21 | 22 | append : forall a. List a -> List a -> List a 23 | append Nil ys = ys 24 | append (Cons x xs) ys = Cons x (append xs ys) 25 | 26 | the : (A : Type) -> A -> A 27 | the _ a = a 28 | 29 | const : forall A B. A -> B -> A 30 | const x _ = x 31 | 32 | IdTy : Type 33 | IdTy = forall A. A -> A 34 | 35 | single : forall A. A -> List A 36 | single a = Cons a Nil 37 | 38 | id : forall A. A -> A 39 | id a = a 40 | 41 | ids : List IdTy 42 | ids = Nil 43 | 44 | app : forall A B. (A -> B) -> A -> B 45 | app = id 46 | 47 | revapp : forall A B. A -> (A -> B) -> B 48 | revapp x f = f x 49 | 50 | poly : IdTy -> Pair Nat Bool 51 | poly f = Pair (f Zero) (f True) 52 | 53 | choose : forall A. A -> A -> A 54 | choose = const 55 | 56 | auto : IdTy -> IdTy 57 | auto = id 58 | 59 | auto2 : forall B. IdTy -> B -> B 60 | auto2 _ b = b 61 | 62 | A2 : IdTy -> IdTy 63 | A2 = choose id 64 | 65 | A3 = choose Nil ids 66 | 67 | A4 : IdTy -> IdTy 68 | A4 x = x x 69 | 70 | A5 : IdTy -> IdTy 71 | A5 = id auto 72 | 73 | A6 : forall B. IdTy -> B -> B 74 | A6 = id auto2 75 | 76 | A7 = choose id auto 77 | 78 | A9 : (forall A. (A -> A) -> List A -> A) -> IdTy 79 | A9 f = f (choose id) ids 80 | 81 | A10 = poly id 82 | 83 | A11 = poly (\x. x) 84 | 85 | A12 = id poly (\x. x) 86 | 87 | C1 = length ids 88 | C2 = tail ids 89 | 90 | C3 : IdTy 91 | C3 = head ids 92 | 93 | C4 : List IdTy 94 | C4 = single id 95 | 96 | C5 = Cons id ids 97 | C6 = Cons (\ x. x) ids 98 | 99 | C7 = append (single Succ) (single id) 100 | 101 | C8 : (forall a. List a -> List a -> a) -> IdTy 102 | C8 g = g (single id) ids 103 | 104 | C9 = map poly (single id) 105 | 106 | C10 = map head (single ids) 107 | 108 | D1 = app poly id 109 | 110 | D2 = revapp id poly 111 | 112 | E2 : (h : Nat -> forall A. A -> A)(k : forall A. A -> List A -> A)(lst : List (forall A. Nat -> A -> A)) -> forall A. Nat -> A -> A 113 | E2 h k lst = k (\x. h x) lst 114 | 115 | E3 : ((forall A. A -> forall B. B -> B) -> Nat) -> Nat 116 | E3 r = r (\x y. y) 117 | -------------------------------------------------------------------------------- /tests/singles/type-checking/global-equality-recursive.vix: -------------------------------------------------------------------------------- 1 | data List a = Nil | Cons a (List a) 2 | 3 | map : forall a b. (a -> b) -> List a -> List b 4 | map f Nil = Nil 5 | map f (Cons a as) = Cons (f a) (map f as) 6 | 7 | map2 : forall a b. (a -> b) -> List a -> List b 8 | map2 f Nil = Nil 9 | map2 f (Cons a as) = Cons (f a) (map2 f as) 10 | 11 | data Equals forall A. (a b : A) where 12 | Refl : Equals a a 13 | 14 | test : forall a b (f : a -> b) as. Equals (map f as) (map2 f as) 15 | test = Refl -- type mismatch error expected 16 | 17 | test2 : forall a b (f : a -> b) as. Equals (map f as) (map2 f as) 18 | test2 @{f, as} = case as of 19 | Nil -> Refl 20 | Cons a as' -> case test2 @{f, as=as'} of 21 | Refl -> Refl 22 | -------------------------------------------------------------------------------- /tests/singles/type-checking/global-equality.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | not : Bool -> Bool 4 | not False = True 5 | not True = False 6 | 7 | data Equals forall A. (a b : A) where 8 | Refl : Equals a a 9 | 10 | f : (b : Bool) -> Equals (not b) False -> Bool 11 | f b Refl = case not b of 12 | False -> True 13 | -------------------------------------------------------------------------------- /tests/singles/type-checking/global-equality2.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | not : Bool -> Bool 4 | not False = True 5 | not True = False 6 | 7 | data Equals forall A. (a b : A) where 8 | Refl : Equals a a 9 | 10 | f : (b : Bool) -> Equals (not b) False -> Equals b True 11 | f b eq = 12 | case b of 13 | False -> case eq of 14 | True -> Refl 15 | -------------------------------------------------------------------------------- /tests/singles/type-checking/gluing.vix: -------------------------------------------------------------------------------- 1 | data Nat = Z | S Nat 2 | 3 | add : Nat -> Nat -> Nat 4 | add Z n = n 5 | add (S m) n = S (add m n) 6 | 7 | mul : Nat -> Nat -> Nat 8 | mul Z n = Z 9 | mul (S m) n = add n (mul m n) 10 | 11 | data Equals forall T. (a b : T) where 12 | Refl : Equals a a 13 | 14 | n10 = S (S (S (S (S (S (S (S (S (S Z))))))))) 15 | n100 = mul n10 n10 16 | n10k = mul n100 n100 17 | n100m = mul n10k n10k 18 | 19 | nfun : Nat -> Type 20 | nfun Z = Type 21 | nfun (S n) = Type -> nfun n 22 | 23 | test1 : nfun n100m -> nfun n100m 24 | test1 x = x 25 | 26 | test2 : Equals n100m n100m 27 | test2 = Refl 28 | -------------------------------------------------------------------------------- /tests/singles/type-checking/id250-implicit.vix: -------------------------------------------------------------------------------- 1 | id : forall (A : Type). A -> A 2 | id = \a. a 3 | 4 | id250 : forall (A : Type). A -> A 5 | id250 = 6 | id id id id id id id id id id 7 | id id id id id id id id id id 8 | id id id id id id id id id id 9 | id id id id id id id id id id 10 | id id id id id id id id id id 11 | id id id id id id id id id id 12 | id id id id id id id id id id 13 | id id id id id id id id id id 14 | id id id id id id id id id id 15 | id id id id id id id id id id 16 | id id id id id id id id id id 17 | id id id id id id id id id id 18 | id id id id id id id id id id 19 | id id id id id id id id id id 20 | id id id id id id id id id id 21 | id id id id id id id id id id 22 | id id id id id id id id id id 23 | id id id id id id id id id id 24 | id id id id id id id id id id 25 | id id id id id id id id id id 26 | id id id id id id id id id id 27 | id id id id id id id id id id 28 | id id id id id id id id id id 29 | id id id id id id id id id id 30 | id id id id id id id id id id 31 | -------------------------------------------------------------------------------- /tests/singles/type-checking/id250.vix: -------------------------------------------------------------------------------- 1 | id : (A : Type) -> A -> A 2 | id = \A a. a 3 | 4 | id250 : (A : Type) -> A -> A 5 | id250 = \A. 6 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 7 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 8 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 9 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 10 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 11 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 12 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 13 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 14 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 15 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 16 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 17 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 18 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 19 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 20 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 21 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 22 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 23 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 24 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 25 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 26 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 27 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 28 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 29 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 30 | (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) (id _) 31 | -------------------------------------------------------------------------------- /tests/singles/type-checking/implicit-aliased-lams.vix: -------------------------------------------------------------------------------- 1 | the : (A : Type) -> A -> A 2 | the = \A a. a 3 | 4 | f : forall X Y. X -> Y -> X 5 | f = \@{X = A, Y = B} x y. the A x 6 | 7 | g : forall X Y. X -> Y -> X 8 | g = \@{Y = A, X = B} x y. the B x 9 | 10 | h : forall X Y. X -> Y -> X 11 | h = \@{X = A} x y. the A x 12 | 13 | i : forall X Y. X -> Y -> X 14 | i = \@{Y = A} x y. x 15 | 16 | j : forall X Y. X -> Y -> X 17 | j = \@{} x y. x 18 | 19 | k = \@{X = A}. the Type A 20 | 21 | l = \@{}. Type 22 | 23 | m : Type 24 | m = 25 | \@{x = a, y = b}. -- unable to infer implicit lambda error expected 26 | a 27 | -------------------------------------------------------------------------------- /tests/singles/type-checking/implicit-apps.vix: -------------------------------------------------------------------------------- 1 | f : forall X Y. X -> Y -> X 2 | f = \x y. x 3 | 4 | g = f @{X = Type, Y = Type} Type 5 | 6 | h = f @{Y = Type, X = Type} Type 7 | 8 | i = f @{X = Type} Type Type 9 | 10 | j = f @{Y = Type} Type 11 | 12 | k = f @{} Type Type 13 | 14 | the : (A : Type) -> A -> A 15 | the = \A a. a 16 | 17 | l : Type 18 | l = 19 | the (Type -> Type -> Type) f @{Z = Type, W = Type} -- implicit application mismatch error expected 20 | -------------------------------------------------------------------------------- /tests/singles/type-checking/implicit-constructor-args.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | test : forall t. t -> List t 6 | test = \@{t = T} x. Cons @{a = T} x (Nil @{a = T}) 7 | -------------------------------------------------------------------------------- /tests/singles/type-checking/implicit-constructor-fields.vix: -------------------------------------------------------------------------------- 1 | data Bool where 2 | False : Bool 3 | True : Bool 4 | 5 | data Wrapped where 6 | MkWrapped : forall (a b : Bool). Wrapped 7 | 8 | notA : Wrapped -> Bool 9 | notA (MkWrapped @{a = False}) = True 10 | notA (MkWrapped @{a = True}) = False 11 | 12 | notB : Wrapped -> Bool 13 | notB (MkWrapped @{b = False}) = True 14 | notB (MkWrapped @{b = True}) = False 15 | 16 | or : Wrapped -> Bool 17 | or (MkWrapped @{a = False, b}) = b 18 | or (MkWrapped @{a = True}) = False 19 | 20 | or2 : Wrapped -> Bool 21 | or2 (MkWrapped @{b = False, a = aa}) = aa 22 | or2 (MkWrapped @{b = True}) = False 23 | 24 | swap : Wrapped -> Wrapped 25 | swap (MkWrapped @{a, b}) = MkWrapped @{a = b, b = a} 26 | -------------------------------------------------------------------------------- /tests/singles/type-checking/implicit-data-param.vix: -------------------------------------------------------------------------------- 1 | data Test forall (a : Type). (b : a) where 2 | MkTest : Test @{a} b 3 | 4 | data Bool where 5 | False : Bool 6 | True : Bool 7 | 8 | test : Test @{a = Bool} True 9 | -------------------------------------------------------------------------------- /tests/singles/type-checking/implicit-lams.vix: -------------------------------------------------------------------------------- 1 | the : (A : Type) -> A -> A 2 | the = \A a. a 3 | 4 | f : forall X Y. X -> Y -> X 5 | f = \@{X, Y} x y. the X x 6 | 7 | g : forall X Y. X -> Y -> X 8 | g = \@{Y, X} x y. the X x 9 | 10 | h : forall X Y. X -> Y -> X 11 | h = \@{X} x y. the X x 12 | 13 | i : forall X Y. X -> Y -> X 14 | i = \@{Y} x y. x 15 | 16 | j : forall X Y. X -> Y -> X 17 | j = \@{} x y. x 18 | 19 | k = \@{X}. the Type X 20 | 21 | l = \@{}. Type 22 | 23 | m : Type 24 | m = 25 | \@{x, y}. -- unable to infer implicit lambda error expected 26 | x 27 | -------------------------------------------------------------------------------- /tests/singles/type-checking/implicit-map.vix: -------------------------------------------------------------------------------- 1 | data List a where 2 | Nil : List a 3 | Cons : a -> List a -> List a 4 | 5 | map : forall a b. List a -> List b 6 | map = \xs. Nil 7 | -------------------------------------------------------------------------------- /tests/singles/type-checking/impredicative-polymorphism-error.vix: -------------------------------------------------------------------------------- 1 | data Equals forall T. (x y : T) where 2 | Refl : Equals x x 3 | 4 | h : ((g : forall a. a -> a) -> Equals g g -> Int) -> Int -- unsolved meta error expected 5 | -------------------------------------------------------------------------------- /tests/singles/type-checking/impredicative-polymorphism.vix: -------------------------------------------------------------------------------- 1 | data Maybe a = Nothing | Just a 2 | 3 | x : Maybe (forall a. a -> a) 4 | x = Just \x. x 5 | 6 | data Equals forall T. (x y : T) where 7 | Refl : Equals x x 8 | 9 | g : ((g : forall a. a -> a) -> Equals @{T = forall a. a -> a} g g -> Int) -> Int 10 | g f = f (\x. x) Refl 11 | 12 | data List a = Nil | Cons a (List a) 13 | 14 | list : List (forall a b. a -> b -> a) 15 | list = Cons (\x y. x) (Cons (\@{a, b}(x : a)(y : b). x) (Cons (\@{b} x (y : b). x) (Cons (\@{a}(x : a) y. x) Nil))) 16 | -------------------------------------------------------------------------------- /tests/singles/type-checking/inductive-families/fin-add.vix: -------------------------------------------------------------------------------- 1 | data Nat where 2 | Zero : Nat 3 | Succ : Nat -> Nat 4 | 5 | data Fin (n : Nat) where 6 | Zero : forall m. Fin (Succ m) 7 | Succ : forall m. Fin m -> Fin (Succ m) 8 | 9 | addNat : Nat -> Nat -> Nat 10 | addNat Zero n = n 11 | addNat (Succ m) n = Succ (addNat m n) 12 | 13 | succIndex : forall n. Fin n -> Fin (Succ n) 14 | succIndex Zero = Zero 15 | succIndex (Succ x) = Succ (succIndex x) 16 | 17 | addIndex : forall n. (m : Nat) -> Fin n -> Fin (addNat m n) 18 | addIndex Zero x = x 19 | addIndex (Succ n) x = succIndex (addIndex n x) 20 | 21 | addFin : forall m n. Fin m -> Fin n -> Fin (addNat m n) 22 | addFin @{m} Zero y = addIndex m y 23 | addFin (Succ x) y = Succ (addFin x y) 24 | -------------------------------------------------------------------------------- /tests/singles/type-checking/inductive-families/fin.vix: -------------------------------------------------------------------------------- 1 | data Nat where 2 | Zero : Nat 3 | Succ : Nat -> Nat 4 | 5 | data Fin (n : Nat) where 6 | Zero : forall m. Fin (Succ m) 7 | Succ : forall m. Fin m -> Fin (Succ m) 8 | 9 | data Unit where 10 | MkUnit : Unit 11 | 12 | f1 : Fin (Succ (Succ (Succ Zero))) 13 | f1 = Succ Zero 14 | 15 | f2 : Fin (Succ (Succ (Succ Zero))) 16 | f2 = Succ (Succ Zero) 17 | 18 | addNat : Nat -> Nat -> Nat 19 | addNat Zero n = n 20 | addNat (Succ m) n = Succ (addNat m n) 21 | 22 | succIndex : forall n. Fin n -> Fin (Succ n) 23 | succIndex Zero = Zero 24 | succIndex (Succ x) = Succ (succIndex x) 25 | 26 | toNat : forall n. Fin n -> Nat 27 | toNat Zero = Zero 28 | toNat (Succ n) = Succ (toNat n) 29 | 30 | impossible : forall a. Fin Zero -> a 31 | impossible fz = case fz of 32 | 33 | onlyZero : Fin (Succ Zero) -> Unit 34 | onlyZero Zero = MkUnit 35 | onlyZero (Succ f) = case f of 36 | 37 | typeIncorrect : Fin (Succ Zero) -> Unit 38 | typeIncorrect Zero = MkUnit 39 | typeIncorrect (Succ z) = case z of 40 | -------------------------------------------------------------------------------- /tests/singles/type-checking/inductive-families/forced.vix: -------------------------------------------------------------------------------- 1 | data Equals forall T. (a b : T) where 2 | Refl : Equals a a 3 | 4 | data Unit where 5 | MkUnit : Unit 6 | 7 | data Nat where 8 | S : Nat -> Nat 9 | Z : Nat 10 | 11 | data List a where 12 | Nil : List a 13 | Cons : a -> List a -> List a 14 | 15 | two = S (S Z) 16 | three = S two 17 | 18 | forced1 : (a b : Type) -> Equals a b -> Equals b a 19 | forced1 ~a a Refl = Refl 20 | 21 | forced2 : (a b : Type) -> Equals a b -> Equals b a 22 | forced2 a ~a Refl = Refl 23 | 24 | forced3 : (a : Nat) -> Equals a two -> Equals two a 25 | forced3 ~two Refl = Refl 26 | 27 | forced4 : (a : List Nat) -> Equals (Cons two Nil) a -> Unit 28 | forced4 ~(Cons _ _) Refl = MkUnit 29 | 30 | wrongForced : (a : Nat) -> Equals a two -> Equals two a 31 | wrongForced ~three Refl = Refl -- type mismatch error expected 32 | -------------------------------------------------------------------------------- /tests/singles/type-checking/inductive-families/impossible.vix: -------------------------------------------------------------------------------- 1 | data Equals forall T. (a b : T) where 2 | Refl : Equals a a 3 | 4 | data Nat where 5 | Z : Nat 6 | S : Nat -> Nat 7 | 8 | two = S (S Z) 9 | three = S two 10 | 11 | impossible : forall a. Equals two three -> a 12 | impossible eq = case eq of 13 | 14 | data Maybe a where 15 | Nothing : Maybe a 16 | Just : a -> Maybe a 17 | 18 | impossible2 : forall a. Equals (Nothing @{a = Nat}) (Just three) -> a 19 | impossible2 eq = case eq of 20 | 21 | impossible3 : forall a. Equals (Just two) (Just three) -> a 22 | impossible3 eq = case eq of 23 | 24 | data List a where 25 | Nil : List a 26 | Cons : a -> List a -> List a 27 | 28 | notImpossible : forall a b. List a -> b 29 | notImpossible xs = case xs of -- non-exhaustive patterns error expected 30 | -------------------------------------------------------------------------------- /tests/singles/type-checking/inductive-families/propositional-equality.vix: -------------------------------------------------------------------------------- 1 | data Nat where 2 | Z : Nat 3 | S : Nat -> Nat 4 | 5 | n = S (S Z) 6 | 7 | data Equals forall T. (a b : T) where 8 | Refl : Equals a a 9 | 10 | lhs1 : forall a b. a -> Equals a b -> b 11 | lhs1 x Refl = x 12 | 13 | id : forall a. a -> a 14 | id x = x 15 | 16 | rhs1 : Equals Nat (id Nat) 17 | rhs1 = Refl 18 | 19 | lhs2 : (a : Nat) -> Equals a n -> Equals n a 20 | lhs2 a Refl = Refl 21 | 22 | rhs2 : Equals n n 23 | rhs2 = Refl 24 | 25 | reflexive : forall T (a : T). Equals a a 26 | reflexive = Refl 27 | 28 | symmetric : forall T (a b : T). Equals a b -> Equals b a 29 | symmetric Refl = Refl 30 | 31 | transitive : forall T (a b c : T). Equals a b -> Equals b c -> Equals a c 32 | transitive Refl Refl = Refl 33 | 34 | mismatch1 : forall a b. a -> Equals a b -> b 35 | mismatch1 a _ = a -- type mismatch error expected 36 | 37 | mismatch2 : forall T (a b : T). Equals a b 38 | mismatch2 = Refl -- type mismatch error expected 39 | -------------------------------------------------------------------------------- /tests/singles/type-checking/inductive-families/vector-append.vix: -------------------------------------------------------------------------------- 1 | data Nat where 2 | Z : Nat 3 | S : Nat -> Nat 4 | 5 | data Vector n a where 6 | Nil : Vector Z a 7 | Cons : forall m. a -> Vector m a -> Vector (S m) a 8 | 9 | add : Nat -> Nat -> Nat 10 | add Z n = n 11 | add (S m) n = S (add m n) 12 | 13 | append : forall m n a. Vector m a -> Vector n a -> Vector (add m n) a 14 | append Nil ys = ys 15 | append (Cons x xs) ys = Cons x (append xs ys) 16 | -------------------------------------------------------------------------------- /tests/singles/type-checking/inductive-families/vector.vix: -------------------------------------------------------------------------------- 1 | data Nat where 2 | Z : Nat 3 | S : Nat -> Nat 4 | 5 | data Vector n a where 6 | Nil : Vector Z a 7 | Cons : forall m. a -> Vector m a -> Vector (S m) a 8 | 9 | matchZero : Vector Z Nat -> Nat 10 | matchZero Nil = Z 11 | 12 | matchSucc : Vector (S Z) Nat -> Nat 13 | matchSucc (Cons _ Nil) = S Z 14 | 15 | zipWith : forall a b c n. (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c 16 | zipWith f Nil Nil = Nil 17 | zipWith f (Cons a as) (Cons b bs) = Cons (f a b) (zipWith f as bs) 18 | 19 | nil = Nil @{a = Nat} 20 | 21 | cons = Cons Z Nil 22 | 23 | cons' : Vector (S Z) Nat 24 | cons' = Cons Z Nil 25 | 26 | add : Nat -> Nat -> Nat 27 | add Z n = n 28 | add (S m) n = S (add m n) 29 | 30 | sum : forall n. Vector n Nat -> Nat 31 | sum Nil = Z 32 | sum (Cons x xs) = add x (sum xs) 33 | -------------------------------------------------------------------------------- /tests/singles/type-checking/let-mutually-recursive-stress.vix: -------------------------------------------------------------------------------- 1 | 2 | x : Type 3 | x = 4 | let 5 | a0 : Type 6 | a1 : Type 7 | a2 : Type 8 | a3 : Type 9 | a4 : Type 10 | a5 : Type 11 | a6 : Type 12 | a7 : Type 13 | a8 : Type 14 | a9 : Type 15 | a0 = a1 16 | a1 = a2 17 | a2 = a3 18 | a3 = a4 19 | a4 = a5 20 | a5 = a6 21 | a6 = a7 22 | a7 = a8 23 | a8 = a9 24 | a9 = Type 25 | b0 : Type 26 | b1 : Type 27 | b2 : Type 28 | b3 : Type 29 | b4 : Type 30 | b5 : Type 31 | b6 : Type 32 | b7 : Type 33 | b8 : Type 34 | b9 : Type 35 | b0 = b1 36 | b1 = b2 37 | b2 = b3 38 | b3 = b4 39 | b4 = b5 40 | b5 = b6 41 | b6 = b7 42 | b7 = b8 43 | b8 = b9 44 | b9 = a0 45 | c0 : Type 46 | c1 : Type 47 | c2 : Type 48 | c3 : Type 49 | c4 : Type 50 | c5 : Type 51 | c6 : Type 52 | c7 : Type 53 | c8 : Type 54 | c9 : Type 55 | c0 = c1 56 | c1 = c2 57 | c2 = c3 58 | c3 = c4 59 | c4 = c5 60 | c5 = c6 61 | c6 = c7 62 | c7 = c8 63 | c8 = c9 64 | c9 = b0 65 | d0 : Type 66 | d1 : Type 67 | d2 : Type 68 | d3 : Type 69 | d4 : Type 70 | d5 : Type 71 | d6 : Type 72 | d7 : Type 73 | d8 : Type 74 | d9 : Type 75 | d0 = d1 76 | d1 = d2 77 | d2 = d3 78 | d3 = d4 79 | d4 = d5 80 | d5 = d6 81 | d6 = d7 82 | d7 = d8 83 | d8 = d9 84 | d9 = c0 85 | e0 : Type 86 | e1 : Type 87 | e2 : Type 88 | e3 : Type 89 | e4 : Type 90 | e5 : Type 91 | e6 : Type 92 | e7 : Type 93 | e8 : Type 94 | e9 : Type 95 | e0 = e1 96 | e1 = e2 97 | e2 = e3 98 | e3 = e4 99 | e4 = e5 100 | e5 = e6 101 | e6 = e7 102 | e7 = e8 103 | e8 = e9 104 | e9 = d0 105 | in 106 | e9 107 | 108 | data Equals forall a. (x y : a) where 109 | Refl : Equals x x 110 | 111 | test : Equals x Type 112 | test = Refl 113 | -------------------------------------------------------------------------------- /tests/singles/type-checking/let-mutually-recursive.vix: -------------------------------------------------------------------------------- 1 | data Nat = Z | S Nat 2 | data Bool = False | True 3 | 4 | data Equals forall a. (x y : a) where 5 | Refl : Equals x x 6 | 7 | even3 : Bool 8 | even3 = 9 | let 10 | even : Nat -> Bool 11 | odd : Nat -> Bool 12 | even Z = True 13 | even (S n) = odd n 14 | odd Z = False 15 | odd (S n) = even n 16 | in 17 | even (S (S (S Z))) 18 | 19 | test : Equals even3 False 20 | test = Refl 21 | 22 | even3' : Bool 23 | even3' = 24 | let 25 | even : Nat -> Bool 26 | odd : Nat -> Bool 27 | even Z = True 28 | even (S n) = odd n 29 | odd Z = False 30 | odd (S n) = even n 31 | e3 = even (S (S (S Z))) 32 | test : Equals e3 False 33 | test = Refl 34 | in 35 | e3 36 | 37 | test' : Equals even3' False 38 | test' = Refl 39 | 40 | noDefinition : Bool 41 | noDefinition = 42 | let 43 | lol : Nat -- undefined let name error expected 44 | in 45 | True 46 | 47 | multipleTypes : Bool 48 | multipleTypes = 49 | let 50 | lol : Nat -- undefined let name error expected 51 | lol : Nat -- duplicate let name error expected 52 | in 53 | True 54 | 55 | multipleDefinitions1 : Bool 56 | multipleDefinitions1 = 57 | let 58 | foo : Nat -- undefined let name error expected 59 | bar : Nat -- undefined let name error expected 60 | foo : Nat -- duplicate let name error expected 61 | in 62 | True 63 | 64 | multipleDefinitions2 : Bool 65 | multipleDefinitions2 = 66 | let 67 | foo : Nat 68 | bar : Nat -- undefined let name error expected 69 | foo = Z 70 | baz : Nat -- undefined let name error expected 71 | foo = Z -- duplicate let name error expected 72 | in 73 | True 74 | -------------------------------------------------------------------------------- /tests/singles/type-checking/let-recursive.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | data Nat = Z | S Nat 3 | 4 | data Equals forall a. (x y : a) where 5 | Refl : Equals x x 6 | 7 | even3 : Bool 8 | even3 = 9 | let 10 | even : Nat -> Bool 11 | even Z = True 12 | even (S Z) = False 13 | even (S (S n)) = even n 14 | in 15 | even (S (S (S Z))) 16 | 17 | test : Equals even3 False 18 | test = Refl 19 | 20 | data List a = Nil | Cons a (List a) 21 | 22 | map : forall a b. (a -> b) -> List a -> List b 23 | map f = 24 | let 25 | go : List _ -> List _ 26 | go Nil = Nil 27 | go (Cons a as) = Cons (f a) (go as) 28 | in 29 | go 30 | 31 | test2 : Equals (map S (Cons Z (Cons (S Z) Nil))) (Cons (S Z) (Cons (S (S Z)) Nil)) 32 | test2 = Refl 33 | -------------------------------------------------------------------------------- /tests/singles/type-checking/local-gluing.vix: -------------------------------------------------------------------------------- 1 | 2 | data Nat = Z | S Nat 3 | 4 | add : Nat -> Nat -> Nat 5 | add Z n = n 6 | add (S m) n = S (add m n) 7 | 8 | mul : Nat -> Nat -> Nat 9 | mul Z n = Z 10 | mul (S m) n = add n (mul m n) 11 | 12 | data Equals forall T. (a b : T) where 13 | Refl : Equals a a 14 | 15 | nfun : Nat -> Type 16 | nfun Z = Type 17 | nfun (S n) = Type -> nfun n 18 | 19 | foo : Nat 20 | foo = 21 | let 22 | n10 = S (S (S (S (S (S (S (S (S (S Z))))))))) 23 | n100 = mul n10 n10 24 | n10k = mul n100 n100 25 | n100m = mul n10k n10k 26 | 27 | test1 : nfun n100m -> nfun n100m 28 | test1 x = x 29 | 30 | test2 : Equals n100m n100m 31 | test2 = Refl 32 | in 33 | Z 34 | -------------------------------------------------------------------------------- /tests/singles/type-checking/matching-circularity.vix: -------------------------------------------------------------------------------- 1 | data Id a = MkId a 2 | 3 | id : forall a. a -> Id a 4 | id -- type mismatch error expected 5 | (MkId a) -- type mismatch error expected 6 | = MkId a 7 | -------------------------------------------------------------------------------- /tests/singles/type-checking/mismatch.vix: -------------------------------------------------------------------------------- 1 | t : Type 2 | t = Type 3 | 4 | f : Type -> Type 5 | f = \x. x 6 | 7 | g : (Type -> Type) -> Type 8 | g = \h. h t 9 | 10 | i : (Type -> Type) -> Type 11 | i = \h. h f -- type mismatch error expected 12 | -------------------------------------------------------------------------------- /tests/singles/type-checking/mutually-recursive-definitions.vix: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | data Nat = Z | S Nat 3 | 4 | even : Nat -> Bool 5 | odd : Nat -> Bool 6 | 7 | even Z = True 8 | even (S n) = odd n 9 | 10 | odd Z = False 11 | odd (S n) = even n 12 | 13 | data Equals forall a. (x y : a) where 14 | Refl : Equals x x 15 | 16 | test1 : Equals (even (S (S (S Z)))) False 17 | test1 = Refl 18 | 19 | test2 : Equals (odd (S (S (S Z)))) True 20 | test2 = Refl 21 | -------------------------------------------------------------------------------- /tests/singles/type-checking/occurs-check.vix: -------------------------------------------------------------------------------- 1 | the : (A : Type) -> A -> A 2 | 3 | f = \x. the Type -- unsolved meta error expected 4 | (x -- type mismatch error expected, type mismatch error expected 5 | x) 6 | -------------------------------------------------------------------------------- /tests/singles/type-checking/occurs-check2.vix: -------------------------------------------------------------------------------- 1 | the : (A : Type) -> A -> A 2 | 3 | f = \(x : _ -> _). the Type -- unsolved meta error expected 4 | (x 5 | x) -- occurs check error expected 6 | -------------------------------------------------------------------------------- /tests/singles/type-checking/pair-stress.vix: -------------------------------------------------------------------------------- 1 | Pair : Type -> Type -> Type 2 | Pair = \A B. (Result : Type) -> (A -> B -> Result) -> Result 3 | 4 | pair : (A B : Type) -> A -> B -> Pair A B 5 | pair = \A B a b Result pair. pair a b 6 | 7 | pairStress : Type 8 | pairStress = 9 | let x0 = pair _ _ Type Type in 10 | let x1 = pair _ _ x0 x0 in 11 | let x2 = pair _ _ x1 x1 in 12 | let x3 = pair _ _ x2 x2 in 13 | let x4 = pair _ _ x3 x3 in 14 | let x5 = pair _ _ x4 x4 in 15 | let x6 = pair _ _ x5 x5 in 16 | let x7 = pair _ _ x6 x6 in 17 | let x8 = pair _ _ x7 x7 in 18 | let x9 = pair _ _ x8 x8 in 19 | let x10 = pair _ _ x9 x9 in 20 | let x11 = pair _ _ x10 x10 in 21 | let x12 = pair _ _ x11 x11 in 22 | -- let x13 = pair _ _ x12 x12 in 23 | -- let x14 = pair _ _ x13 x13 in 24 | -- let x15 = pair _ _ x14 x14 in 25 | -- let x16 = pair _ _ x15 x15 in 26 | -- let x17 = pair _ _ x16 x16 in 27 | -- let x18 = pair _ _ x17 x17 in 28 | -- let x19 = pair _ _ x18 x18 in 29 | -- let x20 = pair _ _ x19 x19 in 30 | Type 31 | -------------------------------------------------------------------------------- /tests/singles/type-checking/polymorphic-variable-inference.vix: -------------------------------------------------------------------------------- 1 | data Nat = Zero | Succ Nat 2 | 3 | NatElim : (P : Nat -> Type) -> P Zero -> (forall n. P n -> P (Succ n)) -> (n : Nat) -> P n 4 | NatElim P P0 s Zero = P0 5 | NatElim P P0 s (Succ n) = s (NatElim P P0 s n) 6 | 7 | etaExpanded P P0 s n = NatElim P P0 s n 8 | -------------------------------------------------------------------------------- /tests/singles/type-checking/propagation.vix: -------------------------------------------------------------------------------- 1 | List : Type -> Type 2 | 3 | data List a where 4 | Nil : List a 5 | Cons : a -> List a -> List a 6 | 7 | List2 : Type -> Type 8 | data List2 a where 9 | Nil : List2 a 10 | Cons : a -> List2 a -> List2 a 11 | 12 | the : (A : Type) -> A -> A 13 | the = \A a. a 14 | 15 | Int' = Type 16 | One = Type 17 | 18 | test1 : List Int' 19 | test1 = Cons One Nil 20 | test2 : List2 Int' 21 | test2 = Cons One Nil 22 | 23 | test3 = the (List Int') (Cons One Nil) 24 | test4 = the (List2 Int') (Cons One Nil) 25 | 26 | test5 = the (_ -> _ -> List _) Cons One Nil 27 | test6 = the (_ -> _ -> List2 _) Cons One Nil 28 | -------------------------------------------------------------------------------- /tests/singles/type-checking/record.vix: -------------------------------------------------------------------------------- 1 | data Telescope where 2 | Nil : Telescope 3 | Cons : (A : Type) -> (A -> Telescope) -> Telescope 4 | 5 | data Record (tele : Telescope) where 6 | Nil : Record Nil 7 | Cons : forall A (B : A -> Telescope). (a : A) -> Record (B a) -> Record (Cons A B) 8 | 9 | project1 : forall A B. Record (Cons A B) -> A 10 | project1 (Cons a _) = 11 | a 12 | 13 | project2 : forall A B. (rec : Record (Cons A B)) -> Record (B (project1 rec)) 14 | project2 (Cons _ b) = 15 | b 16 | 17 | implicitPis : (tele : Telescope) -> (Record tele -> Type) -> Type 18 | implicitPis tele f = 19 | case tele of 20 | Nil -> 21 | f Nil 22 | 23 | Cons A B -> 24 | forall (a : A). implicitPis (B a) (\b. f (Cons @{B} a b)) 25 | 26 | implicitApps : forall tele f. implicitPis tele f -> (args : Record tele) -> f args 27 | implicitApps @{f} fun args = 28 | case args of 29 | Nil -> 30 | fun 31 | 32 | Cons @{B} arg args' -> 33 | implicitApps @{f = \b. f (Cons @{B} arg b)} (fun @{a = arg}) args' 34 | -------------------------------------------------------------------------------- /tests/singles/type-checking/record2.vix: -------------------------------------------------------------------------------- 1 | data Unit = MkUnit 2 | 3 | data Sigma A (B : A -> Type) where 4 | MkSigma : (a : A) -> B a -> Sigma A B 5 | 6 | proj1 : forall A B. Sigma A B -> A 7 | proj1 (MkSigma a _) = a 8 | 9 | proj2 : forall A B. (s : Sigma A B) -> B (proj1 s) 10 | proj2 (MkSigma _ b) = b 11 | 12 | data Telescope where 13 | Nil : Telescope 14 | Cons : (A : Type) -> (A -> Telescope) -> Telescope 15 | 16 | Record : Telescope -> Type 17 | Record Nil = Unit 18 | Record (Cons A tele) = Sigma A (\a. Record (tele a)) 19 | 20 | Pi : (tele : Telescope) -> (Record tele -> Type) -> Type 21 | Pi Nil B = B MkUnit 22 | Pi (Cons A tele) B = forall (a : A). Pi (tele a) (\b. B (MkSigma @{B = \a. Record (tele a)} a b)) 23 | 24 | apply : (tele : Telescope) -> (F : Record tele -> Type) -> Pi tele F -> (rec : Record tele) -> F rec 25 | apply Nil F f MkUnit = f 26 | apply (Cons A tele) F f (MkSigma a rec) = apply (tele a) (\b. F (MkSigma @{B = \a. Record (tele a)} a b)) (f @{a}) rec 27 | -------------------------------------------------------------------------------- /tests/singles/type-checking/singleton.vix: -------------------------------------------------------------------------------- 1 | data Nat = Z | S Nat 2 | 3 | data Singleton forall A. (a : A) where 4 | Singleton : (x : A) -> Singleton x 5 | 6 | unsingleton : forall A (a : A). Singleton a -> A 7 | unsingleton (Singleton x) = x 8 | 9 | data Vector n A where 10 | Nil : Vector Z A 11 | Cons : forall n. A -> Vector n A -> Vector (S n) A 12 | 13 | length : forall n A. Vector n A -> Singleton n 14 | length @{n} _ = Singleton n 15 | 16 | length' : forall n A. Vector n A -> Singleton n 17 | length' Nil = Singleton Z 18 | length' (Cons x xs) = 19 | case length' xs of 20 | Singleton n -> 21 | Singleton (S n) 22 | -------------------------------------------------------------------------------- /tests/singles/type-checking/type-evaluation.vix: -------------------------------------------------------------------------------- 1 | arr = Type -> Type 2 | 3 | test : arr 4 | test = \x. x 5 | -------------------------------------------------------------------------------- /tests/singles/type-checking/unsolved-meta.vix: -------------------------------------------------------------------------------- 1 | 2 | f = _ -- unsolved meta error expected, unsolved meta error expected 3 | -------------------------------------------------------------------------------- /tests/todo/circular.vix: -------------------------------------------------------------------------------- 1 | -- Should fail because of circularity -- we can't compile this using CBV 2 | 3 | g : Type 4 | f = g 5 | g = f 6 | -------------------------------------------------------------------------------- /tests/todo/parse-recovery.vix: -------------------------------------------------------------------------------- 1 | work1 = a 2 | 3 | f : Type 4 | f = 8 a 5 | 6 | work2 = a 7 | 8 | h : Type 9 | h = a a ( 10 | 11 | work3 = a 12 | 13 | g : Type 14 | g = a 8 a 15 | 16 | work4 = a 17 | 18 | j = a 19 | 20 | work5 = a 21 | -------------------------------------------------------------------------------- /tests/todo/typeless-clauses.vix: -------------------------------------------------------------------------------- 1 | data Nat = Z | S Nat 2 | 3 | pred Z = Z 4 | pred (S n) = n 5 | --------------------------------------------------------------------------------